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