jabber-roster.el

   1 ;; jabber-roster.el - displaying the roster    -*- coding: utf-8; -*-
   2
   3 ;; Copyright (C) 2003, 2004, 2007, 2008 - 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              jabber-roster-sort-by-group)
 102   :group 'jabber-roster)
 103
 104 (defcustom jabber-sort-order '("chat" "" "away" "dnd" "xa")
 105   "Sort by status in this order.  Anything not in list goes last.
 106 Offline is represented as nil."
 107   :type '(repeat (restricted-sexp :match-alternatives (stringp nil)))
 108   :group 'jabber-roster)
 109
 110 (defcustom jabber-show-resources 'sometimes
 111   "Show contacts' resources in roster?
 112 This can be one of the following symbols:
 113
 114 nil       Never show resources
 115 sometimes Show resources when there are more than one
 116 always    Always show resources"
 117   :type '(radio (const :tag "Never" nil)
 118                 (const :tag "When more than one connected resource" sometimes)
 119                 (const :tag "Always" always))
 120   :group 'jabber-roster)
 121
 122 (defcustom jabber-show-offline-contacts t
 123   "Show offline contacts in roster when non-nil"
 124   :type 'boolean
 125   :group 'jabber-roster)
 126
 127 (defcustom jabber-remove-newlines t
 128   "Remove newlines in status messages?
 129 Newlines in status messages mess up the roster display.  However,
 130 they are essential to status message poets.  Therefore, you get to
 131 choose the behaviour.
 132
 133 Trailing newlines are always removed, regardless of this variable."
 134   :type 'boolean
 135   :group 'jabber-roster)
 136
 137 (defcustom jabber-roster-show-bindings t
 138   "Show keybindings in roster buffer?"
 139   :type 'boolean
 140   :group 'jabber-roster)
 141
 142 (defcustom jabber-roster-mode-hook nil
 143   "Hook run when entering Roster mode."
 144   :group 'jabber-roster
 145   :type 'hook)
 146
 147 (defface jabber-roster-user-online
 148   '((t (:foreground "blue" :weight bold :slant normal)))
 149   "face for displaying online users"
 150   :group 'jabber-roster)
 151
 152 (defface jabber-roster-user-xa
 153   '((((background dark)) (:foreground "magenta" :weight normal :slant italic))
 154     (t (:foreground "black" :weight normal :slant italic)))
 155   "face for displaying extended away users"
 156   :group 'jabber-roster)
 157
 158 (defface jabber-roster-user-dnd
 159   '((t (:foreground "red" :weight normal :slant italic)))
 160   "face for displaying do not disturb users"
 161   :group 'jabber-roster)
 162
 163 (defface jabber-roster-user-away
 164   '((t (:foreground "dark green" :weight normal :slant italic)))
 165   "face for displaying away users"
 166   :group 'jabber-roster)
 167
 168 (defface jabber-roster-user-chatty
 169   '((t (:foreground "dark orange" :weight bold :slant normal)))
 170   "face for displaying chatty users"
 171   :group 'jabber-roster)
 172
 173 (defface jabber-roster-user-error
 174   '((t (:foreground "red" :weight light :slant italic)))
 175   "face for displaying users sending presence errors"
 176   :group 'jabber-roster)
 177
 178 (defface jabber-roster-user-offline
 179   '((t (:foreground "dark grey" :weight light :slant italic)))
 180   "face for displaying offline users"
 181   :group 'jabber-roster)
 182
 183 (defvar jabber-roster-mode-map
 184   (let ((map (make-sparse-keymap)))
 185     (set-keymap-parent map jabber-common-keymap)
 186     (define-key map [mouse-2] 'jabber-popup-combined-menu)
 187     (define-key map (kbd "TAB") 'jabber-go-to-next-jid)
 188     (define-key map (kbd "S-TAB") 'jabber-go-to-previous-jid)
 189     (define-key map (kbd "M-TAB") 'jabber-go-to-previous-jid)
 190     (define-key map (kbd "<backtab>") 'jabber-go-to-previous-jid)
 191     (define-key map (kbd "RET") 'jabber-chat-with-jid-at-point)
 192     (define-key map (kbd "C-k") 'jabber-roster-delete-jid-at-point)
 193
 194     (define-key map "e" 'jabber-roster-change)
 195     (define-key map "s" 'jabber-send-subscription-request)
 196     (define-key map "q" 'bury-buffer)
 197     (define-key map "i" 'jabber-get-disco-items)
 198     (define-key map "j" 'jabber-groupchat-join)
 199     (define-key map "I" 'jabber-get-disco-info)
 200     (define-key map "b" 'jabber-get-browse)
 201     (define-key map "v" 'jabber-get-version)
 202     (define-key map "a" 'jabber-send-presence)
 203     (define-key map "g" 'jabber-display-roster)
 204     (define-key map "S" 'jabber-ft-send)
 205     (define-key map "o" 'jabber-roster-toggle-offline-display)
 206     (define-key map "H" 'jabber-roster-toggle-binding-display)
 207     ;;(define-key map "D" 'jabber-disconnect)
 208     map))
 209
 210 (defun jabber-roster-mode ()
 211   "Major mode for Jabber roster display.
 212 Use the keybindings (mnemonic as Chat, Roster, Info, MUC, Service) to
 213 bring up menus of actions.
 214 \\{jabber-roster-mode-map}"
 215   (kill-all-local-variables)
 216   (setq major-mode 'jabber-roster-mode
 217         mode-name "jabber-roster")
 218   (use-local-map jabber-roster-mode-map)
 219   (setq buffer-read-only t)
 220   (if (fboundp 'run-mode-hooks)
 221       (run-mode-hooks 'jabber-roster-mode-hook)
 222     (run-hooks 'jabber-roster-mode-hook)))
 223
 224 (put 'jabber-roster-mode 'mode-class 'special)
 225
 226 (defun jabber-switch-to-roster-buffer (&optional jc)
 227   "Switch to roster buffer.
 228 Optional JC argument is ignored; it's there so this function can
 229 be used in `jabber-post-connection-hooks'."
 230   (interactive)
 231   (if (not (get-buffer jabber-roster-buffer))
 232       (jabber-display-roster)
 233     (switch-to-buffer jabber-roster-buffer)))
 234
 235 (defun jabber-sort-roster (jc)
 236   "sort roster according to online status"
 237   (let ((state-data (fsm-get-state-data jc)))
 238     (plist-put state-data :roster
 239                (sort
 240                 (plist-get state-data :roster)
 241                 #'jabber-roster-sort-items))))
 242
 243 (defun jabber-roster-sort-items (a b)
 244   "Sort roster items A and B according to `jabber-roster-sort-functions'.
 245 Return t if A is less than B."
 246   (dolist (fn jabber-roster-sort-functions)
 247     (let ((comparison (funcall fn a b)))
 248       (cond
 249        ((< comparison 0)
 250         (return t))
 251        ((> comparison 0)
 252         (return nil))))))
 253
 254 (defun jabber-roster-sort-by-status (a b)
 255   "Sort roster items by online status.
 256 See `jabber-sort-order' for order used."
 257   (flet ((order (item) (length (member (get item 'show) jabber-sort-order))))
 258     (let ((a-order (order a))
 259           (b-order (order b)))
 260       ;; Note reversed test.  Items with longer X-order go first.
 261       (cond
 262        ((< a-order b-order)
 263         1)
 264        ((> a-order b-order)
 265         -1)
 266        (t
 267         0)))))
 268
 269 (defun jabber-roster-sort-by-displayname (a b)
 270   "Sort roster items by displayed name."
 271   (let ((a-name (jabber-jid-displayname a))
 272         (b-name (jabber-jid-displayname b)))
 273     (cond
 274      ((string-lessp a-name b-name) -1)
 275      ((string= a-name b-name) 0)
 276      (t 1))))
 277
 278 (defun jabber-roster-sort-by-group (a b)
 279   "Sort roster items by group membership."
 280   (flet ((first-group (item) (or (car (get item 'groups)) "")))
 281     (let ((a-group (first-group a))
 282           (b-group (first-group b)))
 283       (cond
 284        ((string-lessp a-group b-group) -1)
 285        ((string= a-group b-group) 0)
 286        (t 1)))))
 287
 288 (defun jabber-fix-status (status)
 289   "Make status strings more readable"
 290   (when status
 291     (when (string-match "\n+$" status)
 292       (setq status (replace-match "" t t status)))
 293     (when jabber-remove-newlines
 294       (while (string-match "\n" status)
 295         (setq status (replace-match " " t t status))))
 296     status))
 297
 298 (defvar jabber-roster-ewoc nil
 299   "Ewoc displaying the roster.
 300 There is only one; we don't rely on buffer-local variables or
 301 such.")
 302
 303 (defun jabber-roster-filter-display (buddies)
 304   "Filter BUDDIES for items to be displayed in the roster"
 305   (remove-if-not (lambda (buddy) (or jabber-show-offline-contacts
 306                                      (get buddy 'connected)))
 307                  buddies))
 308
 309 (defun jabber-roster-toggle-offline-display ()
 310   "Toggle display of offline contacts."
 311   (interactive)
 312   (setq jabber-show-offline-contacts
 313         (not jabber-show-offline-contacts))
 314   (jabber-display-roster))
 315
 316 (defun jabber-roster-toggle-binding-display ()
 317   "Toggle display of the roster binding text."
 318   (interactive)
 319   (setq jabber-roster-show-bindings
 320         (not jabber-roster-show-bindings))
 321   (jabber-display-roster))
 322
 323 (defun jabber-display-roster ()
 324   "switch to the main jabber buffer and refresh the roster display to reflect the current information"
 325   (interactive)
 326   (with-current-buffer (get-buffer-create jabber-roster-buffer)
 327     (if (not (eq major-mode 'jabber-roster-mode))
 328         (jabber-roster-mode))
 329     (setq buffer-read-only nil)
 330     ;; line-number-at-pos is in Emacs >= 21.4.  Only used to avoid
 331     ;; excessive scrolling when updating roster, so not absolutely
 332     ;; necessary.
 333     (let ((current-line (and (fboundp 'line-number-at-pos) (line-number-at-pos)))
 334           (current-column (current-column)))
 335       (erase-buffer)
 336       (setq jabber-roster-ewoc nil)
 337       (insert (jabber-propertize "Jabber roster" 'face 'jabber-title-large) "\n")
 338       (when jabber-roster-show-bindings
 339         (insert "RET      Open chat buffer        C-k      Delete roster item
 340 e        Edit item               s        Send subscription request
 341 q        Bury buffer             i        Get disco items
 342 I        Get disco info          b        Browse
 343 j        Join groupchat (MUC)    v        Get client version
 344 a        Send presence           o        Show offline contacts on/off
 345 C-c C-c  Chat menu               C-c C-m  Multi-User Chat menu
 346 C-c C-i  Info menu               C-c C-r  Roster menu
 347 C-c C-s  Service menu
 348
 349 H        Toggle displaying this text
 350 "))
 351       (insert "__________________________________\n\n")
 352       (if (null jabber-connections)
 353           (insert "Not connected\n")
 354         (let ((map (make-sparse-keymap)))
 355           (define-key map [mouse-2] #'jabber-send-presence)
 356           (insert (jabber-propertize (concat (format " - %s"
 357                                                      (cdr (assoc *jabber-current-show* jabber-presence-strings)))
 358                                              (if (not (zerop (length *jabber-current-status*)))
 359                                                  (format " (%s)"
 360                                                          (jabber-fix-status *jabber-current-status*)))
 361                                              " -")
 362                                      'face (or (cdr (assoc *jabber-current-show* jabber-presence-faces))
 363                                                'jabber-roster-user-online)
 364                                      ;;'mouse-face (cons 'background-color "light grey")
 365                                      'keymap map)
 366                   "\n")))
 367
 368       (dolist (jc jabber-connections)
 369         ;; We sort everything before putting it in the ewoc
 370         (jabber-sort-roster jc)
 371         (let ((before-ewoc (point))
 372               (ewoc (ewoc-create
 373                      (lexical-let ((jc jc))
 374                        (lambda (buddy)
 375                          (jabber-display-roster-entry jc buddy)))
 376                      (concat
 377                       (jabber-propertize (concat
 378                                           (plist-get (fsm-get-state-data jc) :username)
 379                                           "@"
 380                                           (plist-get (fsm-get-state-data jc) :server))
 381                                          'face 'jabber-title-medium)
 382                       "\n__________________________________\n")
 383                      "__________________________________")))
 384           (plist-put (fsm-get-state-data jc) :roster-ewoc ewoc)
 385           (dolist (buddy (jabber-roster-filter-display
 386                           (plist-get (fsm-get-state-data jc) :roster)))
 387             (ewoc-enter-last ewoc buddy))
 388           (goto-char (point-max))
 389           (insert "\n")
 390           (put-text-property before-ewoc (point)
 391                              'jabber-account jc)))
 392
 393       (goto-char (point-min))
 394       (setq buffer-read-only t)
 395       (if (interactive-p)
 396           (dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks))
 397             (run-hook-with-args hook 'roster (current-buffer) (funcall jabber-alert-info-message-function 'roster (current-buffer)))))
 398       (when current-line
 399         ;; Go back to previous line - don't use goto-line, since it
 400         ;; sets the mark.
 401         (goto-char (point-min))
 402         (forward-line (1- current-line))
 403         ;; ...and go back to previous column
 404         (move-to-column current-column)))))
 405
 406 (defun jabber-display-roster-entry (jc buddy)
 407   "Format and insert a roster entry for BUDDY at point.
 408 BUDDY is a JID symbol."
 409   (let ((buddy-str (format-spec jabber-roster-line-format
 410                                 (list
 411                                  (cons ?a (jabber-propertize " "
 412                                                              'display (get buddy 'avatar)))
 413                                  (cons ?c (if (get buddy 'connected) "*" " "))
 414                                  (cons ?u (cdr (assoc (or (get buddy 'subscription) "none")
 415                                                       jabber-roster-subscription-display)))
 416                                  (cons ?n (if (> (length (get buddy 'name)) 0)
 417                                               (get buddy 'name)
 418                                             (symbol-name buddy)))
 419                                  (cons ?j (symbol-name buddy))
 420                                  (cons ?r (or (get buddy 'resource) ""))
 421                                  (cons ?s (or
 422                                            (cdr (assoc (get buddy 'show) jabber-presence-strings))
 423                                            (get buddy 'show)))
 424                                  (cons ?S (if (get buddy 'status)
 425                                               (jabber-fix-status (get buddy 'status))
 426                                             ""))))))
 427     (add-text-properties 0
 428                          (length buddy-str)
 429                          (list
 430                           'face
 431                           (or (cdr (assoc (get buddy 'show) jabber-presence-faces))
 432                               'jabber-roster-user-online)
 433                           ;;'mouse-face
 434                           ;;(cons 'background-color "light grey")
 435                           'help-echo
 436                           (symbol-name buddy)
 437                           'jabber-jid
 438                           (symbol-name buddy)
 439                           'jabber-account
 440                           jc)
 441                          buddy-str)
 442     ;; (let ((map (make-sparse-keymap))
 443     ;;        (chat-with-func (make-symbol (concat "jabber-chat-with" (symbol-name buddy)))))
 444     ;;    (fset chat-with-func `(lambda () (interactive) (jabber-chat-with ,(symbol-name buddy))))
 445     ;;    (define-key map [mouse-2] chat-with-func)
 446     ;;    (put-text-property 0
 447     ;;                       (length buddy-str)
 448     ;;                       'keymap
 449     ;;                       map
 450     ;;                       buddy-str))
 451     (insert buddy-str)
 452
 453     (when (or (eq jabber-show-resources 'always)
 454               (and (eq jabber-show-resources 'sometimes)
 455                    (> (jabber-count-connected-resources buddy) 1)))
 456       (dolist (resource (get buddy 'resources))
 457         (when (plist-get (cdr resource) 'connected)
 458           (let ((resource-str (format-spec jabber-resource-line-format
 459                                            (list
 460                                             (cons ?c "*")
 461                                             (cons ?n (if (> (length (get buddy 'name)) 0)
 462                                                          (get buddy 'name)
 463                                                        (symbol-name buddy)))
 464                                             (cons ?j (symbol-name buddy))
 465                                             (cons ?r (if (> (length (car resource)) 0)
 466                                                          (car resource)
 467                                                        "empty"))
 468                                             (cons ?s (or
 469                                                       (cdr (assoc (plist-get (cdr resource) 'show) jabber-presence-strings))
 470                                                       (plist-get (cdr resource) 'show)))
 471                                             (cons ?S (if (plist-get (cdr resource) 'status)
 472                                                          (jabber-fix-status (plist-get (cdr resource) 'status))
 473                                                        ""))
 474                                             (cons ?p (number-to-string (plist-get (cdr resource) 'priority)))))))
 475             (add-text-properties 0
 476                                  (length resource-str)
 477                                  (list
 478                                   'face
 479                                   (or (cdr (assoc (plist-get (cdr resource) 'show) jabber-presence-faces))
 480                                       'jabber-roster-user-online)
 481                                   'jabber-jid
 482                                   (format "%s/%s" (symbol-name buddy) (car resource))
 483                                   'jabber-account
 484                                   jc)
 485                                  resource-str)
 486             (insert "\n" resource-str)))))))
 487
 488 (defun jabber-roster-update (jc new-items changed-items deleted-items)
 489   "Update roster, in memory and on display.
 490 Add NEW-ITEMS, update CHANGED-ITEMS and remove DELETED-ITEMS, all
 491 three being lists of JID symbols."
 492   (let ((roster (plist-get (fsm-get-state-data jc) :roster))
 493         (ewoc (plist-get (fsm-get-state-data jc) :roster-ewoc)))
 494     (dolist (delete-this deleted-items)
 495       (setq roster (delq delete-this roster)))
 496     (setq roster (append new-items roster))
 497     (plist-put (fsm-get-state-data jc) :roster roster)
 498
 499     ;; If there is no ewoc yet, create the roster buffer.
 500     (if (null ewoc)
 501         (jabber-display-roster)
 502       ;; Otherwise, do incremental changes.
 503
 504       ;; The changed items need to be resorted, so we start by removing
 505       ;; them as well.
 506       (ewoc-filter ewoc
 507                    (lambda (a) (not (or (member a changed-items)
 508                                         (member a deleted-items)))))
 509
 510       ;; Now, insert items into ewoc.
 511       (let* ((to-be-inserted
 512               (sort (jabber-roster-filter-display
 513                      (append new-items changed-items))
 514                     #'jabber-roster-sort-items))
 515              (where (ewoc-nth ewoc 0)))
 516         (while to-be-inserted
 517           (cond
 518            ;; If we are at the end of the ewoc, put all elements there.
 519            ((null where)
 520             (dolist (a to-be-inserted)
 521               (ewoc-enter-last ewoc a))
 522             (setq to-be-inserted nil))
 523            ;; If the next element should go here, put it here.
 524            ((jabber-roster-sort-items (car to-be-inserted)
 525                                       (ewoc-data where))
 526             (ewoc-enter-before ewoc where
 527                                (car to-be-inserted))
 528             (setq to-be-inserted (cdr to-be-inserted)))
 529            ;; Else, advance through the ewoc.
 530            (t
 531             (setq where (ewoc-next ewoc where)))))))))
 532
 533 (defalias 'jabber-presence-update-roster 'ignore)
 534 ;;jabber-presence-update-roster is not needed anymore.
 535 ;;Its work is done in `jabber-process-presence'."
 536 (make-obsolete 'jabber-presence-update-roster 'ignore)
 537
 538 (defun jabber-go-to-next-jid ()
 539   "Move the cursor to the next jid in the buffer"
 540   (interactive)
 541   (let ((next (next-single-property-change (point) 'jabber-jid)))
 542     (when (and next
 543                (not (get-text-property next 'jabber-jid)))
 544       (setq next (next-single-property-change next 'jabber-jid)))
 545     (unless next
 546       (setq next (next-single-property-change (point-min) 'jabber-jid)))
 547     (if next (goto-char (1+ next))
 548       (goto-char (point-min)))))
 549
 550 (defun jabber-go-to-previous-jid ()
 551   "Move the cursor to the previous jid in the buffer"
 552   (interactive)
 553   (let ((previous (previous-single-property-change (point) 'jabber-jid)))
 554     (when (and previous
 555                (not (get-text-property previous 'jabber-jid)))
 556       (setq previous (previous-single-property-change previous 'jabber-jid)))
 557     (unless previous
 558       (setq previous (previous-single-property-change (point-max) 'jabber-jid)))
 559     (if previous (goto-char previous)
 560       (goto-char (point-max)))))
 561
 562 (provide 'jabber-roster)
 563
 564 ;;; arch-tag: 096af063-0526-4dd2-90fd-bc6b5ba07d32