Menu
▾
▴
[SCM] emacs-jabber branch, roster-optimisation, created. 9bf8d47f8caa8c346beb45501293650347836794
|
From: Magnus H. <leg...@us...> - 2015-04-09 22:57:31
|
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "emacs-jabber".
The branch, roster-optimisation has been created
at 9bf8d47f8caa8c346beb45501293650347836794 (commit)
- Log -----------------------------------------------------------------
commit 9bf8d47f8caa8c346beb45501293650347836794
Author: Magnus Henoch <mag...@gm...>
Date: Thu Apr 9 21:13:03 2015 +0100
Sort contacts in incremental roster redisplay
Also add corresponding tests.
diff --git a/jabber-roster.el b/jabber-roster.el
index 1dfb409..9c16241 100644
--- a/jabber-roster.el
+++ b/jabber-roster.el
@@ -861,16 +861,46 @@ three being lists of JID symbols."
(entry (gethash buddy buddy-ewoc-node-hash))
(current-groups (or (get buddy 'groups)
(list jabber-roster-default-group-name)))
- (to-be-removed
- (remove-if
- (lambda (node)
- (member (caar (ewoc-data node)) current-groups))
- entry))
- (to-be-updated
- (set-difference entry to-be-removed)))
- (mapc delete-roster-item to-be-removed)
- (apply #'ewoc-invalidate ewoc to-be-updated)
- (puthash buddy to-be-updated buddy-ewoc-node-hash)))))))
+ new-entry)
+ (dolist (node entry)
+ (if (not (member (caar (ewoc-data node)) current-groups))
+ ;; If the contact has been removed from a roster group,
+ ;; just remove from display under that roster group.
+ (funcall delete-roster-item node)
+ ;; Check if the sort order has changed.
+ (cond
+ ;; Should the item move up?
+ ((let ((previous (ewoc-prev ewoc node))
+ insert-before)
+ (while (let ((previous-buddy (and previous (cadr (ewoc-data previous)))))
+ (when (and previous-buddy
+ (jabber-roster-sort-items buddy previous-buddy))
+ (setq insert-before previous)
+ (setq previous (ewoc-prev ewoc previous))
+ t)))
+ (when insert-before
+ (let ((data (ewoc-data node)))
+ (ewoc-delete ewoc node)
+ (push (ewoc-enter-before ewoc insert-before data) new-entry)))))
+ ;; Should the item move down?
+ ((let ((next (ewoc-next ewoc node))
+ insert-after)
+ (while (let ((next-buddy (and next (cadr (ewoc-data next)))))
+ (when (and next-buddy
+ (jabber-roster-sort-items next-buddy buddy))
+ (setq insert-after next)
+ (setq next (ewoc-next ewoc next))
+ t)))
+ (when insert-after
+ (let ((data (ewoc-data node)))
+ (ewoc-delete ewoc node)
+ (push (ewoc-enter-after ewoc insert-after data) new-entry)))))
+ ;; Or should it be updated in place?
+ (t
+ (ewoc-invalidate ewoc node)
+ (push node new-entry)))))
+ ;; Update hash table with new ewoc node list.
+ (puthash buddy new-entry buddy-ewoc-node-hash)))))))
(defalias 'jabber-presence-update-roster 'ignore)
;;jabber-presence-update-roster is not needed anymore.
diff --git a/tests/roster-display.el b/tests/roster-display.el
index 9ee56fb..c16f7c8 100644
--- a/tests/roster-display.el
+++ b/tests/roster-display.el
@@ -377,3 +377,88 @@
" * ju...@ca... Online \n"
"__________________________________\n"
"\n"))
+
+;;; More than one contact
+
+(setq jabber-show-offline-contacts t)
+
+(jabber-process-input
+ (car jabber-connections)
+ '(iq ((type . "set"))
+ (query ((xmlns . "jabber:iq:roster"))
+ (item ((jid . "mer...@ca..."))
+ (group () "Capulets")))))
+
+(rd-check-roster-buffer)
+
+(rd-compare
+ "Two contacts in separate groups"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "Capulets\n"
+ " mer...@ca... Offline \n"
+ "Lovers\n"
+ " * ju...@ca... Online \n"
+ "__________________________________\n"
+ "\n"))
+
+(jabber-process-input
+ (car jabber-connections)
+ '(iq ((type . "set"))
+ (query ((xmlns . "jabber:iq:roster"))
+ (item ((jid . "ju...@ca..."))
+ (group () "Capulets")
+ (group () "Lovers")))))
+
+(rd-check-roster-buffer)
+
+(rd-compare
+ "One contact in both groups"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "Capulets\n"
+ " * ju...@ca... Online \n"
+ " mer...@ca... Offline \n"
+ "Lovers\n"
+ " * ju...@ca... Online \n"
+ "__________________________________\n"
+ "\n"))
+
+(trace-function-background 'jabber-roster-sort-items "*trace*")
+
+(jabber-process-input
+ (car jabber-connections)
+ '(presence ((from . "mer...@ca.../balcony"))
+ (show () "chat")))
+
+(rd-check-roster-buffer)
+
+(rd-compare
+ "Chatty contact ordered first"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "Capulets\n"
+ " * mer...@ca... Chatty \n"
+ " * ju...@ca... Online \n"
+ "Lovers\n"
+ " * ju...@ca... Online \n"
+ "__________________________________\n"
+ "\n"))
commit 794362d2b703825055fb283292e87b21800f46f6
Author: Magnus Henoch <mag...@gm...>
Date: Thu Apr 9 11:20:30 2015 +0100
Use remove-if-not instead of cl-remove-if-not
The cl- name was introduced in 24.3, but we still want to support Emacs
23.
diff --git a/jabber-roster.el b/jabber-roster.el
index a7efb33..1dfb409 100644
--- a/jabber-roster.el
+++ b/jabber-roster.el
@@ -815,13 +815,13 @@ three being lists of JID symbols."
;; should be added/removed.
(unless jabber-show-offline-contacts
(let* ((actually-added
- (cl-remove-if-not
+ (remove-if-not
(lambda (buddy)
(and (jabber-roster--display-item-p buddy)
(not (gethash buddy buddy-ewoc-node-hash))))
changed-items))
(actually-removed
- (cl-remove-if-not
+ (remove-if-not
(lambda (buddy)
(and (not (jabber-roster--display-item-p buddy))
(gethash buddy buddy-ewoc-node-hash)))
commit 1e82016cce811dcecd81c4f52cf670e123a4545d
Author: Magnus Henoch <mag...@gm...>
Date: Thu Apr 9 11:11:56 2015 +0100
Use defadvice instead of advice-add for roster display test
advice-add was added in Emacs 24.4. Let's support running the test on
previous versions.
diff --git a/tests/roster-display.el b/tests/roster-display.el
index e70885e..9ee56fb 100644
--- a/tests/roster-display.el
+++ b/tests/roster-display.el
@@ -5,14 +5,13 @@
(setq jabber-roster-debug t)
;; Ensure that errors are logged
-(advice-add 'jabber-roster-update :around
- (lambda (oldfun &rest r)
- (condition-case e
- (apply oldfun r)
- (error
- (princ "error in jabber-roster-update!\n")
- (princ (error-message-string e))
- (signal (car e) (cdr e))))))
+(defadvice jabber-roster-update (around log-errors activate)
+ (condition-case e
+ ad-do-it
+ (error
+ (princ "error in jabber-roster-update!\n")
+ (princ (error-message-string e))
+ (signal (car e) (cdr e)))))
(trace-function-background 'jabber-roster-update "*trace*")
(trace-function-background 'fsm-send-sync "*trace*")
commit 40acdf8f5403d0edf112e53a4096c58b9c280ac7
Author: Magnus Henoch <mag...@gm...>
Date: Thu Apr 9 10:54:59 2015 +0100
Print test suite log when tests fail in Travis
diff --git a/.travis.yml b/.travis.yml
index 4f08543..22d210f 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -13,4 +13,5 @@ script:
- automake --version
- autoreconf -i
- ./configure
- - make all check
+ - make all
+ - make check VERBOSE=yes
commit f5fb07b194c3599d1a7c7966d48799d58dd3557d
Author: Magnus Henoch <mag...@gm...>
Date: Wed Apr 8 21:38:57 2015 +0100
First attempt at more efficient roster redisplay
If we're not adding any entries, only updating or removing them, don't
redraw the entire roster buffer, just change the ewoc items that need
changing. Keep ewoc nodes in hash tables for fast lookup.
diff --git a/jabber-roster.el b/jabber-roster.el
index ddec536..a7efb33 100644
--- a/jabber-roster.el
+++ b/jabber-roster.el
@@ -581,7 +581,11 @@ H Toggle displaying this text
'face 'jabber-title-medium)
"\n__________________________________\n")
"__________________________________"))
- (new-groups '()))
+ (new-groups '())
+ (buddy-ewoc-node-hash (make-hash-table :test 'equal))
+ (group-ewoc-node-hash (make-hash-table :test 'equal)))
+ (plist-put (fsm-get-state-data jc) :buddy-ewoc-node-hash buddy-ewoc-node-hash)
+ (plist-put (fsm-get-state-data jc) :group-ewoc-node-hash group-ewoc-node-hash)
(plist-put(fsm-get-state-data jc) :roster-ewoc ewoc)
(dolist (group (plist-get (fsm-get-state-data jc) :roster-groups))
(let* ((group-name (car group))
@@ -591,12 +595,16 @@ H Toggle displaying this text
(when (or jabber-roster-show-empty-group
(> (length buddies) 0))
(let ((group-node (ewoc-enter-last ewoc (list group nil))))
+ (puthash group group-node group-ewoc-node-hash)
(if (not (find
group-name
(plist-get (fsm-get-state-data jc) :roster-roll-groups)
:test 'string=))
(dolist (buddy (reverse buddies))
- (ewoc-enter-after ewoc group-node (list group buddy))))))))
+ (let ((new-node
+ (ewoc-enter-after ewoc group-node (list group buddy)))
+ (entry (gethash buddy buddy-ewoc-node-hash)))
+ (puthash buddy (cons new-node entry) buddy-ewoc-node-hash))))))))
(goto-char (point-max))
(insert "\n")
(put-text-property before-ewoc (point)
@@ -730,24 +738,10 @@ three being lists of JID symbols."
(hash (plist-get (fsm-get-state-data jc) :roster-hash))
(ewoc (plist-get (fsm-get-state-data jc) :roster-ewoc))
(all-groups (plist-get (fsm-get-state-data jc) :roster-groups))
- (terminator
- (lambda (deleted-items)
- (dolist (delete-this deleted-items)
- (let ((groups (get delete-this 'groups))
- (terminator
- (lambda (g)
- (let*
- ((group (or g jabber-roster-default-group-name))
- (buddies (gethash group hash)))
- (when (not buddies)
- (setq new-groups (append new-groups (list group))))
- (puthash group
- (delq delete-this buddies)
- hash)))))
- (if groups
- (dolist (group groups)
- (terminator group))
- (terminator groups)))))))
+ (buddy-ewoc-node-hash (plist-get (fsm-get-state-data jc) :buddy-ewoc-node-hash))
+ (group-ewoc-node-hash (plist-get (fsm-get-state-data jc) :group-ewoc-node-hash))
+ ;; Currently we need to redraw the roster when items are added.
+ (need-redraw (not (null new-items))))
;; fix a old-roster
(dolist (delete-this deleted-items)
@@ -776,11 +770,19 @@ three being lists of JID symbols."
;; insert changed-items
(dolist (insert-this (append changed-items new-items))
- (let ((jid (symbol-name insert-this)))
+ (let* ((jid (symbol-name insert-this))
+ (existing-ewoc-data (mapcar #'ewoc-data (gethash insert-this buddy-ewoc-node-hash)))
+ (old-groups (mapcar #'caar existing-ewoc-data))
+ (new-groups (or (get insert-this 'groups)
+ (list jabber-roster-default-group-name))))
+ ;; If a contact is added to a group, we currently need to
+ ;; redraw the entire roster buffer.
+ (setq need-redraw
+ (or need-redraw
+ (not (null (set-difference new-groups old-groups :test #'string=)))))
(when jabber-roster-debug
(message (concat "insert jid: " jid)))
- (dolist (group (or (get insert-this 'groups)
- (list jabber-roster-default-group-name)))
+ (dolist (group new-groups)
(when jabber-roster-debug
(message (concat "insert jid: " jid " to group " group)))
(puthash group
@@ -804,8 +806,71 @@ three being lists of JID symbols."
(when jabber-roster-debug
(message "re display roster"))
- ;; recreate roster buffer
- (jabber-display-roster)))
+ (if (or (null ewoc) need-redraw)
+ ;; Recreate roster buffer if there is no ewoc, or if items
+ ;; have been added.
+ ;; TODO: handle added items more gracefully.
+ (jabber-display-roster)
+ ;; If we're not showing offline contacts, figure out which items
+ ;; should be added/removed.
+ (unless jabber-show-offline-contacts
+ (let* ((actually-added
+ (cl-remove-if-not
+ (lambda (buddy)
+ (and (jabber-roster--display-item-p buddy)
+ (not (gethash buddy buddy-ewoc-node-hash))))
+ changed-items))
+ (actually-removed
+ (cl-remove-if-not
+ (lambda (buddy)
+ (and (not (jabber-roster--display-item-p buddy))
+ (gethash buddy buddy-ewoc-node-hash)))
+ changed-items)))
+ (setq changed-items (set-difference changed-items actually-added))
+ (setq changed-items (set-difference changed-items actually-removed))
+ (setq new-items (append actually-added new-items))
+ (setq deleted-items (append actually-removed deleted-items))))
+
+ (let ((delete-roster-item
+ (lambda (node)
+ (let ((previous (ewoc-prev ewoc node))
+ (next (ewoc-next ewoc node)))
+ (ewoc-delete ewoc node)
+ (when (and
+ ;; Was the previous ewoc node a group node?
+ (null (cadr (ewoc-data previous)))
+ ;; And is the following node also a group node,
+ ;; or the end of the ewoc?
+ (or (null next) (null (cadr (ewoc-data next)))))
+ ;; That means that we just emptied a group. Let's
+ ;; remove the preceding group heading.
+ (ewoc-delete ewoc previous))))))
+ ;; changed-items and deleted-items are lists of symbols. Let's
+ ;; look them up in buddy-ewoc-node-hash.
+ (dolist (buddy deleted-items)
+ ;; Because a contact can be in multiple groups, there might be
+ ;; several ewoc items.
+ (let ((inhibit-read-only t)
+ (entry (gethash buddy buddy-ewoc-node-hash)))
+ (mapc delete-roster-item entry)
+ (remhash buddy buddy-ewoc-node-hash)))
+ ;; Hm, what is the ewoc data exactly? It's a list, (GROUP BUDDY).
+ ;; BUDDY is a symbol, so it already contains all relevant data.
+ (dolist (buddy changed-items)
+ (let* ((inhibit-read-only t)
+ (entry (gethash buddy buddy-ewoc-node-hash))
+ (current-groups (or (get buddy 'groups)
+ (list jabber-roster-default-group-name)))
+ (to-be-removed
+ (remove-if
+ (lambda (node)
+ (member (caar (ewoc-data node)) current-groups))
+ entry))
+ (to-be-updated
+ (set-difference entry to-be-removed)))
+ (mapc delete-roster-item to-be-removed)
+ (apply #'ewoc-invalidate ewoc to-be-updated)
+ (puthash buddy to-be-updated buddy-ewoc-node-hash)))))))
(defalias 'jabber-presence-update-roster 'ignore)
;;jabber-presence-update-roster is not needed anymore.
commit d68187dc490882fd2d9cc4ca57d419b8e7404f12
Author: Magnus Henoch <mag...@gm...>
Date: Wed Apr 8 21:33:53 2015 +0100
Factor out jabber-roster--display-item-p
diff --git a/jabber-roster.el b/jabber-roster.el
index 6b2f18f..ddec536 100644
--- a/jabber-roster.el
+++ b/jabber-roster.el
@@ -491,11 +491,12 @@ See `jabber-sort-order' for order used."
There is only one; we don't rely on buffer-local variables or
such.")
+(defun jabber-roster--display-item-p (buddy)
+ (or jabber-show-offline-contacts (get buddy 'connected)))
+
(defun jabber-roster-filter-display (buddies)
"Filter BUDDIES for items to be displayed in the roster"
- (remove-if-not (lambda (buddy) (or jabber-show-offline-contacts
- (get buddy 'connected)))
- buddies))
+ (remove-if-not #'jabber-roster--display-item-p buddies))
(defun jabber-roster-toggle-offline-display ()
"Toggle display of offline contacts.
commit c241638e73accce7ae3a96b6d991d74083de9d3e
Author: Magnus Henoch <mag...@gm...>
Date: Wed Apr 8 21:33:01 2015 +0100
More debug output for roster display test
diff --git a/tests/roster-display.el b/tests/roster-display.el
index cafebed..e70885e 100644
--- a/tests/roster-display.el
+++ b/tests/roster-display.el
@@ -2,6 +2,20 @@
(require 'cl)
(setq jabber-roster-show-bindings nil)
+(setq jabber-roster-debug t)
+
+;; Ensure that errors are logged
+(advice-add 'jabber-roster-update :around
+ (lambda (oldfun &rest r)
+ (condition-case e
+ (apply oldfun r)
+ (error
+ (princ "error in jabber-roster-update!\n")
+ (princ (error-message-string e))
+ (signal (car e) (cdr e))))))
+
+(trace-function-background 'jabber-roster-update "*trace*")
+(trace-function-background 'fsm-send-sync "*trace*")
;; jabber-post-connect-hooks is run after the roster has been drawn
;; for the first time - but jabber-send-presence will redraw the
@@ -37,6 +51,8 @@
(prin1 (substring rd-roster-string 0 result))
(princ " ***mismatch here*** ")
(prin1 (substring rd-roster-string result))
+ (princ (with-current-buffer "*fsm-debug*" (buffer-string)))
+ (princ (with-current-buffer "*trace*" (buffer-string)))
(error "Mismatch"))))
(jabberd-connect)
commit 467a028f99637886b83fb42a7623f1460809f029
Author: Magnus Henoch <mag...@gm...>
Date: Wed Apr 8 11:37:49 2015 +0100
Test roster display with offline contacts hidden
diff --git a/tests/roster-display.el b/tests/roster-display.el
index 28a2392..cafebed 100644
--- a/tests/roster-display.el
+++ b/tests/roster-display.el
@@ -224,3 +224,141 @@
"\n"
"__________________________________\n"
"\n"))
+
+;;; Hiding offline contacts
+
+(setq jabber-show-offline-contacts nil)
+
+(jabber-process-input
+ (car jabber-connections)
+ '(iq ((type . "set"))
+ (query ((xmlns . "jabber:iq:roster"))
+ (item ((jid . "ju...@ca..."))))))
+
+(rd-check-roster-buffer)
+
+(rd-compare
+ "One contact (offline)"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "__________________________________\n"
+ "\n"))
+
+(jabber-process-input
+ (car jabber-connections)
+ '(presence ((from . "ju...@ca.../balcony"))))
+
+(rd-check-roster-buffer)
+
+(rd-compare
+ "Contact goes online"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "other\n"
+ " * ju...@ca... Online \n"
+ "__________________________________\n"
+ "\n"))
+
+(jabber-process-input
+ (car jabber-connections)
+ '(iq ((type . "set"))
+ (query ((xmlns . "jabber:iq:roster"))
+ (item ((jid . "ju...@ca..."))
+ (group () "Capulets")
+ (group () "Lovers")))))
+
+(rd-check-roster-buffer)
+
+(rd-compare
+ "Contact in two groups"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "Capulets\n"
+ " * ju...@ca... Online \n"
+ "Lovers\n"
+ " * ju...@ca... Online \n"
+ "__________________________________\n"
+ "\n"))
+
+(jabber-process-input
+ (car jabber-connections)
+ '(iq ((type . "set"))
+ (query ((xmlns . "jabber:iq:roster"))
+ (item ((jid . "ju...@ca..."))
+ (group () "Lovers")))))
+
+(rd-check-roster-buffer)
+
+(rd-compare
+ "Contact moved to one group"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "Lovers\n"
+ " * ju...@ca... Online \n"
+ "__________________________________\n"
+ "\n"))
+
+(jabber-process-input
+ (car jabber-connections)
+ '(presence ((from . "ju...@ca.../balcony")
+ (type . "unavailable"))))
+
+(rd-check-roster-buffer)
+
+(rd-compare
+ "Contact goes offline (offline contacts hidden)"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "__________________________________\n"
+ "\n"))
+
+(jabber-process-input
+ (car jabber-connections)
+ '(presence ((from . "ju...@ca.../balcony"))))
+
+(rd-check-roster-buffer)
+
+(rd-compare
+ "Contact goes online again"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "Lovers\n"
+ " * ju...@ca... Online \n"
+ "__________________________________\n"
+ "\n"))
commit 029b602cd1b0f6157384fa867cf4a7ed52a68151
Author: Magnus Henoch <mag...@gm...>
Date: Wed Apr 8 11:23:37 2015 +0100
Test contact going offline
diff --git a/tests/roster-display.el b/tests/roster-display.el
index 5b12fdd..28a2392 100644
--- a/tests/roster-display.el
+++ b/tests/roster-display.el
@@ -183,6 +183,28 @@
(jabber-process-input
(car jabber-connections)
+ '(presence ((from . "ju...@ca.../balcony")
+ (type . "unavailable"))))
+
+(rd-check-roster-buffer)
+
+(rd-compare
+ "Contact goes offline"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "Lovers\n"
+ " ju...@ca... Offline \n"
+ "__________________________________\n"
+ "\n"))
+
+(jabber-process-input
+ (car jabber-connections)
'(iq ((type . "set"))
(query ((xmlns . "jabber:iq:roster"))
(item ((jid . "ju...@ca...")
commit 1dbb381105214ba8a10e3942841e131f60d5786c
Author: Magnus Henoch <mag...@gm...>
Date: Tue Apr 7 10:36:48 2015 +0100
Wait for or force relevant roster changes in roster-display test
Put them in the rd-check-roster-buffer function, so we can't miss them.
diff --git a/tests/roster-display.el b/tests/roster-display.el
index 85d24c9..5b12fdd 100644
--- a/tests/roster-display.el
+++ b/tests/roster-display.el
@@ -13,6 +13,13 @@
(defvar rd-roster-string nil)
(defun rd-check-roster-buffer (&optional _jc)
+ ;; The presence stanza causes an asynchronous :roster-update message
+ ;; to be sent. Let's wait for that.
+ (accept-process-output nil 0.1)
+
+ ;; Roster updates are batched. Force a timeout.
+ (fsm-send-sync (car jabber-connections) :timeout)
+
(with-current-buffer jabber-roster-buffer
(let ((contents (buffer-string)))
(set-text-properties 0 (length contents) () contents)
@@ -131,9 +138,6 @@
(car jabber-connections)
'(presence ((from . "ju...@ca.../balcony"))))
-;; Roster updates are batched. Force a timeout.
-(fsm-send-sync (car jabber-connections) :timeout)
-
(rd-check-roster-buffer)
(rd-compare
commit d04ad63ad2c6517bce04d4780aac8613b02a6ae9
Author: Magnus Henoch <mag...@gm...>
Date: Fri Apr 3 19:49:54 2015 +0100
Use :key arguments to simplify the code
diff --git a/jabber-roster.el b/jabber-roster.el
index c7ba74b..6b2f18f 100644
--- a/jabber-roster.el
+++ b/jabber-roster.el
@@ -791,18 +791,11 @@ three being lists of JID symbols."
(when jabber-roster-debug
(message "remove duplicates from new group"))
- (setq all-groups (sort
+ (setq all-groups (sort*
(remove-duplicates all-groups
- :test (lambda (g1 g2)
- (let ((g1-name (car g1))
- (g2-name (car g2)))
- (string= g1-name
- g2-name))))
- (lambda (g1 g2)
- (let ((g1-name (car g1))
- (g2-name (car g2)))
- (string< g1-name
- g2-name)))))
+ :test #'string=
+ :key #'car)
+ #'string< :key #'car))
(plist-put (fsm-get-state-data jc) :roster-groups all-groups))
commit 74420285a69be2361d7389294d97b240ee834c9a
Author: Magnus Henoch <mag...@gm...>
Date: Fri Apr 3 19:44:15 2015 +0100
Use function symbols instead of lambdas where possible
It looks tidier, and is probably a tiny tiny bit faster.
diff --git a/jabber-roster.el b/jabber-roster.el
index b62b182..c7ba74b 100644
--- a/jabber-roster.el
+++ b/jabber-roster.el
@@ -766,7 +766,7 @@ three being lists of JID symbols."
(let ((jid (symbol-name delete-this)))
(when jabber-roster-debug
(message (concat "delete jid: " jid)))
- (dolist (group (mapcar (lambda (g) (car g)) all-groups))
+ (dolist (group (mapcar #'car all-groups))
(when jabber-roster-debug
(message (concat "try to delete jid: " jid " from group " group)))
(puthash group
@@ -880,7 +880,7 @@ If optional PREV is non-nil, return position of previous property appearence."
(let* ((groups (plist-get (fsm-get-state-data jc) :roster-roll-groups))
(roll-groups
(if groups
- (mapconcat (lambda (a) (substring-no-properties a)) groups "\n")
+ (mapconcat #'substring-no-properties groups "\n")
"")))
(jabber-private-set jc
`(roster ((xmlns . "emacs-jabber"))
commit e1eaa4331a56f060af9eedd15f48fcf69d9be8fd
Author: Magnus Henoch <mag...@gm...>
Date: Thu Apr 2 18:56:04 2015 +0100
More roster display tests
diff --git a/tests/roster-display.el b/tests/roster-display.el
index 0b30300..85d24c9 100644
--- a/tests/roster-display.el
+++ b/tests/roster-display.el
@@ -75,3 +75,126 @@
" ju...@ca... Offline \n"
"__________________________________\n"
"\n"))
+
+(jabber-process-input
+ (car jabber-connections)
+ '(iq ((type . "set"))
+ (query ((xmlns . "jabber:iq:roster"))
+ (item ((jid . "ju...@ca..."))
+ (group () "Capulets")))))
+
+(rd-check-roster-buffer)
+
+(rd-compare
+ "One contact in one group"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "Capulets\n"
+ " ju...@ca... Offline \n"
+ "__________________________________\n"
+ "\n"))
+
+(jabber-process-input
+ (car jabber-connections)
+ '(iq ((type . "set"))
+ (query ((xmlns . "jabber:iq:roster"))
+ (item ((jid . "ju...@ca..."))
+ (group () "Capulets")
+ (group () "Lovers")))))
+
+(rd-check-roster-buffer)
+
+(rd-compare
+ "One contact in two groups"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "Capulets\n"
+ " ju...@ca... Offline \n"
+ "Lovers\n"
+ " ju...@ca... Offline \n"
+ "__________________________________\n"
+ "\n"))
+
+(jabber-process-input
+ (car jabber-connections)
+ '(presence ((from . "ju...@ca.../balcony"))))
+
+;; Roster updates are batched. Force a timeout.
+(fsm-send-sync (car jabber-connections) :timeout)
+
+(rd-check-roster-buffer)
+
+(rd-compare
+ "Contact goes online"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "Capulets\n"
+ " * ju...@ca... Online \n"
+ "Lovers\n"
+ " * ju...@ca... Online \n"
+ "__________________________________\n"
+ "\n"))
+
+(jabber-process-input
+ (car jabber-connections)
+ '(iq ((type . "set"))
+ (query ((xmlns . "jabber:iq:roster"))
+ (item ((jid . "ju...@ca..."))
+ (group () "Lovers")))))
+
+(rd-check-roster-buffer)
+
+(rd-compare
+ "Contact moved to one group"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "Lovers\n"
+ " * ju...@ca... Online \n"
+ "__________________________________\n"
+ "\n"))
+
+(jabber-process-input
+ (car jabber-connections)
+ '(iq ((type . "set"))
+ (query ((xmlns . "jabber:iq:roster"))
+ (item ((jid . "ju...@ca...")
+ (subscription . "remove"))))))
+
+(rd-check-roster-buffer)
+
+(rd-compare
+ "Contact deleted"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "__________________________________\n"
+ "\n"))
commit 6f54ef927b2c872e723658420266079105decc0e
Author: Magnus Henoch <mag...@gm...>
Date: Wed Apr 1 20:01:49 2015 +0100
Test display of roster with one contact
diff --git a/tests/roster-display.el b/tests/roster-display.el
index 2be1208..0b30300 100644
--- a/tests/roster-display.el
+++ b/tests/roster-display.el
@@ -12,18 +12,6 @@
(defvar rd-roster-string nil)
-(defconst rd-expected-roster
- (concat
- "Jabber roster\n"
- "__________________________________\n"
- "\n"
- " - Online -\n"
- "ro...@mo...\n"
- "__________________________________\n"
- "\n"
- "__________________________________\n"
- "\n"))
-
(defun rd-check-roster-buffer (&optional _jc)
(with-current-buffer jabber-roster-buffer
(let ((contents (buffer-string)))
@@ -52,4 +40,38 @@
(while (not (and rd-roster-string (equal "" *jabber-current-show*)))
(sit-for 0.1)))
-(rd-compare "Empty roster" rd-expected-roster)
+(rd-compare
+ "Empty roster"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "__________________________________\n"
+ "\n"))
+
+(jabber-process-input
+ (car jabber-connections)
+ '(iq ((type . "set"))
+ (query ((xmlns . "jabber:iq:roster"))
+ (item ((jid . "ju...@ca..."))))))
+
+(rd-check-roster-buffer)
+
+(rd-compare
+ "One contact"
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Online -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "other\n"
+ " ju...@ca... Offline \n"
+ "__________________________________\n"
+ "\n"))
commit 71e7352c09cea930c59206e7bce96bea327465ba
Author: Magnus Henoch <mag...@gm...>
Date: Wed Apr 1 19:58:27 2015 +0100
Improve roster display test
Check roster buffer after our presence state has been updated.
Point out where the mismatch is when a test fails.
Display contents of *fsm-debug* buffer if we cannot "connect".
diff --git a/tests/roster-display.el b/tests/roster-display.el
index a616094..2be1208 100644
--- a/tests/roster-display.el
+++ b/tests/roster-display.el
@@ -1,9 +1,14 @@
(require 'jabberd)
+(require 'cl)
(setq jabber-roster-show-bindings nil)
-;; jabber-post-connect-hooks is run after the roster has been drawn.
-(add-hook 'jabber-post-connect-hooks 'rd-check-roster-buffer)
+;; jabber-post-connect-hooks is run after the roster has been drawn
+;; for the first time - but jabber-send-presence will redraw the
+;; roster buffer after sending initial presence! Make sure we check
+;; the roster buffer after that has happened, so that the roster
+;; buffer displays "Online" for ourselves already.
+(add-hook 'jabber-post-connect-hooks 'rd-check-roster-buffer :append)
(defvar rd-roster-string nil)
@@ -12,25 +17,39 @@
"Jabber roster\n"
"__________________________________\n"
"\n"
- " - Offline -\n"
+ " - Online -\n"
"ro...@mo...\n"
"__________________________________\n"
"\n"
"__________________________________\n"
"\n"))
-(defun rd-check-roster-buffer (_jc)
+(defun rd-check-roster-buffer (&optional _jc)
(with-current-buffer jabber-roster-buffer
(let ((contents (buffer-string)))
(set-text-properties 0 (length contents) () contents)
- (prin1 contents)
(setq rd-roster-string contents))))
+(defun rd-compare (title expected)
+ (princ title)
+ (princ "...")
+ (let ((result (mismatch rd-roster-string expected)))
+ (if (null result)
+ (princ "match\n")
+ (princ "mismatch! Expected:\n")
+ (prin1 expected)
+ (princ "\nBut got:\n")
+ (prin1 (substring rd-roster-string 0 result))
+ (princ " ***mismatch here*** ")
+ (prin1 (substring rd-roster-string result))
+ (error "Mismatch"))))
+
(jabberd-connect)
-(with-timeout (5 (error "Timeout"))
- (while (not rd-roster-string)
+(with-timeout (5 (progn
+ (princ (with-current-buffer "*fsm-debug*" (buffer-string)))
+ (error "Timeout")))
+ (while (not (and rd-roster-string (equal "" *jabber-current-show*)))
(sit-for 0.1)))
-(unless (equal rd-roster-string rd-expected-roster)
- (error "Bad roster"))
+(rd-compare "Empty roster" rd-expected-roster)
commit c28359d51faf80780b83ba99e3d850440dfbb145
Author: Magnus Henoch <mag...@gm...>
Date: Wed Apr 1 19:56:44 2015 +0100
Load jabber-autoloads for tests
Not all modules are loaded by (require 'jabber).
diff --git a/tests/jabberd.el b/tests/jabberd.el
index 0985687..ec31550 100644
--- a/tests/jabberd.el
+++ b/tests/jabberd.el
@@ -3,6 +3,7 @@
;;; actual tests.
(require 'jabber)
+(require 'jabber-autoloads)
(require 'cl)
(defvar jabberd-stanza-handlers '(jabberd-sasl jabberd-iq)
commit c456905b2af55310ba0f056bc82e0209ff9703cd
Author: Magnus Henoch <mag...@gm...>
Date: Wed Apr 1 11:05:53 2015 +0100
Add test for display of empty roster
To be expanded.
diff --git a/tests/Makefile.am b/tests/Makefile.am
index 8575ddb..216b4ff 100644
--- a/tests/Makefile.am
+++ b/tests/Makefile.am
@@ -2,5 +2,5 @@
# check" or "make distcheck" to work with earlier versions.
LOG_COMPILER = env top_builddir=$(top_builddir) $(EMACS) -batch -L $(top_builddir) -L $(top_srcdir) -L $(srcdir) -l
TESTS = load-all.el skip-tag-forward.el history.el jabberd.el nick-change-fail.el
-TESTS += caps-hash.el
+TESTS += caps-hash.el roster-display.el
dist_noinst_DATA = $(TESTS)
diff --git a/tests/roster-display.el b/tests/roster-display.el
new file mode 100644
index 0000000..a616094
--- /dev/null
+++ b/tests/roster-display.el
@@ -0,0 +1,36 @@
+(require 'jabberd)
+
+(setq jabber-roster-show-bindings nil)
+
+;; jabber-post-connect-hooks is run after the roster has been drawn.
+(add-hook 'jabber-post-connect-hooks 'rd-check-roster-buffer)
+
+(defvar rd-roster-string nil)
+
+(defconst rd-expected-roster
+ (concat
+ "Jabber roster\n"
+ "__________________________________\n"
+ "\n"
+ " - Offline -\n"
+ "ro...@mo...\n"
+ "__________________________________\n"
+ "\n"
+ "__________________________________\n"
+ "\n"))
+
+(defun rd-check-roster-buffer (_jc)
+ (with-current-buffer jabber-roster-buffer
+ (let ((contents (buffer-string)))
+ (set-text-properties 0 (length contents) () contents)
+ (prin1 contents)
+ (setq rd-roster-string contents))))
+
+(jabberd-connect)
+
+(with-timeout (5 (error "Timeout"))
+ (while (not rd-roster-string)
+ (sit-for 0.1)))
+
+(unless (equal rd-roster-string rd-expected-roster)
+ (error "Bad roster"))
commit b643661ed9e157dc298b3be9ad2f45c5397ac5da
Author: Magnus Henoch <mag...@gm...>
Date: Wed Apr 1 11:05:27 2015 +0100
Add test log files to gitignore
diff --git a/tests/.gitignore b/tests/.gitignore
new file mode 100644
index 0000000..e2f3fd3
--- /dev/null
+++ b/tests/.gitignore
@@ -0,0 +1,2 @@
+*.log
+*.trs
\ No newline at end of file
-----------------------------------------------------------------------
hooks/post-receive
--
emacs-jabber
|