1 ;; jabber-muc.el - advanced MUC functions
3 ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
4 ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
6 ;; This file is a part of jabber.el.
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.
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.
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
22 (require 'jabber-chat
)
23 (require 'jabber-widget
)
24 (require 'jabber-newdisco
)
25 (require 'jabber-autoloads
)
30 (defvar *jabber-active-groupchats
* nil
31 "alist of groupchats and nicknames
32 Keys are strings, the bare JID of the room.
35 (defvar jabber-pending-groupchats
(make-hash-table)
36 "Hash table of groupchats and nicknames.
37 Keys are JID symbols; values are strings.
38 This table records the last nickname used to join the particular
39 chat room. Items are thus never removed.")
41 (defvar jabber-muc-participants nil
42 "alist of groupchats and participants
43 Keys are strings, the bare JID of the room.
44 Values are lists of nickname strings.")
46 (defvar jabber-group nil
47 "the groupchat you are participating in")
49 (defvar jabber-muc-topic
""
50 "The topic of the current MUC room.")
53 (defcustom jabber-muc-default-nicknames nil
54 "Default nickname for specific MUC rooms."
58 (string :tag
"JID of room")
59 (string :tag
"Nickname"))))
62 (defcustom jabber-muc-autojoin nil
63 "List of MUC rooms to automatically join on connection.
64 This list is saved in your Emacs customizations. You can also store
65 such a list on the Jabber server, where it is available to every
66 client; see `jabber-edit-bookmarks'."
68 :type
'(repeat (string :tag
"JID of room")))
70 (defcustom jabber-muc-disable-disco-check nil
71 "If non-nil, disable checking disco#info of rooms before joining them.
72 Disco information can tell whether the room exists and whether it is
73 password protected, but some servers do not support it. If you want
74 to join chat rooms on such servers, set this variable to t."
78 (defcustom jabber-groupchat-buffer-format
"*-jabber-groupchat-%n-*"
79 "The format specification for the name of groupchat buffers.
81 These fields are available (all are about the group you are chatting
84 %n Roster name of group, or JID if no nickname set
85 %j Bare JID (without resource)"
89 (defcustom jabber-groupchat-prompt-format
"[%t] %n> "
90 "The format specification for lines in groupchat.
92 These fields are available:
94 %t Time, formatted according to `jabber-chat-time-format'
97 %j Full JID (room@server/nick)"
101 (defcustom jabber-muc-header-line-format
102 '(" " (:eval
(jabber-jid-displayname jabber-group
))
103 "\t" jabber-muc-topic
)
104 "The specification for the header line of MUC buffers.
106 The format is that of `mode-line-format' and `header-line-format'."
110 (defcustom jabber-muc-private-buffer-format
"*-jabber-muc-priv-%g-%n-*"
111 "The format specification for the buffer name for private MUC messages.
113 These fields are available:
115 %g Roster name of group, or JID if no nickname set
116 %n Nickname of the group member you're chatting with"
120 (defcustom jabber-muc-private-foreign-prompt-format
"[%t] %g/%n> "
121 "The format specification for lines others type in a private MUC buffer.
123 These fields are available:
125 %t Time, formatted according to `jabber-chat-time-format'
127 %g Short room name (either roster name or username part of JID)"
131 (defcustom jabber-muc-private-header-line-format
132 '(" " (:eval
(jabber-jid-resource jabber-chatting-with
))
133 " in " (:eval
(jabber-jid-displayname (jabber-jid-user jabber-chatting-with
)))
134 "\t" jabber-events-message
135 "\t" jabber-chatstates-message
)
136 "The specification for the header line of private MUC chat buffers.
138 The format is that of `mode-line-format' and `header-line-format'."
143 (defvar jabber-muc-printers
'()
144 "List of functions that may be able to print part of a MUC message.
145 This gets prepended to `jabber-chat-printers', which see.")
148 (defun jabber-muc-get-buffer (group)
149 "Return the chat buffer for chatroom GROUP.
150 Either a string or a buffer is returned, so use `get-buffer' or
151 `get-buffer-create'."
152 (format-spec jabber-groupchat-buffer-format
154 (cons ?n
(jabber-jid-displayname group
))
155 (cons ?j
(jabber-jid-user group
)))))
157 (defun jabber-muc-create-buffer (jc group
)
158 "Prepare a buffer for chatroom GROUP.
159 This function is idempotent."
160 (with-current-buffer (get-buffer-create (jabber-muc-get-buffer group
))
161 (unless (eq major-mode
'jabber-chat-mode
)
162 (jabber-chat-mode jc
#'jabber-chat-pp
))
163 ;; Make sure the connection variable is up to date.
164 (setq jabber-buffer-connection jc
)
166 (set (make-local-variable 'jabber-group
) group
)
167 (make-local-variable 'jabber-muc-topic
)
168 (setq jabber-send-function
'jabber-muc-send
)
169 (setq header-line-format jabber-muc-header-line-format
)
173 (defun jabber-muc-private-get-buffer (group nickname
)
174 "Return the chat buffer for private chat with NICKNAME in GROUP.
175 Either a string or a buffer is returned, so use `get-buffer' or
176 `get-buffer-create'."
177 (format-spec jabber-muc-private-buffer-format
179 (cons ?g
(jabber-jid-displayname group
))
180 (cons ?n nickname
))))
182 (defun jabber-muc-private-create-buffer (jc group nickname
)
183 "Prepare a buffer for chatting with NICKNAME in GROUP.
184 This function is idempotent."
185 (with-current-buffer (get-buffer-create (jabber-muc-private-get-buffer group nickname
))
186 (unless (eq major-mode
'jabber-chat-mode
)
187 (jabber-chat-mode jc
#'jabber-chat-pp
))
189 (set (make-local-variable 'jabber-chatting-with
) (concat group
"/" nickname
))
190 (setq jabber-send-function
'jabber-chat-send
)
191 (setq header-line-format jabber-muc-private-header-line-format
)
195 (defun jabber-muc-send (jc body
)
196 "Send BODY to MUC room in current buffer."
197 ;; There is no need to display the sent message in the buffer, as
198 ;; we will get it back from the MUC server.
201 ((to .
,jabber-group
)
202 (type .
"groupchat"))
205 (defun jabber-muc-add-groupchat (group nickname
)
206 "Remember participating in GROUP under NICKNAME."
207 (let ((whichgroup (assoc group
*jabber-active-groupchats
*)))
209 (setcdr whichgroup nickname
)
210 (add-to-list '*jabber-active-groupchats
* (cons group nickname
)))))
212 (defun jabber-muc-remove-groupchat (group)
213 "Remove GROUP from internal bookkeeping."
214 (let ((whichgroup (assoc group
*jabber-active-groupchats
*))
215 (whichparticipants (assoc group jabber-muc-participants
)))
216 (setq *jabber-active-groupchats
*
217 (delq whichgroup
*jabber-active-groupchats
*))
218 (setq jabber-muc-participants
219 (delq whichparticipants jabber-muc-participants
))))
221 (defun jabber-muc-participant-plist (group nickname
)
222 "Return plist associated with NICKNAME in GROUP.
223 Return nil if nothing known about that combination."
224 (let ((whichparticipants (assoc group jabber-muc-participants
)))
225 (when whichparticipants
226 (cdr (assoc nickname whichparticipants
)))))
228 (defun jabber-muc-modify-participant (group nickname new-plist
)
229 "Assign properties in NEW-PLIST to NICKNAME in GROUP."
230 (let ((participants (assoc group jabber-muc-participants
)))
231 ;; either we have a list of participants already...
233 (let ((participant (assoc nickname participants
)))
234 ;; and maybe this participant is already in the list
236 ;; if so, just update role, affiliation, etc.
237 (setf (cdr participant
) new-plist
)
238 (push (cons nickname new-plist
) (cdr participants
))))
240 (push (cons group
(list (cons nickname new-plist
))) jabber-muc-participants
))))
242 (defun jabber-muc-report-delta (nickname old-plist new-plist reason actor
)
243 "Compare OLD-PLIST and NEW-PLIST, and return a string explaining the change.
244 Return nil if nothing noteworthy has happened.
245 NICKNAME is the user experiencing the change. REASON and ACTOR, if non-nil,
246 are the corresponding presence fields.
248 This function is only concerned with presence stanzas resulting
249 in the user entering/staying in the room."
250 ;; The keys in the plist are affiliation, role and jid.
251 (when (plist-get new-plist
'jid
)
252 ;; nickname is only used for displaying, so we can modify it if we
254 (setq nickname
(concat nickname
" <"
255 (jabber-jid-user (plist-get new-plist
'jid
))
259 ;; User enters the room
260 (concat nickname
" enters the room ("
261 (plist-get new-plist
'role
)
262 (unless (string= (plist-get new-plist
'affiliation
) "none")
263 (concat ", " (plist-get new-plist
'affiliation
)))
266 ;; If affiliation changes, the role change is usually the logical
267 ;; one, so don't report it separately.
268 ((not (string= (plist-get old-plist
'affiliation
)
269 (plist-get new-plist
'affiliation
)))
270 (let ((actor-reason (concat (when actor
271 (concat " by " actor
))
273 (concat ": " reason
))))
274 (from (plist-get old-plist
'affiliation
))
275 (to (plist-get new-plist
'affiliation
)))
276 ;; There are many ways to express these transitions in English.
277 ;; This one favors eloquence over regularity and consistency.
279 ;; Higher affiliation
280 ((or (and (member from
'("outcast" "none" "member"))
281 (member to
'("admin" "owner")))
282 (and (string= from
"admin") (string= to
"owner")))
283 (concat nickname
" has been promoted to " to actor-reason
))
285 ((or (and (member from
'("owner" "admin"))
286 (string= to
"member"))
287 (and (string= from
"owner") (string= to
"admin")))
288 (concat nickname
" has been demoted to " to actor-reason
))
290 ((string= to
"member")
291 (concat nickname
" has been granted membership" actor-reason
))
294 (concat nickname
" has been deprived of membership" actor-reason
)))))
297 ((not (string= (plist-get old-plist
'role
)
298 (plist-get new-plist
'role
)))
299 (let ((actor-reason (concat (when actor
300 (concat " by " actor
))
302 (concat ": " reason
))))
303 (from (plist-get old-plist
'role
))
304 (to (plist-get new-plist
'role
)))
305 ;; Possible roles are "none" (not in room, hence not of interest
306 ;; in this function), "visitor" (no voice), "participant" (has
307 ;; voice), and "moderator".
309 ((string= to
"moderator")
310 (concat nickname
" has been granted moderator privileges" actor-reason
))
311 ((and (string= from
"moderator")
312 (string= to
"participant"))
313 (concat nickname
" had moderator privileges revoked" actor-reason
))
314 ((string= to
"participant")
315 (concat nickname
" has been granted voice" actor-reason
))
316 ((string= to
"visitor")
317 (concat nickname
" has been denied voice" actor-reason
)))))))
319 (defun jabber-muc-remove-participant (group nickname
)
320 "Forget everything about NICKNAME in GROUP."
321 (let ((participants (assoc group jabber-muc-participants
)))
323 (let ((participant (assoc nickname
(cdr participants
))))
324 (setf (cdr participants
) (delq participant
(cdr participants
)))))))
326 (defmacro jabber-muc-argument-list
(&optional args
)
327 "Prepend connection and group name to ARGS.
328 If the current buffer is not an MUC buffer, signal an error.
329 This macro is meant for use as an argument to `interactive'."
330 `(if (null jabber-group
)
331 (error "Not in MUC buffer")
332 (nconc (list jabber-buffer-connection jabber-group
) ,args
)))
334 (defun jabber-muc-read-completing (prompt &optional allow-not-joined
)
335 "Read the name of a joined chatroom, or use chatroom of current buffer, if any.
336 If ALLOW-NOT-JOINED is provided and true, permit choosing any
337 JID; only provide completion as a guide."
339 (jabber-read-jid-completing prompt
340 (if (null *jabber-active-groupchats
*)
341 (error "You haven't joined any group")
342 (mapcar (lambda (x) (jabber-jid-symbol (car x
)))
343 *jabber-active-groupchats
*))
344 (not allow-not-joined
)
347 (defun jabber-muc-read-nickname (group prompt
)
348 "Read the nickname of a participant in GROUP."
349 (let ((nicknames (cdr (assoc group jabber-muc-participants
))))
351 (error "Unknown group: %s" group
))
352 (completing-read prompt nicknames nil t
)))
354 (add-to-list 'jabber-jid-muc-menu
355 (cons "Configure groupchat" 'jabber-groupchat-get-config
))
356 (defun jabber-groupchat-get-config (jc group
)
357 "Ask for MUC configuration form"
358 (interactive (jabber-muc-argument-list))
359 (jabber-send-iq jc group
361 '(query ((xmlns .
"http://jabber.org/protocol/muc#owner")))
362 #'jabber-process-data
#'jabber-groupchat-render-config
363 #'jabber-process-data
"MUC configuration request failed"))
365 (defun jabber-groupchat-render-config (jc xml-data
)
366 "Render MUC configuration form"
368 (let ((query (jabber-iq-query xml-data
))
370 (dolist (x (jabber-xml-get-children query
'x
))
371 (if (string= (jabber-xml-get-attribute x
'xmlns
) "jabber:x:data")
374 (insert "No configuration possible.\n")
376 (jabber-init-widget-buffer (jabber-xml-get-attribute xml-data
'from
))
377 (setq jabber-buffer-connection jc
)
379 (jabber-render-xdata-form xdata
)
381 (widget-create 'push-button
:notify
#'jabber-groupchat-submit-config
"Submit")
383 (widget-create 'push-button
:notify
#'jabber-groupchat-cancel-config
"Cancel")
387 (widget-minor-mode 1))))
389 (defun jabber-groupchat-submit-config (&rest ignore
)
390 "Submit MUC configuration form."
392 (jabber-send-iq jabber-buffer-connection jabber-submit-to
394 `(query ((xmlns .
"http://jabber.org/protocol/muc#owner"))
395 ,(jabber-parse-xdata-form))
396 #'jabber-report-success
"MUC configuration"
397 #'jabber-report-success
"MUC configuration"))
399 (defun jabber-groupchat-cancel-config (&rest ignore
)
400 "Cancel MUC configuration form."
402 (jabber-send-iq jabber-buffer-connection jabber-submit-to
404 '(query ((xmlns .
"http://jabber.org/protocol/muc#owner"))
405 (x ((xmlns .
"jabber:x:data") (type .
"cancel"))))
408 (add-to-list 'jabber-jid-muc-menu
409 (cons "Join groupchat" 'jabber-groupchat-join
))
411 (defun jabber-groupchat-join (jc group nickname
&optional popup
)
412 "join a groupchat, or change nick.
413 In interactive calls, or if POPUP is true, switch to the
416 (let ((account (jabber-read-account))
417 (group (jabber-read-jid-completing "group: ")))
418 (list account group
(jabber-muc-read-my-nickname account group
) t
)))
420 ;; If the user is already in the room, we don't need as many checks.
421 (if (or (assoc group
*jabber-active-groupchats
*)
422 ;; Or if the users asked us not to check disco info.
423 jabber-muc-disable-disco-check
)
424 (jabber-groupchat-join-3 jc group nickname nil popup
)
425 ;; Else, send a disco request to find out what we are connecting
427 (jabber-disco-get-info jc group nil
#'jabber-groupchat-join-2
428 (list group nickname popup
))))
430 (defun jabber-groupchat-join-2 (jc closure result
)
431 (destructuring-bind (group nickname popup
) closure
432 (let ( ;; Either success...
433 (identities (car result
))
434 (features (cadr result
))
436 (condition (when (eq (car result
) 'error
) (jabber-error-condition result
))))
438 ;; Maybe the room doesn't exist yet.
439 ((eq condition
'item-not-found
)
440 (unless (y-or-n-p (format "%s doesn't exist. Create it? " (jabber-jid-displayname group
)))
441 (error "Non-existent groupchat")))
443 ;; Maybe the room doesn't support disco.
444 ((eq condition
'feature-not-implemented
)
447 ;; Maybe another error occurred.
449 (error "Couldn't query groupchat: %s" (jabber-parse-error result
)))
451 ;; Maybe it isn't a chat room.
452 ((not (find "conference" identities
453 :key
(lambda (i) (aref i
1))
455 (error "%s is not a groupchat" (jabber-jid-displayname group
))))
458 ;; Is the room password-protected?
459 (when (member "muc_passwordprotected" features
)
461 (jabber-get-conference-data jc group nil
:password
)
462 (read-passwd (format "Password for %s: " (jabber-jid-displayname group
)))))))
464 (jabber-groupchat-join-3 jc group nickname password popup
)))))
466 (defun jabber-groupchat-join-3 (jc group nickname password popup
)
468 ;; Remember that this is a groupchat _before_ sending the stanza.
469 ;; The response might come quicker than you think.
471 (puthash (jabber-jid-symbol group
) nickname jabber-pending-groupchats
)
474 `(presence ((to .
,(format "%s/%s" group nickname
)))
475 (x ((xmlns .
"http://jabber.org/protocol/muc"))
477 `((password () ,password
))))
478 ,@(jabber-presence-children jc
)))
480 ;; There, stanza sent. Now we just wait for the MUC service to
481 ;; mirror the stanza. This is handled in
482 ;; `jabber-muc-process-presence', where a buffer will be created for
485 ;; But if the user interactively asked to join, he/she probably
486 ;; wants the buffer to pop up right now.
488 (let ((buffer (jabber-muc-create-buffer jc group
)))
489 (switch-to-buffer buffer
))))
491 (defun jabber-muc-read-my-nickname (jc group
)
492 "Read nickname for joining GROUP."
493 (let ((default-nickname (or
494 (jabber-get-conference-data jc group nil
:nick
)
495 (cdr (assoc group jabber-muc-default-nicknames
))
496 (plist-get (fsm-get-state-data jc
) :username
))))
497 (jabber-read-with-input-method (format "Nickname: (default %s) "
499 nil nil default-nickname
)))
501 (add-to-list 'jabber-jid-muc-menu
502 (cons "Change nickname" 'jabber-muc-nick
))
504 (defalias 'jabber-muc-nick
'jabber-groupchat-join
)
506 (add-to-list 'jabber-jid-muc-menu
507 (cons "Leave groupchat" 'jabber-groupchat-leave
))
509 (defun jabber-groupchat-leave (jc group
)
511 (interactive (jabber-muc-argument-list))
512 (let ((whichgroup (assoc group
*jabber-active-groupchats
*)))
513 ;; send unavailable presence to our own nick in room
515 `(presence ((to .
,(format "%s/%s" group
(cdr whichgroup
)))
516 (type .
"unavailable"))))))
518 (add-to-list 'jabber-jid-muc-menu
519 (cons "List participants" 'jabber-muc-names
))
521 (defun jabber-muc-names ()
522 "Print names, affiliations, and roles of participants in current buffer."
524 (ewoc-enter-last jabber-chat-ewoc
(list :notice
525 (jabber-muc-print-names
526 (cdr (assoc jabber-group jabber-muc-participants
)))
527 :time
(current-time))))
529 (defun jabber-muc-print-names (participants)
530 "Format and return data in PARTICIPANTS."
531 (apply 'concat
"Participants:\n"
532 (format "%-15s %-15s %-11s %s\n" "Nickname" "Role" "Affiliation" "JID")
534 (let ((plist (cdr x
)))
535 (format "%-15s %-15s %-11s %s\n"
537 (plist-get plist
'role
)
538 (plist-get plist
'affiliation
)
539 (or (plist-get plist
'jid
) ""))))
542 (add-to-list 'jabber-jid-muc-menu
543 (cons "Set topic" 'jabber-muc-set-topic
))
545 (defun jabber-muc-set-topic (jc group topic
)
546 "Set topic of GROUP to TOPIC."
548 (jabber-muc-argument-list
549 (list (jabber-read-with-input-method "New topic: " jabber-muc-topic
))))
550 (jabber-send-message jc group topic nil
"groupchat"))
552 (defun jabber-muc-snarf-topic (xml-data)
553 "Record subject (topic) of the given <message/>, if any."
554 (let ((new-topic (jabber-xml-path xml-data
'(subject ""))))
556 (setq jabber-muc-topic new-topic
))))
558 (add-to-list 'jabber-jid-muc-menu
559 (cons "Set role (kick, voice, op)" 'jabber-muc-set-role
))
561 (defun jabber-muc-set-role (jc group nickname role reason
)
562 "Set role of NICKNAME in GROUP to ROLE, specifying REASON."
564 (jabber-muc-argument-list
565 (let ((nickname (jabber-muc-read-nickname jabber-group
"Nickname: ")))
567 (completing-read "New role: " '(("none") ("visitor") ("participant") ("moderator")) nil t
)
568 (read-string "Reason: ")))))
569 (unless (or (zerop (length nickname
)) (zerop (length role
)))
570 (jabber-send-iq jc group
"set"
571 `(query ((xmlns .
"http://jabber.org/protocol/muc#admin"))
572 (item ((nick .
,nickname
)
574 ,(unless (zerop (length reason
))
575 `(reason () ,reason
))))
576 'jabber-report-success
"Role change"
577 'jabber-report-success
"Role change")))
579 (add-to-list 'jabber-jid-muc-menu
580 (cons "Set affiliation (ban, member, admin)" 'jabber-muc-set-affiliation
))
582 (defun jabber-muc-set-affiliation (jc group nickname-or-jid nickname-p affiliation reason
)
583 "Set affiliation of NICKNAME-OR-JID in GROUP to AFFILIATION.
584 If NICKNAME-P is non-nil, NICKNAME-OR-JID is a nickname in the
585 group, else it is a JID."
587 (jabber-muc-argument-list
588 (let ((nickname-p (y-or-n-p "Specify user by room nickname? ")))
591 (jabber-muc-read-nickname jabber-group
"Nickname: ")
592 (jabber-read-jid-completing "User: "))
594 (completing-read "New affiliation: "
595 '(("none") ("outcast") ("member") ("admin") ("owner")) nil t
)
596 (read-string "Reason: ")))))
599 (let ((participants (cdr (assoc group jabber-muc-participants
))))
601 (error "Couldn't find group %s" group
))
602 (let ((participant (cdr (assoc nickname-or-jid participants
))))
604 (error "Couldn't find %s in group %s" nickname-or-jid group
))
605 (or (plist-get participant
'jid
)
606 (error "JID of %s in group %s is unknown" nickname-or-jid group
))))
608 (jabber-send-iq jc group
"set"
609 `(query ((xmlns .
"http://jabber.org/protocol/muc#admin"))
611 (affiliation .
,affiliation
))
612 ,(unless (zerop (length reason
))
613 `(reason () ,reason
))))
614 'jabber-report-success
"Affiliation change"
615 'jabber-report-success
"Affiliation change")))
617 (add-to-list 'jabber-jid-muc-menu
618 (cons "Invite someone to chatroom" 'jabber-muc-invite
))
620 (defun jabber-muc-invite (jc jid group reason
)
621 "Invite JID to GROUP, stating REASON."
623 (list (jabber-read-account)
624 (jabber-read-jid-completing "Invite whom: ")
625 (jabber-muc-read-completing "To group: ")
626 (jabber-read-with-input-method "Reason: ")))
629 `(message ((to .
,group
))
630 (x ((xmlns .
"http://jabber.org/protocol/muc#user"))
631 (invite ((to .
,jid
))
632 ,(unless (zerop (length reason
))
633 `(reason nil
,reason
)))))))
635 (add-to-list 'jabber-body-printers
'jabber-muc-print-invite
)
637 (defun jabber-muc-print-invite (xml-data who mode
)
638 "Print MUC invitation"
639 (dolist (x (jabber-xml-get-children xml-data
'x
))
640 (when (string= (jabber-xml-get-attribute x
'xmlns
) "http://jabber.org/protocol/muc#user")
641 (let ((invitation (car (jabber-xml-get-children x
'invite
))))
643 (when (eql mode
:insert
)
644 (let ((group (jabber-xml-get-attribute xml-data
'from
))
645 (inviter (jabber-xml-get-attribute invitation
'from
))
646 (reason (car (jabber-xml-node-children (car (jabber-xml-get-children invitation
'reason
))))))
648 (insert "You have been invited to MUC room " (jabber-jid-displayname group
))
650 (insert " by " (jabber-jid-displayname inviter
)))
653 (insert " Reason: " reason
))
657 `(lambda (&rest ignore
) (interactive)
658 (jabber-groupchat-join jabber-buffer-connection
,group
659 (jabber-muc-read-my-nickname ,jabber-buffer-connection
,group
)))))
660 (if (fboundp 'insert-button
)
661 (insert-button "Accept"
663 ;; Simple button replacement
664 (let ((keymap (make-keymap)))
665 (define-key keymap
"\r" action
)
666 (insert (jabber-propertize "Accept"
673 `(lambda (&rest ignore
) (interactive)
675 (jabber-read-with-input-method
678 jabber-buffer-connection
680 (list (cons 'to
,group
))
682 (list (cons 'xmlns
"http://jabber.org/protocol/muc#user"))
684 (list (cons 'to
,inviter
))
685 (unless (zerop (length reason
))
686 (list 'reason nil reason
))))))))))
687 (if (fboundp 'insert-button
)
688 (insert-button "Decline"
690 ;; Simple button replacement
691 (let ((keymap (make-keymap)))
692 (define-key keymap
"\r" action
)
693 (insert (jabber-propertize "Decline"
695 'face
'highlight
))))))))
698 (defun jabber-muc-autojoin (jc)
699 "Join rooms specified in account bookmarks and global `jabber-muc-autojoin'."
700 (interactive (list (jabber-read-account)))
701 (let ((nickname (plist-get (fsm-get-state-data jc
) :username
)))
702 (when (bound-and-true-p jabber-muc-autojoin
)
703 (dolist (group jabber-muc-autojoin
)
704 (jabber-groupchat-join jc group
(or
705 (cdr (assoc group jabber-muc-default-nicknames
))
706 (plist-get (fsm-get-state-data jc
) :username
)))))
707 (jabber-get-bookmarks
709 (lambda (jc bookmarks
)
710 (dolist (bookmark bookmarks
)
711 (setq bookmark
(jabber-parse-conference-bookmark bookmark
))
712 (when (and bookmark
(plist-get bookmark
:autojoin
))
713 (jabber-groupchat-join jc
(plist-get bookmark
:jid
)
714 (or (plist-get bookmark
:nick
)
715 (plist-get (fsm-get-state-data jc
) :username
)))))))))
718 (defun jabber-muc-message-p (message)
719 "Return non-nil if MESSAGE is a groupchat message.
720 That does not include private messages in a groupchat, but does
721 include groupchat invites."
722 ;; Public groupchat messages have type "groupchat" and are from
723 ;; room@server/nick. Public groupchat errors have type "error" and
724 ;; are from room@server.
725 (let ((from (jabber-xml-get-attribute message
'from
))
726 (type (jabber-xml-get-attribute message
'type
)))
728 (string= type
"groupchat")
729 (and (string= type
"error")
730 (gethash (jabber-jid-symbol from
) jabber-pending-groupchats
))
731 (jabber-xml-path message
'(("http://jabber.org/protocol/muc#user" .
"x") invite
)))))
734 (defun jabber-muc-sender-p (jid)
735 "Return non-nil if JID is a full JID of an MUC participant."
736 (and (assoc (jabber-jid-user jid
) *jabber-active-groupchats
*)
737 (jabber-jid-resource jid
)))
740 (defun jabber-muc-private-message-p (message)
741 "Return non-nil if MESSAGE is a private message in a groupchat."
742 (let ((from (jabber-xml-get-attribute message
'from
))
743 (type (jabber-xml-get-attribute message
'type
)))
745 (not (string= type
"groupchat"))
746 (jabber-muc-sender-p from
))))
748 (add-to-list 'jabber-jid-muc-menu
749 (cons "Open private chat" 'jabber-muc-private
))
751 (defun jabber-muc-private (jc group nickname
)
752 "Open private chat with NICKNAME in GROUP."
754 (jabber-muc-argument-list
755 (list (jabber-muc-read-nickname jabber-group
"Nickname: "))))
756 (switch-to-buffer (jabber-muc-private-create-buffer jabber-buffer-connection group nickname
)))
758 (defun jabber-muc-presence-p (presence)
759 "Return non-nil if PRESENCE is presence from groupchat."
760 (let ((from (jabber-xml-get-attribute presence
'from
))
761 (type (jabber-xml-get-attribute presence
'type
))
763 (lambda (x) (equal (jabber-xml-get-attribute x
'xmlns
)
764 "http://jabber.org/protocol/muc#user"))
765 (jabber-xml-get-children presence
'x
))))
766 ;; This is MUC presence if it has an MUC-namespaced tag...
768 ;; ...or if it is error presence from a room we tried to join.
769 (and (string= type
"error")
770 (gethash (jabber-jid-symbol from
) jabber-pending-groupchats
)))))
772 (defun jabber-muc-parse-affiliation (x-muc)
773 "Parse X-MUC in the muc#user namespace and return a plist.
774 Return nil if X-MUC is nil."
775 ;; XXX: parse <actor/> and <reason/> tags? or maybe elsewhere?
776 (apply 'nconc
(mapcar (lambda (prop) (list (car prop
) (cdr prop
)))
777 (jabber-xml-node-attributes
778 (car (jabber-xml-get-children x-muc
'item
))))))
780 (defun jabber-muc-print-prompt (xml-data &optional local dont-print-nick-p
)
781 "Print MUC prompt for message in XML-DATA."
782 (let ((nick (jabber-jid-resource (jabber-xml-get-attribute xml-data
'from
)))
783 (timestamp (car (delq nil
(mapcar 'jabber-x-delay
(jabber-xml-get-children xml-data
'x
))))))
785 (insert (jabber-propertize
786 (format-spec jabber-groupchat-prompt-format
788 (cons ?t
(format-time-string
790 jabber-chat-delayed-time-format
791 jabber-chat-time-format
)
793 (cons ?n
(if dont-print-nick-p
"" nick
))
796 (cons ?j
(concat jabber-group
"/" nick
))))
797 'face
(if local
'jabber-chat-prompt-local
798 'jabber-chat-prompt-foreign
)
799 'help-echo
(concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp
) " from " nick
" in " jabber-group
)))
800 (jabber-muc-system-prompt))))
802 (defun jabber-muc-private-print-prompt (xml-data)
803 "Print prompt for private MUC message in XML-DATA."
804 (let ((nick (jabber-jid-resource (jabber-xml-get-attribute xml-data
'from
)))
805 (group (jabber-jid-user (jabber-xml-get-attribute xml-data
'from
)))
806 (timestamp (car (delq nil
(mapcar 'jabber-x-delay
(jabber-xml-get-children xml-data
'x
))))))
807 (insert (jabber-propertize
808 (format-spec jabber-muc-private-foreign-prompt-format
810 (cons ?t
(format-time-string
812 jabber-chat-delayed-time-format
813 jabber-chat-time-format
)
816 (cons ?g
(or (jabber-jid-rostername group
)
817 (jabber-jid-username group
)))))
818 'face
'jabber-chat-prompt-foreign
819 'help-echo
(concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp
) " from " nick
" in " jabber-group
)))))
821 (defun jabber-muc-system-prompt (&rest ignore
)
822 "Print system prompt for MUC."
823 (insert (jabber-propertize
824 (format-spec jabber-groupchat-prompt-format
826 (cons ?t
(format-time-string jabber-chat-time-format
))
830 (cons ?j jabber-group
)))
831 'face
'jabber-chat-prompt-system
832 'help-echo
(format-time-string "System message on %Y-%m-%d %H:%M:%S"))))
834 (add-to-list 'jabber-message-chain
'jabber-muc-process-message
)
836 (defun jabber-muc-process-message (jc xml-data
)
837 "If XML-DATA is a groupchat message, handle it as such."
838 (when (jabber-muc-message-p xml-data
)
839 (let* ((from (jabber-xml-get-attribute xml-data
'from
))
840 (group (jabber-jid-user from
))
841 (nick (jabber-jid-resource from
))
842 (error-p (jabber-xml-get-children xml-data
'error
))
845 ((string= nick
(cdr (assoc group
*jabber-active-groupchats
*)))
848 (body-text (car (jabber-xml-node-children
849 (car (jabber-xml-get-children
852 (printers (append jabber-muc-printers jabber-chat-printers
)))
854 (with-current-buffer (jabber-muc-create-buffer jc group
)
855 (jabber-muc-snarf-topic xml-data
)
856 ;; Call alert hooks only when something is output
858 (run-hook-with-args-until-success 'printers xml-data type
:printp
))
859 (jabber-maybe-print-rare-time
860 (ewoc-enter-last jabber-chat-ewoc
(list type xml-data
:time
(current-time))))
862 ;; ...except if the message is part of history, in which
863 ;; case we don't want an alert.
864 (let ((children-namespaces (mapcar (lambda (x) (when (listp x
) (jabber-xml-get-attribute x
'xmlns
)))
865 (jabber-xml-node-children xml-data
))))
866 (unless (or (member "urn:xmpp:delay" children-namespaces
)
867 (member "jabber:x:delay" children-namespaces
))
868 (dolist (hook '(jabber-muc-hooks jabber-alert-muc-hooks
))
869 (run-hook-with-args hook
870 nick group
(current-buffer) body-text
871 (funcall jabber-alert-muc-function
872 nick group
(current-buffer) body-text
))))))))))
874 (defun jabber-muc-process-presence (jc presence
)
875 (let* ((from (jabber-xml-get-attribute presence
'from
))
876 (type (jabber-xml-get-attribute presence
'type
))
878 (lambda (x) (equal (jabber-xml-get-attribute x
'xmlns
)
879 "http://jabber.org/protocol/muc#user"))
880 (jabber-xml-get-children presence
'x
)))
881 (group (jabber-jid-user from
))
882 (nickname (jabber-jid-resource from
))
883 (symbol (jabber-jid-symbol from
))
884 (item (car (jabber-xml-get-children x-muc
'item
)))
885 (actor (jabber-xml-get-attribute (car (jabber-xml-get-children item
'actor
)) 'jid
))
886 (reason (car (jabber-xml-node-children (car (jabber-xml-get-children item
'reason
)))))
887 (error-node (car (jabber-xml-get-children presence
'error
)))
888 (status-code (if error-node
889 (jabber-xml-get-attribute error-node
'code
)
890 (jabber-xml-get-attribute (car (jabber-xml-get-children x-muc
'status
)) 'code
))))
891 ;; handle leaving a room
893 ((or (string= type
"unavailable") (string= type
"error"))
894 ;; error from room itself? or are we leaving?
895 (if (or (null nickname
)
896 (string= nickname
(gethash (jabber-jid-symbol group
) jabber-pending-groupchats
)))
897 ;; Assume that an error means that we were thrown out of the
901 ((string= type
"error")
903 ;; ...except for certain cases.
904 ((or (equal status-code
"406")
905 (equal status-code
"409"))
907 (concat "Nickname change not allowed"
909 (concat ": " (jabber-parse-error error-node
)))))
911 (concat "Error entering room"
913 (concat ": " (jabber-parse-error error-node
)))))))
914 ((equal status-code
"301")
915 (concat "You have been banned"
916 (when actor
(concat " by " actor
))
917 (when reason
(concat " - '" reason
"'"))))
918 ((equal status-code
"307")
919 (concat "You have been kicked"
920 (when actor
(concat " by " actor
))
921 (when reason
(concat " - '" reason
"'"))))
923 "You have left the chatroom"))))
925 (jabber-muc-remove-groupchat group
))
926 ;; If there is no buffer for this groupchat, don't bother
927 ;; creating one just to tell that user left the room.
928 (let ((buffer (get-buffer (jabber-muc-get-buffer group
))))
930 (with-current-buffer buffer
931 (jabber-maybe-print-rare-time
932 (ewoc-enter-last jabber-chat-ewoc
933 (list (if (string= type
"error")
937 :time
(current-time)))))
938 (message "%s: %s" (jabber-jid-displayname group
) message
))))
940 (let* ((plist (jabber-muc-participant-plist group nickname
))
941 (jid (plist-get plist
'jid
))
942 (name (concat nickname
945 (jabber-jid-user jid
)
947 (jabber-muc-remove-participant group nickname
)
948 (with-current-buffer (jabber-muc-create-buffer jc group
)
949 (jabber-maybe-print-rare-time
954 ((equal status-code
"301")
955 (concat name
" has been banned"
956 (when actor
(concat " by " actor
))
957 (when reason
(concat " - '" reason
"'"))))
958 ((equal status-code
"307")
959 (concat name
" has been kicked"
960 (when actor
(concat " by " actor
))
961 (when reason
(concat " - '" reason
"'"))))
962 ((equal status-code
"303")
963 (concat name
" changes nickname to "
964 (jabber-xml-get-attribute item
'nick
)))
966 (concat name
" has left the chatroom")))
967 :time
(current-time))))))))
969 ;; someone is entering
971 (when (string= nickname
(gethash (jabber-jid-symbol group
) jabber-pending-groupchats
))
972 ;; Our own nick? We just succeeded in entering the room.
973 (let ((whichgroup (assoc group
*jabber-active-groupchats
*)))
975 (setcdr whichgroup nickname
)
976 (add-to-list '*jabber-active-groupchats
* (cons group nickname
)))))
978 ;; Whoever enters, we create a buffer (if it didn't already
979 ;; exist), and print a notice. This is where autojoined MUC
980 ;; rooms have buffers created for them. We also remember some
982 (let ((old-plist (jabber-muc-participant-plist group nickname
))
983 (new-plist (jabber-muc-parse-affiliation x-muc
)))
984 (jabber-muc-modify-participant group nickname new-plist
)
985 (let ((report (jabber-muc-report-delta nickname old-plist new-plist
988 (with-current-buffer (jabber-muc-create-buffer jc group
)
989 (jabber-maybe-print-rare-time
992 (list :muc-notice report
993 :time
(current-time))))))))))))
995 (provide 'jabber-muc
)
997 ;;; arch-tag: 1ff7ab35-1717-46ae-b803-6f5b3fb2cd7d