code.delx.au - gnu-emacs-elpa/blob - packages/dbus-codegen/dbus-codegen.el

   1 ;;; dbus-codegen.el --- Lisp code generation for D-Bus. -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2015 Free Software Foundation, Inc.
   4
   5 ;; Author: Daiki Ueno <ueno@gnu.org>
   6 ;; Keywords: comm, dbus, convenience
   7 ;; Package-Requires: ((cl-lib "0.5"))
   8 ;; Version: 0.1
   9 ;; Maintainer: emacs-devel@gnu.org
  10
  11 ;; This file is part of GNU Emacs.
  12
  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.
  17
  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.
  22
  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/>.
  25
  26 ;;; Commentary:
  27
  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
  31 ;; enabled.
  32 ;;
  33 ;; * Client support
  34 ;;
  35 ;; A proxy object representing a D-Bus client can be defined with
  36 ;; either `dbus-codegen-define-proxy' or `dbus-codegen-make-proxy'.
  37 ;;
  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.
  44 ;;
  45 ;; ** Example
  46 ;;
  47 ;; Suppose the following code:
  48 ;;
  49 ;; (dbus-codegen-define-proxy test-proxy
  50 ;;                            "\
  51 ;; <node>
  52 ;;   <interface name='org.example.Test'>
  53 ;;     <method name='OpenFile'>
  54 ;;       <arg type='s' name='path' direction='in'/>
  55 ;;     </method>
  56 ;;     <signal name='Changed'>
  57 ;;       <arg type='s' name='a_string'/>
  58 ;;     </signal>
  59 ;;     <property type='s' name='Content' access='read'/>
  60 ;;   </interface>
  61 ;; </node>"
  62 ;;                            "org.example.Test")
  63 ;;
  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'.
  70 ;;
  71 ;; The macro also defines the following wrapper functions:
  72 ;;
  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
  87 ;;
  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.
  91 ;;
  92 ;; To register a class-wide signal handler, define a method
  93 ;; `test-proxy-handle-changed-signal' with `cl-defmethod', like this:
  94 ;;
  95 ;; (cl-defmethod test-proxy-handle-changed-signal ((proxy test-proxy) string)
  96 ;;   ... do something with PROXY and STRING ...)
  97 ;;
  98 ;; * Server support
  99 ;;
 100 ;; A skeleton object representing a D-Bus server can be defined with
 101 ;; `dbus-codegen-define-skeleton'.
 102 ;;
 103 ;; `dbus-codegen-define-skeleton' takes a static XML definition of a
 104 ;; D-Bus service and generates code at compile time.
 105 ;;
 106 ;; ** Example
 107 ;;
 108 ;; Suppose the following code:
 109 ;;
 110 ;; (dbus-codegen-define-skeleton test-skeleton
 111 ;;                            "\
 112 ;; <node>
 113 ;;   <interface name='org.example.Test'>
 114 ;;     <method name='OpenFile'>
 115 ;;       <arg type='s' name='path' direction='in'/>
 116 ;;     </method>
 117 ;;     <signal name='Changed'>
 118 ;;       <arg type='s' name='a_string'/>
 119 ;;     </signal>
 120 ;;     <property type='s' name='Content' access='read'/>
 121 ;;   </interface>
 122 ;; </node>"
 123 ;;                            "org.example.Test")
 124 ;;
 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.
 128 ;;
 129 ;; The macro also defines the following wrapper functions:
 130 ;;
 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
 143 ;;
 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.
 147 ;;
 148 ;; To register a class-wide method handler, define a method
 149 ;; `test-skeleton-handle-open-file-method' with `cl-defmethod', like this:
 150 ;;
 151 ;; (cl-defmethod test-skeleton-handle-open-file-method ((skeleton test-skeleton)
 152 ;;                                                      string)
 153 ;;   ... do something with SKELETON and STRING ...)
 154 ;;
 155 ;; * TODO
 156 ;;
 157 ;; - function documentation generation from annotations
 158
 159 ;;; Code:
 160
 161 (require 'dbus)
 162 (require 'cl-lib)
 163
 164 (eval-when-compile
 165   (require 'xml)
 166   (require 'subword))
 167
 168 ;; Base type of a D-Bus proxy and a skeleton.
 169 (cl-defstruct (dbus-codegen-object
 170                (:constructor nil))
 171   (bus :read-only t)
 172   (service :read-only t)
 173   (path :read-only t)
 174   (interface :read-only t)
 175   registration-list)
 176
 177 ;; Base type of a D-Bus proxy.
 178 (cl-defstruct (dbus-codegen-proxy
 179                (:include dbus-codegen-object)
 180                (:constructor nil)))
 181
 182 ;; Base type of a D-Bus skeleton
 183 (cl-defstruct (dbus-codegen-skeleton
 184                (:include dbus-codegen-object)
 185                (:constructor nil)))
 186
 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)))
 191                 (unless name
 192                   (error "missing \"name\" attribute of %s"
 193                          (xml-node-name elements)))
 194                 (list (funcall transform-name name)
 195                       name
 196                       elements)))
 197           elements))
 198
 199 ;; Return a list of symbols.
 200 (defun dbus-codegen--collect-arglist (args transform-name)
 201   (delq nil
 202         (mapcar
 203          (lambda (arg)
 204            (let ((direction
 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))))
 210
 211 (defconst dbus-codegen--basic-type-to-symbol-alist
 212   '((?y . :byte)
 213     (?b . :boolean)
 214     (?n . :int16)
 215     (?q . :uint16)
 216     (?i . :int32)
 217     (?u . :uint32)
 218     (?x . :int64)
 219     (?t . :uint64)
 220     (?d . :double)
 221     (?s . :string)
 222     (?o . :object-path)
 223     (?g . :signature))
 224   "Mapping from D-Bus type-codes to Lisp symbols.")
 225
 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)))
 231     (if entry
 232         (cons (1+ offset) (cdr entry))
 233       (pcase c
 234         (?{
 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)))))
 240         (?\(
 241          (let ((next-offset (1+ offset))
 242                types
 243                type)
 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)))))
 252         (?a
 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)))))
 257         (?v
 258          (cons (1+ offset) (list :variant)))))))
 259
 260 (defun dbus-codegen--byte-p (value)
 261   (and (integerp value)
 262        (<= 0 value #xFF)))
 263
 264 (defun dbus-codegen--int16-p (value)
 265   (and (integerp value)
 266        (<= (- (- #x7FFF) 1) value #x7FFF)))
 267
 268 (defun dbus-codegen--uint16-p (value)
 269   (and (integerp value)
 270        (<= 0 value #xFFFF)))
 271
 272 (defun dbus-codegen--object-path-p (value)
 273   (and (stringp value)
 274        (string-match "\\`/\\'\\|\\`\\(?:/\\(?:[A-Za-z0-9_]+\\)\\)+\\'" value)))
 275
 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)
 281     (:int32 . integerp)
 282     (:uint32 . natnump)
 283     (:int64 . integerp)
 284     (:uint64 . natnump)
 285     (:double . floatp)
 286     (:string . stringp)
 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.")
 291
 292 (defun dbus-codegen--annotate-arg (type arg)
 293   (pcase type
 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)))
 297        (when (and entry
 298                   (not (funcall (cdr entry) arg)))
 299          (signal 'wrong-type-argument (list (cdr entry) arg))))
 300      (list basic arg))
 301     (`(:array ,elttype)
 302      ;; FIXME: an empty array must have a `:signature' element to
 303      ;; denote the element type.
 304      (list (cons :array
 305                  (apply #'nconc
 306                         (mapcar (lambda (subarg)
 307                                   (dbus-codegen--annotate-arg elttype subarg))
 308                                 arg)))))
 309     (`(:struct . ,memtypes)
 310      (list (cons :struct (apply #'nconc
 311                                 (cl-mapcar
 312                                  (lambda (memtype subarg)
 313                                    (dbus-codegen--annotate-arg memtype subarg))
 314                                  memtypes arg)))))
 315     (`(:variant)
 316      (list (cons :variant (apply #'nconc
 317                                  (mapcar (lambda (subarg) (list subarg))
 318                                          arg)))))
 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))))
 324
 325 (defun dbus-codegen--collect-arglist-with-type-annotation (args transform-name)
 326   (delq nil (mapcar
 327              (lambda (arg)
 328                (let ((direction
 329                       (xml-get-attribute-or-nil (nth 2 arg) 'direction))
 330                      (type
 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))))
 338
 339 (declare-function subword-forward "subword.el" (&optional arg))
 340 (defun dbus-codegen-transform-name (name)
 341   "Transform NAME into suitable Lisp function name."
 342   (require 'subword)
 343   (with-temp-buffer
 344     (let (words)
 345       (insert name)
 346       (goto-char (point-min))
 347       (while (not (eobp))
 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)
 352                                                          (point))))
 353               words))
 354       (mapconcat #'identity (nreverse words) "-"))))
 355
 356 ;; Emit wrappers around `dbus-call-method'.
 357 (defun dbus-codegen--emit-call-method (name methods transform-name)
 358   (apply
 359    #'nconc
 360    (mapcar
 361     (lambda (method)
 362       (let ((arglist (dbus-codegen--collect-arglist
 363                       (xml-get-children
 364                        (car (xml-get-children method 'method))
 365                        'arg)
 366                       transform-name))
 367             (annotated-arglist
 368              (dbus-codegen--collect-arglist-with-type-annotation
 369               (xml-get-children
 370                (car (xml-get-children method 'method)) 'arg)
 371               transform-name)))
 372         `((cl-defgeneric
 373               ,(intern (format "%s-%s" name (car method)))
 374               (object ,@arglist &rest args)
 375             ,(format "Call the \"%s\" method of OBJECT."
 376                      (nth 1 method)))
 377           (cl-defmethod
 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)
 385                    ,(nth 1 method)
 386                    (append ,@annotated-arglist args))))))
 387     methods)))
 388
 389 ;; Emit wrappers around `dbus-call-method-asynchronously'.
 390 (defun dbus-codegen--emit-call-method-asynchronously (name methods
 391                                                            transform-name)
 392   (apply
 393    #'nconc
 394    (mapcar
 395     (lambda (method)
 396       (let ((arglist (dbus-codegen--collect-arglist
 397                       (xml-get-children
 398                        (car (xml-get-children method 'method))
 399                        'arg)
 400                       transform-name))
 401             (annotated-arglist
 402              (dbus-codegen--collect-arglist-with-type-annotation
 403               (xml-get-children
 404                (car (xml-get-children method 'method))
 405                'arg)
 406               transform-name)))
 407         `((cl-defgeneric
 408               ,(intern (format "%s-%s-asynchronously"
 409                                name (car method)))
 410               ((object ,name) ,@arglist handler &rest args)
 411             ,(format "Asynchronously call the \"%s\" method of OBJECT."
 412                      (nth 1 method)))
 413           (cl-defmethod
 414               ,(intern (format "%s-%s-asynchronously"
 415                                name (car method)))
 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)
 422                  ,(nth 1 method)
 423                  handler
 424                  (append ,@annotated-arglist args))))))
 425    methods)))
 426
 427 ;; Emit wrappers around `dbus-register-signal'.
 428 (defun dbus-codegen--emit-register-signal (name signals)
 429   (apply
 430    #'nconc
 431    (mapcar
 432     (lambda (signal)
 433       `((cl-defgeneric
 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."
 437                    (nth 1 signal)))
 438         (cl-defmethod
 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)
 446                      ,(nth 1 signal)
 447                      (lambda (&rest args)
 448                        (apply handler object args))
 449                      args)
 450               (,(intern (format "%s-registration-list" name)) object)))))
 451     signals)))
 452
 453 ;; Emit wrappers around `dbus-send-signal'.
 454 (defun dbus-codegen--emit-send-signal (name signals transform-name)
 455   (apply
 456    #'nconc
 457    (mapcar
 458     (lambda (signal)
 459       (let ((arglist (dbus-codegen--collect-arglist
 460                       (xml-get-children
 461                        (car (xml-get-children signal 'signal))
 462                        'arg)
 463                       transform-name))
 464             (annotated-arglist
 465              (dbus-codegen--collect-arglist-with-type-annotation
 466               (xml-get-children
 467                (car (xml-get-children signal 'signal))
 468                'arg)
 469               transform-name)))
 470         `((cl-defgeneric
 471               ,(intern (format "%s-send-%s-signal"
 472                                name (car signal)))
 473               (object ,@arglist &rest args)
 474             ,(format "Send the \"%s\" signal of OBJECT."
 475                      (nth 1 signal)))
 476           (cl-defmethod
 477               ,(intern (format "%s-send-%s-signal"
 478                                name (car 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)
 485                    ,(nth 1 signal)
 486                    (append ,@annotated-arglist args))))))
 487     signals)))
 488
 489 ;; Emit generic functions for signal handlers.
 490 (defun dbus-codegen--emit-signal-defgeneric (name signals transform-name)
 491   (mapcar
 492    (lambda (signal)
 493      (let ((arglist (dbus-codegen--collect-arglist
 494                      (xml-get-children
 495                       (car (xml-get-children signal 'signal))
 496                       'arg)
 497                      transform-name)))
 498        `(cl-defgeneric
 499             ,(intern (format "%s-handle-%s-signal" name (car signal)))
 500             (object ,@arglist)
 501           ,(format "Generic function called upon receiving the \"%s\" signal."
 502                    (nth 1 signal))
 503           (list object ,@arglist)
 504           nil)))
 505    signals))
 506
 507 ;; Emit wrappers around `dbus-get-property'.
 508 (defun dbus-codegen--emit-retrieve-property (name properties)
 509   (apply
 510    #'nconc
 511    (mapcar
 512     (lambda (property)
 513       `((cl-defgeneric
 514             ,(intern (format "%s-retrieve-%s-property"
 515                              name (car property)))
 516             (object)
 517           ,(format "Retrieve the value of the \"%s\" property of OBJECT."
 518                    (nth 1 property)))
 519         (cl-defmethod
 520             ,(intern (format "%s-retrieve-%s-property"
 521                              name (car property)))
 522             ((object ,name))
 523           (setf (,(intern (format "%s-%s" name (car property)))
 524                  object)
 525                 (dbus-get-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))))))
 531     properties)))
 532
 533 ;; Emit generic functions for method handlers.
 534 (defun dbus-codegen--emit-method-defgeneric (name methods transform-name)
 535   (mapcar
 536    (lambda (method)
 537      (let ((arglist (dbus-codegen--collect-arglist
 538                      (xml-get-children
 539                       (car (xml-get-children method 'method))
 540                       'arg)
 541                      transform-name)))
 542      `(cl-defgeneric
 543           ,(intern (format "%s-handle-%s-method" name (car method)))
 544           (object ,@arglist)
 545         ,(format "Generic function called when the \"%s\" method is called."
 546                  (nth 1 method))
 547         (list object ,@arglist)
 548         nil)))
 549    methods))
 550
 551 ;; Emit wrappers around `dbus-register-method'.
 552 (defun dbus-codegen--emit-register-method (name methods)
 553   (apply
 554    #'nconc
 555    (mapcar
 556     (lambda (method)
 557       `((cl-defgeneric
 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."
 561                    (nth 1 method)))
 562         (cl-defmethod
 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)
 570                        ,(nth 1 method)
 571                        (lambda (&rest args)
 572                          (apply handler object args))
 573                        args)
 574                 (,(intern (format "%s-registration-list" name)) object)))))
 575     methods)))
 576
 577 ;; Emit wrappers around `dbus-register-property'.
 578 (defun dbus-codegen--emit-register-property (name properties)
 579   (apply
 580    #'nconc
 581    (mapcar
 582     (lambda (property)
 583       (let* ((annotations
 584               (delq nil
 585                    (mapcar
 586                     (lambda (annotation)
 587                       (if (equal
 588                            (xml-get-attribute-or-nil annotation 'name)
 589                            "org.freedesktop.DBus.Property.EmitsChangedSignal")
 590                           annotation))
 591                     (xml-get-children (nth 2 property) 'annotation))))
 592             (emits-signal
 593              (or (null annotations)
 594                  (not (equal (xml-get-attribute-or-nil (car annotations)
 595                                                        'value)
 596                              "false")))))
 597         `((cl-defgeneric
 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."
 601                      (nth 1 property)))
 602           (cl-defmethod
 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)
 611                          ,(nth 1 property)
 612                          value
 613                          ,@(if emits-signal
 614                                (list :emits-signal t))
 615                          args)
 616                   (,(intern (format "%s-registration-list" name)) object))))))
 617     properties)))
 618
 619 ;;;###autoload
 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.
 624
 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>'.
 630
 631 INTERFACE is a name of interface which is represented by this
 632 proxy.
 633
 634 ARGS are keyword-value pair.  Currently only one keyword is
 635 supported:
 636
 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
 648                      (insert xml)
 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)
 660                                 interface))
 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)
 666                       transform-name))
 667             (properties (dbus-codegen--apply-transform-name
 668                          (xml-get-children interface-node 'property)
 669                          transform-name))
 670             (signals (dbus-codegen--apply-transform-name
 671                       (xml-get-children interface-node 'signal)
 672                       transform-name)))
 673         `(progn
 674            ;; Define a new struct.
 675            (cl-defstruct (,name (:include dbus-codegen-proxy)
 676                                 (:constructor nil)
 677                                 (:constructor ,(intern (format "%s--make" name))
 678                                               (bus service path interface)))
 679              ;; Slots for cached property values.
 680              ,@(mapcar
 681                 (lambda (property)
 682                   (intern (car property)))
 683                 properties))
 684
 685            ;; Define a constructor.
 686            (defun ,(intern (format "%s-create" name)) (bus service path)
 687              ,(format "Create a new D-Bus proxy for %s.
 688
 689 BUS is either a Lisp symbol, `:system' or `:session', or a string
 690 denoting the bus address.
 691
 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
 694 offered by SERVICE."
 695                   interface)
 696              (let ((proxy (,(intern (format "%s--make" name))
 697                            bus service path ,interface)))
 698                ,(when properties
 699                   ;; Initialize slots.
 700                   `(let ((properties (dbus-get-all-properties bus service path
 701                                                               ,interface)))
 702                      ,@(mapcar
 703                         (lambda (property)
 704                           `(setf (,(intern (format "%s-%s" name (car property)))
 705                                   proxy)
 706                                  (cdr (assoc ,(nth 1 property) properties))))
 707                         properties)
 708                      (push (dbus-register-signal
 709                             bus service path dbus-interface-properties
 710                             "PropertiesChanged"
 711                             (lambda (interface changed invalidated)
 712                               (,(intern (format "%s--handle-properties-changed"
 713                                                 name))
 714                                proxy
 715                                interface changed invalidated))
 716                             :arg0 ,interface)
 717                            (,(intern (format "%s-registration-list" name))
 718                             proxy))))
 719                ;; Register signal handlers.
 720                ,@(mapcar
 721                   (lambda (signal)
 722                     `(push (dbus-register-signal
 723                             bus service path ,interface
 724                             ,(nth 1 signal)
 725                             (lambda (&rest args)
 726                               (apply #',(intern (format "%s-handle-%s-signal"
 727                                                         name (car signal)))
 728                                      proxy args)))
 729                            (,(intern (format "%s-registration-list" name))
 730                             proxy)))
 731                   signals)
 732                proxy))
 733
 734            ,(when properties
 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)
 739                    ,@(mapcar
 740                       (lambda (property)
 741                         `(let ((changed-value
 742                                 (cdr (assoc ,(nth 1 property) changed)))
 743                                (invalidated-property
 744                                 (car (member ,(nth 1 property) invalidated)))
 745                                invalidated-value)
 746                            (when changed-value
 747                              (setf (,(intern (format "%s-%s"
 748                                                      name (car property)))
 749                                     proxy)
 750                                    (car (car changed-value))))
 751                            (when invalidated-property
 752                              (setq invalidated-value
 753                                    (dbus-get-property
 754                                     (,(intern (format "%s-bus" name)) proxy)
 755                                     (,(intern (format "%s-service" name)) proxy)
 756                                     (,(intern (format "%s-path" name)) proxy)
 757                                     ,interface
 758                                     ,(car property)))
 759                              (when invalidated-value
 760                                (setf (,(intern (format "%s-%s"
 761                                                        name (car property)))
 762                                       proxy)
 763                                      invalidated-value)))))
 764                       properties))))
 765
 766            ;; Define a destructor.
 767            (cl-defgeneric ,(intern (format "%s-destroy" name)) (proxy)
 768              "Destroy a D-Bus proxy PROXY.")
 769
 770            (cl-defmethod ,(intern (format "%s-destroy" name)) ((proxy ,name))
 771              (dolist (registration (,(intern (format "%s-registration-list"
 772                                                      name))
 773                                     proxy))
 774                (dbus-unregister-object registration))
 775              (setf (,(intern (format "%s-registration-list" name)) proxy) nil))
 776
 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
 784                                                             transform-name)
 785            ,@(dbus-codegen--emit-retrieve-property name properties))))))
 786
 787 ;;;###autoload
 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.
 790
 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.
 793
 794 BUS is either a Lisp symbol, `:system' or `:session', or a string
 795 denoting the bus address.
 796
 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
 799 offered by SERVICE.
 800
 801 INTERFACE is an interface which is represented by this proxy.
 802
 803 ARGS are keyword-value pair.  Currently only one keyword is
 804 supported:
 805
 806 :redefine FLAG -- if FLAG is non-nil, redefine the data type and
 807 associated functions.
 808
 809 Other keywords are same as `dbus-codegen-define-proxy'."
 810   (require 'xml)
 811   (require 'subword)
 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)
 817                  ,interface
 818                  ,@args)))
 819     (funcall constructor bus service path)))
 820
 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.
 825
 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>'.
 831
 832 INTERFACE is a name of interface which is represented by this
 833 skeleton.
 834
 835 ARGS are keyword-value pair.  Currently only one keyword is
 836 supported:
 837
 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
 849                      (insert xml)
 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)
 861                                 interface))
 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)
 867                       transform-name))
 868             (properties (dbus-codegen--apply-transform-name
 869                          (xml-get-children interface-node 'property)
 870                          transform-name))
 871             (signals (dbus-codegen--apply-transform-name
 872                       (xml-get-children interface-node 'signal)
 873                       transform-name)))
 874         `(progn
 875            ;; Define a new struct.
 876            (cl-defstruct (,name (:include dbus-codegen-skeleton)
 877                                 (:constructor nil)
 878                                 (:constructor ,(intern (format "%s--make" name))
 879                                               (bus service path interface)))
 880              ;; Slots for cached property values.
 881              ,@(mapcar
 882                 (lambda (property)
 883                   (intern (car property)))
 884                 properties))
 885
 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.
 890
 891 BUS is either a Lisp symbol, `:system' or `:session', or a string
 892 denoting the bus address.
 893
 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
 896 offered by SERVICE."
 897                   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.
 902                ,@(mapcar
 903                   (lambda (method)
 904                     `(push (dbus-register-method
 905                             bus service path ,interface
 906                             ,(nth 1 method)
 907                             (lambda (&rest args)
 908                               (apply #',(intern (format "%s-handle-%s-method"
 909                                                         name (car method)))
 910                                      skeleton args)))
 911                            (,(intern (format "%s-registration-list" name))
 912                             skeleton)))
 913                   methods)
 914                skeleton))
 915
 916            ;; Define a destructor.
 917            (cl-defgeneric ,(intern (format "%s-destroy" name)) (skeleton)
 918              "Destroy a D-Bus skeleton SKELETON.")
 919
 920            (cl-defmethod ,(intern (format "%s-destroy" name)) ((skeleton ,name))
 921              (dolist (registration (,(intern (format "%s-registration-list"
 922                                                      name))
 923                                     skeleton))
 924                (dbus-unregister-object registration))
 925              (setf (,(intern (format "%s-registration-list" name)) skeleton)
 926                    nil)
 927              (dbus-unregister-service bus service))
 928
 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))))))
 937
 938 (provide 'dbus-codegen)
 939
 940 ;;; dbus-codegen.el ends here