1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Free Software published under an MIT-like license. See LICENSE ;;;
5 ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;;
7 ;;; Original author: Scott McKay ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package "PROTO-IMPL")
14 ;;; Protocol buffers model classes
16 (defvar *all-schemas* (make-hash-table :test #'equal)
17 "A global table mapping names to 'protobuf-schema' objects.")
19 (defgeneric find-schema (name)
21 "Given a name (a symbol or string), return the 'protobuf-schema' object having that name."))
23 (defmethod find-schema ((name symbol))
24 (values (gethash (keywordify name) *all-schemas*)))
26 (defmethod find-schema ((name string))
27 (values (gethash (string-upcase name) *all-schemas*)))
29 (defmethod find-schema ((path pathname))
30 "Given a pathname, return the 'protobuf-schema' object that came from that path."
31 (values (gethash (make-pathname :type nil :defaults path) *all-schemas*)))
34 (defvar *all-messages* (make-hash-table :test #'equal)
35 "A global table mapping Lisp class names to 'protobuf-message' objects.")
37 (defgeneric find-message-for-class (class)
39 "Given a class or class name, return the message that globally has that name."))
41 (defmethod find-message-for-class (class)
42 "Given the name of a class (a symbol or string), return the 'protobuf-message' for the class."
43 (values (gethash class *all-messages*)))
45 (defmethod find-message-for-class ((class class))
46 (values (gethash (class-name class) *all-messages*)))
49 ;;; "Thread-local" variables
51 ;; Parsing (and even pretty printing schemas) want to keep track of the current schema
52 (defvar *protobuf* nil
53 "Bound to the Protobufs object currently being defined, either a schema or a message.")
55 (defvar *protobuf-package* nil
56 "Bound to the Lisp package in which the Protobufs schema is being defined.")
58 (defvar *protobuf-rpc-package* nil
59 "Bound to the Lisp package in which the Protobufs schema's service definitions are being defined.")
61 (defvar *protobuf-conc-name* nil
62 "Bound to a conc-name to use for all the messages in the schema being defined.
63 This controls the name of the accessors the fields of each message.
64 When it's nil, there is no \"global\" conc-name.
65 When it's t, each message will use the message name as the conc-name.
66 When it's a string, that string will be used as the conc-name for each message.
67 'parse-schema-from-file' defaults conc-name to \"\", meaning that each field in
68 every message has an accessor whose name is the name of the field.")
70 (defvar *protobuf-pathname* nil
71 "Bound to he name of the file from where the .proto file is being parsed.")
73 (defvar *protobuf-search-path* ()
74 "Bound to the search-path to use to resolve any relative pathnames.")
76 (defvar *protobuf-output-path* ()
77 "Bound to the path to use to direct output during imports, etc.")
82 (defclass abstract-protobuf () ())
84 ;; It would be nice if most of the slots had only reader functions, but
85 ;; that makes writing the Protobufs parser a good deal more complicated.
86 ;; Too bad Common Lisp exports '(setf foo)' when you only want to export 'foo'
87 (defclass base-protobuf (abstract-protobuf)
88 ((class :type (or null symbol) ;the Lisp name for this object
89 :accessor proto-class ;this often names a type or class
92 (name :type (or null string) ;the Protobufs name for this enum, message, etc
96 (qual-name :type string ;the fully qualified name, e.g., "proto2.MessageSet"
97 :accessor proto-qualified-name
98 :initarg :qualified-name
100 (parent :type (or null base-protobuf) ;this object's parent
101 :accessor proto-parent
103 (options :type (list-of protobuf-option) ;options, mostly just passed along
104 :accessor proto-options
107 (doc :type (or null string) ;documentation for this object
108 :accessor proto-documentation
109 :initarg :documentation
111 (location :accessor proto-source-location ;a list of (pathname start-pos end-pos)
112 :initarg :source-location
115 "The base class for all Protobufs model classes."))
117 (defun find-qualified-name (name protos
118 &key (proto-key #'proto-name) (full-key #'proto-qualified-name)
120 "Find something by its string name, first doing a simple name match,
121 and, if that fails, exhaustively searching qualified names."
122 (declare (ignore relative-to))
123 (or (find name protos :key proto-key :test #'string=)
124 ;;--- This needs more sophisticated search, e.g., relative to current namespace
125 (find name protos :key full-key :test #'string=)))
128 ;; A Protobufs schema, corresponds to one .proto file
129 (defclass protobuf-schema (base-protobuf)
130 ((syntax :type (or null string) ;syntax, passed on but otherwise ignored
131 :accessor proto-syntax
134 (package :type (or null string) ;the Protobufs package
135 :accessor proto-package
138 (lisp-pkg :type (or null string) ;the Lisp package, from 'option lisp_package = ...'
139 :accessor proto-lisp-package
140 :initarg :lisp-package
142 (imports :type (list-of string) ;the names of schemas to be imported
143 :accessor proto-imports
146 (schemas :type (list-of protobuf-schema) ;the schemas that were successfully imported
147 :accessor proto-imported-schemas ;this gets used for chasing namespaces
149 (enums :type (list-of protobuf-enum) ;the set of enum types
150 :accessor proto-enums
153 (messages :type (list-of protobuf-message) ;all the messages within this protobuf
154 :accessor proto-messages
157 (extenders :type (list-of protobuf-message) ;the 'extend' messages in this protobuf
158 :accessor proto-extenders ;these precede unextended messages in 'find-message'
161 (services :type (list-of protobuf-service)
162 :accessor proto-services
165 (aliases :type (list-of protobuf-type-alias) ;type aliases, a Lisp extension
166 :accessor proto-type-aliases
167 :initarg :type-aliases
170 "The model class that represents a Protobufs schema, i.e., one .proto file."))
172 (defmethod make-load-form ((s protobuf-schema) &optional environment)
173 (with-slots (class name) s
174 (multiple-value-bind (constructor initializer)
175 (make-load-form-saving-slots s :environment environment)
176 (values `(let ((s ,constructor))
177 (record-protobuf s ',class ',name nil)
181 (defgeneric record-protobuf (schema &optional symbol name type)
183 "Record all the names by which the Protobufs schema might be known.")
184 (:method ((schema protobuf-schema) &optional symbol name type)
185 (declare (ignore type))
186 (let ((symbol (or symbol (proto-class schema)))
187 (name (or name (proto-name schema))))
189 (setf (gethash (keywordify symbol) *all-schemas*) schema))
191 (setf (gethash (string-upcase name) *all-schemas*) schema))
192 (let ((path (or *protobuf-pathname* *compile-file-pathname*)))
194 ;; Record the file from which the Protobufs schema came, sans file type
195 (setf (gethash (make-pathname :type nil :defaults path) *all-schemas*) schema))))))
197 (defmethod print-object ((s protobuf-schema) stream)
199 (print-unreadable-object (s stream :type t :identity t)
200 (format stream "~@[~S~]~@[ (package ~A)~]"
201 (and (slot-boundp s 'class) (proto-class s)) (proto-package s)))
202 (format stream "~S" (and (slot-boundp s 'class) (proto-class s)))))
204 (defgeneric make-qualified-name (proto name)
206 "Give a schema or message and a name,
207 generate a fully qualified name string for the name."))
209 (defmethod make-qualified-name ((schema protobuf-schema) name)
210 ;; If we're at the schema, the qualified name is the schema's
211 ;; package "dot" the name
212 (if (proto-package schema)
213 (strcat (proto-package schema) "." name)
216 (defgeneric find-enum (protobuf type &optional relative-to)
218 "Given a Protobufs schema or message and the name of an enum type,
219 returns the Protobufs enum corresponding to the type."))
221 (defmethod find-enum ((schema protobuf-schema) (type symbol) &optional relative-to)
222 (declare (ignore relative-to))
223 (labels ((find-it (schema)
224 (let ((enum (find type (proto-enums schema) :key #'proto-class)))
226 (return-from find-enum enum))
227 (map () #'find-it (proto-imported-schemas schema)))))
230 (defmethod find-enum ((schema protobuf-schema) (name string) &optional relative-to)
231 (let ((relative-to (or relative-to schema)))
232 (labels ((find-it (schema)
233 (let ((enum (find-qualified-name name (proto-enums schema)
234 :relative-to relative-to)))
236 (return-from find-enum enum))
237 (map () #'find-it (proto-imported-schemas schema)))))
240 (defgeneric find-message (protobuf type &optional relative-to)
242 "Given a Protobufs schema or message and a type name or class name,
243 returns the Protobufs message corresponding to the type."))
245 (defmethod find-message ((schema protobuf-schema) (type symbol) &optional relative-to)
246 (declare (ignore relative-to))
247 ;; Extended messages "shadow" non-extended ones
248 (labels ((find-it (schema)
249 (let ((message (or (find type (proto-extenders schema) :key #'proto-class)
250 (find type (proto-messages schema) :key #'proto-class))))
252 (return-from find-message message))
253 (map () #'find-it (proto-imported-schemas schema)))))
256 (defmethod find-message ((schema protobuf-schema) (type class) &optional relative-to)
257 (find-message schema (class-name type) (or relative-to schema)))
259 (defmethod find-message ((schema protobuf-schema) (name string) &optional relative-to)
260 (let ((relative-to (or relative-to schema)))
261 (labels ((find-it (schema)
262 (let ((message (or (find-qualified-name name (proto-extenders schema)
263 :relative-to relative-to)
264 (find-qualified-name name (proto-messages schema)
265 :relative-to relative-to))))
267 (return-from find-message message))
268 (map () #'find-it (proto-imported-schemas schema)))))
271 (defgeneric find-service (protobuf name)
273 "Given a Protobufs schema,returns the Protobufs service of the given name."))
275 (defmethod find-service ((schema protobuf-schema) (name symbol))
276 (find name (proto-services schema) :key #'proto-class))
278 (defmethod find-service ((schema protobuf-schema) (name string))
279 (find-qualified-name name (proto-services schema)))
281 ;; Convenience function that accepts a schema name
282 (defmethod find-service (schema-name name)
283 (let ((schema (find-schema schema-name)))
285 "There is no schema named ~A" schema-name)
286 (find-service schema name)))
289 ;; We accept and store any option, but only act on a few: default, packed,
290 ;; optimize_for, lisp_package, lisp_name, lisp_alias
291 (defclass protobuf-option (abstract-protobuf)
292 ((name :type string ;the key
295 (value :accessor proto-value ;the (untyped) value
298 (type :type (or null symbol) ;(optional) Lisp type,
299 :reader proto-type ; one of string, integer, float, symbol (for now)
303 "The model class that represents a Protobufs options, i.e., a keyword/value pair."))
305 (defmethod make-load-form ((o protobuf-option) &optional environment)
306 (make-load-form-saving-slots o :environment environment))
308 (defmethod print-object ((o protobuf-option) stream)
310 (print-unreadable-object (o stream :type t :identity t)
311 (format stream "~A~@[ = ~S~]" (proto-name o) (proto-value o)))
312 (format stream "~A" (proto-name o))))
314 (defun make-option (name value &optional (type 'string))
315 (check-type name string)
316 (make-instance 'protobuf-option
317 :name name :value value :type type))
319 (defgeneric find-option (protobuf name)
321 "Given a Protobufs schema, message, enum, etc and the name of an option,
322 returns the value of the option and its (Lisp) type. The third value is
323 true if an option was found, otherwise it is false."))
325 (defmethod find-option ((protobuf base-protobuf) (name string))
326 (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
328 (values (proto-value option) (proto-type option) t)
329 (values nil nil nil))))
331 (defmethod find-option ((options list) (name string))
332 (let ((option (find name options :key #'proto-name :test #'option-name=)))
334 (values (proto-value option) (proto-type option) t)
335 (values nil nil nil))))
337 (defgeneric add-option (protobuf name value &optional type)
339 "Given a Protobufs schema, message, enum, etc
340 add the option called 'name' with the value 'value' and type 'type'.
341 If the option was previoously present, it is replaced."))
343 (defmethod add-option ((protobuf base-protobuf) (name string) value &optional (type 'string))
344 (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
346 ;; This side-effects the old option
347 (setf (proto-value option) value
348 (proto-type option) type)
349 ;; This side-effects 'proto-options'
350 (setf (proto-options protobuf)
351 (append (proto-options protobuf)
352 (list (make-option name value type)))))))
354 (defmethod add-option ((options list) (name string) value &optional (type 'string))
355 (let ((option (find name options :key #'proto-name :test #'option-name=)))
356 (append (remove option options)
357 (list (make-option name value type)))))
359 (defgeneric remove-options (protobuf &rest names)
361 "Given a Protobufs schema, message, enum, etc and a set of option names,
362 remove all of those options from the set of options."))
364 (defmethod remove-options ((protobuf base-protobuf) &rest names)
365 (dolist (name names (proto-options protobuf))
366 (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
368 ;; This side-effects 'proto-options'
369 (setf (proto-options protobuf) (remove option (proto-options protobuf)))))))
371 (defmethod remove-options ((options list) &rest names)
372 (dolist (name names options)
373 (let ((option (find name options :key #'proto-name :test #'option-name=)))
375 ;; This does not side-effect the list of options
376 (setq options (remove option options))))))
378 (defun option-name= (name1 name2)
379 (let* ((name1 (string name1))
380 (name2 (string name2))
381 (start1 (if (eql (char name1 0) #\() 1 0))
382 (start2 (if (eql (char name2 0) #\() 1 0))
383 (end1 (if (eql (char name1 0) #\() (- (length name1) 1) (length name1)))
384 (end2 (if (eql (char name2 0) #\() (- (length name2) 1) (length name2))))
385 (string= name1 name2 :start1 start1 :end1 end1 :start2 start2 :end2 end2)))
388 ;; A Protobufs enumeration
389 (defclass protobuf-enum (base-protobuf)
390 ((alias :type (or null symbol) ;use this if you want to make this enum
391 :accessor proto-alias-for ; be an alias for an existing Lisp enum
394 (values :type (list-of protobuf-enum-value) ;all the values for this enum type
395 :accessor proto-values
399 "The model class that represents a Protobufs enumeration type."))
401 (defmethod make-load-form ((e protobuf-enum) &optional environment)
402 (make-load-form-saving-slots e :environment environment))
404 (defmethod print-object ((e protobuf-enum) stream)
406 (print-unreadable-object (e stream :type t :identity t)
407 (format stream "~S~@[ (alias for ~S)~]"
408 (and (slot-boundp e 'class) (proto-class e)) (proto-alias-for e)))
410 (and (slot-boundp e 'class) (proto-class e)))))
412 (defmethod make-qualified-name ((enum protobuf-enum) name)
413 ;; The qualified name is the enum name "dot" the name
414 (let ((qual-name (strcat (proto-name enum) "." name)))
415 (if (proto-parent enum)
416 ;; If there's a parent for this enum (either a message or
417 ;; the schema), prepend the name (or package) of the parent
418 (make-qualified-name (proto-parent enum) qual-name)
419 ;; Guard against a message in the middle of nowhere
423 ;; A Protobufs value within an enumeration
424 (defclass protobuf-enum-value (base-protobuf)
425 ((index :type (signed-byte 32) ;the numeric value of the enum
426 :accessor proto-index
428 (value :type (or null symbol) ;the Lisp value of the enum
429 :accessor proto-value
433 "The model class that represents a Protobufs enumeration value."))
435 (defmethod make-load-form ((v protobuf-enum-value) &optional environment)
436 (make-load-form-saving-slots v :environment environment))
438 (defmethod print-object ((v protobuf-enum-value) stream)
440 (print-unreadable-object (v stream :type t :identity t)
441 (format stream "~A = ~D"
442 (proto-name v) (proto-index v)))
443 (format stream "~A" (proto-name v))))
446 ;; A Protobufs message
447 (defclass protobuf-message (base-protobuf)
448 ((conc :type (or null string) ;the conc-name used for Lisp accessors
449 :accessor proto-conc-name
452 (alias :type (or null symbol) ;use this if you want to make this message
453 :accessor proto-alias-for ; be an alias for an existing Lisp class
456 (enums :type (list-of protobuf-enum) ;the embedded enum types
457 :accessor proto-enums
460 (messages :type (list-of protobuf-message) ;all the messages embedded in this one
461 :accessor proto-messages
464 (extenders :type (list-of protobuf-message) ;the 'extend' messages embedded in this one
465 :accessor proto-extenders ;these precede unextended messages in 'find-message'
468 (fields :type (list-of protobuf-field) ;all the fields of this message
469 :accessor proto-fields ;this includes local ones and extended ones
472 (extended-fields :type (list-of protobuf-field) ;the extended fields defined in this message
473 :accessor proto-extended-fields
475 (extensions :type (list-of protobuf-extension) ;any extension ranges
476 :accessor proto-extensions
479 ;; :message is an ordinary message
480 ;; :group is a (deprecated) group (kind of an "implicit" message)
481 ;; :extends is an 'extends' to an existing message
482 (message-type :type (member :message :group :extends)
483 :accessor proto-message-type
484 :initarg :message-type
486 (aliases :type (list-of protobuf-type-alias) ;type aliases, a Lisp extension
487 :accessor proto-type-aliases
488 :initarg :type-aliases
491 "The model class that represents a Protobufs message."))
493 (defmethod make-load-form ((m protobuf-message) &optional environment)
494 (with-slots (class name message-type) m
495 (multiple-value-bind (constructor initializer)
496 (make-load-form-saving-slots m :environment environment)
497 (values (if (eq message-type :extends)
499 `(let ((m ,constructor))
500 (record-protobuf m ',class ',name ',message-type)
504 (defmethod record-protobuf ((message protobuf-message) &optional class name type)
505 ;; No need to record an extension, it's already been recorded
506 (let ((class (or class (proto-class message)))
507 (name (or name (proto-name message)))
508 (type (or type (proto-message-type message))))
509 (unless (eq type :extends)
511 (setf (gethash class *all-messages*) message))
513 (setf (gethash name *all-messages*) message)))))
515 (defmethod print-object ((m protobuf-message) stream)
517 (print-unreadable-object (m stream :type t :identity t)
518 (format stream "~S~@[ (alias for ~S)~]~@[ (group~*)~]~@[ (extended~*)~]"
519 (and (slot-boundp m 'class) (proto-class m))
521 (eq (proto-message-type m) :group)
522 (eq (proto-message-type m) :extends)))
523 (format stream "~S" (and (slot-boundp m 'class) (proto-class m)))))
525 (defmethod proto-package ((message protobuf-message))
526 (and (proto-parent message)
527 (proto-package (proto-parent message))))
529 (defmethod proto-lisp-package ((message protobuf-message))
530 (and (proto-parent message)
531 (proto-lisp-package (proto-parent message))))
533 (defmethod make-qualified-name ((message protobuf-message) name)
534 ;; The qualified name is the message name "dot" the name
535 (let ((qual-name (strcat (proto-name message) "." name)))
536 (if (proto-parent message)
537 ;; If there's a parent for this message (either a message or
538 ;; the schema), prepend the name (or package) of the parent
539 (make-qualified-name (proto-parent message) qual-name)
540 ;; Guard against a message in the middle of nowhere
543 (defmethod find-message ((message protobuf-message) (type symbol) &optional relative-to)
544 ;; Extended messages "shadow" non-extended ones
545 (or (find type (proto-extenders message) :key #'proto-class)
546 (find type (proto-messages message) :key #'proto-class)
547 (find-message (proto-parent message) type (or relative-to message))))
549 (defmethod find-message ((message protobuf-message) (type class) &optional relative-to)
550 (find-message message (class-name type) (or relative-to message)))
552 (defmethod find-message ((message protobuf-message) (name string) &optional relative-to)
553 (let ((relative-to (or relative-to message)))
554 (or (find-qualified-name name (proto-extenders message)
555 :relative-to relative-to)
556 (find-qualified-name name (proto-messages message)
557 :relative-to relative-to)
558 (find-message (proto-parent message) name relative-to))))
560 (defmethod find-enum ((message protobuf-message) type &optional relative-to)
561 (or (find type (proto-enums message) :key #'proto-class)
562 (find-enum (proto-parent message) type (or relative-to message))))
564 (defmethod find-enum ((message protobuf-message) (name string) &optional relative-to)
565 (let ((relative-to (or relative-to message)))
566 (or (find-qualified-name name (proto-enums message)
567 :relative-to relative-to)
568 (find-enum (proto-parent message) name relative-to))))
570 (defgeneric find-field (message name &optional relative-to)
572 "Given a Protobufs message and a slot name, field name or index,
573 returns the Protobufs field having that name."))
575 (defmethod find-field ((message protobuf-message) (name symbol) &optional relative-to)
576 (declare (ignore relative-to))
577 (find name (proto-fields message) :key #'proto-value))
579 (defmethod find-field ((message protobuf-message) (name string) &optional relative-to)
580 (find-qualified-name name (proto-fields message)
581 :relative-to (or relative-to message)))
583 (defmethod find-field ((message protobuf-message) (index integer) &optional relative-to)
584 (declare (ignore relative-to))
585 (find index (proto-fields message) :key #'proto-index))
588 ;; Extensions protocol
589 (defgeneric get-extension (object slot)
591 "Returns the value of the extended slot 'slot' in 'object'"))
593 (defgeneric set-extension (object slot value)
595 "Sets the value of the extended slot 'slot' to 'value' in 'object'"))
597 (defgeneric has-extension (object slot)
599 "Returns true iff the there is an extended slot named 'slot' in 'object'")
600 ;; The only default method is for 'has-extension'
601 ;; It's an error to call the other three functions on a non-extendable object
602 (:method ((object standard-object) slot)
603 (declare (ignore slot))
606 (defgeneric clear-extension (object slot)
608 "Clears the value of the extended slot 'slot' from 'object'"))
611 (defconstant $empty-default 'empty-default
612 "The marker used in 'proto-default' used to indicate that there is no default value.")
613 (defconstant $empty-list 'empty-list)
614 (defconstant $empty-vector 'empty-vector)
616 ;; A Protobufs field within a message
617 ;;--- Support the 'deprecated' option (have serialization ignore such fields?)
618 (defclass protobuf-field (base-protobuf)
619 ((type :type string ;the name of the Protobuf type for the field
622 (required :type (member :required :optional :repeated)
623 :accessor proto-required
625 (index :type (unsigned-byte 29) ;the index number for this field
626 :accessor proto-index ; which must be strictly positive
628 (value :type (or null symbol) ;the Lisp slot holding the value within an object
629 :accessor proto-value ;this also serves as the Lisp field name
632 (reader :type (or null symbol) ;a reader that is used to access the value
633 :accessor proto-reader ;if it's supplied, it's used instead of 'value'
636 (writer :type (or null symbol list) ;a writer that is used to set the value
637 :accessor proto-writer ;when it's a list, it's something like '(setf title)'
640 (default :accessor proto-default ;default value (untyped), pulled out of the options
642 :initform $empty-default)
643 (packed :type (member t nil) ;packed, pulled out of the options
644 :accessor proto-packed
647 ;; Copied from 'proto-message-type' of the field
648 (message-type :type (member :message :group :extends)
649 :accessor proto-message-type
650 :initarg :message-type
653 "The model class that represents one field within a Protobufs message."))
655 (defmethod initialize-instance :after ((field protobuf-field) &rest initargs)
656 (declare (ignore initargs))
657 (when (slot-boundp field 'index)
658 (assert (and (plusp (proto-index field))
659 (not (<= 19000 (proto-index field) 19999))) ()
660 "Protobuf field indexes must be positive and not between 19000 and 19999 (inclusive)")))
662 (defmethod make-load-form ((f protobuf-field) &optional environment)
663 (make-load-form-saving-slots f :environment environment))
665 (defmethod print-object ((f protobuf-field) stream)
667 (print-unreadable-object (f stream :type t :identity t)
668 (format stream "~S :: ~S = ~D~@[ (group~*)~]~@[ (extended~*)~]"
670 (and (slot-boundp f 'class) (proto-class f))
672 (eq (proto-message-type f) :group)
673 (eq (proto-message-type f) :extends)))
674 (format stream "~S" (proto-value f))))
676 ;; The 'value' slot really holds the name of the slot,
677 ;; so let's give it a better name
678 (defmethod proto-slot ((field protobuf-field))
681 (defmethod (setf proto-slot) (slot (field protobuf-field))
682 (setf (proto-value field) slot))
684 (defgeneric empty-default-p (field)
686 "Returns true iff the default for the field is empty, ie, was not supplied.")
687 (:method ((field protobuf-field))
688 (let ((default (proto-default field)))
689 (or (eq default $empty-default)
690 (eq default $empty-list)
691 (eq default $empty-vector)
692 ;; Special handling for imported CLOS classes
693 (and (not (eq (proto-required field) :optional))
694 (or (null default) (equalp default #())))))))
696 (defgeneric vector-field-p (field)
698 "Returns true if the storage for a 'repeated' field is a vector,
699 returns false if the storage is a list.")
700 (:method ((field protobuf-field))
701 (let ((default (proto-default field)))
702 (or (eq default $empty-vector)
703 (and (vectorp default) (not (stringp default)))))))
706 ;; An extension range within a message
707 (defclass protobuf-extension (abstract-protobuf)
708 ((from :type (integer 1 #.(1- (ash 1 29))) ;the index number for this field
709 :accessor proto-extension-from
711 (to :type (integer 1 #.(1- (ash 1 29))) ;the index number for this field
712 :accessor proto-extension-to
715 "The model class that represents an extension range within a Protobufs message."))
717 (defmethod make-load-form ((e protobuf-extension) &optional environment)
718 (make-load-form-saving-slots e :environment environment))
720 (defmethod print-object ((e protobuf-extension) stream)
721 (print-unreadable-object (e stream :type t :identity t)
722 (format stream "~D - ~D"
723 (proto-extension-from e) (proto-extension-to e))))
726 ;; A Protobufs service
727 (defclass protobuf-service (base-protobuf)
728 ((methods :type (list-of protobuf-method) ;the methods in the service
729 :accessor proto-methods
733 "The model class that represents a Protobufs service."))
735 (defmethod make-load-form ((s protobuf-service) &optional environment)
736 (make-load-form-saving-slots s :environment environment))
738 (defmethod print-object ((s protobuf-service) stream)
740 (print-unreadable-object (s stream :type t :identity t)
741 (format stream "~S" (proto-name s)))
742 (format stream "~S" (proto-name s))))
744 (defgeneric find-method (service name)
746 "Given a Protobufs service and a method name,
747 returns the Protobufs method having that name."))
749 (defmethod find-method ((service protobuf-service) (name symbol))
750 (find name (proto-methods service) :key #'proto-class))
752 (defmethod find-method ((service protobuf-service) (name string))
753 (find-qualified-name name (proto-methods service)))
755 (defmethod find-method ((service protobuf-service) (index integer))
756 (find index (proto-methods service) :key #'proto-index))
759 ;; A Protobufs method within a service
760 (defclass protobuf-method (base-protobuf)
761 ((client-fn :type symbol ;the Lisp name of the client stb
762 :accessor proto-client-stub
763 :initarg :client-stub)
764 (server-fn :type symbol ;the Lisp name of the server stb
765 :accessor proto-server-stub
766 :initarg :server-stub)
767 (itype :type symbol ;the Lisp type name of the input
768 :accessor proto-input-type
769 :initarg :input-type)
770 (iname :type (or null string) ;the Protobufs name of the input
771 :accessor proto-input-name
774 (otype :type symbol ;the Lisp type name of the output
775 :accessor proto-output-type
776 :initarg :output-type)
777 (oname :type (or null string) ;the Protobufs name of the output
778 :accessor proto-output-name
779 :initarg :output-name
781 (stype :type (or symbol null) ;the Lisp type name of the "streams" type
782 :accessor proto-streams-type
783 :initarg :streams-type
785 (sname :type (or null string) ;the Protobufs name of the "streams" type
786 :accessor proto-streams-name
787 :initarg :streams-name
789 (index :type (unsigned-byte 32) ;an identifying index for this method
790 :accessor proto-index ; (used by the RPC implementation)
793 "The model class that represents one method with a Protobufs service."))
795 (defmethod make-load-form ((m protobuf-method) &optional environment)
796 (make-load-form-saving-slots m :environment environment))
798 (defmethod print-object ((m protobuf-method) stream)
800 (print-unreadable-object (m stream :type t :identity t)
801 (format stream "~S (~S) => (~S)"
803 (and (slot-boundp m 'itype) (proto-input-type m))
804 (and (slot-boundp m 'otype) (proto-output-type m))))
805 (format stream "~S" (proto-class m))))
808 ;;; Lisp-only extensions
810 ;; A Protobufs message
811 (defclass protobuf-type-alias (base-protobuf)
812 ((lisp-type :reader proto-lisp-type ;a Lisp type specifier
814 (proto-type :reader proto-proto-type ;a .proto type specifier
815 :initarg :proto-type)
816 (proto-type-str :reader proto-proto-type-str
817 :initarg :proto-type-str)
818 (serializer :reader proto-serializer ;Lisp -> Protobufs conversion function
819 :initarg :serializer)
820 (deserializer :reader proto-deserializer ;Protobufs -> Lisp conversion function
821 :initarg :deserializer))
823 "The model class that represents a Protobufs type alias."))
825 (defmethod make-load-form ((m protobuf-type-alias) &optional environment)
826 (make-load-form-saving-slots m :environment environment))
828 (defmethod print-object ((m protobuf-type-alias) stream)
830 (print-unreadable-object (m stream :type t :identity t)
831 (format stream "~S (maps ~S to ~S)"
833 (proto-lisp-type m) (proto-proto-type m)))
834 (format stream "~S" (proto-class m))))
836 (defgeneric find-type-alias (protobuf type)
838 "Given a Protobufs schema or message and the name of a type alias,
839 returns the Protobufs type alias corresponding to the name."))
841 (defmethod find-type-alias ((schema protobuf-schema) (type symbol))
842 (labels ((find-it (schema)
843 (let ((alias (find type (proto-type-aliases schema) :key #'proto-class)))
845 (return-from find-type-alias alias))
846 (map () #'find-it (proto-imported-schemas schema)))))
849 (defmethod find-type-alias ((message protobuf-message) type)
850 (or (find type (proto-type-aliases message) :key #'proto-class)
851 (find-type-alias (proto-parent message) type)))