Re: [PATCH] Support automatic D-Bus proxy generation

[joakim]

Daiki Ueno <address@hidden> writes:

> For what it's worth, I've turned it into a patch (still work in
> progress).  It ended up with a new module dbus-codegen.el, with two
> different interfaces: one is a static version (`define-dbus-proxy'),
> which takes an interface definition as an argument and expands at
> compile-time.  The other is a dynamic version (`make-dbus-proxy'), which
> retrieves the interface through introspection.
>
> I initially thought that it might fit in dbus.el, but it would be better
> to keep it essential and not to bother with the boring code-generating
> code.
>
> address@hidden writes:
>
>> I use Jan Moringens dbus-proxy in my Inkmacs project, which is an Emacs
>> interface for Inkscape. 
>
> Nice.  I'm playing with it as an example:
> https://github.com/ueno/inkmacs/commit/d5835d2bIt seems partly working (I got 
> 'dbus-call-method: D-Bus error: "Object
> 'inkmacs-flow-layer' not found in document."', maybe my programming
> error somewhere).

Well, Inkmacs can be pretty funky to get working, and sometimes it
depends on a patched Inkscape with better dbus primitives. I cant
remember at the moment.

Thanks for having a look. I will try your dbus framework also.

>
> Regards,
> --
> Daiki Ueno
>
> From 2a01d1fc73017cb2550d1ec47207fd1f0427e8b5 Mon Sep 17 00:00:00 2001
> From: Daiki Ueno <address@hidden>
> Date: Wed, 25 Feb 2015 16:25:30 +0900
> Subject: [PATCH] Support automatic D-Bus proxy generation
>
> * lisp/net/dbus-codegen.el: New file.
> ---
>  lisp/net/dbus-codegen.el | 329 
> +++++++++++++++++++++++++++++++++++++++++++++++
>  1 file changed, 329 insertions(+)
>  create mode 100644 lisp/net/dbus-codegen.el
>
> diff --git a/lisp/net/dbus-codegen.el b/lisp/net/dbus-codegen.el
> new file mode 100644
> index 0000000..e2550f9
> --- /dev/null
> +++ b/lisp/net/dbus-codegen.el
> @@ -0,0 +1,329 @@
> +;;; dbus-codegen.el --- Lisp code generation for D-Bus. -*- lexical-biding: 
> t; -*-
> +
> +;; Copyright (C) 2015 Free Software Foundation, Inc.
> +
> +;; Author: Daiki Ueno <address@hidden>
> +;; Keywords: comm, hardware
> +
> +;; This file is part of GNU Emacs.
> +
> +;; GNU Emacs is free software: you can redistribute it and/or modify
> +;; it under the terms of the GNU General Public License as published by
> +;; the Free Software Foundation, either version 3 of the License, or
> +;; (at your option) any later version.
> +
> +;; GNU Emacs is distributed in the hope that it will be useful,
> +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
> +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
> +;; GNU General Public License for more details.
> +
> +;; You should have received a copy of the GNU General Public License
> +;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.+
> +;;; Commentary:
> +
> +;; This package provides two interfaces to make D-Bus proxy
> +;; implementation easy.  One is `define-dbus-proxy', which takes a
> +;; static definition of a D-Bus service and generates code at
> +;; byte-compilation time.  The following code defines
> +;; `search-provider-make' and
> +;; `search-provider-get-initial-result-set'.
> +;;
> +;;   (define-dbus-proxy search-provider "\
> +;;   <node>
> +;;     <interface name=\"org.gnome.Shell.SearchProvider2\">
> +;;       <method name=\"GetInitialResultSet\">
> +;;         <arg type=\"as\" name=\"terms\" direction=\"in\" />
> +;;         <arg type=\"as\" name=\"results\" direction=\"out\" />
> +;;       </method>
> +;;     </interface>
> +;;   </node>"
> +;;     "org.gnome.Shell.SearchProvider2"
> +;;     :transform-name #'dbus-codegen-transform-name)
> +;;
> +;; This is good for stable D-Bus services.
> +
> +;; The other is `make-dbus-proxy', which retrieves the D-Bus service
> +;; definition from the running service itself through D-Bus
> +;; introspection.  This is good for unstable D-Bus services.
> +
> +;;; Code:
> +
> +(require 'dbus)
> +(require 'xml)
> +(require 'cl-lib)
> +(require 'subword)
> +
> +;; Base type of a D-Bus proxy.
> +(cl-defstruct (dbus-proxy
> +            (:constructor nil))
> +  (bus :read-only t)
> +  (service :read-only t)
> +  (path :read-only t))
> +
> +;; Return a list of elements in the form: (LISP-NAME ORIG-NAME MEMBER).
> +(defun dbus-codegen--apply-transform-name (elements transform-name)
> +  (mapcar (lambda (elements)
> +         (let ((name (xml-get-attribute-or-nil elements 'name)))
> +             (unless name
> +               (error "missing \"name\" attribute of %s"
> +                      (xml-node-name elements)))
> +             (list (funcall transform-name name)
> +                   name
> +                   elements)))
> +       elements))
> +
> +;; Return a list of symbols.
> +(defun dbus-codegen--collect-arglist (args transform-name)
> +  (delq nil
> +     (mapcar
> +      (lambda (arg)
> +        (let ((direction
> +               (xml-get-attribute-or-nil (nth 2 arg) 'direction)))
> +          (if (or (null direction)
> +                  (equal direction "in"))
> +              (intern (car arg)))))
> +      (dbus-codegen--apply-transform-name args transform-name))))
> +
> +(defun dbus-codegen-transform-name (name)
> +  "Transform NAME into suitable Lisp function name."
> +  (with-temp-buffer
> +    (let (words)
> +      (insert name)
> +      (goto-char (point-min))
> +      (while (not (eobp))
> +     ;; Skip characters not recognized by subword-mode.
> +     (if (looking-at "[^[:lower:][:upper:][:digit:]]+")
> +         (goto-char (match-end 0)))
> +     (push (downcase (buffer-substring (point) (progn (subword-forward 1)
> +                                                      (point))))
> +           words))
> +      (mapconcat #'identity (nreverse words) "-"))))
> +
> +;;;###autoload
> +(defmacro define-dbus-proxy (name xml interface &rest args)
> +  "Define a new D-Bus proxy NAME.
> +This defines a new struct type for the proxy and convenient
> +functions for D-Bus method calls and signal registration.
> +
> +XML is either a string which defines the interface of the D-Bus
> +proxy, or a tree already parsed with `xml-parse-file'.  It must
> +comply with the standard D-Bus introspection XML format, and can
> +contain only a single \"interface\" element under the root
> +\"node\" element.
> +
> +INTERFACE is an interface which is represented by this proxy.
> +
> +ARGS are keyword-value pair.  Currently only one keyword is
> +supported:
> +
> +:transform-name FUNCTION -- FUNCTION is a function which converts
> +D-Bus method/signal/property names, into another representation.
> +Use `dbus-codegen-transform-name' to convert all
> +camel-cased names to suitable Lisp function names."
> +  (unless (symbolp name)
> +    (signal 'wrong-type-argument (list 'symbolp name)))
> +  (unless (stringp xml)
> +    (signal 'wrong-type-argument (list 'stringp xml)))
> +  (let ((node (if (stringp xml)
> +               (car (with-temp-buffer
> +                      (insert xml)
> +                      (xml-parse-region (point-min) (point-max))))
> +             xml))
> +     (transform-name (or (plist-get args :transform-name)
> +                         #'identity)))
> +    (unless (eq (xml-node-name node) 'node)
> +      (error "Root is not \"node\""))
> +    (unless (functionp transform-name)
> +      (setq transform-name (eval transform-name)))
> +    (let ((interface-node
> +        (cl-find-if (lambda (element)
> +                      (equal (xml-get-attribute-or-nil element 'name)
> +                             interface))
> +                    (xml-get-children node 'interface))))
> +      (unless interface-node
> +     (error "Interface %s is missing" interface))
> +      (let ((methods (dbus-codegen--apply-transform-name
> +                   (xml-get-children interface-node 'method)
> +                   transform-name))
> +         (properties (dbus-codegen--apply-transform-name
> +                      (xml-get-children interface-node 'properties)
> +                      transform-name))
> +         (signals (dbus-codegen--apply-transform-name
> +                   (xml-get-children interface-node 'signals)
> +                   transform-name)))
> +     `(progn
> +        ;; Define a new struct.
> +        (cl-defstruct (,name (:include dbus-proxy)
> +                             (:constructor nil)
> +                             (:constructor ,(intern (format "%s--make" name))
> +                                           (bus service path)))
> +          ;; Slots for cached property values.
> +          ,@(mapcar
> +             (lambda (property)
> +               (intern (car property)))
> +             properties))
> +
> +        (defun ,(intern (format "%s-make" name)) (bus service path)
> +          ,(format "Create a new D-Bus proxy for %s.
> +
> +BUS is either a Lisp symbol, `:system' or `:session', or a string
> +denoting the bus address.
> +
> +SERVICE is the D-Bus service name to be used.  PATH is the D-Bus
> +object path SERVICE is registered at.  INTERFACE is an interface
> +offered by SERVICE."
> +                   interface)
> +          (let ((proxy (,(intern (format "%s--make" name))
> +                        bus service path)))
> +            ,(when (and properties
> +                        ;; FIXME: See the handler definition below.
> +                        lexical-binding)
> +               ;; Initialize slots.
> +               `(let ((properties (dbus-get-all-properties bus service path
> +                                                           ,interface)))
> +                  ,@(mapcar
> +                     (lambda (property)
> +                       `(setf (,(intern (format "%s-%s" name (car property)))
> +                               proxy)
> +                              (cdr (assoc ,(nth 1 property) properties))))
> +                     properties)
> +                  (dbus-register-signal
> +                   bus service path dbus-interface-properties
> +                   "PropertiesChanged"
> +                   (lambda (interface changed invalidated)
> +                     (funcall
> +                      ,(intern (format "%s--handle-properties-changed"
> +                                       name))
> +                      proxy
> +                      interface changed invalidated)))))
> +            proxy))
> +
> +        ;; Define a handler of PropertiesChanged signal.
> +        (defun ,(intern (format "%s--handle-properties-changed" name))
> +            (proxy interface changed invalidated)
> +          (when (equal interface ,interface)
> +            ,@(mapcar
> +               (lambda (property)
> +                 `(setf (,(intern (format "%s-%s" name (car property)))
> +                         proxy)
> +                        (cdr (assoc ,(nth 1 property) changed))))
> +               properties)))
> +
> +        ;; Define wrappers around `dbus-call-method'.
> +        ,@(mapcar
> +           (lambda (method)
> +             (let ((arglist (dbus-codegen--collect-arglist
> +                             (xml-get-children method 'arg)
> +                             transform-name)))
> +               `(cl-defmethod
> +                    ,(intern (format "%s-%s" name (car method)))
> +                    ((proxy ,name) ,@arglist &rest args)
> +                  (apply #'dbus-call-method
> +                         (dbus-proxy-bus proxy)
> +                         (dbus-proxy-service proxy)
> +                         (dbus-proxy-path proxy)
> +                         ,interface
> +                         ,(nth 1 method)
> +                         ,@arglist
> +                         args))))
> +           methods)
> +
> +        ;; Define wrappers around `dbus-call-method-asynchronously'.
> +        ,@(mapcar
> +           (lambda (method)
> +             (let ((arglist (dbus-codegen--collect-arglist
> +                             (xml-get-children method 'arg)
> +                             transform-name)))
> +               `(cl-defmethod
> +                    ,(intern (format "%s-%s-asynchronously"
> +                                     name (car method)))
> +                    ((proxy ,name) ,@arglist handler &rest args)
> +                  (apply #'dbus-call-method-asynchronously
> +                         (dbus-proxy-bus proxy)
> +                         (dbus-proxy-service proxy)
> +                         (dbus-proxy-path proxy)
> +                         ,interface
> +                         ,(nth 1 method)
> +                         handler
> +                         ,@arglist
> +                         args))))
> +           methods)
> +
> +        ;; Define wrappers around `dbus-register-signal'.
> +        ,@(mapcar
> +           (lambda (signal)
> +             `(cl-defmethod
> +                  ,(intern (format "%s-register-%s-signal"
> +                                   name (car signal)))
> +                  ((proxy ,name) handler &rest args)
> +                (apply #'dbus-register-signal
> +                       (dbus-proxy-bus proxy)
> +                       (dbus-proxy-service proxy)
> +                       (dbus-proxy-path proxy)
> +                       ,interface
> +                       ,(nth 1 signal)
> +                       handler
> +                       args)))
> +           signals)
> +
> +        ;; Define wrappers around `dbus-send-signal'.
> +        ,@(mapcar
> +           (lambda (signal)
> +             (let ((arglist (dbus-codegen--collect-arglist
> +                             (xml-get-children signal 'arg)
> +                             transform-name)))
> +               `(cl-defmethod
> +                    ,(intern (format "%s-send-%s-signal"
> +                                     name (car signal)))
> +                    ((proxy ,name) ,@arglist &rest args)
> +                  (apply #'dbus-register-signal
> +                         (dbus-proxy-bus proxy)
> +                         (dbus-proxy-service proxy)
> +                         (dbus-proxy-path proxy)
> +                         ,interface
> +                         ,(nth 1 signal)
> +                         ,@arglist
> +                         args))))
> +           signals))))))
> +
> +;;;###autoload
> +(defun make-dbus-proxy (name bus service path interface &rest args)
> +  "Create a new D-Bus proxy based on the introspection data.
> +
> +If the data type of the D-Bus proxy is not yet defined, this will
> +define it with `define-dbus-proxy', under a type name NAME.
> +
> +BUS is either a Lisp symbol, `:system' or `:session', or a string
> +denoting the bus address.
> +
> +SERVICE is the D-Bus service name to be used.  PATH is the D-Bus
> +object path SERVICE is registered at.  INTERFACE is an interface
> +offered by SERVICE.
> +
> +INTERFACE is an interface which is represented by this proxy.
> +
> +ARGS are keyword-value pair.  Currently only one keyword is
> +supported:
> +
> +:redefine FLAG -- if FLAG is non-nil, redefine the data type and
> +associated functions.
> +
> +Other keywords are same as `define-dbus-proxy'."
> +  (let ((constructor (intern (format "%s-make" name))))
> +    (if (or (plist-get args :redefine)
> +         (not (fboundp constructor)))
> +     (eval `(define-dbus-proxy ,(intern name)
> +              ,(dbus-introspect bus service path)
> +              ,interface
> +              ,@args)))
> +    (funcall constructor bus service path)))
> +
> +(provide 'dbus-codegen)
> +
> +;;; TODO
> +
> +;; * Property setters
> +;; * Server-side code generation
> +
> +;;; dbus-codegen.el ends here

-- 
Joakim Verona