jabber-roster.el

   1 ;; jabber-roster.el - displaying the roster    -*- coding: utf-8; -*-
   2
   3 ;; Copyright (C) 2003, 2004, 2007 - Magnus Henoch - mange@freemail.hu
   4 ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
   5
   6 ;; This file is a part of jabber.el.
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program; if not, write to the Free Software
  20 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  21
  22 (require 'jabber-presence)
  23 (require 'jabber-util)
  24 (require 'jabber-alert)
  25 (require 'jabber-keymap)
  26 (require 'format-spec)
  27
  28 (defgroup jabber-roster nil "roster display options"
  29   :group 'jabber)
  30
  31 (defcustom jabber-roster-line-format " %a %c %-25n %u %-8s  %S"
  32   "The format specification of the lines in the roster display.
  33
  34 These fields are available:
  35
  36 %a   Avatar, if any
  37 %c   \"*\" if the contact is connected, or \" \" if not
  38 %u   sUbscription state - see below
  39 %n   Nickname of contact, or JID if no nickname
  40 %j   Bare JID of contact (without resource)
  41 %r   Highest-priority resource of contact
  42 %s   Availability of contact as string (\"Online\", \"Away\" etc)
  43 %S   Status string specified by contact
  44
  45 %u is replaced by one of the strings given by
  46 `jabber-roster-subscription-display'."
  47   :type 'string
  48   :group 'jabber-roster)
  49
  50 (defcustom jabber-roster-subscription-display '(("none" . "   ")
  51                                                 ("from" . "<  ")
  52                                                 ("to" . "  >")
  53                                                 ("both" . "<->"))
  54   "Strings used for indicating subscription status of contacts.
  55 \"none\" means that there is no subscription between you and the
  56 contact.
  57 \"from\" means that the contact has a subscription to you, but you
  58 have no subscription to the contact.
  59 \"to\" means that you have a subscription to the contact, but the
  60 contact has no subscription to you.
  61 \"both\" means a mutual subscription.
  62
  63 Having a \"presence subscription\" means being able to see the
  64 other person's presence.
  65
  66 Some fancy arrows you might want to use, if your system can
  67 display them: ← → ⇄ ↔"
  68   :type '(list (cons :format "%v" (const :format "" "none") (string :tag "None"))
  69                (cons :format "%v" (const :format "" "from") (string :tag "From"))
  70                (cons :format "%v" (const :format "" "to") (string :tag "To"))
  71                (cons :format "%v" (const :format "" "both") (string :tag "Both")))
  72   :group 'jabber-roster)
  73
  74 (defcustom jabber-resource-line-format "     %r - %s (%S), priority %p"
  75   "The format specification of resource lines in the roster display.
  76 These are displayed when `jabber-show-resources' permits it.
  77
  78 These fields are available:
  79
  80 %c   \"*\" if the contact is connected, or \" \" if not
  81 %n   Nickname of contact, or JID if no nickname
  82 %j   Bare JID of contact (without resource)
  83 %p   Priority of this resource
  84 %r   Name of this resource
  85 %s   Availability of resource as string (\"Online\", \"Away\" etc)
  86 %S   Status string specified by resource"
  87   :type 'string
  88   :group 'jabber-roster)
  89
  90 (defcustom jabber-roster-sort-functions
  91   '(jabber-roster-sort-by-status jabber-roster-sort-by-displayname)
  92   "Sort roster according to these criteria.
  93
  94 These functions should take two roster items A and B, and return:
  95 <0 if A < B
  96 0  if A = B
  97 >0 if A > B"
  98   :type 'hook
  99   :options '(jabber-roster-sort-by-status
 100              jabber-roster-sort-by-displayname)
 101   :group 'jabber-roster)
 102
 103 (defcustom jabber-sort-order '("chat" "" "away" "dnd" "xa")
 104   "Sort by status in this order.  Anything not in list goes last.
 105 Offline is represented as nil."
 106   :type '(repeat (restricted-sexp :match-alternatives (stringp nil)))
 107   :group 'jabber-roster)
 108
 109 (defcustom jabber-show-resources 'sometimes
 110   "Show resources in roster?"
 111   :type '(radio (const :tag "Never" nil)
 112                 (const :tag "When more than one connected resource" sometimes)
 113                 (const :tag "Always" always))
 114   :group 'jabber-roster)
 115
 116 (defcustom jabber-show-offline-contacts t
 117   "Show offline contacts in roster when non-nil"
 118   :type 'boolean
 119   :group 'jabber-roster)
 120
 121 (defcustom jabber-remove-newlines t
 122   "Remove newlines in status messages?
 123 Newlines in status messages mess up the roster display.  However,
 124 they are essential to status message poets.  Therefore, you get to
 125 choose the behaviour.
 126
 127 Trailing newlines are always removed, regardless of this variable."
 128   :type 'boolean
 129   :group 'jabber-roster)
 130
 131 (defcustom jabber-roster-show-bindings t
 132   "Show keybindings in roster buffer?"
 133   :type 'boolean
 134   :group 'jabber-roster)
 135
 136 (defcustom jabber-roster-mode-hook nil
 137   "Hook run when entering Roster mode."
 138   :group 'jabber-roster
 139   :type 'hook)
 140
 141 (defface jabber-roster-user-online
 142   '((t (:foreground "blue" :weight bold :slant normal)))
 143   "face for displaying online users"
 144   :group 'jabber-roster)
 145
 146 (defface jabber-roster-user-xa
 147   '((((background dark)) (:foreground "magenta" :weight normal :slant italic))
 148     (t (:foreground "black" :weight normal :slant italic)))
 149   "face for displaying extended away users"
 150   :group 'jabber-roster)
 151
 152 (defface jabber-roster-user-dnd
 153   '((t (:foreground "red" :weight normal :slant italic)))
 154   "face for displaying do not disturb users"
 155   :group 'jabber-roster)
 156
 157 (defface jabber-roster-user-away
 158   '((t (:foreground "dark green" :weight normal :slant italic)))
 159   "face for displaying away users"
 160   :group 'jabber-roster)
 161
 162 (defface jabber-roster-user-chatty
 163   '((t (:foreground "dark orange" :weight bold :slant normal)))
 164   "face for displaying chatty users"
 165   :group 'jabber-roster)
 166
 167 (defface jabber-roster-user-error
 168   '((t (:foreground "red" :weight light :slant italic)))
 169   "face for displaying users sending presence errors"
 170   :group 'jabber-roster)
 171
 172 (defface jabber-roster-user-offline
 173   '((t (:foreground "dark grey" :weight light :slant italic)))
 174   "face for displaying offline users"
 175   :group 'jabber-roster)
 176
 177 (defvar jabber-roster-mode-map
 178   (let ((map (make-sparse-keymap)))
 179     (set-keymap-parent map jabber-common-keymap)
 180     (define-key map [mouse-2] 'jabber-popup-combined-menu)
 181     (define-key map (kbd "TAB") 'jabber-go-to-next-jid)
 182     (define-key map (kbd "S-TAB") 'jabber-go-to-previous-jid)
 183     (define-key map (kbd "M-TAB") 'jabber-go-to-previous-jid)
 184     (define-key map (kbd "<backtab>") 'jabber-go-to-previous-jid)
 185     (define-key map (kbd "RET") 'jabber-chat-with-jid-at-point)
 186     (define-key map (kbd "C-k") 'jabber-roster-delete-jid-at-point)
 187
 188     (define-key map "e" 'jabber-roster-change)
 189     (define-key map "s" 'jabber-send-subscription-request)
 190     (define-key map "q" 'bury-buffer)
 191     (define-key map "i" 'jabber-get-disco-items)
 192     (define-key map "j" 'jabber-groupchat-join)
 193     (define-key map "I" 'jabber-get-disco-info)
 194     (define-key map "b" 'jabber-get-browse)
 195     (define-key map "v" 'jabber-get-version)
 196     (define-key map "a" 'jabber-send-presence)
 197     (define-key map "g" 'jabber-display-roster)
 198     (define-key map "S" 'jabber-ft-send)
 199     (define-key map "o" 'jabber-roster-toggle-offline-display)
 200     (define-key map "H" 'jabber-roster-toggle-binding-display)
 201     ;;(define-key map "D" 'jabber-disconnect)
 202     map))
 203
 204 (defun jabber-roster-mode ()
 205   "Major mode for Jabber roster display.
 206 Use the keybindings (mnemonic as Chat, Roster, Info, MUC, Service) to
 207 bring up menus of actions.
 208 \\{jabber-roster-mode-map}"
 209   (kill-all-local-variables)
 210   (setq major-mode 'jabber-roster-mode
 211         mode-name "jabber-roster")
 212   (use-local-map jabber-roster-mode-map)
 213   (setq buffer-read-only t)
 214   (if (fboundp 'run-mode-hooks)
 215       (run-mode-hooks 'jabber-roster-mode-hook)
 216     (run-hooks 'jabber-roster-mode-hook)))
 217
 218 (put 'jabber-roster-mode 'mode-class 'special)
 219
 220 (defun jabber-switch-to-roster-buffer (&optional jc)
 221   "Switch to roster buffer.
 222 Optional JC argument is ignored; it's there so this function can
 223 be used in `jabber-post-connection-hooks'."
 224   (interactive)
 225   (if (not (get-buffer jabber-roster-buffer))
 226       (jabber-display-roster)
 227     (switch-to-buffer jabber-roster-buffer)))
 228
 229 (defun jabber-sort-roster (jc)
 230   "sort roster according to online status"
 231   (let ((state-data (fsm-get-state-data jc)))
 232     (plist-put state-data :roster
 233                (sort
 234                 (plist-get state-data :roster)
 235                 #'jabber-roster-sort-items))))
 236
 237 (defun jabber-roster-sort-items (a b)
 238   "Sort roster items A and B according to `jabber-roster-sort-functions'.
 239 Return t if A is less than B."
 240   (dolist (fn jabber-roster-sort-functions)
 241     (let ((comparison (funcall fn a b)))
 242       (cond
 243        ((< comparison 0)
 244         (return t))
 245        ((> comparison 0)
 246         (return nil))))))
 247
 248 (defun jabber-roster-sort-by-status (a b)
 249   "Sort roster items by online status.
 250 See `jabber-sort-order' for order used."
 251   (flet ((order (item) (length (member (get item 'show) jabber-sort-order))))
 252     (let ((a-order (order a))
 253           (b-order (order b)))
 254       ;; Note reversed test.  Items with longer X-order go first.
 255       (cond
 256        ((< a-order b-order)
 257         1)
 258        ((> a-order b-order)
 259         -1)
 260        (t
 261         0)))))
 262
 263 (defun jabber-roster-sort-by-displayname (a b)
 264   "Sort roster items by displayed name."
 265   (let ((a-name (jabber-jid-displayname a))
 266         (b-name (jabber-jid-displayname b)))
 267     (cond
 268      ((string-lessp a-name b-name) -1)
 269      ((string= a-name b-name) 0)
 270      (t 1))))
 271
 272 (defun jabber-roster-sort-by-group (a b)
 273   "Sort roster items by group membership."
 274   (flet ((first-group (item) (or (car (get item 'groups)) "")))
 275     (let ((a-group (first-group a))
 276           (b-group (first-group b)))
 277       (cond
 278        ((string-lessp a-group b-group) -1)
 279        ((string= a-group b-group) 0)
 280        (t 1)))))
 281
 282 (defun jabber-fix-status (status)
 283   "Make status strings more readable"
 284   (when status
 285     (when (string-match "\n+$" status)
 286       (setq status (replace-match "" t t status)))
 287     (when jabber-remove-newlines
 288       (while (string-match "\n" status)
 289         (setq status (replace-match " " t t status))))
 290     status))
 291
 292 (defvar jabber-roster-ewoc nil
 293   "Ewoc displaying the roster.
 294 There is only one; we don't rely on buffer-local variables or
 295 such.")
 296
 297 (defun jabber-roster-filter-display (buddies)
 298   "Filter BUDDIES for items to be displayed in the roster"
 299   (remove-if-not (lambda (buddy) (or jabber-show-offline-contacts
 300                                      (get buddy 'connected)))
 301                  buddies))
 302
 303 (defun jabber-roster-toggle-offline-display ()
 304   "Toggle display of offline contacts."
 305   (interactive)
 306   (setq jabber-show-offline-contacts
 307         (not jabber-show-offline-contacts))
 308   (jabber-display-roster))
 309
 310 (defun jabber-roster-toggle-binding-display ()
 311   "Toggle display of the roster binding text."
 312   (interactive)
 313   (setq jabber-roster-show-bindings
 314         (not jabber-roster-show-bindings))
 315   (jabber-display-roster))
 316
 317 (defun jabber-display-roster ()
 318   "switch to the main jabber buffer and refresh the roster display to reflect the current information"
 319   (interactive)
 320   (with-current-buffer (get-buffer-create jabber-roster-buffer)
 321     (if (not (eq major-mode 'jabber-roster-mode))
 322         (jabber-roster-mode))
 323     (setq buffer-read-only nil)
 324     ;; line-number-at-pos is in Emacs >= 21.4.  Only used to avoid
 325     ;; excessive scrolling when updating roster, so not absolutely
 326     ;; necessary.
 327     (let ((current-line (and (fboundp 'line-number-at-pos) (line-number-at-pos)))
 328           (current-column (current-column)))
 329       (erase-buffer)
 330       (setq jabber-roster-ewoc nil)
 331       (insert (jabber-propertize "Jabber roster" 'face 'jabber-title-large) "\n")
 332       (when jabber-roster-show-bindings
 333         (insert "RET      Open chat buffer        C-k      Delete roster item
 334 e        Edit item               s        Send subscription request
 335 q        Bury buffer             i        Get disco items
 336 I        Get disco info          b        Browse
 337 j        Join groupchat (MUC)    v        Get client version
 338 a        Send presence           o        Show offline contacts on/off
 339 C-c C-c  Chat menu               C-c C-m  Multi-User Chat menu
 340 C-c C-i  Info menu               C-c C-r  Roster menu
 341 C-c C-s  Service menu
 342
 343 H        Toggle displaying this text
 344 "))
 345       (insert "__________________________________\n\n")
 346       (if (null jabber-connections)
 347           (insert "Not connected\n")
 348         (let ((map (make-sparse-keymap)))
 349           (define-key map [mouse-2] #'jabber-send-presence)
 350           (insert (jabber-propertize (concat (format " - %s"
 351                                                      (cdr (assoc *jabber-current-show* jabber-presence-strings)))
 352                                              (if (not (zerop (length *jabber-current-status*)))
 353                                                  (format " (%s)"
 354                                                          (jabber-fix-status *jabber-current-status*)))
 355                                              " -")
 356                                      'face (or (cdr (assoc *jabber-current-show* jabber-presence-faces))
 357                                                'jabber-roster-user-online)
 358                                      ;;'mouse-face (cons 'background-color "light grey")
 359                                      'keymap map)
 360                   "\n")))
 361
 362       (dolist (jc jabber-connections)
 363         ;; We sort everything before putting it in the ewoc
 364         (jabber-sort-roster jc)
 365         (let ((before-ewoc (point))
 366               (ewoc (ewoc-create
 367                      (lexical-let ((jc jc))
 368                        (lambda (buddy)
 369                          (jabber-display-roster-entry jc buddy)))
 370                      (concat
 371                       (jabber-propertize (concat
 372                                           (plist-get (fsm-get-state-data jc) :username)
 373                                           "@"
 374                                           (plist-get (fsm-get-state-data jc) :server))
 375                                          'face 'jabber-title-medium)
 376                       "\n__________________________________\n")
 377                      "__________________________________")))
 378           (plist-put (fsm-get-state-data jc) :roster-ewoc ewoc)
 379           (dolist (buddy (jabber-roster-filter-display
 380                           (plist-get (fsm-get-state-data jc) :roster)))
 381             (ewoc-enter-last ewoc buddy))
 382           (goto-char (point-max))
 383           (insert "\n")
 384           (put-text-property before-ewoc (point)
 385                              'jabber-account jc)))
 386
 387       (goto-char (point-min))
 388       (setq buffer-read-only t)
 389       (if (interactive-p)
 390           (dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks))
 391             (run-hook-with-args hook 'roster (current-buffer) (funcall jabber-alert-info-message-function 'roster (current-buffer)))))
 392       (when current-line
 393         (goto-line current-line)
 394         (move-to-column current-column)))))
 395
 396 (defun jabber-display-roster-entry (jc buddy)
 397   "Format and insert a roster entry for BUDDY at point.
 398 BUDDY is a JID symbol."
 399   (let ((buddy-str (format-spec jabber-roster-line-format
 400                                 (list
 401                                  (cons ?a (jabber-propertize " "
 402                                                              'display (get buddy 'avatar)))
 403                                  (cons ?c (if (get buddy 'connected) "*" " "))
 404                                  (cons ?u (cdr (assoc (or (get buddy 'subscription) "none")
 405                                                       jabber-roster-subscription-display)))
 406                                  (cons ?n (if (> (length (get buddy 'name)) 0)
 407                                               (get buddy 'name)
 408                                             (symbol-name buddy)))
 409                                  (cons ?j (symbol-name buddy))
 410                                  (cons ?r (or (get buddy 'resource) ""))
 411                                  (cons ?s (or
 412                                            (cdr (assoc (get buddy 'show) jabber-presence-strings))
 413                                            (get buddy 'show)))
 414                                  (cons ?S (if (get buddy 'status)
 415                                               (jabber-fix-status (get buddy 'status))
 416                                             ""))))))
 417     (add-text-properties 0
 418                          (length buddy-str)
 419                          (list
 420                           'face
 421                           (or (cdr (assoc (get buddy 'show) jabber-presence-faces))
 422                               'jabber-roster-user-online)
 423                           ;;'mouse-face
 424                           ;;(cons 'background-color "light grey")
 425                           'help-echo
 426                           (symbol-name buddy)
 427                           'jabber-jid
 428                           (symbol-name buddy)
 429                           'jabber-account
 430                           jc)
 431                          buddy-str)
 432     ;; (let ((map (make-sparse-keymap))
 433     ;;        (chat-with-func (make-symbol (concat "jabber-chat-with" (symbol-name buddy)))))
 434     ;;    (fset chat-with-func `(lambda () (interactive) (jabber-chat-with ,(symbol-name buddy))))
 435     ;;    (define-key map [mouse-2] chat-with-func)
 436     ;;    (put-text-property 0
 437     ;;                       (length buddy-str)
 438     ;;                       'keymap
 439     ;;                       map
 440     ;;                       buddy-str))
 441     (insert buddy-str)
 442
 443     (when (or (eq jabber-show-resources 'always)
 444               (and (eq jabber-show-resources 'sometimes)
 445                    (> (jabber-count-connected-resources buddy) 1)))
 446       (dolist (resource (get buddy 'resources))
 447         (when (plist-get (cdr resource) 'connected)
 448           (let ((resource-str (format-spec jabber-resource-line-format
 449                                            (list
 450                                             (cons ?c "*")
 451                                             (cons ?n (if (> (length (get buddy 'name)) 0)
 452                                                          (get buddy 'name)
 453                                                        (symbol-name buddy)))
 454                                             (cons ?j (symbol-name buddy))
 455                                             (cons ?r (if (> (length (car resource)) 0)
 456                                                          (car resource)
 457                                                        "empty"))
 458                                             (cons ?s (or
 459                                                       (cdr (assoc (plist-get (cdr resource) 'show) jabber-presence-strings))
 460                                                       (plist-get (cdr resource) 'show)))
 461                                             (cons ?S (if (plist-get (cdr resource) 'status)
 462                                                          (jabber-fix-status (plist-get (cdr resource) 'status))
 463                                                        ""))
 464                                             (cons ?p (number-to-string (plist-get (cdr resource) 'priority)))))))
 465             (add-text-properties 0
 466                                  (length resource-str)
 467                                  (list
 468                                   'face
 469                                   (or (cdr (assoc (plist-get (cdr resource) 'show) jabber-presence-faces))
 470                                       'jabber-roster-user-online)
 471                                   'jabber-jid
 472                                   (format "%s/%s" (symbol-name buddy) (car resource))
 473                                   'jabber-account
 474                                   jc)
 475                                  resource-str)
 476             (insert "\n" resource-str)))))))
 477
 478 (defun jabber-roster-update (jc new-items changed-items deleted-items)
 479   "Update roster, in memory and on display.
 480 Add NEW-ITEMS, update CHANGED-ITEMS and remove DELETED-ITEMS, all
 481 three being lists of JID symbols."
 482   (let ((roster (plist-get (fsm-get-state-data jc) :roster))
 483         (ewoc (plist-get (fsm-get-state-data jc) :roster-ewoc)))
 484     (dolist (delete-this deleted-items)
 485       (setq roster (delq delete-this roster)))
 486     (setq roster (append new-items roster))
 487     (plist-put (fsm-get-state-data jc) :roster roster)
 488
 489     ;; If there is no ewoc yet, create the roster buffer.
 490     (if (null ewoc)
 491         (jabber-display-roster)
 492       ;; Otherwise, do incremental changes.
 493
 494       ;; The changed items need to be resorted, so we start by removing
 495       ;; them as well.
 496       (ewoc-filter ewoc
 497                    (lambda (a) (not (or (member a changed-items)
 498                                         (member a deleted-items)))))
 499
 500       ;; Now, insert items into ewoc.
 501       (let* ((to-be-inserted
 502               (sort (jabber-roster-filter-display
 503                      (append new-items changed-items))
 504                     #'jabber-roster-sort-items))
 505              (where (ewoc-nth ewoc 0)))
 506         (while to-be-inserted
 507           (cond
 508            ;; If we are at the end of the ewoc, put all elements there.
 509            ((null where)
 510             (dolist (a to-be-inserted)
 511               (ewoc-enter-last ewoc a))
 512             (setq to-be-inserted nil))
 513            ;; If the next element should go here, put it here.
 514            ((jabber-roster-sort-items (car to-be-inserted)
 515                                       (ewoc-data where))
 516             (ewoc-enter-before ewoc where
 517                                (car to-be-inserted))
 518             (setq to-be-inserted (cdr to-be-inserted)))
 519            ;; Else, advance through the ewoc.
 520            (t
 521             (setq where (ewoc-next ewoc where)))))))))
 522
 523 (defalias 'jabber-presence-update-roster 'ignore)
 524 ;;jabber-presence-update-roster is not needed anymore.
 525 ;;Its work is done in `jabber-process-presence'."
 526 (make-obsolete 'jabber-presence-update-roster 'ignore)
 527
 528 (defun jabber-go-to-next-jid ()
 529   "Move the cursor to the next jid in the buffer"
 530   (interactive)
 531   (let ((next (next-single-property-change (point) 'jabber-jid)))
 532     (when (and next
 533                (not (get-text-property next 'jabber-jid)))
 534       (setq next (next-single-property-change next 'jabber-jid)))
 535     (unless next
 536       (setq next (next-single-property-change (point-min) 'jabber-jid)))
 537     (if next (goto-char (1+ next))
 538       (goto-char (point-min)))))
 539
 540 (defun jabber-go-to-previous-jid ()
 541   "Move the cursor to the previous jid in the buffer"
 542   (interactive)
 543   (let ((previous (previous-single-property-change (point) 'jabber-jid)))
 544     (when (and previous
 545                (not (get-text-property previous 'jabber-jid)))
 546       (setq previous (previous-single-property-change previous 'jabber-jid)))
 547     (unless previous
 548       (setq previous (previous-single-property-change (point-max) 'jabber-jid)))
 549     (if previous (goto-char previous)
 550       (goto-char (point-max)))))
 551
 552 (provide 'jabber-roster)
 553
 554 ;;; arch-tag: 096af063-0526-4dd2-90fd-bc6b5ba07d32