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 ;; FIXME: A lot of redundancy with dbus-codegen-define-skeleton.
641 (unless (symbolp name)
642 (signal 'wrong-type-argument (list 'symbolp name)))
643 ;; Accept a Lisp form as well as a string.
644 (unless (stringp xml)
645 (setq xml (eval xml)))
646 (unless (stringp xml)
647 (signal 'wrong-type-argument (list 'stringp xml)))
648 (let ((node (car (with-temp-buffer
650 (xml-parse-region (point-min) (point-max)))))
651 (transform-name (or (plist-get args :transform-name)
652 #'dbus-codegen-transform-name)))
653 (unless (eq (xml-node-name node) 'node)
654 (error "Root is not \"node\""))
655 ;; Accept a quoted form of a function, such as #'func.
656 (unless (functionp transform-name)
657 (setq transform-name (eval transform-name)))
658 (let ((interface-node
659 (cl-find-if (lambda (element)
660 (equal (xml-get-attribute-or-nil element 'name)
662 (xml-get-children node 'interface))))
663 (unless interface-node
664 (error "Interface %s is missing" interface))
665 (let ((methods (dbus-codegen--apply-transform-name
666 (xml-get-children interface-node 'method)
668 (properties (dbus-codegen--apply-transform-name
669 (xml-get-children interface-node 'property)
671 (signals (dbus-codegen--apply-transform-name
672 (xml-get-children interface-node 'signal)
675 ;; Define a new struct.
676 (cl-defstruct (,name (:include dbus-codegen-proxy)
678 (:constructor ,(intern (format "%s--make" name))
679 (bus service path interface)))
680 ;; Slots for cached property values.
683 (intern (car property)))
686 ;; Define a constructor.
687 (defun ,(intern (format "%s-create" name)) (bus service path)
688 ,(format "Create a new D-Bus proxy for %s.
690 BUS is either a Lisp symbol, `:system' or `:session', or a string
691 denoting the bus address.
693 SERVICE is the D-Bus service name to be used. PATH is the D-Bus
694 object path SERVICE is registered at. INTERFACE is an interface
697 (let ((proxy (,(intern (format "%s--make" name))
698 bus service path ,interface)))
701 `(let ((properties (dbus-get-all-properties bus service path
705 `(setf (,(intern (format "%s-%s" name (car property)))
707 (cdr (assoc ,(nth 1 property) properties))))
709 (push (dbus-register-signal
710 bus service path dbus-interface-properties
712 (lambda (interface changed invalidated)
713 (,(intern (format "%s--handle-properties-changed"
716 interface changed invalidated))
718 (,(intern (format "%s-registration-list" name))
720 ;; Register signal handlers.
723 `(push (dbus-register-signal
724 bus service path ,interface
727 (apply #',(intern (format "%s-handle-%s-signal"
730 (,(intern (format "%s-registration-list" name))
736 ;; Define a handler of PropertiesChanged signal.
737 `(defun ,(intern (format "%s--handle-properties-changed" name))
738 (proxy interface changed invalidated)
739 (when (equal interface ,interface)
742 `(let ((changed-value
743 (cdr (assoc ,(nth 1 property) changed)))
744 (invalidated-property
745 (car (member ,(nth 1 property) invalidated)))
748 (setf (,(intern (format "%s-%s"
749 name (car property)))
751 (car (car changed-value))))
752 (when invalidated-property
753 (setq invalidated-value
755 (,(intern (format "%s-bus" name)) proxy)
756 (,(intern (format "%s-service" name)) proxy)
757 (,(intern (format "%s-path" name)) proxy)
760 (when invalidated-value
761 (setf (,(intern (format "%s-%s"
762 name (car property)))
764 invalidated-value)))))
767 ;; Define a destructor.
768 (cl-defgeneric ,(intern (format "%s-destroy" name)) (proxy)
769 "Destroy a D-Bus proxy PROXY.")
771 (cl-defmethod ,(intern (format "%s-destroy" name)) ((proxy ,name))
772 (dolist (registration (,(intern (format "%s-registration-list"
775 (dbus-unregister-object registration))
776 (setf (,(intern (format "%s-registration-list" name)) proxy) nil))
778 ;; Emit common helper functions.
779 ,@(dbus-codegen--emit-signal-defgeneric name signals transform-name)
780 ,@(dbus-codegen--emit-send-signal name signals transform-name)
781 ,@(dbus-codegen--emit-register-signal name signals)
782 ;; Emit helper functions for proxy.
783 ,@(dbus-codegen--emit-call-method name methods transform-name)
784 ,@(dbus-codegen--emit-call-method-asynchronously name methods
786 ,@(dbus-codegen--emit-retrieve-property name properties))))))
789 (defun dbus-codegen-make-proxy (name bus service path interface &rest args)
790 "Create a new D-Bus proxy based on the introspection data.
792 If the data type of the D-Bus proxy is not yet defined, this will
793 define it with `dbus-codegen-define-proxy', under a type name NAME.
795 BUS is either a Lisp symbol, `:system' or `:session', or a string
796 denoting the bus address.
798 SERVICE is the D-Bus service name to be used. PATH is the D-Bus
799 object path SERVICE is registered at. INTERFACE is an interface
802 INTERFACE is an interface which is represented by this proxy.
804 ARGS are keyword-value pair. Currently only one keyword is
807 :redefine FLAG -- if FLAG is non-nil, redefine the data type and
808 associated functions.
810 Other keywords are same as `dbus-codegen-define-proxy'."
813 (let ((constructor (intern (format "%s--make" name))))
814 (if (or (plist-get args :redefine)
815 (not (fboundp constructor)))
816 (eval `(dbus-codegen-define-proxy ,name
817 ,(dbus-introspect bus service path)
820 (funcall constructor bus service path)))
822 (defmacro dbus-codegen-define-skeleton (name xml interface &rest args)
823 "Define a new D-Bus skeleton NAME.
824 This defines a new struct type for the skeleton and convenient
825 functions for D-Bus method calls and signal registration.
827 XML is either a string which defines the interface of the D-Bus
828 skeleton, or a Lisp form which returns a string. The format of the
829 string must comply with the standard D-Bus introspection data
830 format as described in:
831 `http://dbus.freedesktop.org/doc/dbus-specification.html#introspection-format>'.
833 INTERFACE is a name of interface which is represented by this
836 ARGS are keyword-value pair. Currently only one keyword is
839 :transform-name FUNCTION -- FUNCTION is a function which converts
840 D-Bus method/signal/property names, into another representation.
841 By default `dbus-codegen-transform-name' is used."
842 ;; FIXME: A lot of redundancy with dbus-codegen-define-proxy.
843 (unless (symbolp name)
844 (signal 'wrong-type-argument (list 'symbolp name)))
845 ;; Accept a Lisp form as well as a string.
846 (unless (stringp xml)
847 (setq xml (eval xml)))
848 (unless (stringp xml)
849 (signal 'wrong-type-argument (list 'stringp xml)))
850 (let ((node (car (with-temp-buffer
852 (xml-parse-region (point-min) (point-max)))))
853 (transform-name (or (plist-get args :transform-name)
854 #'dbus-codegen-transform-name)))
855 (unless (eq (xml-node-name node) 'node)
856 (error "Root is not \"node\""))
857 ;; Accept a quoted form of a function, such as #'func.
858 (unless (functionp transform-name)
859 (setq transform-name (eval transform-name)))
860 (let ((interface-node
861 (cl-find-if (lambda (element)
862 (equal (xml-get-attribute-or-nil element 'name)
864 (xml-get-children node 'interface))))
865 (unless interface-node
866 (error "Interface %s is missing" interface))
867 (let ((methods (dbus-codegen--apply-transform-name
868 (xml-get-children interface-node 'method)
870 (properties (dbus-codegen--apply-transform-name
871 (xml-get-children interface-node 'property)
873 (signals (dbus-codegen--apply-transform-name
874 (xml-get-children interface-node 'signal)
877 ;; Define a new struct.
878 (cl-defstruct (,name (:include dbus-codegen-skeleton)
880 (:constructor ,(intern (format "%s--make" name))
881 (bus service path interface)))
882 ;; Slots for cached property values.
885 (intern (car property)))
888 ;; Define a constructor.
889 (defun ,(intern (format "%s-create" name))
890 (bus service path &rest args)
891 ,(format "Create a new D-Bus skeleton for %s.
893 BUS is either a Lisp symbol, `:system' or `:session', or a string
894 denoting the bus address.
896 SERVICE is the D-Bus service name to be used. PATH is the D-Bus
897 object path SERVICE is registered at. INTERFACE is an interface
900 (let ((skeleton (,(intern (format "%s--make" name))
901 bus service path ,interface)))
902 (apply #'dbus-register-service bus service args)
903 ;; Register method handlers.
906 `(push (dbus-register-method
907 bus service path ,interface
910 (apply #',(intern (format "%s-handle-%s-method"
913 (,(intern (format "%s-registration-list" name))
918 ;; Define a destructor.
919 (cl-defgeneric ,(intern (format "%s-destroy" name)) (skeleton)
920 "Destroy a D-Bus skeleton SKELETON.")
922 (cl-defmethod ,(intern (format "%s-destroy" name)) ((skeleton ,name))
923 (dolist (registration (,(intern (format "%s-registration-list"
926 (dbus-unregister-object registration))
927 (setf (,(intern (format "%s-registration-list" name)) skeleton)
929 (dbus-unregister-service bus service))
931 ;; Emit common helper functions.
932 ,@(dbus-codegen--emit-signal-defgeneric name signals transform-name)
933 ,@(dbus-codegen--emit-send-signal name signals transform-name)
934 ,@(dbus-codegen--emit-register-signal name signals)
935 ;; Emit helper functions for skeleton.
936 ,@(dbus-codegen--emit-method-defgeneric name methods transform-name)
937 ,@(dbus-codegen--emit-register-method name methods)
938 ,@(dbus-codegen--emit-register-property name properties))))))
940 (provide 'dbus-codegen)
942 ;;; dbus-codegen.el ends here