1 ;;; dbus-codegen.el --- Lisp code generation for D-Bus. -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2015 Free Software Foundation, Inc.
5 ;; Author: Daiki Ueno <ueno@gnu.org>
6 ;; Keywords: comm, dbus, convenience
7 ;; Package-Requires: ((cl-lib "0.5"))
9 ;; Maintainer: emacs-devel@gnu.org
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 ;; This package provides macros and functions to make D-Bus
29 ;; client/server implementation easy, inspired by the `gdbus-codegen'
30 ;; utility in GLib. To get it work, `lexical-binding' must be
35 ;; A proxy object representing a D-Bus client can be defined with
36 ;; either `dbus-codegen-define-proxy' or `dbus-codegen-make-proxy'.
38 ;; `dbus-codegen-define-proxy' takes a static XML definition of a
39 ;; D-Bus service and generates code at compile time. This is good for
40 ;; stable D-Bus services. On the other hand,
41 ;; `dbus-codegen-make-proxy' uses D-Bus introspection and retrieves a
42 ;; D-Bus service definition from a running service itself. This is
43 ;; good for debugging or for unstable D-Bus services.
47 ;; Suppose the following code:
49 ;; (dbus-codegen-define-proxy test-proxy
52 ;; <interface name='org.example.Test'>
53 ;; <method name='OpenFile'>
54 ;; <arg type='s' name='path' direction='in'/>
56 ;; <signal name='Changed'>
57 ;; <arg type='s' name='a_string'/>
59 ;; <property type='s' name='Content' access='read'/>
62 ;; "org.example.Test")
64 ;; The `dbus-codegen-define-proxy' macro expands to a definition a
65 ;; struct `test-proxy' with a slot `content', which corresponds to the
66 ;; "Content" property. The slot value will be initialized when the
67 ;; proxy is created and updated when the server sends a notification.
68 ;; The proxy can always retrieve the value with the function
69 ;; `PROXY-retrieve-PROPERTY-property'.
71 ;; The macro also defines the following wrapper functions:
73 ;; - `test-proxy-create'
74 ;; constructor of the proxy
75 ;; - `test-proxy-destroy'
76 ;; destructor of the proxy
77 ;; - `test-proxy-open-file'
78 ;; wrapper around calling the "OpenFile" method
79 ;; - `test-proxy-open-file-asynchronously'
80 ;; asynchronous wrapper around calling the "OpenFile" method
81 ;; - `test-proxy-send-changed-signal'
82 ;; wrapper around sending the "Changed" signal
83 ;; - `test-proxy-register-changed-signal'
84 ;; wrapper around registering a handler for the "Changed" signal
85 ;; - `test-proxy-retrieve-content-property'
86 ;; retrieve the value of the "Content" property
88 ;; In addition to those, the macro also defines a generic function
89 ;; `test-proxy-handle-changed-signal' to allow a class-wide signal
90 ;; handler definition.
92 ;; To register a class-wide signal handler, define a method
93 ;; `test-proxy-handle-changed-signal' with `cl-defmethod', like this:
95 ;; (cl-defmethod test-proxy-handle-changed-signal ((proxy test-proxy) string)
96 ;; ... do something with PROXY and STRING ...)
100 ;; A skeleton object representing a D-Bus server can be defined with
101 ;; `dbus-codegen-define-skeleton'.
103 ;; `dbus-codegen-define-skeleton' takes a static XML definition of a
104 ;; D-Bus service and generates code at compile time.
108 ;; Suppose the following code:
110 ;; (dbus-codegen-define-skeleton test-skeleton
113 ;; <interface name='org.example.Test'>
114 ;; <method name='OpenFile'>
115 ;; <arg type='s' name='path' direction='in'/>
117 ;; <signal name='Changed'>
118 ;; <arg type='s' name='a_string'/>
120 ;; <property type='s' name='Content' access='read'/>
123 ;; "org.example.Test")
125 ;; The `dbus-codegen-define-skeleton' macro expands to a definition a
126 ;; struct `test-skeleton' with a slot `content', which corresponds to the
127 ;; "Content" property.
129 ;; The macro also defines the following wrapper functions:
131 ;; - `test-skeleton-create'
132 ;; constructor of the skeleton
133 ;; - `test-skeleton-destroy'
134 ;; destructor of the skeleton
135 ;; - `test-skeleton-register-open-file-method'
136 ;; wrapper around registering a handler for the "OpenFile" method
137 ;; - `test-skeleton-send-changed-signal'
138 ;; wrapper around sending the "Changed" signal
139 ;; - `test-skeleton-register-changed-signal'
140 ;; wrapper around registering a handler for the "Changed" signal
141 ;; - `test-skeleton-register-content-property'
142 ;; wrapper around registering a value of the "Content" property
144 ;; In addition to those, the macro also defines a generic function
145 ;; `test-skeleton-handle-open-file-method' to allow a class-wide method
146 ;; handler definition.
148 ;; To register a class-wide method handler, define a method
149 ;; `test-skeleton-handle-open-file-method' with `cl-defmethod', like this:
151 ;; (cl-defmethod test-skeleton-handle-open-file-method ((skeleton test-skeleton)
153 ;; ... do something with SKELETON and STRING ...)
157 ;; - function documentation generation from annotations
168 ;; Base type of a D-Bus proxy and a skeleton.
169 (cl-defstruct (dbus-codegen-object
172 (service :read-only t)
174 (interface :read-only t)
177 ;; Base type of a D-Bus proxy.
178 (cl-defstruct (dbus-codegen-proxy
179 (:include dbus-codegen-object)
182 ;; Base type of a D-Bus skeleton
183 (cl-defstruct (dbus-codegen-skeleton
184 (:include dbus-codegen-object)
187 ;; Return a list of elements in the form: (LISP-NAME ORIG-NAME MEMBER).
188 (defun dbus-codegen--apply-transform-name (elements transform-name)
189 (mapcar (lambda (elements)
190 (let ((name (xml-get-attribute-or-nil elements 'name)))
192 (error "missing \"name\" attribute of %s"
193 (xml-node-name elements)))
194 (list (funcall transform-name name)
199 ;; Return a list of symbols.
200 (defun dbus-codegen--collect-arglist (args transform-name)
205 (xml-get-attribute-or-nil (nth 2 arg) 'direction)))
206 (if (or (null direction)
207 (equal direction "in"))
208 (intern (car arg)))))
209 (dbus-codegen--apply-transform-name args transform-name))))
211 (defconst dbus-codegen--basic-type-to-symbol-alist
224 "Mapping from D-Bus type-codes to Lisp symbols.")
226 ;; Read a single type from SIGNATURE. Returns a cons cell of
227 ;; (NEXT-OFFSET . TYPE).
228 (defun dbus-codegen--read-signature (signature offset)
229 (let* ((c (aref signature offset))
230 (entry (assq c dbus-codegen--basic-type-to-symbol-alist)))
232 (cons (1+ offset) (cdr entry))
235 (let* ((type1 (dbus-codegen--read-signature signature (1+ offset)))
236 (type2 (dbus-codegen--read-signature signature (car type1))))
237 (unless (eq (aref signature (car type2)) ?})
238 (error "Unterminated dict-entry"))
239 (cons (car type2) (list :dict-entry (cdr type1) (cdr type2)))))
241 (let ((next-offset (1+ offset))
244 (while (and (< next-offset (length signature))
245 (not (eq (setq c (aref signature next-offset)) ?\))))
246 (setq type (dbus-codegen--read-signature signature next-offset)
247 next-offset (car type))
248 (push (cdr type) types))
249 (unless (eq (aref signature (car type)) ?\))
250 (error "Unterminated struct"))
251 (cons next-offset (list :struct (nreverse types)))))
253 (unless (< (1+ offset) (length signature))
254 (error "Unterminated array"))
255 (let ((type (dbus-codegen--read-signature signature (1+ offset))))
256 (cons (car type) (list :array (cdr type)))))
258 (cons (1+ offset) (list :variant)))))))
260 (defun dbus-codegen--byte-p (value)
261 (and (integerp value)
264 (defun dbus-codegen--int16-p (value)
265 (and (integerp value)
266 (<= (- (- #x7FFF) 1) value #x7FFF)))
268 (defun dbus-codegen--uint16-p (value)
269 (and (integerp value)
270 (<= 0 value #xFFFF)))
272 (defun dbus-codegen--object-path-p (value)
274 (string-match "\\`/\\'\\|\\`\\(?:/\\(?:[A-Za-z0-9_]+\\)\\)+\\'" value)))
276 (defconst dbus-codegen--basic-type-check-alist
277 '((:byte . dbus-codegen--byte-p)
278 (:boolean . booleanp)
279 (:int16 . dbus-codegen--int16-p)
280 (:uint16 . dbus-codegen--uint16-p)
287 (:object-path . dbus-codegen--object-path-p)
288 (:signature . stringp)
289 (:unix-fd . natnump))
290 "An alist mapping from Lisp symbols to predicates that check value types.")
292 (defun dbus-codegen--annotate-arg (type arg)
294 ((and basic (or :byte :boolean :int16 :uint16 :int32 :uint32 :int64 :uint64
295 :double :string :object-path :signature :unix-fd))
296 (let ((entry (assq basic dbus-codegen--basic-type-check-alist)))
298 (not (funcall (cdr entry) arg)))
299 (signal 'wrong-type-argument (list (cdr entry) arg))))
302 ;; FIXME: an empty array must have a `:signature' element to
303 ;; denote the element type.
306 (mapcar (lambda (subarg)
307 (dbus-codegen--annotate-arg elttype subarg))
309 (`(:struct . ,memtypes)
310 (list (cons :struct (apply #'nconc
312 (lambda (memtype subarg)
313 (dbus-codegen--annotate-arg memtype subarg))
316 (list (cons :variant (apply #'nconc
317 (mapcar (lambda (subarg) (list subarg))
319 (`(:dict-entry ,keytype ,valtype)
320 (list (cons :dict-entry
321 (nconc (dbus-codegen--annotate-arg keytype (car arg))
322 (dbus-codegen--annotate-arg valtype (cdr arg))))))
323 (_ (error "Unknown type specification: %S" type))))
325 (defun dbus-codegen--collect-arglist-with-type-annotation (args transform-name)
329 (xml-get-attribute-or-nil (nth 2 arg) 'direction))
331 (xml-get-attribute-or-nil (nth 2 arg) 'type)))
332 (if (or (null direction)
333 (equal direction "in"))
334 (let ((signature (dbus-codegen--read-signature type 0)))
335 `(dbus-codegen--annotate-arg ,(cdr signature)
336 ,(intern (car arg)))))))
337 (dbus-codegen--apply-transform-name args transform-name))))
339 (declare-function subword-forward "subword.el" (&optional arg))
340 (defun dbus-codegen-transform-name (name)
341 "Transform NAME into suitable Lisp function name."
346 (goto-char (point-min))
348 ;; Skip characters not recognized by subword-mode.
349 (if (looking-at "[^[:lower:][:upper:][:digit:]]+")
350 (goto-char (match-end 0)))
351 (push (downcase (buffer-substring (point) (progn (subword-forward 1)
354 (mapconcat #'identity (nreverse words) "-"))))
356 ;; Emit wrappers around `dbus-call-method'.
357 (defun dbus-codegen--emit-call-method (name methods transform-name)
362 (let ((arglist (dbus-codegen--collect-arglist
364 (car (xml-get-children method 'method))
368 (dbus-codegen--collect-arglist-with-type-annotation
370 (car (xml-get-children method 'method)) 'arg)
373 ,(intern (format "%s-%s" name (car method)))
374 (object ,@arglist &rest args)
375 ,(format "Call the \"%s\" method of OBJECT."
378 ,(intern (format "%s-%s" name (car method)))
379 ((object ,name) ,@arglist &rest args)
380 (apply #'dbus-call-method
381 (,(intern (format "%s-bus" name )) object)
382 (,(intern (format "%s-service" name)) object)
383 (,(intern (format "%s-path" name)) object)
384 (,(intern (format "%s-interface" name)) object)
386 (append ,@annotated-arglist args))))))
389 ;; Emit wrappers around `dbus-call-method-asynchronously'.
390 (defun dbus-codegen--emit-call-method-asynchronously (name methods
396 (let ((arglist (dbus-codegen--collect-arglist
398 (car (xml-get-children method 'method))
402 (dbus-codegen--collect-arglist-with-type-annotation
404 (car (xml-get-children method 'method))
408 ,(intern (format "%s-%s-asynchronously"
410 ((object ,name) ,@arglist handler &rest args)
411 ,(format "Asynchronously call the \"%s\" method of OBJECT."
414 ,(intern (format "%s-%s-asynchronously"
416 ((object ,name) ,@arglist handler &rest args)
417 (apply #'dbus-call-method-asynchronously
418 (,(intern (format "%s-bus" name )) object)
419 (,(intern (format "%s-service" name)) object)
420 (,(intern (format "%s-path" name)) object)
421 (,(intern (format "%s-interface" name)) object)
424 (append ,@annotated-arglist args))))))
427 ;; Emit wrappers around `dbus-register-signal'.
428 (defun dbus-codegen--emit-register-signal (name signals)
434 ,(intern (format "%s-register-%s-signal" name (car signal)))
435 (object handler &rest args)
436 ,(format "Register HANDLER to the \"%s\" signal of OBJECT."
439 ,(intern (format "%s-register-%s-signal" name (car signal)))
440 ((object ,name) handler &rest args)
441 (push (apply #'dbus-register-signal
442 (,(intern (format "%s-bus" name )) object)
443 (,(intern (format "%s-service" name)) object)
444 (,(intern (format "%s-path" name)) object)
445 (,(intern (format "%s-interface" name)) object)
448 (apply handler object args))
450 (,(intern (format "%s-registration-list" name)) object)))))
453 ;; Emit wrappers around `dbus-send-signal'.
454 (defun dbus-codegen--emit-send-signal (name signals transform-name)
459 (let ((arglist (dbus-codegen--collect-arglist
461 (car (xml-get-children signal 'signal))
465 (dbus-codegen--collect-arglist-with-type-annotation
467 (car (xml-get-children signal 'signal))
471 ,(intern (format "%s-send-%s-signal"
473 (object ,@arglist &rest args)
474 ,(format "Send the \"%s\" signal of OBJECT."
477 ,(intern (format "%s-send-%s-signal"
479 ((object ,name) ,@arglist &rest args)
480 (apply #'dbus-send-signal
481 (,(intern (format "%s-bus" name )) object)
482 (,(intern (format "%s-service" name)) object)
483 (,(intern (format "%s-path" name)) object)
484 (,(intern (format "%s-interface" name)) object)
486 (append ,@annotated-arglist args))))))
489 ;; Emit generic functions for signal handlers.
490 (defun dbus-codegen--emit-signal-defgeneric (name signals transform-name)
493 (let ((arglist (dbus-codegen--collect-arglist
495 (car (xml-get-children signal 'signal))
499 ,(intern (format "%s-handle-%s-signal" name (car signal)))
501 ,(format "Generic function called upon receiving the \"%s\" signal."
503 (list object ,@arglist)
507 ;; Emit wrappers around `dbus-get-property'.
508 (defun dbus-codegen--emit-retrieve-property (name properties)
514 ,(intern (format "%s-retrieve-%s-property"
515 name (car property)))
517 ,(format "Retrieve the value of the \"%s\" property of OBJECT."
520 ,(intern (format "%s-retrieve-%s-property"
521 name (car property)))
523 (setf (,(intern (format "%s-%s" name (car property)))
526 (,(intern (format "%s-bus" name )) object)
527 (,(intern (format "%s-service" name)) object)
528 (,(intern (format "%s-path" name)) object)
529 (,(intern (format "%s-interface" name)) object)
530 ,(nth 1 property))))))
533 ;; Emit generic functions for method handlers.
534 (defun dbus-codegen--emit-method-defgeneric (name methods transform-name)
537 (let ((arglist (dbus-codegen--collect-arglist
539 (car (xml-get-children method 'method))
543 ,(intern (format "%s-handle-%s-method" name (car method)))
545 ,(format "Generic function called when the \"%s\" method is called."
547 (list object ,@arglist)
551 ;; Emit wrappers around `dbus-register-method'.
552 (defun dbus-codegen--emit-register-method (name methods)
558 ,(intern (format "%s-register-%s-method" name (car method)))
559 (object handler &rest args)
560 ,(format "Register HANDLER to the \"%s\" method of OBJECT."
563 ,(intern (format "%s-register-%s-method" name (car method)))
564 ((object ,name) handler &rest args)
565 (push (apply #'dbus-register-method
566 (,(intern (format "%s-bus" name )) object)
567 (,(intern (format "%s-service" name)) object)
568 (,(intern (format "%s-path" name)) object)
569 (,(intern (format "%s-interface" name)) object)
572 (apply handler object args))
574 (,(intern (format "%s-registration-list" name)) object)))))
577 ;; Emit wrappers around `dbus-register-property'.
578 (defun dbus-codegen--emit-register-property (name properties)
588 (xml-get-attribute-or-nil annotation 'name)
589 "org.freedesktop.DBus.Property.EmitsChangedSignal")
591 (xml-get-children (nth 2 property) 'annotation))))
593 (or (null annotations)
594 (not (equal (xml-get-attribute-or-nil (car annotations)
598 ,(intern (format "%s-register-%s-property" name (car property)))
599 (object value &rest args)
600 ,(format "Register VALUE of the \"%s\" property of OBJECT."
603 ,(intern (format "%s-register-%s-property" name (car property)))
604 ((object ,name) value &rest args)
605 (setf (,(intern (format "%s-%s" name (car property))) object) value)
606 (push (apply #'dbus-register-property
607 (,(intern (format "%s-bus" name )) object)
608 (,(intern (format "%s-service" name)) object)
609 (,(intern (format "%s-path" name)) object)
610 (,(intern (format "%s-interface" name)) object)
614 (list :emits-signal t))
616 (,(intern (format "%s-registration-list" name)) object))))))
620 (defmacro dbus-codegen-define-proxy (name xml interface &rest args)
621 "Define a new D-Bus proxy NAME.
622 This defines a new struct type for the proxy and convenient
623 functions for D-Bus method calls and signal registration.
625 XML is either a string which defines the interface of the D-Bus
626 proxy, or a Lisp form which returns a string. The format of the
627 string must comply with the standard D-Bus introspection data
628 format as described in:
629 `http://dbus.freedesktop.org/doc/dbus-specification.html#introspection-format>'.
631 INTERFACE is a name of interface which is represented by this
634 ARGS are keyword-value pair. Currently only one keyword is
637 :transform-name FUNCTION -- FUNCTION is a function which converts
638 D-Bus method/signal/property names, into another representation.
639 By default `dbus-codegen-transform-name' is used."
640 (unless (symbolp name)
641 (signal 'wrong-type-argument (list 'symbolp name)))
642 ;; Accept a Lisp form as well as a string.
643 (unless (stringp xml)
644 (setq xml (eval xml)))
645 (unless (stringp xml)
646 (signal 'wrong-type-argument (list 'stringp xml)))
647 (let ((node (car (with-temp-buffer
649 (xml-parse-region (point-min) (point-max)))))
650 (transform-name (or (plist-get args :transform-name)
651 #'dbus-codegen-transform-name)))
652 (unless (eq (xml-node-name node) 'node)
653 (error "Root is not \"node\""))
654 ;; Accept a quoted form of a function, such as #'func.
655 (unless (functionp transform-name)
656 (setq transform-name (eval transform-name)))
657 (let ((interface-node
658 (cl-find-if (lambda (element)
659 (equal (xml-get-attribute-or-nil element 'name)
661 (xml-get-children node 'interface))))
662 (unless interface-node
663 (error "Interface %s is missing" interface))
664 (let ((methods (dbus-codegen--apply-transform-name
665 (xml-get-children interface-node 'method)
667 (properties (dbus-codegen--apply-transform-name
668 (xml-get-children interface-node 'property)
670 (signals (dbus-codegen--apply-transform-name
671 (xml-get-children interface-node 'signal)
674 ;; Define a new struct.
675 (cl-defstruct (,name (:include dbus-codegen-proxy)
677 (:constructor ,(intern (format "%s--make" name))
678 (bus service path interface)))
679 ;; Slots for cached property values.
682 (intern (car property)))
685 ;; Define a constructor.
686 (defun ,(intern (format "%s-create" name)) (bus service path)
687 ,(format "Create a new D-Bus proxy for %s.
689 BUS is either a Lisp symbol, `:system' or `:session', or a string
690 denoting the bus address.
692 SERVICE is the D-Bus service name to be used. PATH is the D-Bus
693 object path SERVICE is registered at. INTERFACE is an interface
696 (let ((proxy (,(intern (format "%s--make" name))
697 bus service path ,interface)))
700 `(let ((properties (dbus-get-all-properties bus service path
704 `(setf (,(intern (format "%s-%s" name (car property)))
706 (cdr (assoc ,(nth 1 property) properties))))
708 (push (dbus-register-signal
709 bus service path dbus-interface-properties
711 (lambda (interface changed invalidated)
712 (,(intern (format "%s--handle-properties-changed"
715 interface changed invalidated))
717 (,(intern (format "%s-registration-list" name))
719 ;; Register signal handlers.
722 `(push (dbus-register-signal
723 bus service path ,interface
726 (apply #',(intern (format "%s-handle-%s-signal"
729 (,(intern (format "%s-registration-list" name))
735 ;; Define a handler of PropertiesChanged signal.
736 `(defun ,(intern (format "%s--handle-properties-changed" name))
737 (proxy interface changed invalidated)
738 (when (equal interface ,interface)
741 `(let ((changed-value
742 (cdr (assoc ,(nth 1 property) changed)))
743 (invalidated-property
744 (car (member ,(nth 1 property) invalidated)))
747 (setf (,(intern (format "%s-%s"
748 name (car property)))
750 (car (car changed-value))))
751 (when invalidated-property
752 (setq invalidated-value
754 (,(intern (format "%s-bus" name)) proxy)
755 (,(intern (format "%s-service" name)) proxy)
756 (,(intern (format "%s-path" name)) proxy)
759 (when invalidated-value
760 (setf (,(intern (format "%s-%s"
761 name (car property)))
763 invalidated-value)))))
766 ;; Define a destructor.
767 (cl-defgeneric ,(intern (format "%s-destroy" name)) (proxy)
768 "Destroy a D-Bus proxy PROXY.")
770 (cl-defmethod ,(intern (format "%s-destroy" name)) ((proxy ,name))
771 (dolist (registration (,(intern (format "%s-registration-list"
774 (dbus-unregister-object registration))
775 (setf (,(intern (format "%s-registration-list" name)) proxy) nil))
777 ;; Emit common helper functions.
778 ,@(dbus-codegen--emit-signal-defgeneric name signals transform-name)
779 ,@(dbus-codegen--emit-send-signal name signals transform-name)
780 ,@(dbus-codegen--emit-register-signal name signals)
781 ;; Emit helper functions for proxy.
782 ,@(dbus-codegen--emit-call-method name methods transform-name)
783 ,@(dbus-codegen--emit-call-method-asynchronously name methods
785 ,@(dbus-codegen--emit-retrieve-property name properties))))))
788 (defun dbus-codegen-make-proxy (name bus service path interface &rest args)
789 "Create a new D-Bus proxy based on the introspection data.
791 If the data type of the D-Bus proxy is not yet defined, this will
792 define it with `dbus-codegen-define-proxy', under a type name NAME.
794 BUS is either a Lisp symbol, `:system' or `:session', or a string
795 denoting the bus address.
797 SERVICE is the D-Bus service name to be used. PATH is the D-Bus
798 object path SERVICE is registered at. INTERFACE is an interface
801 INTERFACE is an interface which is represented by this proxy.
803 ARGS are keyword-value pair. Currently only one keyword is
806 :redefine FLAG -- if FLAG is non-nil, redefine the data type and
807 associated functions.
809 Other keywords are same as `dbus-codegen-define-proxy'."
812 (let ((constructor (intern (format "%s-make" name))))
813 (if (or (plist-get args :redefine)
814 (not (fboundp constructor)))
815 (eval `(define-dbus-proxy ,(intern name)
816 ,(dbus-introspect bus service path)
819 (funcall constructor bus service path)))
821 (defmacro dbus-codegen-define-skeleton (name xml interface &rest args)
822 "Define a new D-Bus skeleton NAME.
823 This defines a new struct type for the skeleton and convenient
824 functions for D-Bus method calls and signal registration.
826 XML is either a string which defines the interface of the D-Bus
827 skeleton, or a Lisp form which returns a string. The format of the
828 string must comply with the standard D-Bus introspection data
829 format as described in:
830 `http://dbus.freedesktop.org/doc/dbus-specification.html#introspection-format>'.
832 INTERFACE is a name of interface which is represented by this
835 ARGS are keyword-value pair. Currently only one keyword is
838 :transform-name FUNCTION -- FUNCTION is a function which converts
839 D-Bus method/signal/property names, into another representation.
840 By default `dbus-codegen-transform-name' is used."
841 (unless (symbolp name)
842 (signal 'wrong-type-argument (list 'symbolp name)))
843 ;; Accept a Lisp form as well as a string.
844 (unless (stringp xml)
845 (setq xml (eval xml)))
846 (unless (stringp xml)
847 (signal 'wrong-type-argument (list 'stringp xml)))
848 (let ((node (car (with-temp-buffer
850 (xml-parse-region (point-min) (point-max)))))
851 (transform-name (or (plist-get args :transform-name)
852 #'dbus-codegen-transform-name)))
853 (unless (eq (xml-node-name node) 'node)
854 (error "Root is not \"node\""))
855 ;; Accept a quoted form of a function, such as #'func.
856 (unless (functionp transform-name)
857 (setq transform-name (eval transform-name)))
858 (let ((interface-node
859 (cl-find-if (lambda (element)
860 (equal (xml-get-attribute-or-nil element 'name)
862 (xml-get-children node 'interface))))
863 (unless interface-node
864 (error "Interface %s is missing" interface))
865 (let ((methods (dbus-codegen--apply-transform-name
866 (xml-get-children interface-node 'method)
868 (properties (dbus-codegen--apply-transform-name
869 (xml-get-children interface-node 'property)
871 (signals (dbus-codegen--apply-transform-name
872 (xml-get-children interface-node 'signal)
875 ;; Define a new struct.
876 (cl-defstruct (,name (:include dbus-codegen-skeleton)
878 (:constructor ,(intern (format "%s--make" name))
879 (bus service path interface)))
880 ;; Slots for cached property values.
883 (intern (car property)))
886 ;; Define a constructor.
887 (defun ,(intern (format "%s-create" name))
888 (bus service path &rest args)
889 ,(format "Create a new D-Bus skeleton for %s.
891 BUS is either a Lisp symbol, `:system' or `:session', or a string
892 denoting the bus address.
894 SERVICE is the D-Bus service name to be used. PATH is the D-Bus
895 object path SERVICE is registered at. INTERFACE is an interface
898 (let ((skeleton (,(intern (format "%s--make" name))
899 bus service path ,interface)))
900 (apply #'dbus-register-service bus service args)
901 ;; Register method handlers.
904 `(push (dbus-register-method
905 bus service path ,interface
908 (apply #',(intern (format "%s-handle-%s-method"
911 (,(intern (format "%s-registration-list" name))
916 ;; Define a destructor.
917 (cl-defgeneric ,(intern (format "%s-destroy" name)) (skeleton)
918 "Destroy a D-Bus skeleton SKELETON.")
920 (cl-defmethod ,(intern (format "%s-destroy" name)) ((skeleton ,name))
921 (dolist (registration (,(intern (format "%s-registration-list"
924 (dbus-unregister-object registration))
925 (setf (,(intern (format "%s-registration-list" name)) skeleton)
927 (dbus-unregister-service bus service))
929 ;; Emit common helper functions.
930 ,@(dbus-codegen--emit-signal-defgeneric name signals transform-name)
931 ,@(dbus-codegen--emit-send-signal name signals transform-name)
932 ,@(dbus-codegen--emit-register-signal name signals)
933 ;; Emit helper functions for skeleton.
934 ,@(dbus-codegen--emit-method-defgeneric name methods transform-name)
935 ,@(dbus-codegen--emit-register-method name methods)
936 ,@(dbus-codegen--emit-register-property name properties))))))
938 (provide 'dbus-codegen)
940 ;;; dbus-codegen.el ends here