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   ;; 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
 649                      (insert xml)
 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)
 661                                 interface))
 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)
 667                       transform-name))
 668             (properties (dbus-codegen--apply-transform-name
 669                          (xml-get-children interface-node 'property)
 670                          transform-name))
 671             (signals (dbus-codegen--apply-transform-name
 672                       (xml-get-children interface-node 'signal)
 673                       transform-name)))
 674         `(progn
 675            ;; Define a new struct.
 676            (cl-defstruct (,name (:include dbus-codegen-proxy)
 677                                 (:constructor nil)
 678                                 (:constructor ,(intern (format "%s--make" name))
 679                                               (bus service path interface)))
 680              ;; Slots for cached property values.
 681              ,@(mapcar
 682                 (lambda (property)
 683                   (intern (car property)))
 684                 properties))
 685
 686            ;; Define a constructor.
 687            (defun ,(intern (format "%s-create" name)) (bus service path)
 688              ,(format "Create a new D-Bus proxy for %s.
 689
 690 BUS is either a Lisp symbol, `:system' or `:session', or a string
 691 denoting the bus address.
 692
 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
 695 offered by SERVICE."
 696                   interface)
 697              (let ((proxy (,(intern (format "%s--make" name))
 698                            bus service path ,interface)))
 699                ,(when properties
 700                   ;; Initialize slots.
 701                   `(let ((properties (dbus-get-all-properties bus service path
 702                                                               ,interface)))
 703                      ,@(mapcar
 704                         (lambda (property)
 705                           `(setf (,(intern (format "%s-%s" name (car property)))
 706                                   proxy)
 707                                  (cdr (assoc ,(nth 1 property) properties))))
 708                         properties)
 709                      (push (dbus-register-signal
 710                             bus service path dbus-interface-properties
 711                             "PropertiesChanged"
 712                             (lambda (interface changed invalidated)
 713                               (,(intern (format "%s--handle-properties-changed"
 714                                                 name))
 715                                proxy
 716                                interface changed invalidated))
 717                             :arg0 ,interface)
 718                            (,(intern (format "%s-registration-list" name))
 719                             proxy))))
 720                ;; Register signal handlers.
 721                ,@(mapcar
 722                   (lambda (signal)
 723                     `(push (dbus-register-signal
 724                             bus service path ,interface
 725                             ,(nth 1 signal)
 726                             (lambda (&rest args)
 727                               (apply #',(intern (format "%s-handle-%s-signal"
 728                                                         name (car signal)))
 729                                      proxy args)))
 730                            (,(intern (format "%s-registration-list" name))
 731                             proxy)))
 732                   signals)
 733                proxy))
 734
 735            ,(when properties
 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)
 740                    ,@(mapcar
 741                       (lambda (property)
 742                         `(let ((changed-value
 743                                 (cdr (assoc ,(nth 1 property) changed)))
 744                                (invalidated-property
 745                                 (car (member ,(nth 1 property) invalidated)))
 746                                invalidated-value)
 747                            (when changed-value
 748                              (setf (,(intern (format "%s-%s"
 749                                                      name (car property)))
 750                                     proxy)
 751                                    (car (car changed-value))))
 752                            (when invalidated-property
 753                              (setq invalidated-value
 754                                    (dbus-get-property
 755                                     (,(intern (format "%s-bus" name)) proxy)
 756                                     (,(intern (format "%s-service" name)) proxy)
 757                                     (,(intern (format "%s-path" name)) proxy)
 758                                     ,interface
 759                                     ,(car property)))
 760                              (when invalidated-value
 761                                (setf (,(intern (format "%s-%s"
 762                                                        name (car property)))
 763                                       proxy)
 764                                      invalidated-value)))))
 765                       properties))))
 766
 767            ;; Define a destructor.
 768            (cl-defgeneric ,(intern (format "%s-destroy" name)) (proxy)
 769              "Destroy a D-Bus proxy PROXY.")
 770
 771            (cl-defmethod ,(intern (format "%s-destroy" name)) ((proxy ,name))
 772              (dolist (registration (,(intern (format "%s-registration-list"
 773                                                      name))
 774                                     proxy))
 775                (dbus-unregister-object registration))
 776              (setf (,(intern (format "%s-registration-list" name)) proxy) nil))
 777
 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
 785                                                             transform-name)
 786            ,@(dbus-codegen--emit-retrieve-property name properties))))))
 787
 788 ;;;###autoload
 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.
 791
 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.
 794
 795 BUS is either a Lisp symbol, `:system' or `:session', or a string
 796 denoting the bus address.
 797
 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
 800 offered by SERVICE.
 801
 802 INTERFACE is an interface which is represented by this proxy.
 803
 804 ARGS are keyword-value pair.  Currently only one keyword is
 805 supported:
 806
 807 :redefine FLAG -- if FLAG is non-nil, redefine the data type and
 808 associated functions.
 809
 810 Other keywords are same as `dbus-codegen-define-proxy'."
 811   (require 'xml)
 812   (require 'subword)
 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)
 818                  ,interface
 819                  ,@args)))
 820     (funcall constructor bus service path)))
 821
 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.
 826
 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'.
 832
 833 INTERFACE is a name of interface which is represented by this
 834 skeleton.
 835
 836 ARGS are keyword-value pair.  Currently only one keyword is
 837 supported:
 838
 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
 851                      (insert xml)
 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)
 863                                 interface))
 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)
 869                       transform-name))
 870             (properties (dbus-codegen--apply-transform-name
 871                          (xml-get-children interface-node 'property)
 872                          transform-name))
 873             (signals (dbus-codegen--apply-transform-name
 874                       (xml-get-children interface-node 'signal)
 875                       transform-name)))
 876         `(progn
 877            ;; Define a new struct.
 878            (cl-defstruct (,name (:include dbus-codegen-skeleton)
 879                                 (:constructor nil)
 880                                 (:constructor ,(intern (format "%s--make" name))
 881                                               (bus service path interface)))
 882              ;; Slots for cached property values.
 883              ,@(mapcar
 884                 (lambda (property)
 885                   (intern (car property)))
 886                 properties))
 887
 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.
 892
 893 BUS is either a Lisp symbol, `:system' or `:session', or a string
 894 denoting the bus address.
 895
 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
 898 offered by SERVICE."
 899                   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.
 904                ,@(mapcar
 905                   (lambda (method)
 906                     `(push (dbus-register-method
 907                             bus service path ,interface
 908                             ,(nth 1 method)
 909                             (lambda (&rest args)
 910                               (apply #',(intern (format "%s-handle-%s-method"
 911                                                         name (car method)))
 912                                      skeleton args)))
 913                            (,(intern (format "%s-registration-list" name))
 914                             skeleton)))
 915                   methods)
 916                skeleton))
 917
 918            ;; Define a destructor.
 919            (cl-defgeneric ,(intern (format "%s-destroy" name)) (skeleton)
 920              "Destroy a D-Bus skeleton SKELETON.")
 921
 922            (cl-defmethod ,(intern (format "%s-destroy" name)) ((skeleton ,name))
 923              (dolist (registration (,(intern (format "%s-registration-list"
 924                                                      name))
 925                                     skeleton))
 926                (dbus-unregister-object registration))
 927              (setf (,(intern (format "%s-registration-list" name)) skeleton)
 928                    nil)
 929              (dbus-unregister-service bus service))
 930
 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))))))
 939
 940 (provide 'dbus-codegen)
 941
 942 ;;; dbus-codegen.el ends here