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