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

   1 ;;; systemd-codegen.el --- D-Bus Introspection      -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2016  Free Software Foundation, Inc.
   4
   5 ;; Author: Mario Lang <mlang@delysid.org>
   6 ;; Keywords:
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;; This library is used to automatically generate D-Bus bindings for systemd
  24 ;; and related components via introspection.
  25 ;;
  26 ;; The macro `systemd-codegen-define' can be used to generate Lisp code according
  27 ;; to the currently available introspection data.  This can be useful for
  28 ;; development.
  29 ;;
  30 ;; To avoid a dependency on systemd at compile time, `systemd-codegen-to-string'
  31 ;; is provided to statically generate all the Lisp code for the currently running
  32 ;; version of systemd.
  33 ;;
  34 ;; `systemd-codegen-to-string' is used to generate the bulk of the content of
  35 ;; systemd.el.
  36
  37 ;;; Code:
  38
  39 (require 'cl-lib)
  40 (require 'dbus)
  41
  42 (defvar systemd-codegen-interfaces
  43   '(("org.freedesktop.systemd1.Manager"
  44      :prefix "systemd"
  45      :interface systemd-dbus-interface-manager)
  46     ("org.freedesktop.systemd1.Automount"
  47      :prefix "systemd-automount"
  48      :interface systemd-dbus-interface-automount)
  49     ("org.freedesktop.systemd1.BusName"
  50      :prefix "systemd-bus-name"
  51      :interface systemd-dbus-interface-bus-name)
  52     ("org.freedesktop.systemd1.Device"
  53      :prefix "systemd-device"
  54      :interface systemd-dbus-interface-device)
  55     ("org.freedesktop.systemd1.Mount"
  56      :prefix "systemd-mount"
  57      :interface systemd-dbus-interface-mount)
  58     ("org.freedesktop.systemd1.Path"
  59      :prefix "systemd-path"
  60      :interface systemd-dbus-interface-path)
  61     ("org.freedesktop.systemd1.Service"
  62      :prefix "systemd-service"
  63      :interface systemd-dbus-interface-service)
  64     ("org.freedesktop.systemd1.Scope"
  65      :prefix "systemd-scope"
  66      :interface systemd-dbus-interface-scope)
  67     ("org.freedesktop.systemd1.Slice"
  68      :prefix "systemd-slice"
  69      :interface systemd-dbus-interface-slice)
  70     ("org.freedesktop.systemd1.Socket"
  71      :prefix "systemd-socket"
  72      :interface systemd-dbus-interface-socket)
  73     ("org.freedesktop.systemd1.Swap"
  74      :prefix "systemd-swap"
  75      :interface systemd-dbus-interface-swap)
  76     ("org.freedesktop.systemd1.Target"
  77      :prefix "systemd-target"
  78      :interface systemd-dbus-interface-target)
  79     ("org.freedesktop.systemd1.Timer"
  80      :prefix "systemd-timer"
  81      :interface systemd-dbus-interface-timer)
  82     ("org.freedesktop.systemd1.Unit"
  83      :prefix "systemd-unit"
  84      :interface systemd-dbus-interface-unit)
  85     ("org.freedesktop.login1.Manager"
  86      :prefix "systemd-logind"
  87      :interface systemd-dbus-interface-logind-mamanger)
  88     ("org.freedesktop.login1.Seat"
  89      :prefix "systemd-logind-seat"
  90      :interface systemd-dbus-interface-logind-seat)
  91     ("org.freedesktop.login1.Session"
  92      :prefix "systemd-logind-session"
  93      :interface systemd-dbus-interface-logind-session)
  94     ("org.freedesktop.login1.User"
  95      :prefix "systemd-logind-user"
  96      :interface systemd-dbus-interface-logind-user)
  97     ("org.freedesktop.network1.Manager"
  98      :prefix "systemd-networkd"
  99      :interface systemd-dbus-interface-networkd-manager)
 100     ("org.freedesktop.network1.Link"
 101      :prefix "systemd-networkd-link"
 102      :interface systemd-dbus-interface-networkd-link)
 103     ("org.freedesktop.network1.Network"
 104      :prefix "systemd-networkd-network"
 105      :interface systemd-dbus-interface-networkd-network)
 106     ("org.freedesktop.resolve1.Manager"
 107      :prefix "systemd-resolved"
 108      :interface systemd-dbus-interface-resolved-manager)
 109     ("org.freedesktop.resolve1.Link"
 110      :prefix "systemd-resolved-link"
 111      :interface systemd-dbus-interface-resolved-link)
 112     ("org.freedesktop.hostname1"
 113      :prefix "systemd-hostnamed"
 114      :interface systemd-dbus-interface-hostnamed)
 115     ("org.freedesktop.locale1"
 116      :prefix "systemd-localed"
 117      :interface systemd-dbus-interface-localed)
 118     ("org.freedesktop.timedate1"
 119      :prefix "systemd-timedated"
 120      :interface systemd-dbus-interface-timedated)
 121     ("org.freedesktop.machine1.Manager"
 122      :prefix "systemd-machined"
 123      :interface systemd-dbus-interface-machined-mananger)
 124     ("org.freedesktop.machine1.Image"
 125      :prefix "systemd-machined-image"
 126      :interface systemd-dbus-interface-machined-image)
 127     ("org.freedesktop.machine1.Machine"
 128      :prefix "systemd-machined-machine"
 129      :interface systemd-dbus-interface-machined-machine)))
 130
 131 (defun systemd-codegen-introspect (service path &optional interfaces)
 132   (let ((xml (dbus-introspect-xml :system service path)))
 133     (dolist (item
 134              (and (eq (car-safe xml) 'node)
 135                   (xml-node-children xml))
 136              (sort interfaces (lambda (a b) (string-lessp (car a) (car b)))))
 137       (cond
 138        ((and (listp item) (eq 'interface (car-safe item)))
 139         (let* ((interface (xml-get-attribute-or-nil item 'name))
 140                (interface-info (cdr (assoc interface systemd-codegen-interfaces)))
 141                (prefix (plist-get interface-info :prefix))
 142                (object-interface (not (string-match "\\(\\.Manager\\|1\\)$" interface)))
 143                (service (pcase service
 144                           ("org.freedesktop.systemd1" 'systemd-dbus-service)
 145                           (_ service)))
 146                (path (pcase path
 147                        ("/org/freedesktop/systemd1" 'systemd-dbus-path)
 148                        (_ path)))
 149                forms)
 150           (when (and prefix (not (assoc interface interfaces)))
 151             (push `(defconst ,(plist-get interface-info :interface) ,interface) forms)
 152             (setq
 153              interfaces
 154              (append
 155               interfaces
 156               (list
 157                (cons
 158                 interface
 159                 (let ((interface (plist-get interface-info :interface)))
 160                   (dolist (interface-item (cddr item) (nreverse forms))
 161                     (cond
 162                      ((eq 'property (car-safe interface-item))
 163                       (let* ((property (xml-get-attribute interface-item 'name))
 164                              (name (intern (concat prefix "-" property)))
 165                              (readwrite
 166                               (string-equal
 167                                "readwrite"
 168                                (xml-get-attribute interface-item 'access)))
 169                              (arglist `(bus
 170                                         ,@(when object-interface
 171                                             '(path)))))
 172                         (push `(defun ,name ,arglist
 173                                  ,(if readwrite
 174                                       "Use `setf' to set the value of this property."
 175                                     "Read only property.")
 176                                  (dbus-get-property
 177                                   bus ,service
 178                                   ,(if object-interface 'path path)
 179                                   ,interface ,property))
 180                               forms)
 181                         (when readwrite
 182                           (push (list 'gv-define-setter name (cons 'value arglist)
 183                                       (list '\`
 184                                             (list 'dbus-set-property
 185                                                   '(\, bus)
 186                                                   service
 187                                                   (if object-interface
 188                                                       '(\, path)
 189                                                     path)
 190                                                   interface property
 191                                                   '(\, value))))
 192                                 forms))))
 193
 194                      ((eq 'method (car-safe interface-item))
 195                       (let* ((method (xml-get-attribute interface-item 'name))
 196                              (name (intern (concat prefix "-" method)))
 197                              (args (cl-remove-if-not
 198                                     (lambda (arg)
 199                                       (string= "in"
 200                                                (xml-get-attribute
 201                                                 arg 'direction)))
 202                                     (xml-get-children interface-item 'arg)))
 203                              (arglist `(bus ,@(when object-interface '(path))
 204                                             ,@(when args '(&rest args)))))
 205                         (push `(defun ,name ,arglist
 206                                  (,@(if args
 207                                         '(apply #'dbus-call-method)
 208                                       '(dbus-call-method))
 209                                   bus ,service
 210                                   ,(if object-interface 'path path)
 211                                   ,interface ,method
 212                                   ,@(when args '(args))))
 213                               forms)))))))))))))
 214        ((and (listp item) (eq 'node (xml-node-name item)))
 215         (let ((name (xml-get-attribute-or-nil item 'name)))
 216           (setq interfaces (systemd-codegen-introspect
 217                             service (concat path "/" name) interfaces))))))))
 218
 219 (defmacro systemd-codegen-define (suffix)
 220   (cons 'progn (cl-mapcan #'cdr (systemd-codegen-introspect
 221                                  (concat "org.freedesktop." suffix)
 222                                  (concat "/org/freedesktop/" suffix)))))
 223
 224 (defun systemd-codegen-to-string (suffix)
 225   (with-temp-buffer
 226     (pcase-dolist (`(,interface . ,forms)
 227                    (systemd-codegen-introspect
 228                     (concat "org.freedesktop." suffix)
 229                     (concat "/org/freedesktop/" suffix)))
 230       (insert ";;; " interface "\n\n")
 231       (dolist (form forms)
 232         (pp form (current-buffer))
 233         (insert "\n")))
 234     (delete-char -1)
 235     (emacs-lisp-mode)
 236     (goto-char (point-min))
 237     (while (re-search-forward "^(\\(defun\\|gv-define-setter\\)" nil t)
 238       (goto-char (match-beginning 0))
 239       (down-list 1) (forward-sexp 2) (delete-char 4) (up-list 1))
 240     (goto-char (point-min))
 241     (while (re-search-forward "(dbus-\\(get\\|set\\)-property" nil t)
 242       (goto-char (match-beginning 0))
 243       (down-list 1) (forward-sexp 4) (insert "\n") (up-list -1) (indent-sexp)
 244       (up-list 1))
 245     (goto-char (point-min))
 246     (while (re-search-forward "(apply #'dbus-call-method" nil t)
 247       (goto-char (match-beginning 0))
 248       (down-list 1) (forward-sexp 5) (insert "\n") (up-list -1) (indent-sexp)
 249       (up-list 1))
 250     (goto-char (point-min))
 251     (while (re-search-forward "(dbus-call-method" nil t)
 252       (goto-char (match-beginning 0))
 253       (down-list 1) (forward-sexp 4) (insert "\n") (up-list -1) (indent-sexp)
 254       (up-list 1))
 255     (buffer-string)))
 256
 257 (provide 'systemd-codegen)
 258 ;;; systemd-codegen.el ends here