1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
|
;;; debase.el --- DBus convenience -*- lexical-binding: t; -*-
;; Copyright (C) 2019, 2020, 2021, 2022, 2023 Ian Eure
;; Author: Ian Eure <ian@retrospec.tv>
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; lol
;;; Code:
(require 'dbus)
(require 'eieio)
(require 'pcase)
(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
|
