jabber-roster.el

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