From: Michael Albinus <michael.albinus@gmx.de>
To: Hugh Daschbach <hugh@ccss.com>
Cc: 43146@debbugs.gnu.org
Subject: bug#43146: 27.1; D-Bus property handling incomplete
Date: Thu, 03 Sep 2020 13:52:50 +0200 [thread overview]
Message-ID: <87o8mnt6ul.fsf@gmx.de> (raw)
In-Reply-To: <877dtbsurc.fsf@ccss.com> (Hugh Daschbach's message of "Wed, 02 Sep 2020 15:01:43 -0700")
[-- Attachment #1: Type: text/plain, Size: 369 bytes --]
Hugh Daschbach <hugh@ccss.com> writes:
Hi Hugh,
> I've tweaked the test script to examine the "Set" and "GetAll"
> methods. The updated version is attached below.
Thanks for the test file.
I've appended another patch, could you pls apply this instead of the
first one? Locally, I've tested your script successfully.
> Thanks again,
> Hugh
Best regards, Michael.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 5663 bytes --]
*** /tmp/ediffWCMSQF 2020-09-03 13:49:33.193916784 +0200
--- /home/albinus/src/emacs-27/lisp/net/dbus.el 2020-09-03 13:36:44.960364842 +0200
***************
*** 1477,1482 ****
--- 1477,1502 ----
(nreverse result))
(push (cons (car dict) (cl-caadr dict)) result)))))
+ (defun dbus-get-this-registered-property (bus _service path interface property)
+ "Return PROPERTY entry of `dbus-registered-objects-table'.
+ Filter out not matching PATH."
+ ;; Remove entries not belonging to this case.
+ (seq-remove
+ (lambda (item)
+ (not (string-equal path (nth 2 item))))
+ (gethash (list :property bus interface property)
+ dbus-registered-objects-table)))
+
+ (defun dbus-get-other-registered-property (bus _service path interface property)
+ "Return PROPERTY entry of `dbus-registered-objects-table'.
+ Filter out matching PATH."
+ ;; Remove matching entries.
+ (seq-remove
+ (lambda (item)
+ (string-equal path (nth 2 item)))
+ (gethash (list :property bus interface property)
+ dbus-registered-objects-table)))
+
(defun dbus-register-property
(bus service path interface property access value
&optional emits-signal dont-register-service)
***************
*** 1543,1554 ****
;; because the property might be accessed from anybody.
(let ((key (list :property bus interface property))
(val
! (list
(list
nil service path
(cons
(if emits-signal (list access :emits-signal) (list access))
! value)))))
(puthash key val dbus-registered-objects-table)
;; Return the object.
--- 1563,1576 ----
;; because the property might be accessed from anybody.
(let ((key (list :property bus interface property))
(val
! (cons
(list
nil service path
(cons
(if emits-signal (list access :emits-signal) (list access))
! value))
! (dbus-get-other-registered-property
! bus service path interface property))))
(puthash key val dbus-registered-objects-table)
;; Return the object.
***************
*** 1566,1581 ****
(cond
;; "Get" returns a variant.
((string-equal method "Get")
! (let ((entry (gethash (list :property bus interface property)
! dbus-registered-objects-table)))
(when (string-equal path (nth 2 (car entry)))
`((:variant ,(cdar (last (car entry))))))))
;; "Set" expects a variant.
((string-equal method "Set")
(let* ((value (caar (cddr args)))
! (entry (gethash (list :property bus interface property)
! dbus-registered-objects-table))
;; The value of the hash table is a list; in case of
;; properties it contains just one element (UNAME SERVICE
;; PATH OBJECT). OBJECT is a cons cell of a list, which
--- 1588,1603 ----
(cond
;; "Get" returns a variant.
((string-equal method "Get")
! (let ((entry (dbus-get-this-registered-property
! bus service path interface property)))
(when (string-equal path (nth 2 (car entry)))
`((:variant ,(cdar (last (car entry))))))))
;; "Set" expects a variant.
((string-equal method "Set")
(let* ((value (caar (cddr args)))
! (entry (dbus-get-this-registered-property
! bus service path interface property))
;; The value of the hash table is a list; in case of
;; properties it contains just one element (UNAME SERVICE
;; PATH OBJECT). OBJECT is a cons cell of a list, which
***************
*** 1590,1597 ****
(signal 'dbus-error
(list "Property not writable at path" property path)))
(puthash (list :property bus interface property)
! (list (append (butlast (car entry))
! (list (cons (car object) value))))
dbus-registered-objects-table)
;; Send the "PropertiesChanged" signal.
(when (member :emits-signal (car object))
--- 1612,1621 ----
(signal 'dbus-error
(list "Property not writable at path" property path)))
(puthash (list :property bus interface property)
! (cons (append (butlast (car entry))
! (list (cons (car object) value)))
! (dbus-get-other-registered-property
! bus service path interface property))
dbus-registered-objects-table)
;; Send the "PropertiesChanged" signal.
(when (member :emits-signal (car object))
***************
*** 1607,1620 ****
(let (result)
(maphash
(lambda (key val)
! (when (and (equal (butlast key) (list :property bus interface))
! (string-equal path (nth 2 (car val)))
! (not (functionp (car (last (car val))))))
! (push
! (list :dict-entry
! (car (last key))
! (list :variant (cdar (last (car val)))))
! result)))
dbus-registered-objects-table)
;; Return the result, or an empty array.
(list :array (or result '(:signature "{sv}"))))))))
--- 1631,1645 ----
(let (result)
(maphash
(lambda (key val)
! (dolist (item val)
! (when (and (equal (butlast key) (list :property bus interface))
! (string-equal path (nth 2 item))
! (not (functionp (car (last item)))))
! (push
! (list :dict-entry
! (car (last key))
! (list :variant (cdar (last item))))
! result))))
dbus-registered-objects-table)
;; Return the result, or an empty array.
(list :array (or result '(:signature "{sv}"))))))))
next prev parent reply other threads:[~2020-09-03 11:52 UTC|newest]
Thread overview: 8+ messages / expand[flat|nested] mbox.gz Atom feed top
2020-09-01 1:41 bug#43146: 27.1; D-Bus property handling incomplete Hugh Daschbach
2020-09-02 17:58 ` Michael Albinus
2020-09-02 19:01 ` Hugh Daschbach
2020-09-02 22:01 ` Hugh Daschbach
2020-09-03 11:52 ` Michael Albinus [this message]
2020-09-03 18:23 ` Hugh Daschbach
2020-09-03 18:57 ` Michael Albinus
2020-09-03 6:50 ` Michael Albinus
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87o8mnt6ul.fsf@gmx.de \
--to=michael.albinus@gmx.de \
--cc=43146@debbugs.gnu.org \
--cc=hugh@ccss.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).