]> crepu.dev Git - config.git/blame_incremental - djavu-asus/elpa/jabber-20230715.456/jabber-roster.el
projects / config.git / blame_incremental
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (non-incremental) | history | HEAD
Configuracion en desarrollo PC pega
[config.git] / djavu-asus / elpa / jabber-20230715.456 / jabber-roster.el
... / ...
CommitLineData
1;; jabber-roster.el - displaying the roster -*- coding: utf-8; -*-
2
3;; Copyright (C) 2009 - Kirill A. Korinskiy - catap@catap.ru
4;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
5;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
6
7;; This file is a part of jabber.el.
8
9;; This program is free software; you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation; either version 2 of the License, or
12;; (at your option) any later version.
13
14;; This program is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with this program; if not, write to the Free Software
21;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
22
23(require 'jabber-presence)
24(require 'jabber-util)
25(require 'jabber-alert)
26(require 'jabber-keymap)
27(require 'format-spec)
28(require 'cl-lib) ;for `find'
29(require 'jabber-private)
30
31(defgroup jabber-roster nil "roster display options"
32 :group 'jabber)
33
34(defcustom jabber-roster-line-format " %a %c %-25n %u %-8s %S"
35 "The format specification of the lines in the roster display.
36
37These fields are available:
38
39%a Avatar, if any
40%c \"*\" if the contact is connected, or \" \" if not
41%u sUbscription state - see below
42%n Nickname of contact, or JID if no nickname
43%j Bare JID of contact (without resource)
44%r Highest-priority resource of contact
45%s Availability of contact as string (\"Online\", \"Away\" etc)
46%S Status string specified by contact
47
48%u is replaced by one of the strings given by
49`jabber-roster-subscription-display'."
50 :type 'string
51 :group 'jabber-roster)
52
53(defcustom jabber-roster-subscription-display '(("none" . " ")
54 ("from" . "< ")
55 ("to" . " >")
56 ("both" . "<->"))
57 "Strings used for indicating subscription status of contacts.
58\"none\" means that there is no subscription between you and the
59contact.
60\"from\" means that the contact has a subscription to you, but you
61have no subscription to the contact.
62\"to\" means that you have a subscription to the contact, but the
63contact has no subscription to you.
64\"both\" means a mutual subscription.
65
66Having a \"presence subscription\" means being able to see the
67other person's presence.
68
69Some fancy arrows you might want to use, if your system can
70display them: ← → ⇄ ↔"
71 :type '(list (cons :format "%v" (const :format "" "none") (string :tag "None"))
72 (cons :format "%v" (const :format "" "from") (string :tag "From"))
73 (cons :format "%v" (const :format "" "to") (string :tag "To"))
74 (cons :format "%v" (const :format "" "both") (string :tag "Both")))
75 :group 'jabber-roster)
76
77(defcustom jabber-resource-line-format " %r - %s (%S), priority %p"
78 "The format specification of resource lines in the roster display.
79These are displayed when `jabber-show-resources' permits it.
80
81These fields are available:
82
83%c \"*\" if the contact is connected, or \" \" if not
84%n Nickname of contact, or JID if no nickname
85%j Bare JID of contact (without resource)
86%p Priority of this resource
87%r Name of this resource
88%s Availability of resource as string (\"Online\", \"Away\" etc)
89%S Status string specified by resource."
90 :type 'string
91 :group 'jabber-roster)
92
93(defcustom jabber-roster-sort-functions
94 '(jabber-roster-sort-by-status jabber-roster-sort-by-displayname)
95 "Sort roster according to these criteria.
96
97These functions should take two roster items A and B, and return:
98<0 if A < B
990 if A = B
100>0 if A > B."
101 :type 'hook
102 :options '(jabber-roster-sort-by-status
103 jabber-roster-sort-by-displayname
104 jabber-roster-sort-by-group)
105 :group 'jabber-roster)
106
107(defcustom jabber-sort-order '("chat" "" "away" "dnd" "xa")
108 "Sort by status in this order. Anything not in list goes last.
109Offline is represented as nil."
110 :type '(repeat (restricted-sexp :match-alternatives (stringp nil)))
111 :group 'jabber-roster)
112
113(defcustom jabber-show-resources 'sometimes
114 "Show contacts' resources in roster?
115This can be one of the following symbols:
116
117nil Never show resources
118sometimes Show resources when there are more than one
119always Always show resources."
120 :type '(radio (const :tag "Never" nil)
121 (const :tag "When more than one connected resource" sometimes)
122 (const :tag "Always" always))
123 :group 'jabber-roster)
124
125(defcustom jabber-show-offline-contacts t
126 "Show offline contacts in roster when non-nil."
127 :type 'boolean
128 :group 'jabber-roster)
129
130(defcustom jabber-remove-newlines t
131 "Remove newlines in status messages?
132Newlines in status messages mess up the roster display. However,
133they are essential to status message poets. Therefore, you get to
134choose the behaviour.
135
136Trailing newlines are always removed, regardless of this variable."
137 :type 'boolean
138 :group 'jabber-roster)
139
140(defcustom jabber-roster-show-bindings t
141 "Show keybindings in roster buffer?."
142 :type 'boolean
143 :group 'jabber-roster)
144
145(defcustom jabber-roster-show-title t
146 "Show title in roster buffer?."
147 :type 'boolean
148 :group 'jabber-roster)
149
150(defcustom jabber-roster-mode-hook nil
151 "Hook run when entering Roster mode."
152 :group 'jabber-roster
153 :type 'hook)
154
155(defcustom jabber-roster-default-group-name "other"
156 "Default group name for buddies without groups."
157 :group 'jabber-roster
158 :type 'string
159 :get '(lambda (var)
160 (let ((val (symbol-value var)))
161 (when (stringp val)
162 (set-text-properties 0 (length val) nil val))
163 val))
164 :set '(lambda (var val)
165 (when (stringp val)
166 (set-text-properties 0 (length val) nil val))
167 (custom-set-default var val)))
168
169(defcustom jabber-roster-show-empty-group nil
170 "Show empty groups in roster?."
171 :group 'jabber-roster
172 :type 'boolean)
173
174(defcustom jabber-roster-roll-up-group nil
175 "Show empty groups in roster?."
176 :group 'jabber-roster
177 :type 'boolean)
178
179(defface jabber-roster-user-online
180 '((t (:foreground "blue" :weight bold :slant normal)))
181 "Face for displaying online users."
182 :group 'jabber-roster)
183
184(defface jabber-roster-user-xa
185 '((((background dark)) (:foreground "magenta" :weight normal :slant italic))
186 (t (:foreground "black" :weight normal :slant italic)))
187 "Face for displaying extended away users."
188 :group 'jabber-roster)
189
190(defface jabber-roster-user-dnd
191 '((t (:foreground "red" :weight normal :slant italic)))
192 "Face for displaying do not disturb users."
193 :group 'jabber-roster)
194
195(defface jabber-roster-user-away
196 '((t (:foreground "dark green" :weight normal :slant italic)))
197 "Face for displaying away users."
198 :group 'jabber-roster)
199
200(defface jabber-roster-user-chatty
201 '((t (:foreground "dark orange" :weight bold :slant normal)))
202 "Face for displaying chatty users."
203 :group 'jabber-roster)
204
205(defface jabber-roster-user-error
206 '((t (:foreground "red" :weight light :slant italic)))
207 "Face for displaying users sending presence errors."
208 :group 'jabber-roster)
209
210(defface jabber-roster-user-offline
211 '((t (:foreground "dark grey" :weight light :slant italic)))
212 "Face for displaying offline users."
213 :group 'jabber-roster)
214
215(defvar jabber-roster-debug nil
216 "Debug roster draw.")
217
218(defvar jabber-roster-mode-map
219 (let ((map (make-sparse-keymap)))
220 (suppress-keymap map)
221 (set-keymap-parent map jabber-common-keymap)
222 (define-key map [mouse-2] 'jabber-roster-mouse-2-action-at-point)
223 (define-key map (kbd "TAB") 'jabber-go-to-next-roster-item)
224 (define-key map (kbd "S-TAB") 'jabber-go-to-previous-roster-item)
225 (define-key map (kbd "M-TAB") 'jabber-go-to-previous-roster-item)
226 (define-key map (kbd "<backtab>") 'jabber-go-to-previous-roster-item)
227 (define-key map (kbd "RET") 'jabber-roster-ret-action-at-point)
228 (define-key map (kbd "C-k") 'jabber-roster-delete-at-point)
229
230 (define-key map "e" 'jabber-roster-edit-action-at-point)
231 (define-key map "s" 'jabber-send-subscription-request)
232 (define-key map "q" 'bury-buffer)
233 (define-key map "i" 'jabber-get-disco-items)
234 (define-key map "j" 'jabber-muc-join)
235 (define-key map "I" 'jabber-get-disco-info)
236 (define-key map "b" 'jabber-get-browse)
237 (define-key map "v" 'jabber-get-version)
238 (define-key map "a" 'jabber-send-presence)
239 (define-key map "g" 'jabber-display-roster)
240 (define-key map "S" 'jabber-ft-send)
241 (define-key map "o" 'jabber-roster-toggle-offline-display)
242 (define-key map "H" 'jabber-roster-toggle-binding-display)
243 ;;(define-key map "D" 'jabber-disconnect)
244 map))
245
246(defun jabber-roster-ret-action-at-point ()
247 "Action for RET.
248Before try to roll up/down group. Eval `chat-with-jid-at-point' is no group at
249point."
250 (interactive)
251 (let ((group-at-point (get-text-property (point)
252 'jabber-group))
253 (account-at-point (get-text-property (point)
254 'jabber-account))
255 (jid-at-point (get-text-property (point)
256 'jabber-jid)))
257 (if (and group-at-point account-at-point)
258 (jabber-roster-roll-group account-at-point group-at-point)
259 ;; Is this a normal contact, or a groupchat? Let's ask it.
260 (jabber-disco-get-info
261 account-at-point (jabber-jid-user jid-at-point) nil
262 #'jabber-roster-ret-action-at-point-1
263 jid-at-point))))
264
265(defun jabber-roster-ret-action-at-point-1 (jc jid result)
266 ;; If we get an error, assume it's a normal contact.
267 (if (eq (car result) 'error)
268 (jabber-chat-with jc jid)
269 ;; Otherwise, let's check whether it has a groupchat identity.
270 (let ((identities (car result)))
271 (if (cl-find "conference" (if (sequencep identities) identities nil)
272 :key (lambda (i) (aref i 1))
273 :test #'string=)
274 ;; Yes! Let's join it.
275 (jabber-muc-join jc jid
276 (jabber-muc-read-my-nickname jc jid t)
277 t)
278 ;; No. Let's open a normal chat buffer.
279 (jabber-chat-with jc jid)))))
280
281(defun jabber-roster-mouse-2-action-at-point (e)
282 "Action for mouse 2.
283Before try to roll up/down group. Eval `chat-with-jid-at-point' is no group
284at point."
285 (interactive "e")
286 (mouse-set-point e)
287 (let ((group-at-point (get-text-property (point)
288 'jabber-group))
289 (account-at-point (get-text-property (point)
290 'jabber-account)))
291 (if (and group-at-point account-at-point)
292 (jabber-roster-roll-group account-at-point group-at-point)
293 (jabber-popup-combined-menu))))
294
295(defun jabber-roster-delete-at-point ()
296 "Delete at point from roster.
297Try to delete the group from all contaacs.
298Delete a jid if there is no group at point."
299 (interactive)
300 (let ((group-at-point (get-text-property (point)
301 'jabber-group))
302 (account-at-point (get-text-property (point)
303 'jabber-account)))
304 (if (and group-at-point account-at-point)
305 (let ((jids-with-group
306 (gethash group-at-point
307 (plist-get
308 (fsm-get-state-data account-at-point)
309 :roster-hash))))
310 (jabber-roster-delete-group-from-jids account-at-point
311 jids-with-group
312 group-at-point))
313 (jabber-roster-delete-jid-at-point))))
314
315(defun jabber-roster-edit-action-at-point ()
316 "Action for e. Before try to edit group name.
317Eval `jabber-roster-change' is no group at point."
318 (interactive)
319 (let ((group-at-point (get-text-property (point)
320 'jabber-group))
321 (account-at-point (get-text-property (point)
322 'jabber-account)))
323 (if (and group-at-point account-at-point)
324 (let ((jids-with-group
325 (gethash group-at-point
326 (plist-get
327 (fsm-get-state-data account-at-point)
328 :roster-hash))))
329 (jabber-roster-edit-group-from-jids account-at-point
330 jids-with-group
331 group-at-point))
332 (call-interactively 'jabber-roster-change))))
333
334(defun jabber-roster-roll-group (jc group-name &optional set)
335 "Roll up/down group in roster.
336If optional SET is t, roll up group.
337If SET is nor t or nil, roll down group."
338 (let* ((state-data (fsm-get-state-data jc))
339 (roll-groups (plist-get state-data :roster-roll-groups))
340 (new-roll-groups (if (cl-find group-name roll-groups :test 'string=)
341 ;; group is rolled up, roll it down if needed
342 (if (or (not set) (and set (not (eq set t))))
343 (cl-remove-if-not (lambda (group-name-in-list)
344 (not (string= group-name
345 group-name-in-list)))
346 roll-groups)
347 roll-groups)
348 ;; group is rolled down, roll it up if needed
349 (if (or (not set) (and set (eq set t)))
350 (append roll-groups (list group-name))
351 roll-groups))))
352 (unless (equal roll-groups new-roll-groups)
353 (plist-put
354 state-data :roster-roll-groups
355 new-roll-groups)
356 (jabber-display-roster))))
357
358(defun jabber-roster-mode ()
359 "Major mode for Jabber roster display.
360Use the keybindings (mnemonic as Chat, Roster, Info, MUC, Service) to
361bring up menus of actions.
362\\{jabber-roster-mode-map}"
363 (kill-all-local-variables)
364 (setq major-mode 'jabber-roster-mode
365 mode-name "jabber-roster")
366 (use-local-map jabber-roster-mode-map)
367 (setq buffer-read-only t)
368 (if (fboundp 'run-mode-hooks)
369 (run-mode-hooks 'jabber-roster-mode-hook)
370 (run-hooks 'jabber-roster-mode-hook)))
371
372(put 'jabber-roster-mode 'mode-class 'special)
373
374;;;###autoload
375(defun jabber-switch-to-roster-buffer (&optional _jc)
376 "Switch to roster buffer.
377Optional JC argument is ignored; it's there so this function can
378be used in `jabber-post-connection-hooks'."
379 (interactive)
380 (if (not (get-buffer jabber-roster-buffer))
381 (jabber-display-roster)
382 (switch-to-buffer jabber-roster-buffer)))
383
384(defun jabber-sort-roster (jc)
385 "Sort roster according to online status.
386JC is the Jabber connection."
387 (let ((state-data (fsm-get-state-data jc)))
388 (dolist (group (plist-get state-data :roster-groups))
389 (let ((group-name (car group)))
390 (puthash group-name
391 (sort
392 (gethash group-name
393 (plist-get state-data :roster-hash))
394 #'jabber-roster-sort-items)
395 (plist-get state-data :roster-hash))))))
396
397(defun jabber-roster-prepare-roster (jc)
398 "Make a hash based roster.
399JC is the Jabber connection."
400 (let* ((state-data (fsm-get-state-data jc))
401 (hash (make-hash-table :test 'equal))
402 (buddies (plist-get state-data :roster))
403 (all-groups '()))
404 (dolist (buddy buddies)
405 (let ((groups (get buddy 'groups)))
406 (if groups
407 (progn
408 (dolist (group groups)
409 (progn
410 (setq all-groups (append all-groups (list group)))
411 (puthash group
412 (append (gethash group hash)
413 (list buddy))
414 hash))))
415 (progn
416 (setq all-groups (append all-groups
417 (list jabber-roster-default-group-name)))
418 (puthash jabber-roster-default-group-name
419 (append (gethash jabber-roster-default-group-name hash)
420 (list buddy))
421 hash)))))
422
423 ;; remove duplicates name of group
424 (setq all-groups (sort
425 (cl-remove-duplicates all-groups
426 :test 'string=)
427 'string<))
428
429 ;; put to state-data all-groups as list of list
430 (plist-put state-data :roster-groups
431 (mapcar #'list all-groups))
432
433 ;; put to state-data hash-roster
434 (plist-put state-data :roster-hash
435 hash)))
436
437(defun jabber-roster-sort-items (a b)
438 "Sort roster items A and B according to `jabber-roster-sort-functions'.
439Return t if A is less than B."
440 (let ((result nil))
441 (seq-find (lambda (fn)
442 (setq result (funcall fn a b))
443 (not (= result 0)))
444 jabber-roster-sort-functions)
445 (< result 0)))
446
447(defun jabber-roster-sort-by-status (a b)
448 "Sort roster items by online status.
449See `jabber-sort-order' for order used."
450 (cl-flet ((order (item) (length (member (get item 'show) jabber-sort-order))))
451 (let ((a-order (order a))
452 (b-order (order b)))
453 ;; Note reversed test. Items with longer X-order go first.
454 (cond
455 ((< a-order b-order)
456 1)
457 ((> a-order b-order)
458 -1)
459 (t
460 0)))))
461
462(defun jabber-roster-sort-by-displayname (a b)
463 "Sort roster items by displayed name."
464 (let ((a-name (jabber-jid-displayname a))
465 (b-name (jabber-jid-displayname b)))
466 (cond
467 ((string-lessp a-name b-name) -1)
468 ((string= a-name b-name) 0)
469 (t 1))))
470
471(defun jabber-roster-sort-by-group (a b)
472 "Sort roster items by group membership."
473 (cl-flet ((first-group (item) (or (car (get item 'groups)) "")))
474 (let ((a-group (first-group a))
475 (b-group (first-group b)))
476 (cond
477 ((string-lessp a-group b-group) -1)
478 ((string= a-group b-group) 0)
479 (t 1)))))
480
481(defun jabber-fix-status (status)
482 "Make status strings more readable."
483 (when status
484 (when (string-match "\n+$" status)
485 (setq status (replace-match "" t t status)))
486 (when jabber-remove-newlines
487 (while (string-match "\n" status)
488 (setq status (replace-match " " t t status))))
489 status))
490
491(defvar jabber-roster-ewoc nil
492 "Ewoc displaying the roster.
493There is only one; we don't rely on buffer-local variables or
494such.")
495
496(defun jabber-roster-filter-display (buddies)
497 "Filter BUDDIES for items to be displayed in the roster."
498 (cl-remove-if-not (lambda (buddy) (or jabber-show-offline-contacts
499 (get buddy 'connected)))
500 buddies))
501
502(defun jabber-roster-toggle-offline-display ()
503 "Toggle display of offline contacts.
504To change this permanently, customize the `jabber-show-offline-contacts'."
505 (interactive)
506 (setq jabber-show-offline-contacts
507 (not jabber-show-offline-contacts))
508 (jabber-display-roster))
509
510(defun jabber-roster-toggle-binding-display ()
511 "Toggle display of the roster binding text."
512 (interactive)
513 (setq jabber-roster-show-bindings
514 (not jabber-roster-show-bindings))
515 (jabber-display-roster))
516
517(defun jabber-display-roster ()
518 "Switch to the main jabber buffer and refresh it.
519Switch to the roster display and refresh it to reflect the current
520information."
521 (interactive)
522 (with-current-buffer (get-buffer-create jabber-roster-buffer)
523 (if (not (eq major-mode 'jabber-roster-mode))
524 (jabber-roster-mode))
525 (setq buffer-read-only nil)
526 ;; line-number-at-pos is in Emacs >= 21.4. Only used to avoid
527 ;; excessive scrolling when updating roster, so not absolutely
528 ;; necessary.
529 (let ((current-line (and (fboundp 'line-number-at-pos) (line-number-at-pos)))
530 (current-column (current-column)))
531 (erase-buffer)
532 (setq jabber-roster-ewoc nil)
533 (when jabber-roster-show-title
534 (insert (jabber-propertize "Jabber roster" 'face 'jabber-title-large) "\n"))
535 (when jabber-roster-show-bindings
536 (insert "RET Open chat buffer C-k Delete roster item
537e Edit item s Send subscription request
538q Bury buffer i Get disco items
539I Get disco info b Browse
540j Join groupchat (MUC) v Get client version
541a Send presence o Show offline contacts on/off
542C-c C-c Chat menu C-c C-m Multi-User Chat menu
543C-c C-i Info menu C-c C-r Roster menu
544C-c C-s Service menu
545
546H Toggle displaying this text
547"))
548 (insert "__________________________________\n\n")
549 (if (null jabber-connections)
550 (insert "Not connected\n")
551 (let ((map (make-sparse-keymap)))
552 (define-key map [mouse-2] #'jabber-send-presence)
553 (insert (jabber-propertize (concat (format " - %s"
554 (cdr (assoc *jabber-current-show* jabber-presence-strings)))
555 (if (not (zerop (length *jabber-current-status*)))
556 (format " (%s)"
557 (jabber-fix-status *jabber-current-status*)))
558 " -")
559 'face (or (cdr (assoc *jabber-current-show* jabber-presence-faces))
560 'jabber-roster-user-online)
561 ;;'mouse-face (cons 'background-color "light grey")
562 'keymap map)
563 "\n")))
564
565 (dolist (jc jabber-connections)
566 ;; use a hash-based roster
567 (when (not (plist-get (fsm-get-state-data jc) :roster-hash))
568 (jabber-roster-prepare-roster jc))
569 ;; We sort everything before putting it in the ewoc
570 (jabber-sort-roster jc)
571 (let ((before-ewoc (point))
572 (ewoc (ewoc-create
573 (let ((jc jc))
574 (lambda (data)
575 (let* ((group (car data))
576 (group-name (car group))
577 (buddy (car (cdr data))))
578 (jabber-display-roster-entry jc group-name buddy))))
579 (concat
580 (jabber-propertize (concat
581 (plist-get (fsm-get-state-data jc) :username)
582 "@"
583 (plist-get (fsm-get-state-data jc) :server))
584 'face 'jabber-title-medium)
585 "\n__________________________________\n")
586 "__________________________________"))
587 (new-groups '()))
588 (plist-put(fsm-get-state-data jc) :roster-ewoc ewoc)
589 (dolist (group (plist-get (fsm-get-state-data jc) :roster-groups))
590 (let* ((group-name (car group))
591 (buddies (jabber-roster-filter-display
592 (gethash group-name
593 (plist-get (fsm-get-state-data jc) :roster-hash)))))
594 (when (or jabber-roster-show-empty-group
595 (> (length buddies) 0))
596 (let ((group-node (ewoc-enter-last ewoc (list group nil))))
597 (if (not (cl-find
598 group-name
599 (plist-get (fsm-get-state-data jc) :roster-roll-groups)
600 :test 'string=))
601 (dolist (buddy (reverse buddies))
602 (ewoc-enter-after ewoc group-node (list group buddy))))))))
603 (goto-char (point-max))
604 (insert "\n")
605 (put-text-property before-ewoc (point)
606 'jabber-account jc)))
607
608 (goto-char (point-min))
609 (setq buffer-read-only t)
610 (if (called-interactively-p 'interactive)
611 (dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks))
612 (run-hook-with-args hook 'roster (current-buffer) (funcall jabber-alert-info-message-function 'roster (current-buffer)))))
613 (when current-line
614 ;; Go back to previous line - don't use goto-line, since it
615 ;; sets the mark.
616 (goto-char (point-min))
617 (forward-line (1- current-line))
618 ;; ...and go back to previous column
619 (move-to-column current-column)))))
620
621(defun jabber-display-roster-entry (jc group-name buddy)
622 "Format and insert a roster entry for BUDDY at point.
623BUDDY is a JID symbol. JC is the Jabber connection."
624 (if buddy
625 (let ((buddy-str (format-spec
626 jabber-roster-line-format
627 (list
628 (cons ?a (jabber-propertize " " 'display (get buddy 'avatar)))
629 (cons ?c (if (get buddy 'connected) "*" " "))
630 (cons ?u (cdr (assoc
631 (or
632 (get buddy 'subscription) "none")
633 jabber-roster-subscription-display)))
634 (cons ?n (if (> (length (get buddy 'name)) 0)
635 (get buddy 'name)
636 (symbol-name buddy)))
637 (cons ?j (symbol-name buddy))
638 (cons ?r (or (get buddy 'resource) ""))
639 (cons ?s (or (cdr (assoc (get buddy 'show)
640 jabber-presence-strings))
641 (get buddy 'show)))
642 (cons ?S (if (get buddy 'status)
643 (jabber-fix-status (get buddy 'status))
644 ""))))))
645 (add-text-properties 0
646 (length buddy-str)
647 (list
648 'face
649 (or (cdr (assoc (get buddy 'show) jabber-presence-faces))
650 'jabber-roster-user-online)
651 ;;'mouse-face
652 ;;(cons 'background-color "light grey")
653 'help-echo
654 (symbol-name buddy)
655 'jabber-jid
656 (symbol-name buddy)
657 'jabber-account
658 jc)
659 buddy-str)
660 (insert buddy-str)
661
662 (when (or (eq jabber-show-resources 'always)
663 (and (eq jabber-show-resources 'sometimes)
664 (> (jabber-count-connected-resources buddy) 1)))
665 (dolist (resource (get buddy 'resources))
666 (when (plist-get (cdr resource) 'connected)
667 (let ((resource-str (format-spec jabber-resource-line-format
668 (list
669 (cons ?c "*")
670 (cons ?n (if (>
671 (length
672 (get buddy 'name)) 0)
673 (get buddy 'name)
674 (symbol-name buddy)))
675 (cons ?j (symbol-name buddy))
676 (cons ?r (if (>
677 (length
678 (car resource)) 0)
679 (car resource)
680 "empty"))
681 (cons ?s (or
682 (cdr (assoc
683 (plist-get
684 (cdr resource) 'show)
685 jabber-presence-strings))
686 (plist-get
687 (cdr resource) 'show)))
688 (cons ?S (if (plist-get
689 (cdr resource) 'status)
690 (jabber-fix-status
691 (plist-get (cdr resource)
692 'status))
693 ""))
694 (cons ?p (number-to-string
695 (plist-get (cdr resource)
696 'priority)))))))
697 (add-text-properties 0
698 (length resource-str)
699 (list
700 'face
701 (or (cdr (assoc (plist-get
702 (cdr resource)
703 'show)
704 jabber-presence-faces))
705 'jabber-roster-user-online)
706 'jabber-jid
707 (format "%s/%s" (symbol-name buddy) (car resource))
708 'jabber-account
709 jc)
710 resource-str)
711 (insert "\n" resource-str))))))
712 (let ((group-name (or group-name
713 jabber-roster-default-group-name)))
714 (add-text-properties 0
715 (length group-name)
716 (list
717 'face 'jabber-title-small
718 'jabber-group group-name
719 'jabber-account jc)
720 group-name)
721 (insert group-name))))
722
723;;;###autoload
724(defun jabber-roster-update (jc new-items changed-items deleted-items)
725 "Update roster, in memory and on display.
726Add NEW-ITEMS, update CHANGED-ITEMS and remove DELETED-ITEMS, all
727three being lists of JID symbols.
728JC is the Jabber connection."
729 (let* ((roster (plist-get (fsm-get-state-data jc) :roster))
730 (hash (plist-get (fsm-get-state-data jc) :roster-hash))
731 (ewoc (plist-get (fsm-get-state-data jc) :roster-ewoc))
732 (all-groups (plist-get (fsm-get-state-data jc) :roster-groups))
733 (terminator
734 (lambda (deleted-items)
735 (dolist (delete-this deleted-items)
736 (let ((groups (get delete-this 'groups))
737 (terminator
738 (lambda (g)
739 (let*
740 ((group (or g jabber-roster-default-group-name))
741 (buddies (gethash group hash)))
742 (when (not buddies)
743 (setq new-groups (append new-groups (list group))))
744 (puthash group
745 (delq delete-this buddies)
746 hash)))))
747 (if groups
748 (dolist (group groups)
749 (terminator group))
750 (terminator groups)))))))
751
752 ;; fix a old-roster
753 (dolist (delete-this deleted-items)
754 (setq roster (delq delete-this roster)))
755 (setq roster (append new-items roster))
756 (plist-put (fsm-get-state-data jc) :roster roster)
757
758 ;; update a hash-roster
759 (if (not hash)
760 (jabber-roster-prepare-roster jc)
761
762 (when jabber-roster-debug
763 (message "update hash-based roster"))
764
765 ;; delete items
766 (dolist (delete-this (append deleted-items changed-items))
767 (let ((jid (symbol-name delete-this)))
768 (when jabber-roster-debug
769 (message (concat "delete jid: " jid)))
770 (dolist (group (mapcar (lambda (g) (car g)) all-groups))
771 (when jabber-roster-debug
772 (message (concat "try to delete jid: " jid " from group " group)))
773 (puthash group
774 (delq delete-this (gethash group hash))
775 hash))))
776
777 ;; insert changed-items
778 (dolist (insert-this (append changed-items new-items))
779 (let ((jid (symbol-name insert-this)))
780 (when jabber-roster-debug
781 (message (concat "insert jid: " jid)))
782 (dolist (group (or (get insert-this 'groups)
783 (list jabber-roster-default-group-name)))
784 (when jabber-roster-debug
785 (message (concat "insert jid: " jid " to group " group)))
786 (puthash group
787 (append (gethash group hash)
788 (list insert-this))
789 hash)
790 (setq all-groups (append all-groups (list (list group)))))))
791
792 (when jabber-roster-debug
793 (message "remove duplicates from new group"))
794 (setq all-groups (sort
795 (cl-remove-duplicates all-groups
796 :test (lambda (g1 g2)
797 (let ((g1-name (car g1))
798 (g2-name (car g2)))
799 (string= g1-name
800 g2-name))))
801 (lambda (g1 g2)
802 (let ((g1-name (car g1))
803 (g2-name (car g2)))
804 (string< g1-name
805 g2-name)))))
806
807 (plist-put (fsm-get-state-data jc) :roster-groups all-groups))
808
809 (when jabber-roster-debug
810 (message "re display roster"))
811
812 ;; recreate roster buffer
813 (jabber-display-roster)))
814
815(defalias 'jabber-presence-update-roster 'ignore)
816;;jabber-presence-update-roster is not needed anymore.
817;;Its work is done in `jabber-process-presence'."
818(make-obsolete 'jabber-presence-update-roster 'ignore "27.2")
819
820(defun jabber-next-property (&optional prev)
821 "Return position of next property appearence or nil if there is none.
822If optional PREV is non-nil, return position of previous property appearence."
823 (let ((pos (point))
824 (found nil)
825 (nextprev (if prev 'previous-single-property-change
826 'next-single-property-change)))
827 (while (not found)
828 (setq pos
829 (let ((jid (funcall nextprev pos 'jabber-jid))
830 (group (funcall nextprev pos 'jabber-group)))
831 (cond
832 ((not jid) group)
833 ((not group) jid)
834 (t (funcall (if prev 'max 'min) jid group)))))
835 (if (not pos)
836 (setq found t)
837 (setq found (or (get-text-property pos 'jabber-jid)
838 (get-text-property pos 'jabber-group)))))
839 pos))
840
841(defun jabber-go-to-next-roster-item ()
842 "Move the cursor to the next jid/group in the buffer."
843 (interactive)
844 (let* ((next (jabber-next-property))
845 (next (if (not next)
846 (progn (goto-char (point-min))
847 (jabber-next-property)) next)))
848 (if next (goto-char next)
849 (goto-char (point-min)))))
850
851(defun jabber-go-to-previous-roster-item ()
852 "Move the cursor to the previous jid/group in the buffer."
853 (interactive)
854 (let* ((previous (jabber-next-property 'prev))
855 (previous (if (not previous)
856 (progn (goto-char (point-max))
857 (jabber-next-property 'prev)) previous)))
858 (if previous (goto-char previous)
859 (goto-char (point-max)))))
860
861(defun jabber-roster-restore-groups (jc)
862 "Restore roster's groups rolling state from private storage.
863JC is the Jabber connection."
864 (interactive (list (jabber-read-account)))
865 (jabber-private-get jc 'roster "emacs-jabber"
866 'jabber-roster-restore-groups-1 'ignore))
867
868(defun jabber-roster-restore-groups-1 (jc xml-data)
869 "Parse roster groups and restore rolling state.
870
871JC is the Jabber connection.
872XML-DATA is the parsed tree data from the stream (stanzas)
873obtained from `xml-parse-region'."
874 (when (string= (jabber-xml-get-xmlns xml-data) "emacs-jabber")
875 (let* ((data (car (last xml-data)))
876 (groups (if (stringp data) (split-string data "\n") nil)))
877 (dolist (group groups)
878 (jabber-roster-roll-group jc group t)))))
879
880(defun jabber-roster-save-groups ()
881 "Save roster's groups rolling state in private storage."
882 (interactive)
883 (dolist (jc jabber-connections)
884 (let* ((groups (plist-get (fsm-get-state-data jc) :roster-roll-groups))
885 (roll-groups
886 (if groups
887 (mapconcat (lambda (a) (substring-no-properties a)) groups "\n")
888 "")))
889 (jabber-private-set jc
890 `(roster ((xmlns . "emacs-jabber"))
891 ,roll-groups)
892 'jabber-report-success "Roster groups saved"
893 'jabber-report-success "Failed to save roster groups"))))
894
895(provide 'jabber-roster)
896
897;;; arch-tag: 096af063-0526-4dd2-90fd-bc6b5ba07d32
Configuraciones personales para sincronizar cuando hay internet