debase/0000775000175500017550000000000014731552026012042 5ustar debacledebacledebase/README_src.org0000664000175500017550000004750014537355023014367 0ustar debacledebacle#+OPTIONS: toc:nil author:nil title:nil #+EXPORT_FILE_NAME: README.md * Debase, the D-Bus convenience layer for Emacs :PROPERTIES: :ID: 2055fdfe-f336-4c8c-b238-978bfe84d09c :END: #+TITLE: Debase, illustrated [[file:sorry.jpg]] D-Bus is an [[https://en.wikipedia.org/wiki/Inter-process_communication][IPC system]] which is ubiquitous on Linux, and (in this author’s opinion) not very good. Emacs has bindings for interfacing with it (see the former point), which are annoying to use (see the latter point). These days, numerous common system management tasks are implemented as D-Bus services rather than tradidional executables, and many of the command-line tools themselves are now front-ends which communicate via D-Bus. Mounting and unmounting disks, monitoring battery status, controlling display brightness, connecting to wireless networks and more are now handled with D-Bus services. It makes no sense to shell out to the tools when one could interact with them directly via D-Bus, if only it was less annoying to do so. Debase frees you from writing repetitive, annoying boilerplate code to drive D-Bus services by throwing another pile of abstraction at the problem, in the form of unreadably dense, macro-heavy, profoundly cursed Lisp. ** D-Bus Crash Course :PROPERTIES: :ID: d00772f4-8bfe-4f63-8d7f-ccc43d2586f2 :END: - Bus. A bus contains services; D-Bus can manage many different busses, but the two standard ones are: - System bus. This generally has hardware-interfacing and system management services. - Session bus. This is private to the current session, i.e. a logged-in user. - Services. A service exists on a bus, and is a set of information and operations offered by a program. Example: =org.bluez= on the system bus is the service which manages Bluetooth. - Objects. An object exists within a service, and typically represents a resource it manages. Objects are identified by paths; paths are namespaced under the service. Example: =/org/bluez/hci0/dev_01_23_45_67_89_AB= is the path to an object representing a specific Bluetooth device. Because this is part of the service, that path doesn’t represent anything in a different service, like =org.freedesktop.fwupd=. - Interfaces. An interface is a view into the capabilities of an object. Objects can (and almost always do) support multiple interfaces. Example: =org.bluez.Device1= is a general interface for managing pairing/unpairing/connecting/disconnecting from Bluetooth devices; =org.bluez.MediaControl1= is an interface for media devices, such as speakers or speakerphones. Since =/org/bluez/hci0/dev_01_23_45_67_89_AB= is a media device, it supports both interfaces. - Properties. A property is a value attached to an interface, which exposes information about an object. For example, the =Name= property in the =org.bluez.Device1= interface of =/org/bluez/hci0/dev_01_23_45_67_89_AB= is "Bluetooth Speaker" — the name of the device. Properties can be read/write, read-only, or write-only. - Methods. A method is a remote function call attached to an interface. For example, the =VolumeUp()= method in the =org.bluez.MediaControl1= interface of object =/org/bluez/hci0/dev_01_23_45_67_89_AB= in the =org.bluez= service of the system bus increases the volume of "Bluetooth Speaker." Methods can take arguments and return values. - Signals. D-Bus enabled applications can generate and respond to signals. A signal represents some kind of event, such as hardware being plugged in or unplugged. - Common interfaces. /Most/ D-Bus objects support some common interfaces: - [[https://dbus.freedesktop.org/doc/dbus-java/api/org/freedesktop/DBus.Introspectable.html][=org.freedesktop.DBus.Introspectable=]]. Allows retrieving the schema for the object as XML. It has all the interfaces it supports, as well as their properties and methods. - [[https://dbus.freedesktop.org/doc/dbus-java/api/org/freedesktop/DBus.Peer.html][=org.freedesktop.DBus.Peer=]]. Provides a =Ping= method. - [[https://dbus.freedesktop.org/doc/dbus-java/api/org/freedesktop/DBus.Properties.html][=org.freedesktop.DBus.Properties=]]. An interface which exposes object properties, and provides signals so other D-Bus applications receive notifications of changes to them. - [[https://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-objectmanager][=org.freedesktop.DBus.ObjectManager=]]. Used by D-Bus applications which manage other D-Bus objects. For example, the =org.bluez= service’s =/= object implements =ObjectManager=, which can be used to enumerate connected Bluetooth devices. It also provides signals when managed objects are added or removed. ** Debase Objects :PROPERTIES: :ID: a7ea0d8e-9923-4cd8-9d15-0e69158fda85 :END: Debase defines a =DEBASE-OBJECT= EIEIO base class, which acts as a proxy between Emacs Lisp and the D-Bus service. A =DEBASE-OBJECT= maps 1:1 with a D-Bus object, and stores the bus, service, path, and (optionally) interface of that object. #+BEGIN_SRC emacs-lisp :eval never (setf upower (debase-object :bus :system :service "org.freedesktop.UPower" :path "/org/freedesktop/UPower" :interface "org.freedesktop.UPower")) #+END_SRC Since many D-Bus objects use identical (or readily computable) values for service, path, and interface, you may omit the path and/or interface, and Debase will fill them in with what seem like reasonable values. The =DEBASE-TARGET= function will return a plist of these values, whether computed or provided explicitly. #+BEGIN_SRC emacs-lisp :results value verbatim :exports both (debase-object-target (debase-object :bus :system :service "org.freedesktop.UPower")) #+END_SRC #+RESULTS: : (:bus :system :service "org.freedesktop.UPower" :path "/org/freedesktop/UPower" :interface "org.freedesktop.UPower") #+BEGIN_SRC emacs-lisp :results value verbatim (debase-object-target (debase-object :bus :system :service "org.freedesktop.UDisks2" :interface "org.freedesktop.UDisks2.Manager")) #+END_SRC #+RESULTS: : (:bus :system :service "org.freedesktop.UDisks2" :path "/org/freedesktop/UDisks2/Manager" :interface "org.freedesktop.UDisks2.Manager") Debase also provides generic functions which mirror the ones in =dbus.el=, but take a single =DEBASE-OBJECT= instance instead of the bus/service/path/interface. So instead of slogging through a dozen lengthy variations: #+BEGIN_SRC emacs-lisp :results value verbatim (list (dbus-get-property :system "org.freedesktop.UDisks2" "/org/freedesktop/UDisks2/Manager" "org.freedesktop.UDisks2.Manager" "Version") (dbus-get-property :system "org.freedesktop.UDisks2" "/org/freedesktop/UDisks2/Manager" "org.freedesktop.UDisks2.Manager" "SupportedFilesystems")) #+END_SRC #+RESULTS: : ("2.8.1" ("ext2" "ext3" "ext4" "vfat" "ntfs" "exfat" "xfs" "reiserfs" "nilfs2" "btrfs" "minix" "udf" "f2fs" "swap")) You can set a single object and use it over and over: #+BEGIN_SRC emacs-lisp :results value verbatim (let ((udisks2-manager (debase-object :bus :system :service "org.freedesktop.UDisks2" :interface "org.freedesktop.UDisks2.Manager"))) (list (debase-get-property udisks2-manager "Version") (debase-get-property udisks2-manager "SupportedFilesystems"))) #+END_SRC #+RESULTS: : ("2.8.1" ("ext2" "ext3" "ext4" "vfat" "ntfs" "exfat" "xfs" "reiserfs" "nilfs2" "btrfs" "minix" "udf" "f2fs" "swap")) Replacing the =DBUS-= prefix of most =dbus.el= function names with =DEBASE-= should work, for example =DEBASE-GET-PROPERTY= instead of =DBUS-GET-PROPERTY=. *** Retargeting :PROPERTIES: :ID: ff136236-e61e-4b73-85e9-1ffdb42e547b :END: Many times, you’ll need to change the interface or path of a =DEBASE-OBJECT=, either to access a different facet of the object, or to access another object within the same service. EIEIO’s =CLONE= function makes it easy to swap out any part of the targeted object: #+BEGIN_SRC emacs-lisp :results value verbatim (let* ((block (debase-object :bus :system :service "org.freedesktop.UDisks2" :path "/org/freedesktop/UDisks2/block_devices/sda1" :interface "org.freedesktop.UDisks2.Block")) (block-dev (substring (apply #'string (debase-object-get block "Device")) 0 -1)) (partition (clone block :interface "org.freedesktop.UDisks2.Partition"))) (list block-dev (debase-object-get partition "UUID"))) #+END_SRC #+RESULTS: : ("/dev/sda1" "43754339-01") ** Building Blocks :PROPERTIES: :ID: 6f38ce0d-f488-4ceb-aab2-771e83b2428d :END: Even though Debase makes this easier, many D-Bus methods require additional type wrangling or conversion to be used comfortably. For these cases, you should subclass =DEBASE-OBJECT= and write more specialized methods. #+BEGIN_SRC emacs-lisp :results value verbatim (defclass udisks2-block (debase-object) ()) (cl-defmethod initialize-instance :after ((this udisks2-block) &rest ignore) (with-slots (bus service interface) this (setf bus :system service "org.freedesktop.UDisks2" interface "org.freedesktop.UDisks2.Block"))) (cl-defmethod udisks2-block-preferred-device ((this udisks2-block)) "Returns the preferred device for `UDISKS2-BLOCK' object THIS." (substring (apply #'string (debase-object-get this "Device")) 0 -1)) (let ((block (udisks2-block :path "/org/freedesktop/UDisks2/block_devices/sda1"))) (udisks2-block-preferred-device block)) #+END_SRC #+RESULTS: : "/dev/sda1" *** Object Manager :PROPERTIES: :ID: a55f476b-ed6a-4498-a4be-964cea6d2f29 :END: Debase provides a =DEBASE-OBJECTMANAGER= class which interacts with the =org.freedesktop.DBus.ObjectManager= interface. It maintains a local cache of managed objects, which is populated on instantiation and automatically updated when one is added or removed. If a class inherits from it, accessing the =MANAGED-OBJECTS= slot will return the currently managed objects. It can also dispatch notifications when the list of managed objects changes. ** Limitations :PROPERTIES: :ID: 1ad004df-82aa-4249-af27-8473d7b9ac75 :END: - Support for providing D-Bus services from Emacs (which non-Emacs programs could invoke) is not supported. ** Code Generation (Experimental) :PROPERTIES: :ID: 3a84fa53-e074-457e-8ac7-bb75b7ab7703 :END: Debase also offers a code generation facility, which turns the XML D-Bus interface descriptions into EIEIO classes. The intent is to eliminate the drudgery of building the code that interacts with D-Bus, so you can focus on making it do interesting things instead. This is an experimental feature, and while I think it might be a good idea, I’ve struggled with usability for actual projects. Feedback and/or code welcomed. Codegen is implemented as a hierarchy of EIEIO classes which extend the =DEBASE-GEN= base class, and provide a =DEBASE-GEN-CODE= generic functions which produce the desired output. The =DEBASE-GEN-CLASS= class is the main entrypoint. Basic example: #+BEGIN_SRC emacs-lisp :results code (thread-first (debase-gen-class :bus :system :service "org.freedesktop.UDisks2" :interface "org.freedesktop.UDisks2.Manager" :class-name 'udisks2-manager) debase-gen-code) #+END_SRC #+RESULTS: #+begin_src emacs-lisp (prog1 (defclass udisks2-manager (debase-object) ((version :type string :accessor version) (supported-filesystems :type t :accessor supported-filesystems)) :documentation "Debase interface class for D-Bus interface \"org.freedesktop.UDisks2.Manager\"") (cl-defmethod version ((this udisks2-manager)) (with-slots (bus service path interface) this (dbus-get-property bus service path interface "Version"))) (cl-defmethod supported-filesystems ((this udisks2-manager)) (with-slots (bus service path interface) this (dbus-get-property bus service path interface "SupportedFilesystems"))) (cl-defmethod can-format ((obj udisks2-manager) type) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"can-format\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "can-format" type)) (cl-defmethod can-resize ((obj udisks2-manager) type) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"can-resize\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "can-resize" type)) (cl-defmethod can-check ((obj udisks2-manager) type) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"can-check\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "can-check" type)) (cl-defmethod can-repair ((obj udisks2-manager) type) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"can-repair\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "can-repair" type)) (cl-defmethod loop-setup ((obj udisks2-manager) fd options) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"loop-setup\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "loop-setup" fd options)) (cl-defmethod mdraid-create ((obj udisks2-manager) blocks level name chunk options) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"mdraid-create\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "mdraid-create" blocks level name chunk options)) (cl-defmethod enable-modules ((obj udisks2-manager) enable) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"enable-modules\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "enable-modules" enable)) (cl-defmethod get-block-devices ((obj udisks2-manager) options) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"get-block-devices\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "get-block-devices" options)) (cl-defmethod resolve-device ((obj udisks2-manager) devspec options) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"resolve-device\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "resolve-device" devspec options))) #+end_src *** Name Mangling :PROPERTIES: :ID: 2975089a-7802-45fd-ac2f-f63b65c2d9cc :END: To make generated code more pleasant, =DEBASE-GEN= mangles D-Bus names into ones that are Lispier. The default mangling is handled by =DEBASE-GEN-MANGLE=, but you can supply your own functions for properties, methods, and argument names. For example, to leave method and argument names untouched, and prefix properties with "Prop": #+BEGIN_SRC emacs-lisp :results code (thread-first (debase-gen-class :bus :system :service "org.freedesktop.UDisks2" :interface "org.freedesktop.UDisks2.Manager" :class-name 'udisks2-manager :property-mangle (debase-gen-mangle-prefix "Prop") :method-mangle #'identity) debase-gen-code) #+END_SRC #+RESULTS: #+begin_src emacs-lisp (prog1 (defclass udisks2-manager (debase-object) ((PropVersion :type string :accessor PropVersion) (PropSupportedFilesystems :type t :accessor PropSupportedFilesystems)) :documentation "Debase interface class for D-Bus interface \"org.freedesktop.UDisks2.Manager\"") (cl-defmethod PropVersion ((this udisks2-manager)) (with-slots (bus service path interface) this (dbus-get-property bus service path interface "Version"))) (cl-defmethod PropSupportedFilesystems ((this udisks2-manager)) (with-slots (bus service path interface) this (dbus-get-property bus service path interface "SupportedFilesystems"))) (cl-defmethod CanFormat ((obj udisks2-manager) type) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"CanFormat\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "CanFormat" type)) (cl-defmethod CanResize ((obj udisks2-manager) type) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"CanResize\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "CanResize" type)) (cl-defmethod CanCheck ((obj udisks2-manager) type) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"CanCheck\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "CanCheck" type)) (cl-defmethod CanRepair ((obj udisks2-manager) type) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"CanRepair\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "CanRepair" type)) (cl-defmethod LoopSetup ((obj udisks2-manager) fd options) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"LoopSetup\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "LoopSetup" fd options)) (cl-defmethod MDRaidCreate ((obj udisks2-manager) blocks level name chunk options) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"MDRaidCreate\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "MDRaidCreate" blocks level name chunk options)) (cl-defmethod EnableModules ((obj udisks2-manager) enable) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"EnableModules\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "EnableModules" enable)) (cl-defmethod GetBlockDevices ((obj udisks2-manager) options) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"GetBlockDevices\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "GetBlockDevices" options)) (cl-defmethod ResolveDevice ((obj udisks2-manager) devspec options) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"ResolveDevice\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "ResolveDevice" devspec options))) #+end_src *** Multiple Inheritance :PROPERTIES: :ID: f56b2057-98b7-4d0c-857d-47550896dd22 :END: Fully representing a D-Bus object with EIEIO classes means generating one class for each interface it has, then creating a new class which inherits from all of them. I haven’t found a nice way of making this easy yet, so you’re on your own. debase/debase-objectmanager.el0000664000175500017550000000721714537355023016417 0ustar debacledebacle;;; debase-objectmanager.el --- D-Bus ObjectManager -*- lexical-binding: t; -*- ;; Copyright (C) 2021, 2022 Ian Eure ;; Author: Ian Eure ;; Keywords: lisp, unix ;; URL: https://github.com/ieure/debase ;; Version: 0.7 ;; Package-Requires: ((emacs "25.1")) ;; This program 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. ;; This program 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 this program. If not, see . ;;; Commentary: ;; DEBASE-OBJECTMANAGER implements the ;; org.freedesktop.DBus.ObjectManager D-Bus interface. ;;; Code: (require 'debase) (require 'eieio) (require 'dbus) (defclass debase-objectmanager (debase-object) ((managed-objects :type cons :documentation "List of objects this object manages.") (-objectmanager-on-change :initform '() :documentation "List of hook functions to call when MANAGED-OBJECTS changes.") (-objectmanager-signals :type cons :documentation "D-Bus signals this object has registered.")) :documentation "A class representing the D-Bus ObjectManager interface.") (cl-defmethod debase-objectmanager-onchange ((this debase-objectmanager) f) "When the state of objects manged by THIS changes, call function F." (with-slots (-objectmanager-on-change) this (add-to-list '-objectmanager-on-change f))) (cl-defmethod debase-objectmanager--changed ((this debase-objectmanager) &rest ignore) "Refresh objects managed by THIS. Calls hook functions in -OBJECTMANAGER-ON-CHANGE." (with-slots (managed-objects -objectmanager-on-change) this (setf managed-objects (debase-call (clone this :interface dbus-interface-objectmanager) "GetManagedObjects")) (dolist (f -objectmanager-on-change) (funcall f)))) (cl-defmethod initialize-instance :after ((this debase-objectmanager) &rest ignore) "Initialize instance THIS by populating managed objects." (unless (slot-boundp this 'interface) (error "Must target `%s' interface!" dbus-interface-objectmanager)) (debase-object-assert-interface this dbus-interface-objectmanager) (debase-objectmanager--changed this)) (cl-defmethod debase-objectmanager-start ((this debase-objectmanager)) "Begin listening for updates to managed objects on THIS." (with-slots (-objectmanager-signals) this (let ((om (clone this :interface dbus-interface-objectmanager))) (setf -objectmanager-signals (cl-loop for signal in '("InterfacesAdded" "InterfacesRemoved") collect (debase-listen om signal (apply-partially #'debase-objectmanager--changed this))))))) (cl-defmethod debase-objectmanager-started? ((this debase-objectmanager)) "Returns non-NIL if ObjectManager THIS is listening for changes." (and (slot-boundp this '-objectmanager-signals) (not (null (slot-value this '-objectmanager-signals))))) (cl-defmethod debase-objectmanager-stop ((this debase-objectmanager)) "Stop listening for updates to managed objects on THIS." (with-slots (-objectmanager-signals) this (mapc #'dbus-unregister-object -objectmanager-signals) (setf -objectmanager-signals nil))) (provide 'debase-objectmanager) ;;; debase-objectmanager.el ends here debase/debase--test.el0000664000175500017550000000310214537355023014637 0ustar debacledebacle;;; debase--tests.el --- Tests for debase -*- lexical-binding: t; -*- ;; Copyright (C) 2021 Ian Eure ;; Author: Ian Eure ;; Keywords: extensions ;; This program 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. ;; This program 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 this program. If not, see . ;;; Commentary: ;; Test code. ;;; Code: (require 'ert) (require 'debase) (ert-deftest debase--test--assert-success () (should (not (debase--assert '(interface) 'interface))) (should (not (debase--assert '(node) 'node))) (should (not (debase--assert '(property) 'property)))) (ert-deftest debase--test--assert-failure () :expected-result :failed (should (not (debase--assert '(interface) 'property))) (should (not (debase--assert '(node) 'property))) (should (not (debase--assert '(property) 'method)))) (ert-deftest debase--test--flet-partial () (debase-flet-partial ((+ 1) (message "Hello %s")) (should (= 6 (+ 5))) (should (string= "Hello world" (message "world"))))) (provide 'debase--tests) ;;; debase--tests.el ends here debase/debase-gen--test.el0000664000175500017550000004301114537355023015411 0ustar debacledebacle;;; debase-gen--test.el --- Tests for DEBASE-GEN -*- lexical-binding: t; -*- ;; Copyright (C) 2021 Ian Eure ;; Author: Ian Eure ;; Keywords: extensions ;; This program 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. ;; This program 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 this program. If not, see . ;;; Commentary: ;; Tests. ;;; Code: (require 'ert) (require 'debase-gen) (defconst debase-gen--test--xml '(node nil "\n " (interface ((name . "org.freedesktop.DBus.Properties")) "\n " (method ((name . "Get")) "\n " (arg ((type . "s") (name . "interface_name") (direction . "in"))) "\n " (arg ((type . "s") (name . "property_name") (direction . "in"))) "\n " (arg ((type . "v") (name . "value") (direction . "out"))) "\n ") "\n " (method ((name . "GetAll")) "\n " (arg ((type . "s") (name . "interface_name") (direction . "in"))) "\n " (arg ((type . "a{sv}") (name . "properties") (direction . "out"))) "\n ") "\n " (method ((name . "Set")) "\n " (arg ((type . "s") (name . "interface_name") (direction . "in"))) "\n " (arg ((type . "s") (name . "property_name") (direction . "in"))) "\n " (arg ((type . "v") (name . "value") (direction . "in"))) "\n ") "\n " (signal ((name . "PropertiesChanged")) "\n " (arg ((type . "s") (name . "interface_name"))) "\n " (arg ((type . "a{sv}") (name . "changed_properties"))) "\n " (arg ((type . "as") (name . "invalidated_properties"))) "\n ") "\n ") "\n " (interface ((name . "org.freedesktop.DBus.Introspectable")) "\n " (method ((name . "Introspect")) "\n " (arg ((type . "s") (name . "xml_data") (direction . "out"))) "\n ") "\n ") "\n " (interface ((name . "org.freedesktop.DBus.Peer")) "\n " (method ((name . "Ping"))) "\n " (method ((name . "GetMachineId")) "\n " (arg ((type . "s") (name . "machine_uuid") (direction . "out"))) "\n ") "\n ") "\n " (interface ((name . "org.freedesktop.UDisks2.Manager")) "\n " (method ((name . "CanFormat")) "\n " (arg ((type . "s") (name . "type") (direction . "in"))) "\n " (arg ((type . "(bs)") (name . "available") (direction . "out"))) "\n ") "\n " (method ((name . "CanResize")) "\n " (arg ((type . "s") (name . "type") (direction . "in"))) "\n " (arg ((type . "(bts)") (name . "available") (direction . "out"))) "\n ") "\n " (method ((name . "CanCheck")) "\n " (arg ((type . "s") (name . "type") (direction . "in"))) "\n " (arg ((type . "(bs)") (name . "available") (direction . "out"))) "\n ") "\n " (method ((name . "CanRepair")) "\n " (arg ((type . "s") (name . "type") (direction . "in"))) "\n " (arg ((type . "(bs)") (name . "available") (direction . "out"))) "\n ") "\n " (method ((name . "LoopSetup")) "\n " (arg ((type . "h") (name . "fd") (direction . "in"))) "\n " (arg ((type . "a{sv}") (name . "options") (direction . "in"))) "\n " (arg ((type . "o") (name . "resulting_device") (direction . "out"))) "\n ") "\n " (method ((name . "MDRaidCreate")) "\n " (arg ((type . "ao") (name . "blocks") (direction . "in"))) "\n " (arg ((type . "s") (name . "level") (direction . "in"))) "\n " (arg ((type . "s") (name . "name") (direction . "in"))) "\n " (arg ((type . "t") (name . "chunk") (direction . "in"))) "\n " (arg ((type . "a{sv}") (name . "options") (direction . "in"))) "\n " (arg ((type . "o") (name . "resulting_array") (direction . "out"))) "\n ") "\n " (method ((name . "EnableModules")) "\n " (arg ((type . "b") (name . "enable") (direction . "in"))) "\n ") "\n " (method ((name . "GetBlockDevices")) "\n " (arg ((type . "a{sv}") (name . "options") (direction . "in"))) "\n " (arg ((type . "ao") (name . "block_objects") (direction . "out"))) "\n ") "\n " (method ((name . "ResolveDevice")) "\n " (arg ((type . "a{sv}") (name . "devspec") (direction . "in"))) "\n " (arg ((type . "a{sv}") (name . "options") (direction . "in"))) "\n " (arg ((type . "ao") (name . "devices") (direction . "out"))) "\n ") "\n " (property ((type . "s") (name . "Version") (access . "read"))) "\n " (property ((type . "as") (name . "SupportedFilesystems") (access . "read"))) "\n ") "\n")) (ert-deftest debase-gen-method--test () (let* ((cgen (debase-gen-class :class-name 'foo :interface "org.freedesktop.UDisks2.Manager")) (method '(method ((name . "Get")) "\n " (arg ((type . "s") (name . "interface_name") (direction . "in"))) "\n " (arg ((type . "s") (name . "property_name") (direction . "in"))) "\n " (arg ((type . "v") (name . "value") (direction . "out"))) "\n ")) (gen (debase-gen-method :class-generator cgen :xml method))) (should (equal (debase-gen-method-->arglist gen) '(interface_name property_name))) (should (equal (debase-gen-code gen) '(cl-defmethod Get ((obj foo) interface_name property_name) "Return the results of calling D-Bus interface \"org.freedesktop.UDisks2.Manager\" method \"Get\" on a `DEBASE-OBJECT' OBJ." (dbus-call-method this "Get" interface_name property_name)))))) (ert-deftest debase-test--property-readable? () (should (debase--property-readable? '(property ((type . "ao") (name . "Devices") (access . "read"))))) (should (debase--property-readable? '(property ((type . "ao") (name . "Devices") (access . "readwrite"))))) (should (null (debase--property-readable? '(property ((type . "ao") (name . "Devices") (access . "write"))))))) (ert-deftest debase-test--property-writeable? () (should (null (debase--property-writeable? '(property ((type . "ao") (name . "Devices") (access . "read")))))) (should (eq t (debase--property-writeable? '(property ((type . "ao") (name . "Devices") (access . "write")))))) (should (eq t (debase--property-writeable? '(property ((type . "ao") (name . "Devices") (access . "readwrite"))))))) (provide 'debase-gen--test) ;;; debase-gen--test.el ends here debase/README.md0000664000175500017550000002546414537355023013336 0ustar debacledebacle# Debase, the D-Bus convenience layer for Emacs ![img](sorry.jpg) D-Bus is an [IPC system](https://en.wikipedia.org/wiki/Inter-process_communication) which is ubiquitous on Linux, and (in this author’s opinion) not very good. Emacs has bindings for interfacing with it (see the former point), which are annoying to use (see the latter point). These days, numerous common system management tasks are implemented as D-Bus services rather than tradidional executables, and many of the command-line tools themselves are now front-ends which communicate via D-Bus. Mounting and unmounting disks, monitoring battery status, controlling display brightness, connecting to wireless networks and more are now handled with D-Bus services. It makes no sense to shell out to the tools when one could interact with them directly via D-Bus, if only it was less annoying to do so. Debase frees you from writing repetitive, annoying boilerplate code to drive D-Bus services by throwing another pile of abstraction at the problem, in the form of unreadably dense, macro-heavy, profoundly cursed Lisp. ## D-Bus Crash Course - Bus. A bus contains services; D-Bus can manage many different busses, but the two standard ones are: - System bus. This generally has hardware-interfacing and system management services. - Session bus. This is private to the current session, i.e. a logged-in user. - Services. A service exists on a bus, and is a set of information and operations offered by a program. Example: `org.bluez` on the system bus is the service which manages Bluetooth. - Objects. An object exists within a service, and typically represents a resource it manages. Objects are identified by paths; paths are namespaced under the service. Example: `/org/bluez/hci0/dev_01_23_45_67_89_AB` is the path to an object representing a specific Bluetooth device. Because this is part of the service, that path doesn’t represent anything in a different service, like `org.freedesktop.fwupd`. - Interfaces. An interface is a view into the capabilities of an object. Objects can (and almost always do) support multiple interfaces. Example: `org.bluez.Device1` is a general interface for managing pairing/unpairing/connecting/disconnecting from Bluetooth devices; `org.bluez.MediaControl1` is an interface for media devices, such as speakers or speakerphones. Since `/org/bluez/hci0/dev_01_23_45_67_89_AB` is a media device, it supports both interfaces. - Properties. A property is a value attached to an interface, which exposes information about an object. For example, the `Name` property in the `org.bluez.Device1` interface of `/org/bluez/hci0/dev_01_23_45_67_89_AB` is "Bluetooth Speaker" — the name of the device. Properties can be read/write, read-only, or write-only. - Methods. A method is a remote function call attached to an interface. For example, the `VolumeUp()` method in the `org.bluez.MediaControl1` interface of object `/org/bluez/hci0/dev_01_23_45_67_89_AB` in the `org.bluez` service of the system bus increases the volume of "Bluetooth Speaker." Methods can take arguments and return values. - Signals. D-Bus enabled applications can generate and respond to signals. A signal represents some kind of event, such as hardware being plugged in or unplugged. - Common interfaces. *Most* D-Bus objects support some common interfaces: - [`org.freedesktop.DBus.Introspectable`](https://dbus.freedesktop.org/doc/dbus-java/api/org/freedesktop/DBus.Introspectable.html). Allows retrieving the schema for the object as XML. It has all the interfaces it supports, as well as their properties and methods. - [`org.freedesktop.DBus.Peer`](https://dbus.freedesktop.org/doc/dbus-java/api/org/freedesktop/DBus.Peer.html). Provides a `Ping` method. - [`org.freedesktop.DBus.Properties`](https://dbus.freedesktop.org/doc/dbus-java/api/org/freedesktop/DBus.Properties.html). An interface which exposes object properties, and provides signals so other D-Bus applications receive notifications of changes to them. - [`org.freedesktop.DBus.ObjectManager`](https://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-objectmanager). Used by D-Bus applications which manage other D-Bus objects. For example, the `org.bluez` service’s `/` object implements `ObjectManager`, which can be used to enumerate connected Bluetooth devices. It also provides signals when managed objects are added or removed. ## Debase Objects Debase defines a `DEBASE-OBJECT` EIEIO base class, which acts as a proxy between Emacs Lisp and the D-Bus service. A `DEBASE-OBJECT` maps 1:1 with a D-Bus object, and stores the bus, service, path, and (optionally) interface of that object. ```emacs-lisp (setf upower (debase-object :bus :system :service "org.freedesktop.UPower" :path "/org/freedesktop/UPower" :interface "org.freedesktop.UPower")) ``` Since many D-Bus objects use identical (or readily computable) values for service, path, and interface, you may omit the path and/or interface, and Debase will fill them in with what seem like reasonable values. The `DEBASE-TARGET` function will return a plist of these values, whether computed or provided explicitly. ```emacs-lisp (debase-object-target (debase-object :bus :system :service "org.freedesktop.UPower")) ``` (:bus :system :service "org.freedesktop.UPower" :path "/org/freedesktop/UPower" :interface "org.freedesktop.UPower") ```emacs-lisp (debase-object-target (debase-object :bus :system :service "org.freedesktop.UDisks2" :interface "org.freedesktop.UDisks2.Manager")) ``` Debase also provides generic functions which mirror the ones in `dbus.el`, but take a single `DEBASE-OBJECT` instance instead of the bus/service/path/interface. So instead of slogging through a dozen lengthy variations: ```emacs-lisp (list (dbus-get-property :system "org.freedesktop.UDisks2" "/org/freedesktop/UDisks2/Manager" "org.freedesktop.UDisks2.Manager" "Version") (dbus-get-property :system "org.freedesktop.UDisks2" "/org/freedesktop/UDisks2/Manager" "org.freedesktop.UDisks2.Manager" "SupportedFilesystems")) ``` You can set a single object and use it over and over: ```emacs-lisp (let ((udisks2-manager (debase-object :bus :system :service "org.freedesktop.UDisks2" :interface "org.freedesktop.UDisks2.Manager"))) (list (debase-get-property udisks2-manager "Version") (debase-get-property udisks2-manager "SupportedFilesystems"))) ``` Replacing the `DBUS-` prefix of most `dbus.el` function names with `DEBASE-` should work, for example `DEBASE-GET-PROPERTY` instead of `DBUS-GET-PROPERTY`. ### Retargeting Many times, you’ll need to change the interface or path of a `DEBASE-OBJECT`, either to access a different facet of the object, or to access another object within the same service. EIEIO’s `CLONE` function makes it easy to swap out any part of the targeted object: ```emacs-lisp (let* ((block (debase-object :bus :system :service "org.freedesktop.UDisks2" :path "/org/freedesktop/UDisks2/block_devices/sda1" :interface "org.freedesktop.UDisks2.Block")) (block-dev (substring (apply #'string (debase-object-get block "Device")) 0 -1)) (partition (clone block :interface "org.freedesktop.UDisks2.Partition"))) (list block-dev (debase-object-get partition "UUID"))) ``` ## Building Blocks Even though Debase makes this easier, many D-Bus methods require additional type wrangling or conversion to be used comfortably. For these cases, you should subclass `DEBASE-OBJECT` and write more specialized methods. ```emacs-lisp (defclass udisks2-block (debase-object) ()) (cl-defmethod initialize-instance :after ((this udisks2-block) &rest ignore) (with-slots (bus service interface) this (setf bus :system service "org.freedesktop.UDisks2" interface "org.freedesktop.UDisks2.Block"))) (cl-defmethod udisks2-block-preferred-device ((this udisks2-block)) "Returns the preferred device for `UDISKS2-BLOCK' object THIS." (substring (apply #'string (debase-object-get this "Device")) 0 -1)) (let ((block (udisks2-block :path "/org/freedesktop/UDisks2/block_devices/sda1"))) (udisks2-block-preferred-device block)) ``` ### Object Manager Debase provides a `DEBASE-OBJECTMANAGER` class which interacts with the `org.freedesktop.DBus.ObjectManager` interface. It maintains a local cache of managed objects, which is populated on instantiation and automatically updated when one is added or removed. If a class inherits from it, accessing the `MANAGED-OBJECTS` slot will return the currently managed objects. It can also dispatch notifications when the list of managed objects changes. ## Limitations - Support for providing D-Bus services from Emacs (which non-Emacs programs could invoke) is not supported. ## Code Generation (Experimental) Debase also offers a code generation facility, which turns the XML D-Bus interface descriptions into EIEIO classes. The intent is to eliminate the drudgery of building the code that interacts with D-Bus, so you can focus on making it do interesting things instead. This is an experimental feature, and while I think it might be a good idea, I’ve struggled with usability for actual projects. Feedback and/or code welcomed. Codegen is implemented as a hierarchy of EIEIO classes which extend the `DEBASE-GEN` base class, and provide a `DEBASE-GEN-CODE` generic functions which produce the desired output. The `DEBASE-GEN-CLASS` class is the main entrypoint. Basic example: ```emacs-lisp (thread-first (debase-gen-class :bus :system :service "org.freedesktop.UDisks2" :interface "org.freedesktop.UDisks2.Manager" :class-name 'udisks2-manager) debase-gen-code) ``` ### Name Mangling To make generated code more pleasant, `DEBASE-GEN` mangles D-Bus names into ones that are Lispier. The default mangling is handled by `DEBASE-GEN-MANGLE`, but you can supply your own functions for properties, methods, and argument names. For example, to leave method and argument names untouched, and prefix properties with "Prop": ```emacs-lisp (thread-first (debase-gen-class :bus :system :service "org.freedesktop.UDisks2" :interface "org.freedesktop.UDisks2.Manager" :class-name 'udisks2-manager :property-mangle (debase-gen-mangle-prefix "Prop") :method-mangle #'identity) debase-gen-code) ``` ### Multiple Inheritance Fully representing a D-Bus object with EIEIO classes means generating one class for each interface it has, then creating a new class which inherits from all of them. I haven’t found a nice way of making this easy yet, so you’re on your own. debase/debase-gen.el0000664000175500017550000002622014537355023014362 0ustar debacledebacle;;; debase-gen.el --- Debase code generation -*- lexical-binding: t; -*- ;; Copyright (C) 2019, 2020, 2021, 2022 Ian Eure ;; Author: Ian Eure ;; Keywords: lisp, unix ;; URL: https://github.com/ieure/debase ;; Version: 0.7 ;; Package-Requires: ((emacs "25.1")) ;; This program 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. ;; This program 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 this program. If not, see . ;;; Commentary: ;; DEBASE-GEN creates EIEIO classes for D-Bus interfaces. ;;; Code: (require 'debase) (require 'eieio) (require 'gv) (require 'dom) ;; Name mangling (defun debase-gen-mangle (dbus-name) "Mangles DBUS-NAME into something Lispier. ex. FooBARQuux -> foo-bar-quux." (let ((case-fold-search)) (downcase (replace-regexp-in-string "\\([a-z]\\)\\([A-Z]\\)" "\\1-\\2" dbus-name)))) (defun debase-gen-mangle-prefix (prefix) "Return a function that mangles a dbus name by adding PREFIX to it." (lambda (dbus-name) (concat prefix dbus-name))) (defun debase-mangle-compose (&rest manglers) "Compose MANGLERS, returning a function which runs them in order. Like Clojure's function composition.." (lambda (dbus-name) (cl-loop with name = dbus-name for mangler in manglers do (setf name (funcall mangler name)) finally return name))) ;; Base class (defclass debase-gen (debase-object) ((class-generator :initarg :class-generator :documentation "Reference to the class generator associated with this generator.") (mangle :initarg :mangle :type function :initform #'debase-gen-mangle :documentation "A function to produce Lisp names from D-Bus string identifiers.")) :abstract t :documentation "Base class for Debase code generation. Code generation produces an EIEIO class which extends `DEBASE-OBJECT' and represents a D-Bus interface. ") ;; Method generation (defclass debase-gen-method (debase-gen) () :documentation "Class to generate D-Bus methods.") (cl-defmethod debase-gen-method-->arglist ((this debase-gen-method)) "Return the CL argument list for `debase-gen-method' THIS." (with-slots (xml mangle) this (cl-loop for child in (dom-non-text-children xml) with i = 0 when (eq 'arg (dom-tag child)) when (string= "in" (cdr (assoc 'direction (dom-attributes child)))) collect (intern (or (funcall mangle (cdr (assoc 'name (dom-attributes child)))) (format "arg%d" i))) do (cl-incf i)))) (cl-defmethod initialize-instance :after ((this debase-gen-method) &rest ignore) "Initialize `DEBASE-GEN-METHOD' instance THIS." (with-slots (xml) this (debase--assert xml 'method))) (cl-defmethod debase-gen-code ((this debase-gen-method)) "Return generated EIEIO method definition for THIS." (with-slots (class-generator xml mangle) this (with-slots (class-name) class-generator (let ((method-name (funcall mangle (cdr (assoc 'name (dom-attributes xml))))) (args (debase-gen-method-->arglist this))) `(cl-defmethod ,(intern method-name) ((obj ,class-name) ,@args) ,(format "Return the results of calling D-Bus interface \"%s\" method \"%s\" on `DEBASE-OBJECT' OBJ." (oref class-generator interface) method-name) (dbus-call-method this ,method-name ,@args)))))) ;; Properties: slot definitions (defclass debase-gen-slotdef (debase-gen) ((method-mangle :initarg :method-mangle :initform nil :documentation "A function to mangle method names.")) :documentation "Class to generate slot definitions for D-Bus properties.") (cl-defmethod initialize-instance :after ((this debase-gen-slotdef) &rest igore) (with-slots (xml) this (debase--assert xml 'property))) (cl-defmethod debase-gen-code ((this debase-gen-slotdef)) "Return slot definition for property PROPERTY-DEF." (with-slots (xml mangle method-mangle) this (let ((property-name (cdr (assoc 'name (dom-attributes xml))))) ;; Ignore the prefix for the property name's slot. `(,(intern (funcall mangle property-name)) :type ,(debase--type->lisp (cdr (assoc 'type (dom-attributes xml)))) ;; But use it for the accessor. :accessor ,(intern (funcall (or method-mangle mangle) property-name)))))) ;; Properties: accessors (defclass debase-gen-accessors (debase-gen) ((property-mangle :initarg :property-mangle :initform nil :documentation "A function to mangle property names.")) :documentation "Class to generate D-Bus properties.") (cl-defmethod initialize-instance :after ((this debase-gen-accessors) &rest igore) (with-slots (xml) this (debase--assert xml 'property))) (cl-defmethod debase-gen-accessors--access ((this debase-gen-accessors)) "Return the access specification of D-Bus property THIS." (with-slots (xml) this (cdr (assoc 'access (dom-attributes xml))))) (cl-defmethod debase-gen-accessors--readable? ((this debase-gen-accessors)) "Returns non-NIL if properpty THIS is readable." (member (debase-gen-accessors--access this) '("read" "readwrite"))) (cl-defmethod debase-gen-accessors--writeable? ((this debase-gen-accessors)) "Returns non-NIL if property THIS is writable." (member (debase-gen-accessors--access this) '("write" "readwrite"))) (cl-defmethod debase-gen-code ((this debase-gen-accessors)) "Return the EIEIO method definition for THIS." (with-slots (xml mangle property-mangle class-generator) this (with-slots (class-name) class-generator (let* ((helpers) (pm (or property-mangle mangle)) (raw-property-name (cdr (assoc 'name (dom-attributes xml)))) (property-name (if pm (funcall pm raw-property-name) raw-property-name)) (accessor (intern (funcall mangle property-name)))) (when (debase-gen-accessors--writeable? this) ;; Clear the setter, if there is one, otherwise `gv-setter' complains. (put accessor 'gv-expander nil) (thread-first `(gv-define-setter ,accessor (val obj) (debase-set-property obj ,raw-property-name ,val)) (push helpers))) (thread-first `(cl-defmethod ,accessor ((this ,class-name)) ,(format "Access slot %s of `%s'." (upcase property-name) (upcase (format "%s" class-name))) ,(if (debase-gen-accessors--readable? this) `(debase-get-property this ,raw-property-name) `(error "Property `%s' isn't readable" ,property-name))) (push helpers)) helpers)))) ;; Classes (defun debase-gen-class--properties (interface-def) "Return properties for D-Bus interface INTERFACE-DEF." (debase--assert interface-def 'interface) (thread-first (lambda (child) (eq 'property (dom-tag child))) (cl-remove-if-not (dom-non-text-children interface-def)))) (defun debase-gen-class--methods (interface-def) "Return methods for D-Bus interface INTERFACE-DEF." (debase--assert interface-def 'interface) (thread-first (lambda (child) (eq 'method (dom-tag child))) (cl-remove-if-not (dom-non-text-children interface-def)))) (defclass debase-gen-class (debase-gen) ((class-name :initarg :class-name :type symbol :documentation "Name of the class to generate.") (slotdef-generator :initform #'debase-gen-slotdef :documentation "Constructor for class to generate slot definitions for properties.") (accessors-generator :initform #'debase-gen-accessors :documentation "Constructor for class to generate accessors for properties.") (property-mangle :initarg :property-mangle :documentation "A function to mangle property names. Passed to SLOTDEF-GENERATOR and ACCESSORS-GENERATOR. Defaults to the value of the MANGLE slot.") (method-generator :initform #'debase-gen-method :documentation "Constructor for class to generate methods.") (method-mangle :initarg :method-mangle :documentation "A function to mangle method names. Defaults to the value of the MANGLE slot.")) :documentation "A class which generates other classes.") (cl-defmethod initialize-instance :after ((this debase-gen-class) &rest args) (unless (and (slot-boundp this 'class-name) (slot-value this 'class-name)) (error "Must specify :CLASS-NAME")) (unless (and (slot-boundp this 'interface) (slot-value this 'interface)) (error "Must specify :INTERFACE")) (with-slots (interface class-name mangle) this (debase-object-assert-interface this interface) (unless (slot-boundp this 'property-mangle) (oset this property-mangle mangle)) (unless (slot-boundp this 'method-mangle) (oset this method-mangle (debase-mangle-compose mangle (debase-gen-mangle-prefix (format "%s-" class-name))))))) (cl-defmethod debase-gen-code ((this debase-gen-class)) "Return definition of an EIEIO class to interface with D-Bus. The return value is an expression for an EIEIO class, its generic methods, and property accessors." (with-slots (interface property-mangle slotdef-generator accessors-generator method-generator method-mangle) this (let* ((interface-def (car (debase-object--interfaces this interface))) (slotdef-generators (mapcar (lambda (xml) (funcall slotdef-generator :class-generator this :mangle property-mangle :method-mangle method-mangle :xml xml)) (debase-gen-class--properties interface-def))) (accessors-generators (mapcar (lambda (xml) (funcall accessors-generator :class-generator this :property-mangle property-mangle :mangle method-mangle :xml xml)) (debase-gen-class--properties interface-def))) (method-generators (mapcar (lambda (xml) (funcall method-generator :class-generator this :mangle method-mangle :xml xml)) (debase-gen-class--methods interface-def)))) (with-slots (class-name) this `(prog1 (defclass ,class-name (debase-object) ,(mapcar #'debase-gen-code slotdef-generators) :documentation ,(format "Debase interface class for D-Bus interface \"%s\"" interface)) ;; Each generator returns a list of accessors, because ;; properties may have readers and writers. Append all the ;; results together. ,@(apply #'append (mapcar #'debase-gen-code accessors-generators)) ,@(mapcar #'debase-gen-code method-generators)))))) (provide 'debase-gen) ;;; debase-gen.el ends here debase/debase.el0000664000175500017550000002070714537355023013617 0ustar debacledebacle;;; debase.el --- DBus convenience -*- lexical-binding: t; -*- ;; Copyright (C) 2019, 2020, 2021, 2022, 2023 Ian Eure ;; Author: Ian Eure ;; Keywords: lisp, unix ;; URL: https://github.com/ieure/debase ;; Version: 0.7 ;; Package-Requires: ((emacs "25.1")) ;; This program 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. ;; This program 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 this program. If not, see . ;;; Commentary: ;; lol ;;; Code: (require 'dbus) (require 'eieio) (require 'pcase) (require 'dom) (defvar debase--ignore-interfaces '("org.freedesktop.DBus.Properties" "org.freedesktop.DBus.Introspectable" "org.freedesktop.DBus.Peer") "Interfaces to ignore.") ;; Helper functions (defun debase--assert (xml? expected-type) "Assert that D-Bus XML? is of type EXPECTED-TYPE." (let ((actual-type (car xml?))) (cl-assert (eq expected-type actual-type) "Expected type `%s', but got `%s'" expected-type actual-type))) (defun debase-interface-name (interface-def) "Return the name of the interface in INTERFACE-DEF XML." (debase--assert interface-def 'interface) (cdr (assoc 'name (dom-attributes interface-def)))) (defun debase--type->lisp (type) "Return the Lisp type for a D-Bus type specification." ;; https://dbus.freedesktop.org/doc/dbus-specification.html (pcase type ("b" 'boolean) ("s" 'string) ; string ("o" 'string) ; object path ("g" 'string) ; type signature ((or "y" "n" "q" "i" "u" "x" "t") 'string) ("d" 'float) (_ t))) (defun debase--type->hint (type) "Return the dbus.el type hint for a D-Bus type specification." ;; https://dbus.freedesktop.org/doc/dbus-specification.html (pcase type ("a" '(:array)) ("a{sv}" `(:array :signature "{sv}")))) ;; Binding helpers (cl-defmacro debase-flet-partial (bindings &rest forms) "Like FLET, but binds ARGS partially applied to FUNC around FORMS. \(fn ((FUNC ARGS) ...) FORMS)" (declare (indent 1)) `(cl-flet ,(cl-loop for (func . args) in bindings collect `(,func (apply-partially #',func ,@args))) ,@forms)) (cl-defmacro debase-bind* ((bus service path &optional interface) &rest forms) "Bind D-Bus functions around FORMS, targeting BUS SERVICE PATH INTERFACE Inside FORMS, calls to DBUS-INTROSPECT-XML, DBUS-CALL-METHOD, DBUS-GET-PROPERTY, AND DBUS-SET-PROPERTY take their bus, service, path, from this function's arguments. \(fn (BUS SERVICE PATH &OPTIONAL INTERFACE) &REST FORMS)" (declare (indent 2)) (let ((oargs (list bus service path)) (iargs `(,bus ,service ,path ,(when interface interface)))) `(debase-flet-partial ((dbus-introspect-xml ,@oargs) (dbus-get-property ,@iargs) (dbus-set-property ,@iargs) (dbus-call-method ,@iargs) (dbus-register-signal ,@iargs)) ,@forms))) (cl-defmacro debase-bind (debase-object &rest forms) "Bind FORMS so D-Bus methods implicitly target DEBASE-OBJECT. Inside FORMS, calls to DBUS-INTROSPECT-XML, DBUS-CALL-METHOD, DBUS-GET-PROPERTY, AND DBUS-SET-PROPERTY take their bus, service, path, and interface arguments from DBUS-OBJECT, and don't require them to be set. \(fn DEBASE-OBJECT &REST FORMS)" (declare (indent 1)) `(with-slots (bus service path interface) ,debase-object (debase-bind* (bus service path interface) ,@forms))) ;; Objects (defclass debase-object () ((bus :initarg :bus :type symbol :documentation "Bus the D-Bus service is on.") (service :initarg :service :type string :documentation "D-Bus service.") (path :initarg :path :type string :documentation "Path to D-Bus object.") (interface :initarg :interface :type string :accessor debase-object--interfaces :documentation "Interface this object binds to, if any.") (xml :initarg :xml :type cons :accessor debase-object--xml :documentation "XML representation of the D-Bus object. See `DBUS-INTROSPECT-XML'.")) :documentation "Base class for D-Bus objects.") (cl-defmethod initialize-instance :after ((this debase-object) &rest ignore) "Initialize `DEBASE-OBJECT' instance THIS, ignoring args IGNORE." (with-slots (service) this (unless (slot-boundp this 'interface) (ignore-errors (oset this interface service))) (unless (slot-boundp this 'path) (ignore-errors (oset this path (concat "/" (replace-regexp-in-string "\\." "/" (oref this interface)))))))) (cl-defmethod debase-object-target ((this debase-object)) "Return the target of `DEBASE-OBJECT' THIS. Target is a list (BUS SERVICE PATH &OPTIONAL INTERFACE)." (with-slots (bus service path interface) this (list :bus bus :service service :path path :interface interface))) (cl-defmethod debase-object--xml ((this debase-object)) "Return XML representation of D-Bus object THIS." (unless (slot-boundp this 'xml) (oset this xml (debase-bind this (dbus-introspect-xml)))) (oref this xml)) (cl-defmethod debase-object-assert-interface ((this debase-object) interface) "Assert that `DEBASE-OBJECT' THIS supports INTERFACE." (cl-assert (member interface (mapcar #'debase-interface-name (debase-object--interfaces this :all))) nil "Object `%s' doesn't implement interface `%s'" (type-of this) interface)) (cl-defmethod debase-object--interfaces ((this debase-object) &optional interfaces) "Return D-Bus interface definitions INTERFACES from XML. If INTERFACES is nil, returns all interfaces except those in `debase--ignore-interfaces'. If INTERFACES is :all, returns all interfaces, even those in `debase--ignore-interfaces'. If INTERFACES is a list of strings, return interfaces matching them." (let ((xml (debase-object--xml this))) (debase--assert xml 'node) (cl-loop for child in (dom-non-text-children xml) when (eq 'interface (dom-tag child)) when (cond ((eq interfaces :all) t) ((consp interfaces) (member (debase-interface-name child) interfaces)) (t (not (member (debase-interface-name child) debase--ignore-interfaces)))) collect child))) (cl-defmethod debase-call-method ((this debase-object) method &rest args) "Call METHOD with ARGS on interface THIS. See `dbus-call-method' for the complete semantics." (debase-bind this (apply #'dbus-call-method method args))) (cl-defmethod debase-call-method-asynchronously ((this debase-object) method handler &rest args) "Call METHOD with ARGS on interface THIS, asynchronously. See `dbus-call-method-asynchronously' for the complete semantics." (debase-bind this (if args (apply #'dbus-call-method-asynchronously method handler args) (funcall #'dbus-call-method-asynchronously method handler)))) (cl-defmethod debase-get-property ((this debase-object) property) "Get value of PROPERTY on interface THIS. See `dbus-get-property' for the complete semantics." (debase-bind this (dbus-get-property property))) (cl-defmethod debase-set-property ((this debase-object) property value) "Set value of PROPERTY to VALUE on interface THIS. See `dbus-set-property' for the complete semantics." (debase-bind this (dbus-set-property property value))) (cl-defmethod debase-register-signal ((this debase-object) signal handler &rest args) "When SIGNAL fires on THIS, invoke HANDLER wtih ARGS. See `dbus-register-signal' for the complete semantics." (debase-bind this (if args (apply #'dbus-register-signal signal handler args) (funcall #'dbus-register-signal signal handler)))) ;; Aliases for convenience. (defalias #'debase-call #'debase-call-method) (defalias #'debase-get #'debase-get-property) (defalias #'debase-set #'debase-set-property) (defalias #'debase-listen #'debase-register-signal) (provide 'debase) ;;; debase.el ends here