From 6d86bef0d030d8b99074936f7f41b91cb72e3b68 Mon Sep 17 00:00:00 2001
From: contrapunctus
Date: Wed, 13 Jul 2022 20:29:22 +0530
Subject: [PATCH 01/29] De-literate jabber.org using :old-file:
---
jabber-activity.el | 391 +
jabber-ahc-presence.el | 84 +
jabber-ahc.el | 210 +
jabber-alert.el | 490 ++
jabber-autoaway.el | 185 +
jabber-avatar.el | 190 +
jabber-bookmarks.el | 222 +
jabber-browse.el | 75 +
jabber-carbons.el | 20 +
jabber-chat.el | 692 ++
jabber-chatbuffer.el | 115 +
jabber-chatstates.el | 138 +
jabber-compose.el | 57 +
jabber-conn.el | 377 +
jabber-console.el | 122 +
jabber-core.el | 968 +++
jabber-disco.el | 634 ++
jabber-events.el | 208 +
jabber-export.el | 224 +
jabber-feature-neg.el | 97 +
jabber-history.el | 303 +
jabber-iq.el | 199 +
jabber-keepalive.el | 136 +
jabber-keymap.el | 33 +
jabber-legacy-socks5.el | 646 ++
jabber-logon.el | 59 +
jabber-menu.el | 175 +
jabber-modeline.el | 72 +
jabber-muc-nick-coloring.el | 57 +
jabber-muc-nick-completion.el | 157 +
jabber-muc.el | 1180 +++
jabber-ping.el | 42 +
jabber-presence.el | 554 ++
jabber-private.el | 38 +
jabber-register.el | 126 +
jabber-roster.el | 866 ++
jabber-rtt.el | 285 +
jabber-sasl.el | 139 +
jabber-search.el | 88 +
jabber-socks5.el | 646 ++
jabber-time.el | 196 +
jabber-truncate.el | 46 +
jabber-util.el | 719 ++
jabber-vcard-avatars.el | 113 +
jabber-vcard.el | 485 ++
jabber-version.el | 65 +
jabber-watch.el | 48 +
jabber-widget.el | 342 +
jabber-xml.el | 259 +
jabber.el | 14106 +-------------------------------
jabber.org | 100 +-
51 files changed, 13624 insertions(+), 14155 deletions(-)
create mode 100644 jabber-activity.el
create mode 100644 jabber-ahc-presence.el
create mode 100644 jabber-ahc.el
create mode 100644 jabber-alert.el
create mode 100644 jabber-autoaway.el
create mode 100644 jabber-avatar.el
create mode 100644 jabber-bookmarks.el
create mode 100644 jabber-browse.el
create mode 100644 jabber-carbons.el
create mode 100644 jabber-chat.el
create mode 100644 jabber-chatbuffer.el
create mode 100644 jabber-chatstates.el
create mode 100644 jabber-compose.el
create mode 100644 jabber-conn.el
create mode 100644 jabber-console.el
create mode 100644 jabber-core.el
create mode 100644 jabber-disco.el
create mode 100644 jabber-events.el
create mode 100644 jabber-export.el
create mode 100644 jabber-feature-neg.el
create mode 100644 jabber-history.el
create mode 100644 jabber-iq.el
create mode 100644 jabber-keepalive.el
create mode 100644 jabber-keymap.el
create mode 100644 jabber-legacy-socks5.el
create mode 100644 jabber-logon.el
create mode 100644 jabber-menu.el
create mode 100644 jabber-modeline.el
create mode 100644 jabber-muc-nick-coloring.el
create mode 100644 jabber-muc-nick-completion.el
create mode 100644 jabber-muc.el
create mode 100644 jabber-ping.el
create mode 100644 jabber-presence.el
create mode 100644 jabber-private.el
create mode 100644 jabber-register.el
create mode 100644 jabber-roster.el
create mode 100644 jabber-rtt.el
create mode 100644 jabber-sasl.el
create mode 100644 jabber-search.el
create mode 100644 jabber-socks5.el
create mode 100644 jabber-time.el
create mode 100644 jabber-truncate.el
create mode 100644 jabber-util.el
create mode 100644 jabber-vcard-avatars.el
create mode 100644 jabber-vcard.el
create mode 100644 jabber-version.el
create mode 100644 jabber-watch.el
create mode 100644 jabber-widget.el
create mode 100644 jabber-xml.el
diff --git a/jabber-activity.el b/jabber-activity.el
new file mode 100644
index 0000000..9cf2285
--- /dev/null
+++ b/jabber-activity.el
@@ -0,0 +1,391 @@
+(defgroup jabber-activity nil
+ "Activity tracking options."
+ :group 'jabber)
+
+(defcustom jabber-activity-make-string 'jabber-activity-make-string-default
+ "Function to call to show a string in the modeline.
+Function to call, for making the string to put in the mode
+line. The default function returns the nick of the user."
+ :set #'(lambda (var val)
+ (custom-set-default var val)
+ (when (and (featurep 'jabber-activity)
+ (fboundp 'jabber-activity-make-name-alist))
+ (jabber-activity-make-name-alist)
+ (jabber-activity-mode-line-update)))
+ :type 'function
+ :group 'jabber-activity)
+
+(defcustom jabber-activity-shorten-minimum 1
+ "Length of the strings returned by `jabber-activity-make-strings-shorten'.
+All strings returned by `jabber-activity-make-strings-shorten' will be
+at least this long, when possible."
+ :group 'jabber-activity
+ :type 'number)
+
+(defcustom jabber-activity-make-strings 'jabber-activity-make-strings-default
+ "Function which should return an alist of JID -> string given a list of JIDs."
+ :set #'(lambda (var val)
+ (custom-set-default var val)
+ (when (and (featurep 'jabber-activity)
+ (fboundp 'jabber-activity-make-name-alist))
+ (jabber-activity-make-name-alist)
+ (jabber-activity-mode-line-update)))
+ :type '(choice (function-item :tag "Keep strings"
+ :value jabber-activity-make-strings-default)
+ (function-item :tag "Shorten strings"
+ :value jabber-activity-make-strings-shorten)
+ (function :tag "Other function"))
+ :group 'jabber-activity)
+
+(defcustom jabber-activity-count-in-title nil
+ "If non-nil, display number of active JIDs in frame title."
+ :type 'boolean
+ :group 'jabber-activity
+ :set #'(lambda (var val)
+ (custom-set-default var val)
+ (when (and (featurep 'jabber-activity)
+ (bound-and-true-p jabber-activity-mode))
+ (jabber-activity-mode -1)
+ (jabber-activity-mode 1))))
+
+(defcustom jabber-activity-count-in-title-format
+ '(jabber-activity-jids ("[" jabber-activity-count-string "] "))
+ "Format string used for displaying activity in frame titles.
+Same syntax as `mode-line-format'."
+ :type 'sexp
+ :group 'jabber-activity
+ :set #'(lambda (var val)
+ (if (not (and (featurep 'jabber-activity) (bound-and-true-p jabber-activity-mode)))
+ (custom-set-default var val)
+ (jabber-activity-mode -1)
+ (custom-set-default var val)
+ (jabber-activity-mode 1))))
+
+(defcustom jabber-activity-show-p 'jabber-activity-show-p-default
+ "Function that checks if the given JID should be shown on the mode line.
+Predicate function to call to check if the given JID should be
+shown in the mode line or not."
+ :type 'function
+ :group 'jabber-activity)
+
+(defcustom jabber-activity-query-unread t
+ "Cancel Emacs killing when there are unread messages?
+Query the user as to whether killing Emacs should be cancelled when
+there are unread messages which otherwise would be lost."
+ :type 'boolean
+ :group 'jabber-activity)
+
+(defcustom jabber-activity-banned nil
+ "List of regexps of banned JID."
+ :type '(repeat string)
+ :group 'jabber-activity)
+
+(defface jabber-activity-face
+ '((t (:foreground "red" :weight bold)))
+ "The face for displaying jabber-activity-string in the mode line."
+ :group 'jabber-activity)
+
+(defface jabber-activity-personal-face
+ '((t (:foreground "blue" :weight bold)))
+ "The face for displaying personal jabber-activity-string in the mode line."
+ :group 'jabber-activity)
+
+(defvar jabber-activity-jids nil
+ "A list of JIDs which have caused activity.")
+
+(defvar jabber-activity-personal-jids nil
+ "Subset of `jabber-activity-jids' for JIDs with \"personal\" activity.")
+
+(defvar jabber-activity-name-alist nil
+ "Alist of mode line names for bare JIDs.")
+
+(defvar jabber-activity-mode-string ""
+ "The mode string for jabber activity.")
+
+(defvar jabber-activity-count-string "0"
+ "Number of active JIDs as a string.")
+
+(defvar jabber-activity-update-hook nil
+ "Hook called when `jabber-activity-jids' changes.
+It is called after `jabber-activity-mode-string' and
+`jabber-activity-count-string' are updated.")
+
+;; Protect this variable from being set in Local variables etc.
+(put 'jabber-activity-mode-string 'risky-local-variable t)
+(put 'jabber-activity-count-string 'risky-local-variable t)
+
+(defun jabber-activity-make-string-default (jid)
+ "Return the nick of the JID.
+If no nick is available, return
+the user name part of the JID. In private MUC conversations,
+return the user's nickname."
+ (if (jabber-muc-sender-p jid)
+ (jabber-jid-resource jid)
+ (let ((nick (jabber-jid-displayname jid))
+ (user (jabber-jid-user jid))
+ (username (jabber-jid-username jid)))
+ (if (and username (string= nick user))
+ username
+ nick))))
+
+(defun jabber-activity-make-strings-default (jids)
+ "Apply `jabber-activity-make-string' on JIDS."
+ (mapcar #'(lambda (jid) (cons jid (funcall jabber-activity-make-string jid)))
+ jids))
+
+(defun jabber-activity-common-prefix (s1 s2)
+ "Return length of common prefix string shared by S1 and S2."
+ (let ((len (min (length s1) (length s2))))
+ (or (dotimes (i len)
+ (when (not (eq (aref s1 i) (aref s2 i)))
+ (cl-return i)))
+ ;; Substrings, equal, nil, or empty ("")
+ len)))
+
+(defun jabber-activity-make-strings-shorten (jids)
+ "Return an alist of (JID . short-names).
+Return an alist of JID -> names acquired by running
+`jabber-activity-make-string' on JIDS, and then shortening the names
+as much as possible such that all strings still are unique and at
+least `jabber-activity-shorten-minimum' long."
+ (let ((alist
+ (sort (mapcar
+ #'(lambda (x) (cons x (funcall jabber-activity-make-string x)))
+ jids)
+ #'(lambda (x y) (string-lessp (cdr x) (cdr y))))))
+ (cl-loop for ((prev-jid . prev) (cur-jid . cur) (next-jid . next))
+ on (cons nil alist)
+ until (null cur)
+ collect
+ (cons
+ cur-jid
+ (substring
+ cur
+ 0 (min (length cur)
+ (max jabber-activity-shorten-minimum
+ (1+ (jabber-activity-common-prefix cur prev))
+ (1+ (jabber-activity-common-prefix cur next)))))))))
+
+(defun jabber-activity-find-buffer-name (jid)
+ "Find the name of the buffer that messages from JID would use."
+ (or (and (jabber-jid-resource jid)
+ (get-buffer (jabber-muc-private-get-buffer
+ (jabber-jid-user jid)
+ (jabber-jid-resource jid))))
+ (get-buffer (jabber-chat-get-buffer jid))
+ (get-buffer (jabber-muc-get-buffer jid))))
+
+(defun jabber-activity-show-p-default (jid)
+ "Return t only if there is an invisible buffer for JID.
+And, JID is not in `jabber-activity-banned'."
+ (let ((buffer (jabber-activity-find-buffer-name jid)))
+ (and (buffer-live-p buffer)
+ (not (get-buffer-window buffer 'visible))
+ (not (dolist (entry jabber-activity-banned)
+ (when (string-match entry jid)
+ (cl-return t)))))))
+
+(defun jabber-activity-make-name-alist ()
+ "Rebuild `jabber-activity-name-alist' based on currently known JIDs."
+ (let ((jids (or (mapcar #'car jabber-activity-name-alist)
+ (mapcar #'symbol-name *jabber-roster*))))
+ (setq jabber-activity-name-alist
+ (funcall jabber-activity-make-strings jids))))
+
+(defun jabber-activity-lookup-name (jid)
+ "Lookup name in `jabber-activity-name-alist' and return (jid . string).
+Lookup name in `jabber-activity-name-alist', creates an entry
+if needed, and returns a (jid . string) pair suitable for the mode line"
+ (let ((elm (assoc jid jabber-activity-name-alist)))
+ (if elm
+ elm
+ (progn
+ ;; Remake alist with the new JID
+ (setq jabber-activity-name-alist
+ (funcall jabber-activity-make-strings
+ (cons jid (mapcar #'car jabber-activity-name-alist))))
+ (jabber-activity-lookup-name jid)))))
+
+(defun jabber-activity-mode-line-update ()
+ "Update the string shown in the mode line using `jabber-activity-make-string'.
+Update the string shown in the mode line using `jabber-activity-make-string'
+on JIDs where `jabber-activity-show-p'. Optional not-nil GROUP mean that
+message come from MUC.
+Optional TEXT used with one-to-one or MUC chats and may be used to identify
+personal MUC message.
+Optional PRESENCE mean personal presence request or alert."
+ (setq jabber-activity-mode-string
+ (if jabber-activity-jids
+ (mapconcat
+ (lambda (x)
+ (let ((jump-to-jid (car x)))
+ (jabber-propertize
+ (cdr x)
+ 'face (if (member jump-to-jid jabber-activity-personal-jids)
+ 'jabber-activity-personal-face
+ 'jabber-activity-face)
+ ;; XXX: XEmacs doesn't have make-mode-line-mouse-map.
+ ;; Is there another way to make this work?
+ 'local-map (when (fboundp 'make-mode-line-mouse-map)
+ (make-mode-line-mouse-map
+ 'mouse-1 `(lambda ()
+ (interactive "@")
+ (jabber-activity-switch-to
+ ,(car x)))))
+ 'help-echo (concat "Jump to "
+ (jabber-jid-displayname (car x))
+ "'s buffer"))))
+ (mapcar #'jabber-activity-lookup-name
+ jabber-activity-jids)
+ ",")
+ ""))
+ (setq jabber-activity-count-string
+ (number-to-string (length jabber-activity-jids)))
+ (force-mode-line-update 'all)
+ (run-hooks 'jabber-activity-update-hook))
+
+(defun jabber-activity-clean ()
+ "Remove JIDs where `jabber-activity-show-p' no longer is true."
+ (setq jabber-activity-jids (cl-delete-if-not jabber-activity-show-p
+ jabber-activity-jids))
+ (setq jabber-activity-personal-jids
+ (cl-delete-if-not jabber-activity-show-p
+ jabber-activity-personal-jids))
+ (jabber-activity-mode-line-update))
+
+(defun jabber-activity-add (from buffer text proposed-alert)
+ "Add a JID to mode line when `jabber-activity-show-p'."
+ (when (funcall jabber-activity-show-p from)
+ (add-to-list 'jabber-activity-jids from)
+ (add-to-list 'jabber-activity-personal-jids from)
+ (jabber-activity-mode-line-update)))
+
+(defun jabber-activity-add-muc (nick group buffer text proposed-alert)
+ "Add a JID to mode line when `jabber-activity-show-p'."
+ (when (funcall jabber-activity-show-p group)
+ (add-to-list 'jabber-activity-jids group)
+ (when (jabber-muc-looks-like-personal-p text group)
+ (add-to-list 'jabber-activity-personal-jids group))
+ (jabber-activity-mode-line-update)))
+
+(defun jabber-activity-presence (who oldstatus newstatus statustext proposed-alert)
+ "Add a JID to mode line on subscription requests."
+ (when (string= newstatus "subscribe")
+ (add-to-list 'jabber-activity-jids (symbol-name who))
+ (add-to-list 'jabber-activity-personal-jids (symbol-name who))
+ (jabber-activity-mode-line-update)))
+
+(defun jabber-activity-kill-hook ()
+ "Query the user if is sure to kill Emacs when there are unread messages.
+Query the user as to whether killing Emacs should be cancelled
+when there are unread messages which otherwise would be lost, if
+`jabber-activity-query-unread' is t"
+ (if (and jabber-activity-jids
+ jabber-activity-query-unread)
+ (or jabber-silent-mode (yes-or-no-p
+ "You have unread Jabber messages, are you sure you want to quit?"))
+ t))
+
+(defvar jabber-activity-last-buffer nil
+ "Last non-Jabber buffer used.")
+
+(defun jabber-activity-switch-to (&optional jid-param)
+ "If JID-PARAM is provided, switch to that buffer.
+If JID-PARAM is nil and
+there has been activity in another buffer, switch to that buffer. If no such
+buffer exists, switch back to the last non Jabber chat buffer used."
+ (interactive)
+ (if (or jid-param jabber-activity-jids)
+ (let ((jid (or jid-param (car jabber-activity-jids))))
+ (unless (eq major-mode 'jabber-chat-mode)
+ (setq jabber-activity-last-buffer (current-buffer)))
+ (switch-to-buffer (jabber-activity-find-buffer-name jid))
+ (jabber-activity-clean))
+ (if (eq major-mode 'jabber-chat-mode)
+ ;; Switch back to the buffer used last
+ (when (buffer-live-p jabber-activity-last-buffer)
+ (switch-to-buffer jabber-activity-last-buffer))
+ (message "No new activity"))))
+
+(defvar jabber-activity-idle-timer nil "Idle timer used for activity cleaning.")
+
+;;;###autoload
+(define-minor-mode jabber-activity-mode
+ "Toggle display of activity in hidden jabber buffers in the mode line.
+
+With a numeric arg, enable this display if arg is positive."
+ :global t
+ :group 'jabber-activity
+ :init-value t
+ (if jabber-activity-mode
+ (progn
+ ;; XEmacs compatibilty hack from erc-track
+ (if (featurep 'xemacs)
+ (defadvice switch-to-buffer (after jabber-activity-update (&rest args) activate)
+ (jabber-activity-clean))
+ (add-hook 'window-configuration-change-hook
+ 'jabber-activity-clean))
+ (add-hook 'jabber-message-hooks
+ 'jabber-activity-add)
+ (add-hook 'jabber-muc-hooks
+ 'jabber-activity-add-muc)
+ (add-hook 'jabber-presence-hooks
+ 'jabber-activity-presence)
+ (setq jabber-activity-idle-timer (run-with-idle-timer 2 t 'jabber-activity-clean))
+ ;; XXX: reactivate
+ ;; (add-hook 'jabber-post-connect-hooks
+;; 'jabber-activity-make-name-alist)
+ (add-to-list 'kill-emacs-query-functions
+ 'jabber-activity-kill-hook)
+ (add-to-list 'global-mode-string
+ '(t jabber-activity-mode-string))
+ (when jabber-activity-count-in-title
+ ;; Be careful not to override specific meanings of the
+ ;; existing title format. In particular, if the car is
+ ;; a symbol, we can't just add our stuff at the beginning.
+ ;; If the car is "", we should be safe.
+ ;;
+ ;; In my experience, sometimes the activity count gets
+ ;; included twice in the title. I'm not sure exactly why,
+ ;; but it would be nice to replace the code below with
+ ;; something cleaner.
+ (if (equal (car-safe frame-title-format) "")
+ (add-to-list 'frame-title-format
+ jabber-activity-count-in-title-format)
+ (setq frame-title-format (list ""
+ jabber-activity-count-in-title-format
+ frame-title-format)))
+ (if (equal (car-safe icon-title-format) "")
+ (add-to-list 'icon-title-format
+ jabber-activity-count-in-title-format)
+ (setq icon-title-format (list ""
+ jabber-activity-count-in-title-format
+ icon-title-format)))))
+ (progn
+ (if (featurep 'xemacs)
+ (ad-disable-advice 'switch-to-buffer 'after 'jabber-activity-update)
+ (remove-hook 'window-configuration-change-hook
+ 'jabber-activity-remove-visible))
+ (remove-hook 'jabber-message-hooks
+ 'jabber-activity-add)
+ (remove-hook 'jabber-muc-hooks
+ 'jabber-activity-add-muc)
+ (remove-hook 'jabber-presence-hooks
+ 'jabber-activity-presence)
+ (ignore-errors (cancel-timer jabber-activity-idle-timer))
+ ;; XXX: reactivate
+;; (remove-hook 'jabber-post-connect-hooks
+;; 'jabber-activity-make-name-alist)
+ (setq global-mode-string (delete '(t jabber-activity-mode-string)
+ global-mode-string))
+ (when (listp frame-title-format)
+ (setq frame-title-format
+ (delete jabber-activity-count-in-title-format
+ frame-title-format)))
+ (when (listp icon-title-format)
+ (setq icon-title-format
+ (delete jabber-activity-count-in-title-format
+ icon-title-format))))))
+
+;; XXX: define-minor-mode should probably do this for us, but it doesn't.
+(if jabber-activity-mode (jabber-activity-mode 1))
diff --git a/jabber-ahc-presence.el b/jabber-ahc-presence.el
new file mode 100644
index 0000000..c076898
--- /dev/null
+++ b/jabber-ahc-presence.el
@@ -0,0 +1,84 @@
+(defconst jabber-ahc-presence-node "http://jabber.org/protocol/rc#set-status"
+ "Node used by function `jabber-ahc-presence'.")
+
+(jabber-ahc-add jabber-ahc-presence-node "Set presence" 'jabber-ahc-presence
+ 'jabber-my-jid-p)
+
+(defun jabber-ahc-presence (jc xml-data)
+ "Process presence change command.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+
+ (let* ((query (jabber-iq-query xml-data))
+ (sessionid (jabber-xml-get-attribute query 'sessionid))
+ (action (jabber-xml-get-attribute query 'action)))
+ ;; No session state is kept; instead, lack of session-id is used
+ ;; as indication of first command.
+ (cond
+ ;; command cancelled
+ ((string= action "cancel")
+ `(command ((xmlns . "http://jabber.org/protocol/commands")
+ (sessionid . ,sessionid)
+ (node . ,jabber-ahc-presence-node)
+ (status . "canceled"))))
+ ;; return form
+ ((null sessionid)
+ `(command ((xmlns . "http://jabber.org/protocol/commands")
+ (sessionid . "jabber-ahc-presence")
+ (node . ,jabber-ahc-presence-node)
+ (status . "executing"))
+ (x ((xmlns . "jabber:x:data")
+ (type . "form"))
+ (title nil ,(format "Set presence of %s" (jabber-connection-jid jc)))
+ (instructions nil "Select new presence status.")
+ (field ((var . "FORM_TYPE") (type . "hidden"))
+ (value nil "http://jabber.org/protocol/rc"))
+ (field ((var . "status")
+ (label . "Status")
+ (type . "list-single"))
+ (value nil ,(if (string= *jabber-current-show* "")
+ "online"
+ *jabber-current-show*))
+ (option ((label . "Online")) (value nil "online"))
+ (option ((label . "Chatty")) (value nil "chat"))
+ (option ((label . "Away")) (value nil "away"))
+ (option ((label . "Extended away")) (value nil "xa"))
+ (option ((label . "Do not disturb")) (value nil "dnd")))
+ (field ((var . "status-message")
+ (label . "Message")
+ (type . "text-single"))
+ (value nil ,*jabber-current-status*))
+ (field ((var . "status-priority")
+ (label . "Priority")
+ (type . "text-single"))
+ (value nil ,(int-to-string *jabber-current-priority*))))))
+ ;; process form
+ (t
+ (let* ((x (car (jabber-xml-get-children query 'x)))
+ ;; we assume that the first is the jabber:x:data one
+ (fields (jabber-xml-get-children x 'field))
+ (new-show *jabber-current-show*)
+ (new-status *jabber-current-status*)
+ (new-priority *jabber-current-priority*))
+ (dolist (field fields)
+ (let ((var (jabber-xml-get-attribute field 'var))
+ ;; notice that multi-value fields won't be handled properly
+ ;; by this
+ (value (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value))))))
+ (cond
+ ((string= var "status")
+ (setq new-show (if (string= value "online")
+ ""
+ value)))
+ ((string= var "status-message")
+ (setq new-status value))
+ ((string= var "status-priority")
+ (setq new-priority (string-to-number value))))))
+ (jabber-send-presence new-show new-status new-priority))
+ `(command ((xmlns . "http://jabber.org/protocol/commands")
+ (sessionid . ,sessionid)
+ (node . ,jabber-ahc-presence-node)
+ (status . "completed"))
+ (note ((type . "info")) "Presence has been changed."))))))
diff --git a/jabber-ahc.el b/jabber-ahc.el
new file mode 100644
index 0000000..a041d23
--- /dev/null
+++ b/jabber-ahc.el
@@ -0,0 +1,210 @@
+(defvar jabber-ahc-sessionid nil
+ "Session ID of Ad-Hoc Command session.")
+
+(defvar jabber-ahc-node nil
+ "Node to send commands to.")
+
+(defvar jabber-ahc-commands nil
+ "Commands provided.
+
+This is an alist, where the keys are node names as strings (which
+means that they must not conflict). The values are plists having
+following properties:
+
+acl - function taking connection object and JID of requester,
+ returning non-nil for access allowed. No function means
+ open for everyone.
+name - name of command
+func - function taking connection object and entire IQ stanza as
+ arguments and returning a node
+
+Use the function `jabber-ahc-add' to add a command to this list.")
+
+(add-to-list 'jabber-disco-info-nodes
+ (list "http://jabber.org/protocol/commands"
+ '((identity ((category . "automation")
+ (type . "command-list")
+ (name . "Ad-Hoc Command list")))
+ (feature ((var . "http://jabber.org/protocol/commands")))
+ (feature ((var . "http://jabber.org/protocol/disco#items")))
+ (feature
+ ((var . "http://jabber.org/protocol/disco#info"))))))
+
+(defun jabber-ahc-add (node name func acl)
+ "Add a command to internal lists.
+NODE is the node name to be used. It must be unique.
+NAME is the natural-language name of the command.
+FUNC is a function taking the entire IQ stanza as single argument when
+this command is invoked, and returns a node.
+ACL is a function taking JID as single argument, returning non-nil for
+access allowed. nil means open for everyone."
+ (add-to-list 'jabber-ahc-commands (cons node (list 'name name
+ 'func func
+ 'acl acl)))
+ (add-to-list 'jabber-disco-info-nodes
+ (list node `((identity ((category . "automation")
+ (type . "command-node")
+ (name . ,name)))
+ (feature ((var . "http://jabber.org/protocol/commands")))
+ (feature ((var . "http://jabber.org/protocol/disco#info")))
+ (feature ((var . "jabber:x:data")))))))
+
+(jabber-disco-advertise-feature "http://jabber.org/protocol/commands")
+(add-to-list 'jabber-disco-items-nodes
+ (list "http://jabber.org/protocol/commands" #'jabber-ahc-disco-items nil))
+(defun jabber-ahc-disco-items (jc xml-data)
+ "Return commands in response to disco#items request.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let ((jid (jabber-xml-get-attribute xml-data 'from)))
+ (mapcar (function
+ (lambda (command)
+ (let ((node (car command))
+ (plist (cdr command)))
+ (let ((acl (plist-get plist 'acl))
+ (name (plist-get plist 'name))
+ (func (plist-get plist 'func)))
+ (when (or (not (functionp acl))
+ (funcall acl jc jid))
+ `(item ((name . ,name)
+ (jid . ,(jabber-connection-jid jc))
+ (node . ,node))))))))
+ jabber-ahc-commands)))
+
+(add-to-list 'jabber-iq-set-xmlns-alist
+ (cons "http://jabber.org/protocol/commands" 'jabber-ahc-process))
+(defun jabber-ahc-process (jc xml-data)
+
+ (let ((to (jabber-xml-get-attribute xml-data 'from))
+ (id (jabber-xml-get-attribute xml-data 'id))
+ (node (jabber-xml-get-attribute (jabber-iq-query xml-data) 'node)))
+ ;; find command
+ (let* ((plist (cdr (assoc node jabber-ahc-commands)))
+ (acl (plist-get plist 'acl))
+ (func (plist-get plist 'func)))
+ (if plist
+ ;; found
+ (if (or (not (functionp acl))
+ (funcall acl jc to))
+ ;; access control passed
+ (jabber-send-iq jc to "result"
+ (funcall func jc xml-data)
+ nil nil nil nil id)
+ ;; ...or failed
+ (jabber-signal-error "Cancel" 'not-allowed))
+ ;; No such node
+ (jabber-signal-error "Cancel" 'item-not-found)))))
+
+(add-to-list 'jabber-jid-service-menu
+ (cons "Request command list" 'jabber-ahc-get-list))
+(defun jabber-ahc-get-list (jc to)
+ "Request list of ad-hoc commands.
+
+See XEP-0050.
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "Request command list from: " nil nil nil nil nil)))
+ (jabber-get-disco-items jc to "http://jabber.org/protocol/commands"))
+
+(add-to-list 'jabber-jid-service-menu
+ (cons "Execute command" 'jabber-ahc-execute-command))
+(defun jabber-ahc-execute-command (jc to node)
+ "Execute ad-hoc command.
+
+See XEP-0050.
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "Execute command of: " nil nil nil nil nil)
+ (jabber-read-node "Node of command: ")))
+ (jabber-send-iq jc to
+ "set"
+ `(command ((xmlns . "http://jabber.org/protocol/commands")
+ (node . ,node)
+ (action . "execute")))
+ #'jabber-process-data #'jabber-ahc-display
+ #'jabber-process-data "Command execution failed"))
+
+(defun jabber-ahc-display (jc xml-data)
+ (let* ((from (jabber-xml-get-attribute xml-data 'from))
+ (query (jabber-iq-query xml-data))
+ (node (jabber-xml-get-attribute query 'node))
+ (notes (jabber-xml-get-children query 'note))
+ (sessionid (jabber-xml-get-attribute query 'sessionid))
+ (status (jabber-xml-get-attribute query 'status))
+ (actions (car (jabber-xml-get-children query 'actions)))
+ xdata
+ (inhibit-read-only t))
+
+ (make-local-variable 'jabber-ahc-sessionid)
+ (setq jabber-ahc-sessionid sessionid)
+ (make-local-variable 'jabber-ahc-node)
+ (setq jabber-ahc-node node)
+ (make-local-variable 'jabber-buffer-connection)
+ (setq jabber-buffer-connection jc)
+
+ (dolist (x (jabber-xml-get-children query 'x))
+ (when (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data")
+ (setq xdata x)))
+
+ (cond
+ ((string= status "executing")
+ (insert "Executing command\n\n"))
+ ((string= status "completed")
+ (insert "Command completed\n\n"))
+ ((string= status "canceled")
+ (insert "Command canceled\n\n")))
+
+ (dolist (note notes)
+ (let ((note-type (jabber-xml-get-attribute note 'type)))
+ (cond
+ ((string= note-type "warn")
+ (insert "Warning: "))
+ ((string= note-type "error")
+ (insert "Error: ")))
+ (insert (car (jabber-xml-node-children note)) "\n")))
+ (insert "\n")
+
+ (when xdata
+ (jabber-init-widget-buffer from)
+
+ (let ((formtype (jabber-xml-get-attribute xdata 'type)))
+ (if (string= formtype "result")
+ (jabber-render-xdata-search-results xdata)
+ (jabber-render-xdata-form xdata)
+
+ (when (string= status "executing")
+ (let ((button-titles
+ (cond
+ ((null actions)
+ '(complete cancel))
+ (t
+ (let ((children (mapcar #'jabber-xml-node-name (jabber-xml-node-children actions)))
+ (default-action (jabber-xml-get-attribute actions 'execute)))
+ (if (or (null default-action) (memq (intern default-action) children))
+ children
+ (cons (intern default-action) children)))))))
+ (dolist (button-title button-titles)
+ (widget-create 'push-button :notify `(lambda (&rest ignore) (jabber-ahc-submit (quote ,button-title))) (symbol-name button-title))
+ (widget-insert "\t")))
+ (widget-insert "\n"))))
+
+ (widget-setup)
+ (widget-minor-mode 1))))
+
+(defun jabber-ahc-submit (action)
+ "Submit Ad-Hoc Command."
+
+ (jabber-send-iq jabber-buffer-connection jabber-submit-to
+ "set"
+ `(command ((xmlns . "http://jabber.org/protocol/commands")
+ (sessionid . ,jabber-ahc-sessionid)
+ (node . ,jabber-ahc-node)
+ (action . ,(symbol-name action)))
+ ,(if (and (not (eq action 'cancel))
+ (eq jabber-form-type 'xdata))
+ (jabber-parse-xdata-form)))
+
+ #'jabber-process-data #'jabber-ahc-display
+ #'jabber-process-data "Command execution failed"))
diff --git a/jabber-alert.el b/jabber-alert.el
new file mode 100644
index 0000000..eb8d457
--- /dev/null
+++ b/jabber-alert.el
@@ -0,0 +1,490 @@
+(defgroup jabber-alerts nil "auditory and visual alerts for jabber events"
+ :group 'jabber)
+
+(defcustom jabber-alert-message-hooks '(jabber-message-echo
+ jabber-message-scroll)
+ "Hooks run when a new message arrives.
+
+Arguments are FROM, BUFFER, TEXT and TITLE. FROM is the JID of
+the sender, BUFFER is the the buffer where the message can be
+read, and TEXT is the text of the message. TITLE is the string
+returned by `jabber-alert-message-function' for these arguments,
+so that hooks do not have to call it themselves.
+
+This hook is meant for user customization of message alerts. For
+other uses, see `jabber-message-hooks'."
+ :type 'hook
+ :options '(jabber-message-beep
+ jabber-message-wave
+ jabber-message-echo
+ jabber-message-switch
+ jabber-message-display
+ jabber-message-scroll)
+ :group 'jabber-alerts)
+
+(defvar jabber-message-hooks nil
+ "Internal hooks run when a new message arrives.
+
+This hook works just like `jabber-alert-message-hooks', except that
+it's not meant to be customized by the user.")
+
+(defcustom jabber-alert-message-function
+ 'jabber-message-default-message
+ "Function for constructing short message alert messages.
+
+Arguments are FROM, BUFFER, and TEXT. This function should return a
+string containing an appropriate text message, or nil if no message
+should be displayed.
+
+The provided hooks displaying a text message get it from this function,
+and show no message if it returns nil. Other hooks do what they do
+every time."
+ :type 'function
+ :group 'jabber-alerts)
+
+(defcustom jabber-alert-muc-hooks '(jabber-muc-echo jabber-muc-scroll)
+ "Hooks run when a new MUC message arrives.
+
+Arguments are NICK, GROUP, BUFFER, TEXT and TITLE. NICK is the
+nickname of the sender. GROUP is the JID of the group. BUFFER
+is the the buffer where the message can be read, and TEXT is the
+text of the message. TITLE is the string returned by
+`jabber-alert-muc-function' for these arguments, so that hooks do
+not have to call it themselves."
+ :type 'hook
+ :options '(jabber-muc-beep
+ jabber-muc-wave
+ jabber-muc-echo
+ jabber-muc-switch
+ jabber-muc-display
+ jabber-muc-scroll)
+ :group 'jabber-alerts)
+
+(defvar jabber-muc-hooks '()
+ "Internal hooks run when a new MUC message arrives.
+
+This hook works just like `jabber-alert-muc-hooks', except that
+it's not meant to be customized by the user.")
+
+(defcustom jabber-alert-muc-function
+ 'jabber-muc-default-message
+ "Function for constructing short message alert messages.
+
+Arguments are NICK, GROUP, BUFFER, and TEXT. This function
+should return a string containing an appropriate text message, or
+nil if no message should be displayed.
+
+The provided hooks displaying a text message get it from this function,
+and show no message if it returns nil. Other hooks do what they do
+every time."
+ :type 'function
+ :group 'jabber-alerts)
+
+(defcustom jabber-alert-presence-hooks
+ '(jabber-presence-echo)
+ "Hooks run when a user's presence changes.
+
+Arguments are WHO, OLDSTATUS, NEWSTATUS, STATUSTEXT and
+PROPOSED-ALERT. WHO is a symbol whose text is the JID of the contact,
+and which has various interesting properties. OLDSTATUS is the old
+presence or nil if disconnected. NEWSTATUS is the new presence, or
+one of \"subscribe\", \"unsubscribe\", \"subscribed\" and
+\"unsubscribed\". TITLE is the string returned by
+`jabber-alert-presence-message-function' for these arguments."
+ :type 'hook
+ :options '(jabber-presence-beep
+ jabber-presence-wave
+ jabber-presence-switch
+ jabber-presence-display
+ jabber-presence-echo)
+ :group 'jabber-alerts)
+
+(defvar jabber-presence-hooks '(jabber-presence-watch)
+ "Internal hooks run when a user's presence changes.
+
+This hook works just like `jabber-alert-presence-hooks', except that
+it's not meant to be customized by the user.")
+
+(defcustom jabber-alert-presence-message-function
+ 'jabber-presence-default-message
+ "Function for constructing title of presence alert messages.
+
+Arguments are WHO, OLDSTATUS, NEWSTATUS and STATUSTEXT. See
+`jabber-alert-presence-hooks' for documentation. This function
+should return a string containing an appropriate text message, or nil
+if no message should be displayed.
+
+The provided hooks displaying a text message get it from this function.
+All hooks refrain from action if this function returns nil."
+ :type 'function
+ :group 'jabber-alerts)
+
+(defcustom jabber-alert-info-message-hooks '(jabber-info-display jabber-info-echo)
+ "Hooks run when an info request is completed.
+
+First argument is WHAT, a symbol telling the kind of info request completed.
+That might be 'roster, for requested roster updates, and 'browse, for
+browse requests. Second argument in BUFFER, a buffer containing the result.
+Third argument is PROPOSED-ALERT, containing the string returned by
+`jabber-alert-info-message-function' for these arguments."
+ :type 'hook
+ :options '(jabber-info-beep
+ jabber-info-wave
+ jabber-info-echo
+ jabber-info-switch
+ jabber-info-display)
+ :group 'jabber-alerts)
+
+(defvar jabber-info-message-hooks '()
+ "Internal hooks run when an info request is completed.
+
+This hook works just like `jabber-alert-info-message-hooks',
+except that it's not meant to be customized by the user.")
+
+(defcustom jabber-alert-info-message-function
+ 'jabber-info-default-message
+ "Function for constructing info alert messages.
+
+Arguments are WHAT, a symbol telling the kind of info request completed,
+and BUFFER, a buffer containing the result."
+ :type 'function
+ :group 'jabber-alerts)
+
+(defcustom jabber-info-message-alist
+ '((roster . "Roster display updated")
+ (browse . "Browse request completed"))
+ "Alist for info alert messages, used by `jabber-info-default-message'."
+ :type '(alist :key-type symbol :value-type string
+ :options (roster browse))
+ :group 'jabber-alerts)
+
+(defcustom jabber-alert-message-wave ""
+ "A sound file to play when a message arrived.
+See `jabber-alert-message-wave-alist' if you want other sounds
+for specific contacts."
+ :type 'file
+ :group 'jabber-alerts)
+
+(defcustom jabber-alert-message-wave-alist nil
+ "Specific sound files for messages from specific contacts.
+The keys are regexps matching the JID, and the values are sound
+files."
+ :type '(alist :key-type regexp :value-type file)
+ :group 'jabber-alerts)
+
+(defcustom jabber-alert-muc-wave ""
+ "A sound file to play when a MUC message arrived."
+ :type 'file
+ :group 'jabber-alerts)
+
+(defcustom jabber-alert-presence-wave ""
+ "A sound file to play when a presence arrived."
+ :type 'file
+ :group 'jabber-alerts)
+
+(defcustom jabber-alert-presence-wave-alist nil
+ "Specific sound files for presence from specific contacts.
+The keys are regexps matching the JID, and the values are sound
+files."
+ :type '(alist :key-type regexp :value-type file)
+ :group 'jabber-alerts)
+
+(defcustom jabber-alert-info-wave ""
+ "A sound file to play when an info query result arrived."
+ :type 'file
+ :group 'jabber-alerts)
+
+(defcustom jabber-play-sound-file 'play-sound-file
+ "A function to call to play alert sound files."
+ :type 'function
+ :group 'jabber-alerts)
+
+(defmacro define-jabber-alert (name docstring function)
+ "Define a new family of external alert hooks.
+Use this macro when your hooks do nothing except displaying a string
+in some new innovative way. You write a string display function, and
+this macro does all the boring and repetitive work.
+
+NAME is the name of the alert family. The resulting hooks will be
+called jabber-{message,muc,presence,info}-NAME.
+DOCSTRING is the docstring to use for those hooks.
+FUNCTION is a function that takes one argument, a string,
+and displays it in some meaningful way. It can be either a
+lambda form or a quoted function name.
+The created functions are inserted as options in Customize.
+
+Examples:
+\(define-jabber-alert foo \"Send foo alert\" 'foo-message)
+\(define-jabber-alert bar \"Send bar alert\"
+ (lambda (msg) (bar msg 42)))"
+ (let ((sn (symbol-name name)))
+ (let ((msg (intern (format "jabber-message-%s" sn)))
+ (muc (intern (format "jabber-muc-%s" sn)))
+ (pres (intern (format "jabber-presence-%s" sn)))
+ (info (intern (format "jabber-info-%s" sn))))
+ `(progn
+ (defun ,msg (from buffer text title)
+ ,docstring
+ (when title
+ (funcall ,function text title)))
+ (cl-pushnew (quote ,msg) (get 'jabber-alert-message-hooks 'custom-options))
+ (defun ,muc (nick group buffer text title)
+ ,docstring
+ (when title
+ (funcall ,function text title)))
+ (cl-pushnew (quote ,muc) (get 'jabber-alert-muc-hooks 'custom-options))
+ (defun ,pres (who oldstatus newstatus statustext title)
+ ,docstring
+ (when title
+ (funcall ,function statustext title)))
+ (cl-pushnew (quote ,pres) (get 'jabber-alert-presence-hooks 'custom-options))
+ (defun ,info (infotype buffer text)
+ ,docstring
+ (when text
+ (funcall ,function text)))
+ (cl-pushnew (quote ,info) (get 'jabber-alert-info-message-hooks 'custom-options))))))
+
+;; Alert hooks
+(define-jabber-alert echo "Show a message in the echo area"
+ (lambda (text &optional title) (message "%s" (or title text))))
+(define-jabber-alert beep "Beep on event"
+ (lambda (&rest _ignore) (beep)))
+
+;; Message alert hooks
+(defun jabber-message-default-message (from buffer text)
+ (when (or jabber-message-alert-same-buffer
+ (not (memq (selected-window) (get-buffer-window-list buffer))))
+ (if (jabber-muc-sender-p from)
+ (format "Private message from %s in %s"
+ (jabber-jid-resource from)
+ (jabber-jid-displayname (jabber-jid-user from)))
+ (format "Message from %s" (jabber-jid-displayname from)))))
+
+(defcustom jabber-message-alert-same-buffer t
+ "If nil, don't display message alerts for the current buffer."
+ :type 'boolean
+ :group 'jabber-alerts)
+
+(defcustom jabber-muc-alert-self nil
+ "If nil, don't display MUC alerts for your own messages."
+ :type 'boolean
+ :group 'jabber-alerts)
+
+(defun jabber-message-wave (from buffer text title)
+ "Play the wave file specified in `jabber-alert-message-wave'."
+ (when title
+ (let* ((case-fold-search t)
+ (bare-jid (jabber-jid-user from))
+ (sound-file (or (dolist (entry jabber-alert-message-wave-alist)
+ (when (string-match (car entry) bare-jid)
+ (cl-return (cdr entry))))
+ jabber-alert-message-wave)))
+ (unless (equal sound-file "")
+ (funcall jabber-play-sound-file sound-file)))))
+
+(defun jabber-message-display (from buffer text title)
+ "Display the buffer where a new message has arrived."
+ (when title
+ (display-buffer buffer)))
+
+(defun jabber-message-switch (from buffer text title)
+ "Switch to the buffer where a new message has arrived."
+ (when title
+ (switch-to-buffer buffer)))
+
+(defun jabber-message-scroll (from buffer text title)
+ "Scroll all nonselected windows where the chat buffer is displayed."
+ ;; jabber-chat-buffer-display will DTRT with point in the buffer.
+ ;; But this change will not take effect in nonselected windows.
+ ;; Therefore we do that manually here.
+ ;;
+ ;; There are three cases:
+ ;; 1. The user started typing a message in this window. Point is
+ ;; greater than jabber-point-insert. In that case, we don't
+ ;; want to move point.
+ ;; 2. Point was at the end of the buffer, but no message was being
+ ;; typed. After displaying the message, point is now close to
+ ;; the end of the buffer. We advance it to the end.
+ ;; 3. The user was perusing history in this window. There is no
+ ;; simple way to distinguish this from 2, so the user loses.
+ (let ((windows (get-buffer-window-list buffer nil t))
+ (new-point-max (with-current-buffer buffer (point-max))))
+ (dolist (w windows)
+ (unless (eq w (selected-window))
+ (set-window-point w new-point-max)))))
+
+;; MUC alert hooks
+(defun jabber-muc-default-message (nick group buffer text)
+ (when (or jabber-message-alert-same-buffer
+ (not (memq (selected-window) (get-buffer-window-list buffer))))
+ (if nick
+ (when (or jabber-muc-alert-self
+ (not (string= nick (cdr (assoc group *jabber-active-groupchats*)))))
+ (format "Message from %s in %s" nick (jabber-jid-displayname
+ group)))
+ (format "Message in %s" (jabber-jid-displayname group)))))
+
+(defun jabber-muc-wave (nick group buffer text title)
+ "Play the wave file specified in `jabber-alert-muc-wave'."
+ (when title
+ (funcall jabber-play-sound-file jabber-alert-muc-wave)))
+
+(defun jabber-muc-display (nick group buffer text title)
+ "Display the buffer where a new message has arrived."
+ (when title
+ (display-buffer buffer)))
+
+(defun jabber-muc-switch (nick group buffer text title)
+ "Switch to the buffer where a new message has arrived."
+ (when title
+ (switch-to-buffer buffer)))
+
+(defun jabber-muc-scroll (nick group buffer text title)
+ "Scroll buffer even if it is in an unselected window."
+ (jabber-message-scroll nil buffer nil nil))
+
+;; Presence alert hooks
+(defun jabber-presence-default-message (who oldstatus newstatus statustext)
+ "Return a string with the status change if OLDSTATUS and NEWSTATUS differs.
+
+Return nil if OLDSTATUS and NEWSTATUS are equal, and in other
+cases a string of the form \"'name' (jid) is now NEWSTATUS (STATUSTEXT)\".
+
+This function is not called directly, but is the default for
+`jabber-alert-presence-message-function'."
+ (cond
+ ((equal oldstatus newstatus)
+ nil)
+ (t
+ (let ((formattedname
+ (if (> (length (get who 'name)) 0)
+ (get who 'name)
+ (symbol-name who)))
+ (formattedstatus
+ (or
+ (cdr (assoc newstatus
+ '(("subscribe" . " requests subscription to your presence")
+ ("subscribed" . " has granted presence subscription to you")
+ ("unsubscribe" . " no longer subscribes to your presence")
+ ("unsubscribed" . " cancels your presence subscription"))))
+ (concat " is now "
+ (or
+ (cdr (assoc newstatus jabber-presence-strings))
+ newstatus)))))
+ (concat formattedname formattedstatus)))))
+
+(defun jabber-presence-only-chat-open-message (who oldstatus newstatus statustext)
+ "Same as `jabber-presence-default-message' but managing the presence messages.
+
+Return the same as `jabber-presence-default-message' but only
+if there is a chat buffer open for WHO, keeping the amount of presence messages
+at a more manageable level when there are lots of users.
+
+This function is not called directly, but can be used as the value for
+`jabber-alert-presence-message-function'."
+ (when (get-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from)))
+ (jabber-presence-default-message who oldstatus newstatus statustext)))
+
+(defun jabber-presence-wave (who oldstatus newstatus statustext proposed-alert)
+ "Play the wave file specified in `jabber-alert-presence-wave'."
+ (when proposed-alert
+ (let* ((case-fold-search t)
+ (bare-jid (symbol-name who))
+ (sound-file (or (dolist (entry jabber-alert-presence-wave-alist)
+ (when (string-match (car entry) bare-jid)
+ (cl-return (cdr entry))))
+ jabber-alert-presence-wave)))
+ (unless (equal sound-file "")
+ (funcall jabber-play-sound-file sound-file)))))
+
+;; This is now defined in jabber-roster.el.
+;; (defun jabber-presence-update-roster (who oldstatus newstatus statustext proposed-alert)
+;; "Update the roster display by calling `jabber-display-roster'"
+;; (jabber-display-roster))
+
+(defun jabber-presence-display (who oldstatus newstatus statustext proposed-alert)
+ "Display the roster buffer."
+ (when proposed-alert
+ (display-buffer jabber-roster-buffer)))
+
+(defun jabber-presence-switch (who oldstatus newstatus statustext proposed-alert)
+ "Switch to the roster buffer."
+ (when proposed-alert
+ (switch-to-buffer jabber-roster-buffer)))
+
+(defun jabber-info-default-message (infotype buffer)
+ "Function for constructing info alert messages.
+
+The argument is INFOTYPE, a symbol telling the kind of info request completed.
+This function uses `jabber-info-message-alist' to find a message."
+ (concat (cdr (assq infotype jabber-info-message-alist))
+ " (buffer "(buffer-name buffer) ")"))
+
+(defun jabber-info-wave (infotype buffer proposed-alert)
+ "Play the wave file specified in `jabber-alert-info-wave'."
+ (if proposed-alert
+ (funcall jabber-play-sound-file jabber-alert-info-wave)))
+
+(defun jabber-info-display (infotype buffer proposed-alert)
+ "Display buffer of completed request."
+ (when proposed-alert
+ (display-buffer buffer)))
+
+(defun jabber-info-switch (infotype buffer proposed-alert)
+ "Switch to buffer of completed request."
+ (when proposed-alert
+ (switch-to-buffer buffer)))
+
+;;; Personal alert hooks
+(defmacro define-personal-jabber-alert (name)
+ "From ALERT function, make ALERT-personal function.
+
+This makes sense only for MUC.
+
+NAME: the name of the sender."
+ (let ((sn (symbol-name name)))
+ (let ((func (intern (format "%s-personal" sn))))
+ `(progn
+ (defun ,func (nick group buffer text title)
+ (if (jabber-muc-looks-like-personal-p text group)
+ (,name nick group buffer text title)))
+ (cl-pushnew (quote ,func) (get 'jabber-alert-muc-hooks 'custom-options))))))
+
+(define-personal-jabber-alert jabber-muc-beep)
+(define-personal-jabber-alert jabber-muc-wave)
+(define-personal-jabber-alert jabber-muc-echo)
+(define-personal-jabber-alert jabber-muc-switch)
+(define-personal-jabber-alert jabber-muc-display)
+
+(defcustom jabber-autoanswer-alist nil
+ "Specific phrases to autoanswer on specific message.
+The keys are regexps matching the incoming message text, and the values are
+autoanswer phrase."
+ :type '(alist :key-type regexp :value-type string)
+ :group 'jabber-alerts)
+
+(defun jabber-autoanswer-answer (from buffer text proposed-alert)
+ "Answer automaticaly when incoming text is in `jabber-autoanswer-alist'.
+Answer automaticaly when incoming text match the first element of
+`jabber-autoanswer-alist'"
+ (when (and from buffer text proposed-alert jabber-autoanswer-alist)
+ (let ((message
+ (dolist (entry jabber-autoanswer-alist)
+ (when (string-match (car entry) text)
+ (cl-return (cdr entry))))))
+ (if message
+ (jabber-chat-send jabber-buffer-connection message)))))
+(cl-pushnew 'jabber-autoanswer-answer (get 'jabber-alert-message-hooks 'custom-options))
+
+(defun jabber-autoanswer-answer-muc (nick group buffer text proposed-alert)
+ "Answer automaticaly when incoming text is in `jabber-autoanswer-alist'.
+Answer automaticaly when incoming text match first element
+of `jabber-autoanswer-alist'."
+ (when (and nick group buffer text proposed-alert jabber-autoanswer-alist)
+ (let ((message
+ (dolist (entry jabber-autoanswer-alist)
+ (when (string-match (car entry) text)
+ (cl-return (cdr entry))))))
+ (if message
+ (jabber-chat-send jabber-buffer-connection message)))))
+(cl-pushnew 'jabber-autoanswer-answer-muc (get 'jabber-alert-muc-hooks 'custom-options))
diff --git a/jabber-autoaway.el b/jabber-autoaway.el
new file mode 100644
index 0000000..3324def
--- /dev/null
+++ b/jabber-autoaway.el
@@ -0,0 +1,185 @@
+(require 'time-date)
+
+(defgroup jabber-autoaway nil
+ "Change status to away after idleness."
+ :group 'jabber)
+
+(defcustom jabber-autoaway-methods
+ (if (fboundp 'jabber-autoaway-method)
+ (list jabber-autoaway-method)
+ (list 'jabber-current-idle-time
+ 'jabber-xprintidle-get-idle-time
+ 'jabber-termatime-get-idle-time))
+ "Methods used to keep track of idleness.
+This is a list of functions that takes no arguments, and returns the
+number of seconds since the user was active, or nil on error."
+ :group 'jabber-autoaway
+ :options '(jabber-current-idle-time
+ jabber-xprintidle-get-idle-time
+ jabber-termatime-get-idle-time))
+
+(defcustom jabber-autoaway-timeout 5
+ "Minutes of inactivity before changing status to away."
+ :group 'jabber-autoaway
+ :type 'number)
+
+(defcustom jabber-autoaway-xa-timeout 10
+ "Minutes of inactivity before changing status to xa.
+Set to 0 to disable."
+ :group 'jabber-autoaway
+ :type 'number)
+
+(defcustom jabber-autoaway-status "Idle"
+ "Status string for autoaway."
+ :group 'jabber-autoaway
+ :type 'string)
+
+(defcustom jabber-autoaway-xa-status "Extended away"
+ "Status string for autoaway in xa state."
+ :group 'jabber-autoaway
+ :type 'string)
+
+(defcustom jabber-autoaway-priority nil
+ "Priority for autoaway.
+If nil, don't change priority. See the manual for more
+information about priority."
+ :group 'jabber-autoaway
+ :type '(choice (const :tag "Don't change")
+ (integer :tag "Priority"))
+ :link '(info-link "(jabber)Presence"))
+
+(defcustom jabber-autoaway-xa-priority nil
+ "Priority for autoaway in xa state.
+If nil, don't change priority. See the manual for more
+information about priority."
+ :group 'jabber-autoaway
+ :type '(choice (const :tag "Don't change")
+ (integer :tag "Priority"))
+ :link '(info-link "(jabber)Presence"))
+
+(defcustom jabber-xprintidle-program (executable-find "xprintidle")
+ "Name of the xprintidle program."
+ :group 'jabber-autoaway
+ :type 'string)
+
+(defcustom jabber-autoaway-verbose nil
+ "If nil, don't print autoaway status messages."
+ :group 'jabber-autoaway
+ :type 'boolean)
+
+(defvar jabber-autoaway-timer nil)
+
+(defvar jabber-autoaway-last-idle-time nil
+ "Seconds of idle time the last time we checked.
+This is used to detect whether the user has become unidle.")
+
+(defun jabber-autoaway-message (&rest args)
+ (when jabber-autoaway-verbose
+ (apply #'message args)))
+
+;;;###autoload
+(defun jabber-autoaway-start (&optional ignored)
+ "Start autoaway timer.
+The IGNORED argument is there so you can put this function in
+`jabber-post-connect-hooks'."
+ (interactive)
+ (unless jabber-autoaway-timer
+ (setq jabber-autoaway-timer
+ (run-with-timer (* jabber-autoaway-timeout 60) nil #'jabber-autoaway-timer))
+ (jabber-autoaway-message "Autoaway timer started")))
+
+(defun jabber-autoaway-stop ()
+ "Stop autoaway timer."
+ (interactive)
+ (when jabber-autoaway-timer
+ (jabber-cancel-timer jabber-autoaway-timer)
+ (setq jabber-autoaway-timer nil)
+ (jabber-autoaway-message "Autoaway timer stopped")))
+
+(defun jabber-autoaway-get-idle-time ()
+ "Get idle time in seconds according to `jabber-autoaway-methods'.
+Return nil on error."
+ (car (sort (mapcar 'funcall jabber-autoaway-methods) (lambda (a b) (if a (if b (< a b) t) nil)))))
+
+(defun jabber-autoaway-timer ()
+ ;; We use one-time timers, so reset the variable.
+ (setq jabber-autoaway-timer nil)
+ (let ((idle-time (jabber-autoaway-get-idle-time)))
+ (when (numberp idle-time)
+ ;; Has "idle timeout" passed?
+ (if (> idle-time (* 60 jabber-autoaway-timeout))
+ ;; If so, mark ourselves idle.
+ (jabber-autoaway-set-idle)
+ ;; Else, start a timer for the remaining amount.
+ (setq jabber-autoaway-timer
+ (run-with-timer (- (* 60 jabber-autoaway-timeout) idle-time)
+ nil #'jabber-autoaway-timer))))))
+
+(defun jabber-autoaway-set-idle (&optional xa)
+ (jabber-autoaway-message "Autoaway triggered")
+ ;; Send presence, unless the user has set a custom presence
+ (unless (member *jabber-current-show* '("xa" "dnd"))
+ (jabber-send-presence
+ (if xa "xa" "away")
+ (if (or (string= *jabber-current-status* jabber-default-status) (string= *jabber-current-status* jabber-autoaway-status)) (if xa jabber-autoaway-xa-status jabber-autoaway-status) *jabber-current-status*)
+ (or (if xa jabber-autoaway-priority jabber-autoaway-xa-priority) *jabber-current-priority*)))
+
+ (setq jabber-autoaway-last-idle-time (jabber-autoaway-get-idle-time))
+ ;; Run unidle timer every 10 seconds (if xa specified, timer already running)
+ (unless xa
+ (setq jabber-autoaway-timer (run-with-timer 10 10
+ #'jabber-autoaway-maybe-unidle))))
+
+(defun jabber-autoaway-maybe-unidle ()
+ (let ((idle-time (jabber-autoaway-get-idle-time)))
+ (jabber-autoaway-message "Idle for %d seconds" idle-time)
+ (if (member *jabber-current-show* '("xa" "away"))
+ ;; As long as idle time increases monotonically, stay idle.
+ (if (> idle-time jabber-autoaway-last-idle-time)
+ (progn
+ ;; Has "Xa timeout" passed?
+ (if (and (> jabber-autoaway-xa-timeout 0) (> idle-time (* 60 jabber-autoaway-xa-timeout)))
+ ;; iIf so, mark ourselves xa.
+ (jabber-autoaway-set-idle t))
+ (setq jabber-autoaway-last-idle-time idle-time))
+ ;; But if it doesn't, go back to unidle state.
+ (jabber-autoaway-message "Back to unidle")
+ ;; But don't mess with the user's custom presence.
+ (if (or (string= *jabber-current-status* jabber-autoaway-status) (string= *jabber-current-status* jabber-autoaway-xa-status))
+ (jabber-send-default-presence)
+ (progn
+ (jabber-send-presence jabber-default-show *jabber-current-status* jabber-default-priority)
+ (jabber-autoaway-message "%S /= %S - not resetting presence" *jabber-current-status* jabber-autoaway-status)))
+ (jabber-autoaway-stop)
+ (jabber-autoaway-start)))))
+
+(defun jabber-xprintidle-get-idle-time ()
+ "Get idle time through the xprintidle program."
+ (when jabber-xprintidle-program
+ (with-temp-buffer
+ (when (zerop (call-process jabber-xprintidle-program
+ nil t))
+ (/ (string-to-number (buffer-string)) 1000.0)))))
+
+(defun jabber-termatime-get-idle-time ()
+ "Get idle time through atime of terminal.
+The method for finding the terminal only works on GNU/Linux."
+ (let ((terminal (cond
+ ((file-exists-p "/proc/self/fd/0")
+ "/proc/self/fd/0")
+ (t
+ nil))))
+ (when terminal
+ (let* ((atime-of-tty (nth 4 (file-attributes terminal)))
+ (diff (time-to-seconds (time-since atime-of-tty))))
+ (when (> diff 0)
+ diff)))))
+
+(defun jabber-current-idle-time ()
+ "Get idle time through `current-idle-time'.
+`current-idle-time' was introduced in Emacs 22."
+ (if (fboundp 'current-idle-time)
+ (let ((idle-time (current-idle-time)))
+ (if (null idle-time)
+ 0
+ (float-time idle-time)))))
diff --git a/jabber-avatar.el b/jabber-avatar.el
new file mode 100644
index 0000000..50758fb
--- /dev/null
+++ b/jabber-avatar.el
@@ -0,0 +1,190 @@
+(require 'mailcap)
+
+(defgroup jabber-avatar nil
+ "Avatar related settings"
+ :group 'jabber)
+
+(defcustom jabber-avatar-cache-directory
+ (locate-user-emacs-file "jabber-avatar-cache" ".jabber-avatars")
+ "Directory to use for cached avatars."
+ :group 'jabber-avatar
+ :type 'directory)
+
+(defcustom jabber-avatar-verbose nil
+ "Display messages about irregularities with other people's avatars."
+ :group 'jabber-avatar
+ :type 'boolean)
+
+(defcustom jabber-avatar-max-width 96
+ "Maximum width of avatars."
+ :group 'jabber-avatar
+ :type 'integer)
+
+(defcustom jabber-avatar-max-height 96
+ "Maximum height of avatars."
+ :group 'jabber-avatar
+ :type 'integer)
+
+ (cl-defstruct
+ avatar sha1-sum mime-type url base64-data height width bytes)
+
+(defun jabber-avatar-from-url (url)
+ "Construct an avatar structure from the given URL.
+Retrieves the image to find info about it."
+ (with-current-buffer (let ((coding-system-for-read 'binary))
+ (url-retrieve-synchronously url))
+ (let* ((case-fold-search t)
+ (mime-type (ignore-errors
+ (search-forward-regexp "^content-type:[ \t]*\\(.*\\)$")
+ (match-string 1)))
+ (data (progn
+ (search-forward "\n\n")
+ (buffer-substring (point) (point-max)))))
+ (prog1
+ (jabber-avatar-from-data data nil mime-type)
+ (kill-buffer nil)))))
+
+(defun jabber-avatar-from-file (filename)
+ "Construct an avatar structure from FILENAME."
+ (require 'mailcap)
+ (let ((data (with-temp-buffer
+ (insert-file-contents-literally filename)
+ (buffer-string)))
+ (mime-type (when (string-match "\\.[^.]+$" filename)
+ (mailcap-extension-to-mime (match-string 0 filename)))))
+ (jabber-avatar-from-data data nil mime-type)))
+
+(defun jabber-avatar-from-base64-string (base64-string &optional mime-type)
+ "Construct an avatar stucture from BASE64-STRING.
+If MIME-TYPE is not specified, try to find it from the image data."
+ (jabber-avatar-from-data nil base64-string mime-type))
+
+(defun jabber-avatar-from-data (raw-data base64-string &optional mime-type)
+ "Construct an avatar structure from RAW-DATA and/or BASE64-STRING.
+If either is not provided, it is computed.
+If MIME-TYPE is not specified, try to find it from the image data."
+ (let* ((data (or raw-data (base64-decode-string base64-string)))
+ (bytes (length data))
+ (sha1-sum (sha1 data))
+ (base64-data (or base64-string (base64-encode-string raw-data)))
+ (type (or mime-type
+ (cdr (assq (get :type (cdr (condition-case nil
+ (jabber-create-image data nil t)
+ (error nil))))
+ '((png "image/png")
+ (jpeg "image/jpeg")
+ (gif "image/gif")))))))
+ (jabber-avatar-compute-size
+ (make-avatar :mime-type mime-type :sha1-sum sha1-sum :base64-data base64-data :bytes bytes))))
+
+;; XXX: This function is based on an outdated version of XEP-0084.
+;; (defun jabber-avatar-from-data-node (data-node)
+;; "Construct an avatar structure from the given node."
+;; (jabber-xml-let-attributes
+;; (content-type id bytes height width) data-node
+;; (let ((base64-data (car (jabber-xml-node-children data-node))))
+;; (make-avatar :mime-type content-type :sha1-sum id :bytes bytes
+;; :height height :width width :base64-data base64-data))))
+
+(defun jabber-avatar-image (avatar)
+ "Create an image from AVATAR.
+Return nil if images of this type are not supported."
+ (condition-case nil
+ (jabber-create-image (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert (avatar-base64-data avatar))
+ (base64-decode-region (point-min) (point-max))
+ (buffer-string))
+ nil
+ t)
+ (error nil)))
+
+(defun jabber-avatar-compute-size (avatar)
+ "Compute and set the width and height fields of AVATAR.
+Return AVATAR."
+ ;; image-size only works when there is a window system.
+ ;; But display-graphic-p doesn't exist on XEmacs...
+ (let ((size (and (fboundp 'display-graphic-p)
+ (display-graphic-p)
+ (let ((image (jabber-avatar-image avatar)))
+ (and image
+ (image-size image t))))))
+ (when size
+ (setf (avatar-width avatar) (car size))
+ (setf (avatar-height avatar) (cdr size)))
+ avatar))
+
+(defun jabber-avatar-find-cached (sha1-sum)
+ "Return file name of cached image for avatar identified by SHA1-SUM.
+If there is no cached image, return nil."
+ (let ((filename (expand-file-name sha1-sum jabber-avatar-cache-directory)))
+ (if (file-exists-p filename)
+ filename
+ nil)))
+
+(defun jabber-avatar-cache (avatar)
+ "Cache the AVATAR."
+ (let* ((id (avatar-sha1-sum avatar))
+ (base64-data (avatar-base64-data avatar))
+ (mime-type (avatar-mime-type avatar))
+ (filename (expand-file-name id jabber-avatar-cache-directory)))
+ (unless (file-directory-p jabber-avatar-cache-directory)
+ (make-directory jabber-avatar-cache-directory t))
+
+ (if (file-exists-p filename)
+ (when jabber-avatar-verbose
+ (message "Caching avatar, but %s already exists" filename))
+ (with-temp-buffer
+ (let ((require-final-newline nil)
+ (coding-system-for-write 'binary))
+ (if (fboundp 'set-buffer-multibyte)
+ (set-buffer-multibyte nil))
+ (insert base64-data)
+ (base64-decode-region (point-min) (point-max))
+ (write-region (point-min) (point-max) filename nil 'silent))))))
+
+;;;; Set avatar for contact
+(defun jabber-avatar-set (jid avatar)
+ "Set the avatar of JID to be AVATAR.
+JID is a string containing a bare JID.
+AVATAR may be one of:
+ * An avatar structure.
+ * The SHA1 sum of a cached avatar.
+ * nil, meaning no avatar."
+ ;; We want to optimize for the case of same avatar.
+ ;; Loading an image is expensive, so do it lazily.
+ (let ((jid-symbol (jabber-jid-symbol jid))
+ image hash)
+ (cond
+ ((avatar-p avatar)
+ (setq hash (avatar-sha1-sum avatar))
+ (setq image (lambda () (jabber-avatar-image avatar))))
+ ((stringp avatar)
+ (setq hash avatar)
+ (setq image (lambda ()
+ (condition-case nil
+ (jabber-create-image (jabber-avatar-find-cached avatar))
+ (error nil)))))
+ (t
+ (setq hash nil)
+ (setq image #'ignore)))
+
+ (unless (string= hash (get jid-symbol 'avatar-hash))
+ (put jid-symbol 'avatar (funcall image))
+ (put jid-symbol 'avatar-hash hash)
+ (jabber-presence-update-roster jid-symbol))))
+
+(defun jabber-create-image (file-or-data &optional type data-p)
+ "Create image, scaled down to jabber-avatar-max-width/height.
+If width/height exceeds either of those, and ImageMagick is
+available."
+ (let* ((image (create-image file-or-data type data-p))
+ (size (image-size image t))
+ (spec (cdr image)))
+ (when (and (functionp 'imagemagick-types)
+ (or (> (car size) jabber-avatar-max-width)
+ (> (cdr size) jabber-avatar-max-height)))
+ (plist-put spec :type 'imagemagick)
+ (plist-put spec :width jabber-avatar-max-width)
+ (plist-put spec :height jabber-avatar-max-height))
+ image))
diff --git a/jabber-bookmarks.el b/jabber-bookmarks.el
new file mode 100644
index 0000000..f9706c1
--- /dev/null
+++ b/jabber-bookmarks.el
@@ -0,0 +1,222 @@
+(defvar jabber-bookmarks (make-hash-table :test 'equal)
+ "Mapping from full JIDs to bookmarks.
+Bookmarks are what has been retrieved from the server, as list of
+XML elements. This is nil if bookmarks have not been retrieved,
+and t if no bookmarks where found.")
+
+;;;###autoload
+(defun jabber-get-conference-data (jc conference-jid cont &optional key)
+ "Get bookmark data for CONFERENCE-JID.
+KEY may be nil or one of :name, :autojoin, :nick and :password.
+If KEY is nil, a plist containing the above keys is returned.
+CONT is called when the result is available, with JC and the
+result as arguments. If CONT is nil, return the requested data
+immediately, and return nil if it is not in the cache."
+ (if (null cont)
+ (let ((cache (jabber-get-bookmarks-from-cache jc)))
+ (if (and cache (listp cache))
+ (jabber-get-conference-data-internal
+ cache conference-jid key)))
+ (jabber-get-bookmarks
+ jc
+ (let ((conference-jid conference-jid)
+ (key key)
+ (cont cont))
+ (lambda (jc result)
+ (let ((entry (jabber-get-conference-data-internal result conference-jid key)))
+ (funcall cont jc entry)))))))
+
+(defun jabber-get-conference-data-internal (result conference-jid key)
+ (let ((entry (dolist (node result)
+ (when (and (eq (jabber-xml-node-name node) 'conference)
+ (string= (jabber-xml-get-attribute node 'jid) conference-jid))
+ (cl-return (jabber-parse-conference-bookmark node))))))
+ (if key
+ (plist-get entry key)
+ entry)))
+
+;;;###autoload
+(defun jabber-parse-conference-bookmark (node)
+ "Convert a tag into a plist.
+The plist may contain the keys :jid, :name, :autojoin,
+:nick and :password."
+ (when (eq (jabber-xml-node-name node) 'conference)
+ (list :jid (jabber-xml-get-attribute node 'jid)
+ :name (jabber-xml-get-attribute node 'name)
+ :autojoin (member (jabber-xml-get-attribute node 'autojoin)
+ '("true" "1"))
+ :nick (car (jabber-xml-node-children
+ (car (jabber-xml-get-children node 'nick))))
+ :password (car (jabber-xml-node-children
+ (car (jabber-xml-get-children node 'password)))))))
+
+;;;###autoload
+(defun jabber-get-bookmarks (jc cont &optional refresh)
+ "Retrieve bookmarks (if needed) and call CONT.
+Arguments to CONT are JC and the bookmark list. CONT will be
+called as the result of a filter function or a timer.
+If REFRESH is non-nil, always fetch bookmarks."
+ (let ((bookmarks (gethash (jabber-connection-bare-jid jc) jabber-bookmarks)))
+ (if (and (not refresh) bookmarks)
+ (run-with-timer 0 nil cont jc (when (listp bookmarks) bookmarks))
+ (let* ((cont cont)
+ (callback (lambda (jc result) (jabber-get-bookmarks-1 jc result cont))))
+ (jabber-private-get jc 'storage "storage:bookmarks"
+ callback callback)))))
+
+(defun jabber-get-bookmarks-1 (jc result cont)
+ (let ((my-jid (jabber-connection-bare-jid jc))
+ (value
+ (if (eq (jabber-xml-node-name result) 'storage)
+ (or (jabber-xml-node-children result) t)
+ t)))
+ (puthash my-jid value jabber-bookmarks)
+ (funcall cont jc (when (listp value) value))))
+
+;;;###autoload
+(defun jabber-get-bookmarks-from-cache (jc)
+ "Return cached bookmarks for JC.
+If bookmarks have not yet been fetched by `jabber-get-bookmarks',
+return nil."
+ (gethash (jabber-connection-bare-jid jc) jabber-bookmarks))
+
+(defun jabber-set-bookmarks (jc bookmarks &optional callback)
+ "Set bookmarks to BOOKMARKS, which is a list of XML elements.
+If CALLBACK is non-nil, call it with JC and t or nil as arguments
+on success or failure, respectively."
+ (unless callback
+ (setq callback #'ignore))
+ (jabber-private-set
+ jc
+ `(storage ((xmlns . "storage:bookmarks"))
+ ,@bookmarks)
+ callback t
+ callback nil))
+
+;;;###autoload
+(defun jabber-edit-bookmarks (jc)
+ "Create a buffer for editing bookmarks interactively.
+
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)))
+ (jabber-get-bookmarks jc 'jabber-edit-bookmarks-1 t))
+
+(defun jabber-edit-bookmarks-1 (jc bookmarks)
+ (setq bookmarks
+ (mapcar
+ (lambda (e)
+ (cl-case (jabber-xml-node-name e)
+ (url
+ (list 'url (or (jabber-xml-get-attribute e 'url) "")
+ (or (jabber-xml-get-attribute e 'name) "")))
+ (conference
+ (list 'conference
+ (or (jabber-xml-get-attribute e 'jid) "")
+ (or (jabber-xml-get-attribute e 'name) "")
+ (not (not (member (jabber-xml-get-attribute e 'autojoin)
+ '("true" "1"))))
+ (or (jabber-xml-path e '(nick "")) "")
+ (or (jabber-xml-path e '(password "")) "")))))
+ bookmarks))
+ (setq bookmarks (delq nil bookmarks))
+ (with-current-buffer (get-buffer-create "Edit bookmarks")
+ (jabber-init-widget-buffer nil)
+ (setq jabber-buffer-connection jc)
+
+ (widget-insert (jabber-propertize (concat "Edit bookmarks for "
+ (jabber-connection-bare-jid jc))
+ 'face 'jabber-title-large)
+ "\n\n")
+
+ (when (or (bound-and-true-p jabber-muc-autojoin)
+ (bound-and-true-p jabber-muc-default-nicknames))
+ (widget-insert "The variables `jabber-muc-autojoin' and/or `jabber-muc-default-nicknames'\n"
+ "contain values. They are only available to jabber.el on this machine.\n"
+ "You may want to import them into your bookmarks, to make them available\n"
+ "to any client on any machine.\n")
+ (widget-create 'push-button :notify 'jabber-bookmarks-import "Import values from variables")
+ (widget-insert "\n\n"))
+
+ (push (cons 'bookmarks
+ (widget-create
+ '(repeat
+ :tag "Bookmarks"
+ (choice
+ (list :tag "Conference"
+ (const :format "" conference)
+ (string :tag "JID") ;XXX: jid widget type?
+ (string :tag "Name")
+ (checkbox :tag "Autojoin" :format "%[%v%] Autojoin?\n")
+ (string :tag "Nick") ;or nil?
+ (string :tag "Password") ;or nil?
+ )
+ (list :tag "URL"
+ (const :format "" url)
+ (string :tag "URL")
+ (string :tag "Name"))))
+ :value bookmarks))
+ jabber-widget-alist)
+
+ (widget-insert "\n")
+ (widget-create 'push-button :notify 'jabber-bookmarks-submit "Submit")
+
+ (widget-setup)
+ (widget-minor-mode 1)
+ (switch-to-buffer (current-buffer))
+ (goto-char (point-min))))
+
+(defun jabber-bookmarks-submit (&rest _ignore)
+ (let ((bookmarks (widget-value (cdr (assq 'bookmarks jabber-widget-alist)))))
+ (setq bookmarks
+ (mapcar
+ (lambda (entry)
+ (cl-case (car entry)
+ (url
+ (cl-destructuring-bind (symbol url name) entry
+ `(url ((url . ,url)
+ (name . ,name)))))
+ (conference
+ (cl-destructuring-bind (symbol jid name autojoin nick password)
+ entry
+ `(conference ((jid . ,jid)
+ (name . ,name)
+ (autojoin . ,(if autojoin
+ "1"
+ "0")))
+ ,@(unless (zerop (length nick))
+ `((nick () ,nick)))
+ ,@(unless (zerop (length password))
+ `((password () ,password))))))))
+ bookmarks))
+ (remhash (jabber-connection-bare-jid jabber-buffer-connection) jabber-bookmarks)
+ (jabber-private-set
+ jabber-buffer-connection
+ `(storage ((xmlns . "storage:bookmarks"))
+ ,@bookmarks)
+ 'jabber-report-success "Storing bookmarks"
+ 'jabber-report-success "Storing bookmarks")))
+
+(defun jabber-bookmarks-import (&rest _ignore)
+ (let* ((value (widget-value (cdr (assq 'bookmarks jabber-widget-alist))))
+ (conferences (mapcar
+ 'cdr
+ (cl-remove-if-not
+ (lambda (entry)
+ (eq (car entry) 'conference))
+ value))))
+ (dolist (default-nickname jabber-muc-default-nicknames)
+ (cl-destructuring-bind (muc-jid . nick) default-nickname
+ (let ((entry (assoc muc-jid conferences)))
+ (if entry
+ (setf (cl-fourth entry) nick)
+ (setq entry (list muc-jid "" nil nick ""))
+ (push entry conferences)
+ (push (cons 'conference entry) value)))))
+ (dolist (autojoin jabber-muc-autojoin)
+ (let ((entry (assoc autojoin conferences)))
+ (if entry
+ (setf (cl-third entry) t)
+ (setq entry (list autojoin "" t "" ""))
+ (push (cons 'conference entry) value))))
+ (widget-value-set (cdr (assq 'bookmarks jabber-widget-alist)) value)
+ (widget-setup)))
diff --git a/jabber-browse.el b/jabber-browse.el
new file mode 100644
index 0000000..e216211
--- /dev/null
+++ b/jabber-browse.el
@@ -0,0 +1,75 @@
+(add-to-list 'jabber-jid-info-menu
+ (cons "Send browse query" 'jabber-get-browse))
+(defun jabber-get-browse (jc to)
+ "Send a browse infoquery request to someone.
+
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "browse: " nil nil nil nil t)))
+ (jabber-send-iq jc to
+ "get"
+ '(query ((xmlns . "jabber:iq:browse")))
+ #'jabber-process-data #'jabber-process-browse
+ #'jabber-process-data "Browse failed"))
+
+;; called from jabber-process-data
+(defun jabber-process-browse (jc xml-data)
+ "Handle results from jabber:iq:browse requests.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (dolist (item (jabber-xml-node-children xml-data))
+ (when (and (listp item)
+ (not (eq (jabber-xml-node-name item) 'ns)))
+ (let ((jid (jabber-xml-get-attribute item 'jid))
+ (beginning (point)))
+ (cond
+ ((or
+ (eq (jabber-xml-node-name item) 'user)
+ (string= (jabber-xml-get-attribute item 'category) "user"))
+ (insert (jabber-propertize "$ USER"
+ 'face 'jabber-title-medium)
+ "\n\n"))
+ ((or
+ (eq (jabber-xml-node-name item) 'service)
+ (string= (jabber-xml-get-attribute item 'category) "service"))
+ (insert (jabber-propertize "* SERVICE"
+ 'face 'jabber-title-medium)
+ "\n\n"))
+ ((or
+ (eq (jabber-xml-node-name item) 'conference)
+ (string= (jabber-xml-get-attribute item 'category) "conference"))
+ (insert (jabber-propertize "@ CONFERENCE"
+ 'face 'jabber-title-medium)
+ "\n\n"))
+ (t
+ ;; So far I've seen "server" and "directory", both in the node-name.
+ ;; Those are actually service disco categories, but jabberd 2 seems
+ ;; to use them for browse results as well. It's not right (as in
+ ;; XEP-0011), but it's reasonable.
+ (let ((category (jabber-xml-get-attribute item 'category)))
+ (if (= (length category) 0)
+ (setq category (jabber-xml-node-name item)))
+ (insert (jabber-propertize (format "! OTHER: %s" category)
+ 'face 'jabber-title-medium)
+ "\n\n"))))
+ (dolist (attr '((type . "Type:\t\t")
+ (jid . "JID:\t\t")
+ (name . "Name:\t\t")
+ (version . "Version:\t")))
+ (let ((data (jabber-xml-get-attribute item (car attr))))
+ (if (> (length data) 0)
+ (insert (cdr attr) data "\n"))))
+
+ (dolist (ns (jabber-xml-get-children item 'ns))
+ (if (stringp (car (jabber-xml-node-children ns)))
+ (insert "Namespace:\t" (car (jabber-xml-node-children ns)) "\n")))
+
+ (insert "\n")
+ (put-text-property beginning (point) 'jabber-jid jid)
+ (put-text-property beginning (point) 'jabber-account jc)
+
+ ;; XXX: Is this kind of recursion really needed?
+ (if (listp (car (jabber-xml-node-children item)))
+ (jabber-process-browse jc item))))))
diff --git a/jabber-carbons.el b/jabber-carbons.el
new file mode 100644
index 0000000..743fc9d
--- /dev/null
+++ b/jabber-carbons.el
@@ -0,0 +1,20 @@
+(defun jabber-carbon-success (jc xml-data context)
+ (when (equal "result" (jabber-xml-get-attribute xml-data 'type))
+ (message "Carbons feature successfully enabled")))
+
+(defun jabber-carbon-failure (jc xml-data context)
+ (message "Carbons feature could not be enabled: %S" xml-data))
+
+(add-to-list 'jabber-jid-service-menu
+ (cons "Enable Carbons" 'jabber-enable-carbons))
+(defun jabber-enable-carbons (jc)
+ "Send request to enable XEP-0280 Message Carbons.
+
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)))
+ (jabber-send-iq jc
+ nil
+ "set"
+ `(enable ((xmlns . "urn:xmpp:carbons:2")))
+ #'jabber-carbon-success "Carbons feature enablement"
+ #'jabber-carbon-failure "Carbons feature enablement"))
diff --git a/jabber-chat.el b/jabber-chat.el
new file mode 100644
index 0000000..1903464
--- /dev/null
+++ b/jabber-chat.el
@@ -0,0 +1,692 @@
+(require 'ewoc)
+
+(defgroup jabber-chat nil "chat display options"
+ :group 'jabber)
+
+(defcustom jabber-chat-buffer-format "*-jabber-chat-%n-*"
+ "The format specification for the name of chat buffers.
+
+These fields are available (all are about the person you are chatting
+with):
+
+%n Nickname, or JID if no nickname set
+%j Bare JID (without resource)
+%r Resource"
+ :type 'string
+ :group 'jabber-chat)
+
+(defcustom jabber-chat-header-line-format
+ '("" (jabber-chat-buffer-show-avatar
+ (:eval
+ (let ((buddy (jabber-jid-symbol jabber-chatting-with)))
+ (jabber-propertize " "
+ 'display (get buddy 'avatar)))))
+ (:eval (jabber-jid-displayname jabber-chatting-with))
+ "\t" (:eval (let ((buddy (jabber-jid-symbol jabber-chatting-with)))
+ (propertize
+ (or
+ (cdr (assoc (get buddy 'show) jabber-presence-strings))
+ (get buddy 'show))
+ 'face
+ (or (cdr (assoc (get buddy 'show) jabber-presence-faces))
+ 'jabber-roster-user-online))))
+ "\t" (:eval (jabber-fix-status (get (jabber-jid-symbol jabber-chatting-with) 'status)))
+ "\t" jabber-events-message ;see jabber-events.el
+ "\t" jabber-chatstates-message) ;see jabber-chatstates.el
+ "The specification for the header line of chat buffers.
+
+The format is that of `mode-line-format' and `header-line-format'."
+ :type 'sexp
+ :group 'jabber-chat)
+
+(defcustom jabber-chat-buffer-show-avatar t
+ "Show avatars in header line of chat buffer?
+This variable might not take effect if you have changed
+`jabber-chat-header-line-format'."
+ :type 'boolean
+ :group 'jabber-chat)
+
+(defcustom jabber-chat-time-format "%H:%M"
+ "The format specification for instant messages in the chat buffer.
+See also `jabber-chat-delayed-time-format'.
+
+See `format-time-string' for valid values."
+ :type 'string
+ :group 'jabber-chat)
+
+(defcustom jabber-chat-delayed-time-format "%Y-%m-%d %H:%M"
+ "The format specification for delayed messages in the chat buffer.
+See also `jabber-chat-time-format'.
+
+See `format-time-string' for valid values."
+ :type 'string
+ :group 'jabber-chat)
+
+(defcustom jabber-print-rare-time t
+ "Non-nil means to print \"rare time\" indications in chat buffers.
+The default settings tell every new hour."
+ :type 'boolean
+ :group 'jabber-chat)
+
+(defcustom jabber-rare-time-format "%a %e %b %Y %H:00"
+ "The format specification for the rare time information.
+Rare time information will be printed whenever the current time,
+formatted according to this string, is different to the last
+rare time printed."
+ :type 'string
+ :group 'jabber-chat)
+
+(defface jabber-rare-time-face
+ '((t (:foreground "darkgreen" :underline t)))
+ "face for displaying the rare time info"
+ :group 'jabber-chat)
+
+(defcustom jabber-chat-local-prompt-format "[%t] %n> "
+ "The format specification for lines you type in the chat buffer.
+
+These fields are available:
+
+%t Time, formatted according to `jabber-chat-time-format'
+ or `jabber-chat-delayed-time-format'
+%u Username
+%n Nickname (obsolete, same as username)
+%r Resource
+%j Bare JID (without resource)"
+ :type 'string
+ :group 'jabber-chat)
+
+(defcustom jabber-chat-foreign-prompt-format "[%t] %n> "
+ "The format specification for lines others type in the chat buffer.
+
+These fields are available:
+
+%t Time, formatted according to `jabber-chat-time-format'
+ or `jabber-chat-delayed-time-format'
+%n Nickname, or JID if no nickname set
+%u Username
+%r Resource
+%j Bare JID (without resource)"
+ :type 'string
+ :group 'jabber-chat)
+
+(defcustom jabber-chat-system-prompt-format "[%t] *** "
+ "The format specification for lines from the system or special chat.
+The format specification for lines from the system or that are special in the
+chat buffer."
+ :type 'string
+ :group 'jabber-chat)
+
+(defface jabber-chat-prompt-local
+ '((t (:foreground "blue" :weight bold)))
+ "face for displaying the chat prompt for what you type in"
+ :group 'jabber-chat)
+
+(defface jabber-chat-prompt-foreign
+ '((t (:foreground "red" :weight bold)))
+ "face for displaying the chat prompt for what they send"
+ :group 'jabber-chat)
+
+(defface jabber-chat-prompt-system
+ '((t (:foreground "green" :weight bold)))
+ "face used for system and special messages"
+ :group 'jabber-chat)
+
+(defface jabber-chat-text-local '((t ()))
+ "Face used for text you write"
+ :group 'jabber-chat)
+
+(defface jabber-chat-text-foreign '((t ()))
+ "Face used for text others write"
+ :group 'jabber-chat)
+
+(defface jabber-chat-error
+ '((t (:foreground "red" :weight bold)))
+ "Face used for error messages"
+ :group 'jabber-chat)
+
+;;;###autoload
+(defvar jabber-chatting-with nil
+ "JID of the person you are chatting with.")
+
+(defvar jabber-chat-printers '(jabber-chat-print-subject
+ jabber-chat-print-body
+ jabber-chat-print-url
+ jabber-chat-goto-address)
+ "List of functions that may be able to print part of a message.
+Each function receives these arguments:
+
+XML-DATA The entire message stanza
+WHO :local or :foreign, for sent or received stanza, respectively
+MODE :insert or :printp. For :insert, insert text at point.
+ For :printp, return non-nil if function would insert text.")
+
+(defvar jabber-body-printers '(jabber-chat-normal-body)
+ "List of functions that may be able to print a body for a message.
+Each function receives these arguments:
+
+XML-DATA The entire message stanza
+WHO :local, :foreign or :error
+MODE :insert or :printp. For :insert, insert text at point.
+ For :printp, return non-nil if function would insert text.
+
+These functions are called in order, until one of them returns
+non-nil.
+
+Add a function to the beginning of this list if the tag it handles
+replaces the contents of the tag.")
+
+(defvar jabber-chat-send-hooks nil
+ "List of functions called when a chat message is sent.
+The arguments are the text to send, and the id attribute of the
+message.
+
+The functions should return a list of XML nodes they want to be
+added to the outgoing message.")
+
+(defvar jabber-chat-earliest-backlog nil
+ "Float-time of earliest backlog entry inserted into buffer.
+nil if no backlog has been inserted.")
+
+;;;###autoload
+(defun jabber-chat-get-buffer (chat-with)
+ "Return the chat buffer for chatting with CHAT-WITH (bare or full JID).
+Either a string or a buffer is returned, so use `get-buffer' or
+`get-buffer-create'."
+ (format-spec jabber-chat-buffer-format
+ (list
+ (cons ?n (jabber-jid-displayname chat-with))
+ (cons ?j (jabber-jid-user chat-with))
+ (cons ?r (or (jabber-jid-resource chat-with) "")))))
+
+(defun jabber-chat-create-buffer (jc chat-with)
+ "Prepare a buffer for chatting with CHAT-WITH.
+This function is idempotent.
+JC is the Jabber connection."
+ (with-current-buffer (get-buffer-create (jabber-chat-get-buffer chat-with))
+ (unless (eq major-mode 'jabber-chat-mode)
+ (jabber-chat-mode jc #'jabber-chat-pp)
+
+ (make-local-variable 'jabber-chatting-with)
+ (setq jabber-chatting-with chat-with)
+ (setq jabber-send-function 'jabber-chat-send)
+ (setq header-line-format jabber-chat-header-line-format)
+
+ (make-local-variable 'jabber-chat-earliest-backlog)
+
+ ;; insert backlog
+ (when (null jabber-chat-earliest-backlog)
+ (let ((backlog-entries (jabber-history-backlog chat-with)))
+ (if (null backlog-entries)
+ (setq jabber-chat-earliest-backlog (jabber-float-time))
+ (setq jabber-chat-earliest-backlog
+ (jabber-float-time (jabber-parse-time
+ (aref (car backlog-entries) 0))))
+ (mapc 'jabber-chat-insert-backlog-entry (nreverse backlog-entries))))))
+
+ ;; Make sure the connection variable is up to date.
+ (setq jabber-buffer-connection jc)
+
+ (current-buffer)))
+
+(defun jabber-chat-insert-backlog-entry (msg)
+ "Insert backlog entry MSG at beginning of buffer."
+ ;; Rare timestamps are especially important in backlog. We risk
+ ;; having superfluous timestamps if we just add before each backlog
+ ;; entry.
+ (let* ((message-time (jabber-parse-time (aref msg 0)))
+ (fake-stanza `(message ((from . ,(aref msg 2)))
+ (body nil ,(aref msg 4))
+ (x ((xmlns . "jabber:x:delay")
+ (stamp . ,(jabber-encode-legacy-time message-time))))))
+ (node-data (list (if (string= (aref msg 1) "in") :foreign :local)
+ fake-stanza :delayed t)))
+
+ ;; Insert after existing rare timestamp?
+ (if (and jabber-print-rare-time
+ (ewoc-nth jabber-chat-ewoc 0)
+ (eq (car (ewoc-data (ewoc-nth jabber-chat-ewoc 0))) :rare-time)
+ (not (jabber-rare-time-needed message-time (cadr (ewoc-data (ewoc-nth jabber-chat-ewoc 0))))))
+ (ewoc-enter-after jabber-chat-ewoc (ewoc-nth jabber-chat-ewoc 0) node-data)
+ ;; Insert first.
+ (ewoc-enter-first jabber-chat-ewoc node-data)
+ (when jabber-print-rare-time
+ (ewoc-enter-first jabber-chat-ewoc (list :rare-time message-time))))))
+
+(add-to-list 'jabber-jid-chat-menu
+ (cons "Display more context" 'jabber-chat-display-more-backlog))
+
+(defun jabber-chat-display-more-backlog (how-many)
+ "Display more context.
+The HOW-MANY argument is number of messages.
+Specify 0 to display all messages."
+ (interactive "nHow many more messages (Specify 0 to display all)? ")
+ (let* ((inhibit-read-only t)
+ (jabber-backlog-days nil)
+ (jabber-backlog-number (if (= how-many 0) t how-many))
+ (backlog-entries (jabber-history-backlog
+ (or jabber-chatting-with jabber-group) jabber-chat-earliest-backlog)))
+ (when backlog-entries
+ (setq jabber-chat-earliest-backlog
+ (jabber-float-time (jabber-parse-time
+ (aref (car backlog-entries) 0))))
+ (save-excursion
+ (goto-char (point-min))
+ (mapc 'jabber-chat-insert-backlog-entry (nreverse backlog-entries))))))
+
+(add-to-list 'jabber-message-chain 'jabber-process-chat)
+
+(defun jabber-get-forwarded-message (xml-data)
+ (let* ((sent (car (jabber-xml-get-children xml-data 'sent)))
+ (forwarded (car (jabber-xml-get-children sent 'forwarded)))
+ (forwarded-message (car (jabber-xml-get-children forwarded 'message))))
+ (when forwarded-message
+ forwarded-message)))
+
+(defun jabber-process-chat (jc xml-data)
+ "If XML-DATA is a one-to-one chat message, handle it as such.
+JC is the Jabber connection."
+ ;; For now, everything that is not a public MUC message is
+ ;; potentially a 1to1 chat message.
+ (when (not (jabber-muc-message-p xml-data))
+ ;; Note that we handle private MUC messages here.
+ (cl-destructuring-bind (xml-data chat-buffer)
+ (if (car (jabber-xml-get-children xml-data 'sent))
+ (let* ((fwd-msg (jabber-get-forwarded-message xml-data))
+ (to (jabber-xml-get-attribute fwd-msg 'to)))
+ (list fwd-msg
+ (jabber-chat-create-buffer jc to)))
+ (list xml-data nil))
+ (let ((from (jabber-xml-get-attribute xml-data 'from))
+ (error-p (jabber-xml-get-children xml-data 'error))
+ (body-text (car (jabber-xml-node-children
+ (car (jabber-xml-get-children
+ xml-data 'body))))))
+ ;; First check if we would output anything for this stanza.
+ (when (or error-p
+ (run-hook-with-args-until-success 'jabber-chat-printers
+ xml-data
+ :foreign :printp))
+ ;; If so, create chat buffer, if necessary...
+ (with-current-buffer (if (jabber-muc-sender-p from)
+ (jabber-muc-private-create-buffer
+ jc
+ (jabber-jid-user from)
+ (jabber-jid-resource from))
+ (or chat-buffer
+ (jabber-chat-create-buffer jc from)))
+ ;; ...add the message to the ewoc...
+ (let ((node (ewoc-enter-last jabber-chat-ewoc
+ (list (if error-p :error :foreign)
+ xml-data
+ :time
+ (current-time)))))
+ (jabber-maybe-print-rare-time node))
+
+ ;; ...and call alert hooks.
+ (dolist (hook '(jabber-message-hooks jabber-alert-message-hooks))
+ (run-hook-with-args hook
+ from (current-buffer) body-text
+ (funcall jabber-alert-message-function
+ from (current-buffer) body-text)))))))))
+
+(defun jabber-chat-send (jc body)
+ "Send BODY through connection JC, and display it in chat buffer.
+JC is the Jabber connection."
+ ;; Build the stanza...
+ (let* ((id (apply 'format "emacs-msg-%d.%d.%d" (current-time)))
+ (stanza-to-send `(message
+ ((to . ,jabber-chatting-with)
+ (type . "chat")
+ (id . ,id))
+ (body () ,body))))
+ ;; ...add additional elements...
+ ;; TODO: Once we require Emacs 24.1, use `run-hook-wrapped' instead.
+ ;; That way we don't need to eliminate the "local hook" functionality
+ ;; here.
+ (dolist (hook jabber-chat-send-hooks)
+ (if (eq hook t)
+ ;; Local hook referring to global...
+ (when (local-variable-p 'jabber-chat-send-hooks)
+ (dolist (global-hook (default-value 'jabber-chat-send-hooks))
+ (nconc stanza-to-send (funcall global-hook body id))))
+ (nconc stanza-to-send (funcall hook body id))))
+ ;; ...display it, if it would be displayed.
+ (when (run-hook-with-args-until-success 'jabber-chat-printers stanza-to-send :local :printp)
+ (jabber-maybe-print-rare-time
+ (ewoc-enter-last jabber-chat-ewoc (list :local stanza-to-send :time (current-time)))))
+ ;; ...and send it...
+ (jabber-send-sexp jc stanza-to-send)))
+
+(defun jabber-chat-pp (data)
+ "Pretty-print a stanza.
+\(car data) is either :local, :foreign, :error or :notice.
+\(cadr data) is the stanza.
+This function is used as an ewoc prettyprinter."
+ (let* ((beg (point))
+ (original-timestamp (when (listp (cadr data))
+ (jabber-message-timestamp (cadr data))))
+ (internal-time
+ (plist-get (cddr data) :time))
+ (body (ignore-errors (car
+ (jabber-xml-node-children
+ (car
+ (jabber-xml-get-children (cadr data) 'body))))))
+ (/me-p
+ (and (> (length body) 4)
+ (string= (substring body 0 4) "/me "))))
+
+ ;; Print prompt...
+ (let ((delayed (or original-timestamp (plist-get (cddr data) :delayed)))
+ (prompt-start (point)))
+ (cl-case (car data)
+ (:local
+ (jabber-chat-self-prompt (or original-timestamp internal-time)
+ delayed
+ /me-p))
+ (:foreign
+ (if (and (listp (cadr data))
+ (jabber-muc-private-message-p (cadr data)))
+ (jabber-muc-private-print-prompt (cadr data))
+ ;; For :error and :notice, this might be a string... beware
+ (jabber-chat-print-prompt (when (listp (cadr data)) (cadr data))
+ (or original-timestamp internal-time)
+ delayed
+ /me-p)))
+ ((:error :notice :subscription-request)
+ (jabber-chat-system-prompt (or original-timestamp internal-time)))
+ (:muc-local
+ (jabber-muc-print-prompt (cadr data) t /me-p))
+ (:muc-foreign
+ (jabber-muc-print-prompt (cadr data) nil /me-p))
+ ((:muc-notice :muc-error)
+ (jabber-muc-system-prompt)))
+ (put-text-property prompt-start (point) 'field 'jabber-prompt))
+
+ ;; ...and body
+ (cl-case (car data)
+ ((:local :foreign)
+ (run-hook-with-args 'jabber-chat-printers (cadr data) (car data) :insert))
+ ((:muc-local :muc-foreign)
+ (dolist (hook '(jabber-muc-printers jabber-chat-printers))
+ (run-hook-with-args hook (cadr data) (car data) :insert)))
+ ((:error :muc-error)
+ (if (stringp (cadr data))
+ (insert (jabber-propertize (cadr data) 'face 'jabber-chat-error))
+ (jabber-chat-print-error (cadr data))))
+ ((:notice :muc-notice)
+ (insert (cadr data)))
+ (:rare-time
+ (insert (jabber-propertize (format-time-string jabber-rare-time-format (cadr data))
+ 'face 'jabber-rare-time-face)))
+ (:subscription-request
+ (insert "This user requests subscription to your presence.\n")
+ (when (and (stringp (cadr data)) (not (zerop (length (cadr data)))))
+ (insert "Message: " (cadr data) "\n"))
+ (insert "Accept?\n\n")
+ (cl-flet ((button
+ (text action)
+ (if (fboundp 'insert-button)
+ (insert-button text 'action action)
+ ;; simple button replacement
+ (let ((keymap (make-keymap)))
+ (define-key keymap "\r" action)
+ (insert (jabber-propertize text 'keymap keymap 'face 'highlight))))
+ (insert "\t")))
+ (button "Mutual" 'jabber-subscription-accept-mutual)
+ (button "One-way" 'jabber-subscription-accept-one-way)
+ (button "Decline" 'jabber-subscription-decline))))
+
+ (when jabber-chat-fill-long-lines
+ (save-restriction
+ (narrow-to-region beg (point))
+ (jabber-chat-buffer-fill-long-lines)))
+
+ (put-text-property beg (point) 'read-only t)
+ (put-text-property beg (point) 'front-sticky t)
+ (put-text-property beg (point) 'rear-nonsticky t)))
+
+(defun jabber-rare-time-needed (time1 time2)
+ "Return non-nil if a timestamp should be printed between TIME1 and TIME2."
+ (not (string= (format-time-string jabber-rare-time-format time1)
+ (format-time-string jabber-rare-time-format time2))))
+
+(defun jabber-maybe-print-rare-time (node)
+ "Print rare time before NODE, if appropriate."
+ (let* ((prev (ewoc-prev jabber-chat-ewoc node))
+ (data (ewoc-data node))
+ (prev-data (when prev (ewoc-data prev))))
+ (cl-flet ((entry-time (entry)
+ (or (when (listp (cadr entry))
+ (jabber-message-timestamp (cadr entry)))
+ (plist-get (cddr entry) :time))))
+ (when (and jabber-print-rare-time
+ (or (null prev)
+ (jabber-rare-time-needed (entry-time prev-data)
+ (entry-time data))))
+ (ewoc-enter-before jabber-chat-ewoc node
+ (list :rare-time (entry-time data)))))))
+
+(defun jabber-chat-print-prompt (xml-data timestamp delayed dont-print-nick-p)
+ "Print prompt for received message in XML-DATA.
+TIMESTAMP is the timestamp to print, or nil to get it
+from a jabber:x:delay element.
+If DELAYED is non-nil, print long timestamp
+\(`jabber-chat-delayed-time-format' as opposed to
+`jabber-chat-time-format').
+If DONT-PRINT-NICK-P is non-nil, don't include nickname."
+ (let ((from (jabber-xml-get-attribute xml-data 'from))
+ (timestamp (or timestamp (jabber-message-timestamp xml-data))))
+ (insert (jabber-propertize
+ (format-spec jabber-chat-foreign-prompt-format
+ (list
+ (cons ?t (format-time-string
+ (if delayed
+ jabber-chat-delayed-time-format
+ jabber-chat-time-format)
+ timestamp))
+ (cons ?n (if dont-print-nick-p "" (jabber-jid-displayname from)))
+ (cons ?u (or (jabber-jid-username from) from))
+ (cons ?r (jabber-jid-resource from))
+ (cons ?j (jabber-jid-user from))))
+ 'face 'jabber-chat-prompt-foreign
+ 'help-echo
+ (concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from " from)))))
+
+(defun jabber-chat-system-prompt (timestamp)
+ (insert (jabber-propertize
+ (format-spec jabber-chat-foreign-prompt-format
+ (list
+ (cons ?t (format-time-string jabber-chat-time-format
+ timestamp))
+ (cons ?n "")
+ (cons ?u "")
+ (cons ?r "")
+ (cons ?j "")))
+ 'face 'jabber-chat-prompt-system
+ 'help-echo
+ (concat (format-time-string "System message on %Y-%m-%d %H:%M:%S" timestamp)))))
+
+(defun jabber-chat-self-prompt (timestamp delayed dont-print-nick-p)
+ "Print prompt for sent message.
+TIMESTAMP is the timestamp to print, or nil for now.
+If DELAYED is non-nil, print long timestamp
+\(`jabber-chat-delayed-time-format' as opposed to
+`jabber-chat-time-format').
+If DONT-PRINT-NICK-P is non-nil, don't include nickname."
+ (let* ((state-data (fsm-get-state-data jabber-buffer-connection))
+ (username (plist-get state-data :username))
+ (server (plist-get state-data :server))
+ (resource (plist-get state-data :resource))
+ (nickname username))
+ (insert (jabber-propertize
+ (format-spec jabber-chat-local-prompt-format
+ (list
+ (cons ?t (format-time-string
+ (if delayed
+ jabber-chat-delayed-time-format
+ jabber-chat-time-format)
+ timestamp))
+ (cons ?n (if dont-print-nick-p "" nickname))
+ (cons ?u username)
+ (cons ?r resource)
+ (cons ?j (concat username "@" server))))
+ 'face 'jabber-chat-prompt-local
+ 'help-echo
+ (concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from you")))))
+
+(defun jabber-chat-print-error (xml-data)
+ "Print error in given in a readable way.
+
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let ((the-error (car (jabber-xml-get-children xml-data 'error))))
+ (insert
+ (jabber-propertize
+ (concat "Error: " (jabber-parse-error the-error))
+ 'face 'jabber-chat-error))))
+
+(defun jabber-chat-print-subject (xml-data who mode)
+ "Print subject of given , if any.
+
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let ((subject (car
+ (jabber-xml-node-children
+ (car
+ (jabber-xml-get-children xml-data 'subject))))))
+ (when (not (zerop (length subject)))
+ (cl-case mode
+ (:printp
+ t)
+ (:insert
+ (insert (jabber-propertize
+ "Subject: " 'face 'jabber-chat-prompt-system)
+ (jabber-propertize
+ subject
+ 'face 'jabber-chat-text-foreign)
+ "\n"))))))
+
+(defun jabber-chat-print-body (xml-data who mode)
+ (run-hook-with-args-until-success 'jabber-body-printers xml-data who mode))
+
+(defun jabber-chat-normal-body (xml-data who mode)
+ "Print body for received message in XML-DATA."
+ (let ((body (car
+ (jabber-xml-node-children
+ (car
+ (jabber-xml-get-children xml-data 'body))))))
+ (when body
+
+ (when (eql mode :insert)
+ (if (and (> (length body) 4)
+ (string= (substring body 0 4) "/me "))
+ (let ((action (substring body 4))
+ (nick (cond
+ ((eq who :local)
+ (plist-get (fsm-get-state-data jabber-buffer-connection) :username))
+ ((or (jabber-muc-message-p xml-data)
+ (jabber-muc-private-message-p xml-data))
+ (jabber-jid-resource (jabber-xml-get-attribute xml-data 'from)))
+ (t
+ (jabber-jid-displayname (jabber-xml-get-attribute xml-data 'from))))))
+ (insert (jabber-propertize
+ (concat nick
+ " "
+ action)
+ 'face 'jabber-chat-prompt-system)))
+ (insert (jabber-propertize
+ body
+ 'face (cl-case who
+ ((:foreign :muc-foreign) 'jabber-chat-text-foreign)
+ ((:local :muc-local) 'jabber-chat-text-local))))))
+ t)))
+
+(defun jabber-chat-print-url (xml-data who mode)
+ "Print URLs provided in jabber:x:oob namespace.
+
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let ((foundp nil))
+ (dolist (x (jabber-xml-node-children xml-data))
+ (when (and (listp x) (eq (jabber-xml-node-name x) 'x)
+ (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:oob"))
+ (setq foundp t)
+
+ (when (eql mode :insert)
+ (let ((url (car (jabber-xml-node-children
+ (car (jabber-xml-get-children x 'url)))))
+ (desc (car (jabber-xml-node-children
+ (car (jabber-xml-get-children x 'desc))))))
+ (insert "\n"
+ (jabber-propertize
+ "URL: " 'face 'jabber-chat-prompt-system)
+ (format "%s <%s>" desc url))))))
+ foundp))
+
+(defun jabber-chat-goto-address (xml-data who mode)
+ "Call `goto-address' on the newly written text.
+
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (when (eq mode :insert)
+ (ignore-errors
+ (let ((end (point))
+ (limit (max (- (point) 1000) (1+ (point-min)))))
+ ;; We only need to fontify the text written since the last
+ ;; prompt. The prompt has a field property, so we can find it
+ ;; using `field-beginning'.
+ (goto-address-fontify (field-beginning nil nil limit) end)))))
+
+(add-to-list 'jabber-jid-chat-menu
+ (cons "Compose message" 'jabber-compose))
+
+(defun jabber-send-message (jc to subject body type)
+ "Send a message tag to the server.
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "to: ")
+ (jabber-read-with-input-method "subject: ")
+ (jabber-read-with-input-method "body: ")
+ (read-string "type: ")))
+ (jabber-send-sexp jc
+ `(message ((to . ,to)
+ ,(if (> (length type) 0)
+ `(type . ,type)))
+ ,(if (> (length subject) 0)
+ `(subject () ,subject))
+ ,(if (> (length body) 0)
+ `(body () ,body))))
+ (if (and jabber-history-enabled (not (string= type "groupchat")))
+ (jabber-history-log-message "out" nil to body (current-time))))
+
+(add-to-list 'jabber-jid-chat-menu
+ (cons "Start chat" 'jabber-chat-with))
+
+(defun jabber-chat-with (jc jid &optional other-window)
+ "Open an empty chat window for chatting with JID.
+With a prefix argument, open buffer in other window.
+Returns the chat buffer.
+JC is the Jabber connection."
+ (interactive (let* ((jid
+ (jabber-read-jid-completing "chat with:"))
+ (account
+ (jabber-read-account nil jid)))
+ (list
+ account jid current-prefix-arg)))
+ (let ((buffer (jabber-chat-create-buffer jc jid)))
+ (if other-window
+ (switch-to-buffer-other-window buffer)
+ (switch-to-buffer buffer))))
+
+(defun jabber-chat-with-jid-at-point (&optional other-window)
+ "Start chat with JID at point.
+Signal an error if there is no JID at point.
+With a prefix argument, open buffer in other window."
+ (interactive "P")
+ (let ((jid-at-point (get-text-property (point)
+ 'jabber-jid))
+ (account (get-text-property (point)
+ 'jabber-account)))
+ (if (and jid-at-point account)
+ (jabber-chat-with account jid-at-point other-window)
+ (error "No contact at point"))))
diff --git a/jabber-chatbuffer.el b/jabber-chatbuffer.el
new file mode 100644
index 0000000..29ae446
--- /dev/null
+++ b/jabber-chatbuffer.el
@@ -0,0 +1,115 @@
+(defvar jabber-point-insert nil
+ "Position where the message being composed starts.")
+
+(defvar jabber-send-function nil
+ "Function for sending a message from a chat buffer.")
+
+(defvar jabber-chat-mode-hook nil
+ "Hook called at the end of `jabber-chat-mode'.
+Note that functions in this hook have no way of knowing
+what kind of chat buffer is being created.")
+
+(defcustom jabber-chat-fill-long-lines t
+ "If non-nil, fill long lines in chat buffers.
+Lines are broken at word boundaries at the width of the
+window or at `fill-column', whichever is shorter."
+ :group 'jabber-chat
+ :type 'boolean)
+
+(defvar jabber-chat-ewoc nil
+ "The ewoc showing the messages of this chat buffer.")
+
+;;;###autoload
+(defvar jabber-buffer-connection nil
+ "The connection used by this buffer.")
+;;;###autoload
+(make-variable-buffer-local 'jabber-buffer-connection)
+
+(defun jabber-chat-mode (jc ewoc-pp)
+ "Jabber chat mode.
+\\{jabber-chat-mode-map}
+
+JC is the Jabber connection."
+ (kill-all-local-variables)
+ ;; Make sure to set this variable somewhere
+ (make-local-variable 'jabber-send-function)
+ (make-local-variable 'scroll-conservatively)
+ (make-local-variable 'jabber-point-insert)
+ (make-local-variable 'jabber-chat-ewoc)
+ (make-local-variable 'buffer-undo-list)
+
+ (setq jabber-buffer-connection jc
+ scroll-conservatively 5
+ buffer-undo-list t) ;dont keep undo list for chatbuffer
+
+ (unless jabber-chat-ewoc
+ (setq jabber-chat-ewoc
+ (ewoc-create ewoc-pp nil "---"))
+ (goto-char (point-max))
+ (put-text-property (point-min) (point) 'read-only t)
+ (let ((inhibit-read-only t))
+ (put-text-property (point-min) (point) 'front-sticky t)
+ (put-text-property (point-min) (point) 'rear-nonsticky t))
+ (setq jabber-point-insert (point-marker)))
+
+ ;;(setq header-line-format jabber-chat-header-line-format)
+
+ (setq major-mode 'jabber-chat-mode
+ mode-name "jabber-chat")
+ (use-local-map jabber-chat-mode-map)
+
+ (if (fboundp 'run-mode-hooks)
+ (run-mode-hooks 'jabber-chat-mode-hook)
+ (run-hooks 'jabber-chat-mode-hook)))
+
+(put 'jabber-chat-mode 'mode-class 'special)
+
+;; Spell check only what you're currently writing
+(defun jabber-chat-mode-flyspell-verify ()
+ (>= (point) jabber-point-insert))
+(put 'jabber-chat-mode 'flyspell-mode-predicate
+ 'jabber-chat-mode-flyspell-verify)
+
+(defvar jabber-chat-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map jabber-common-keymap)
+ (define-key map "\r" 'jabber-chat-buffer-send)
+ map))
+
+(defun jabber-chat-buffer-send ()
+ (interactive)
+ ;; If user accidentally hits RET without writing anything, just
+ ;; ignore it.
+ (when (cl-plusp (- (point-max) jabber-point-insert))
+ ;; If connection was lost...
+ (unless (memq jabber-buffer-connection jabber-connections)
+ ;; ...maybe there is a new connection to the same account.
+ (let ((new-jc (jabber-find-active-connection jabber-buffer-connection)))
+ (if new-jc
+ ;; If so, just use it.
+ (setq jabber-buffer-connection new-jc)
+ ;; Otherwise, ask for a new account.
+ (setq jabber-buffer-connection (jabber-read-account t)))))
+
+ (let ((body (delete-and-extract-region jabber-point-insert (point-max))))
+ (funcall jabber-send-function jabber-buffer-connection body))))
+
+(defun jabber-chat-buffer-fill-long-lines ()
+ "Fill lines that are wider than the window width."
+ ;; This was mostly stolen from article-fill-long-lines
+ (interactive)
+ (save-excursion
+ (let ((inhibit-read-only t)
+ (width (window-width (get-buffer-window (current-buffer)))))
+ (goto-char (point-min))
+ (let ((adaptive-fill-mode nil)) ;Why? -sm
+ (while (not (eobp))
+ (end-of-line)
+ (when (>= (current-column) (min fill-column width))
+ (save-restriction
+ (narrow-to-region (min (1+ (point)) (point-max))
+ (point-at-bol))
+ (let ((goback (point-marker)))
+ (fill-paragraph nil)
+ (goto-char (marker-position goback)))))
+ (forward-line 1))))))
diff --git a/jabber-chatstates.el b/jabber-chatstates.el
new file mode 100644
index 0000000..4ae04ee
--- /dev/null
+++ b/jabber-chatstates.el
@@ -0,0 +1,138 @@
+(defgroup jabber-chatstates nil
+ "Chat state notifications."
+ :group 'jabber)
+
+(defconst jabber-chatstates-xmlns "http://jabber.org/protocol/chatstates"
+ "XML namespace for the chatstates feature.")
+
+(defcustom jabber-chatstates-confirm t
+ "Send notifications about chat states?"
+ :group 'jabber-chatstates
+ :type 'boolean)
+
+(defvar jabber-chatstates-requested 'first-time
+ "Whether or not chat states notification was requested.
+This is one of the following:
+first-time - send state in first stanza, then switch to nil
+t - send states
+nil - don't send states")
+(make-variable-buffer-local 'jabber-chatstates-requested)
+
+(defvar jabber-chatstates-last-state nil
+ "The last seen chat state.")
+(make-variable-buffer-local 'jabber-chatstates-last-state)
+
+(defvar jabber-chatstates-message ""
+ "Human-readable presentation of chat state information.")
+(make-variable-buffer-local 'jabber-chatstates-message)
+
+(defun jabber-chatstates-update-message ()
+ (setq jabber-chatstates-message
+ (if (and jabber-chatstates-last-state
+ (not (eq 'active jabber-chatstates-last-state)))
+ (format " (%s)" (symbol-name jabber-chatstates-last-state))
+ "")))
+
+(add-hook 'jabber-chat-send-hooks 'jabber-chatstates-when-sending)
+(defun jabber-chatstates-when-sending (text id)
+ (jabber-chatstates-update-message)
+ (jabber-chatstates-stop-timer)
+ (when (and jabber-chatstates-confirm jabber-chatstates-requested)
+ (when (eq jabber-chatstates-requested 'first-time)
+ ;; don't send more notifications until we know that the other
+ ;; side wants them.
+ (setq jabber-chatstates-requested nil))
+ (setq jabber-chatstates-composing-sent nil)
+ `((active ((xmlns . ,jabber-chatstates-xmlns))))))
+
+(defvar jabber-chatstates-composing-sent nil
+ "Has composing notification been sent?
+It can be sent and cancelled several times.")
+(make-variable-buffer-local 'jabber-chatstates-composing-sent)
+
+(defvar jabber-chatstates-paused-timer nil
+ "Timer that counts down from 'composing state to 'paused.")
+(make-variable-buffer-local 'jabber-chatstates-paused-timer)
+
+(defun jabber-chatstates-stop-timer ()
+ "Stop the 'paused timer."
+ (when jabber-chatstates-paused-timer
+ (cancel-timer jabber-chatstates-paused-timer)))
+
+(defun jabber-chatstates-kick-timer ()
+ "Start (or restart) the 'paused timer as approriate."
+ (jabber-chatstates-stop-timer)
+ (setq jabber-chatstates-paused-timer
+ (run-with-timer 5 nil 'jabber-chatstates-send-paused)))
+
+(defun jabber-chatstates-send-paused ()
+ "Send an 'paused state notification."
+ (when (and jabber-chatstates-requested jabber-chatting-with)
+ (setq jabber-chatstates-composing-sent nil)
+ (jabber-send-sexp-if-connected
+ jabber-buffer-connection
+ `(message
+ ((to . ,jabber-chatting-with)
+ (type . "chat"))
+ (paused ((xmlns . ,jabber-chatstates-xmlns)))))))
+
+(defun jabber-chatstates-after-change ()
+ (let* ((composing-now (not (= (point-max) jabber-point-insert)))
+ (state (if composing-now 'composing 'active)))
+ (when (and jabber-chatstates-confirm
+ jabber-chatting-with
+ jabber-chatstates-requested
+ (not (eq composing-now jabber-chatstates-composing-sent)))
+ (jabber-send-sexp-if-connected
+ jabber-buffer-connection
+ `(message
+ ((to . ,jabber-chatting-with)
+ (type . "chat"))
+ (,state ((xmlns . ,jabber-chatstates-xmlns)))))
+ (when (setq jabber-chatstates-composing-sent composing-now)
+ (jabber-chatstates-kick-timer)))))
+
+(defun jabber-handle-incoming-message-chatstates (jc xml-data)
+ (when (get-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from)))
+ (with-current-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from))
+ (cond
+ ;; If we get an error message, we shouldn't report any
+ ;; events, as the requests are mirrored from us.
+ ((string= (jabber-xml-get-attribute xml-data 'type) "error")
+ (remove-hook 'post-command-hook 'jabber-chatstates-after-change t)
+ (setq jabber-chatstates-requested nil))
+
+ (t
+ (let ((state
+ (or
+ (let ((node
+ (cl-find jabber-chatstates-xmlns
+ (jabber-xml-node-children xml-data)
+ :key #'(lambda (x) (jabber-xml-get-attribute x 'xmlns))
+ :test #'string=)))
+ (jabber-xml-node-name node))
+ (let ((node
+ ;; XXX: this is how we interoperate with
+ ;; Google Talk. We should really use a
+ ;; namespace-aware XML parser.
+ (cl-find jabber-chatstates-xmlns
+ (jabber-xml-node-children xml-data)
+ :key #'(lambda (x) (jabber-xml-get-attribute x 'xmlns:cha))
+ :test #'string=)))
+ (when node
+ ;; Strip the "cha:" prefix
+ (let ((name (symbol-name (jabber-xml-node-name node))))
+ (when (> (length name) 4)
+ (intern (substring name 4)))))))))
+ ;; Set up hooks for composition notification
+ (when (and jabber-chatstates-confirm state)
+ (setq jabber-chatstates-requested t)
+ (add-hook 'post-command-hook 'jabber-chatstates-after-change nil t))
+
+ (setq jabber-chatstates-last-state state)
+ (jabber-chatstates-update-message)))))))
+
+;; Add function last in chain, so a chat buffer is already created.
+(add-to-list 'jabber-message-chain 'jabber-handle-incoming-message-chatstates t)
+
+(jabber-disco-advertise-feature "http://jabber.org/protocol/chatstates")
diff --git a/jabber-compose.el b/jabber-compose.el
new file mode 100644
index 0000000..69a6f68
--- /dev/null
+++ b/jabber-compose.el
@@ -0,0 +1,57 @@
+;;;###autoload
+(defun jabber-compose (jc &optional recipient)
+ "Create a buffer for composing a Jabber message.
+
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "To whom? ")))
+
+ (with-current-buffer (get-buffer-create
+ (generate-new-buffer-name
+ (concat
+ "Jabber-Compose"
+ (when recipient
+ (format "-%s" (jabber-jid-displayname recipient))))))
+ (set (make-local-variable 'jabber-widget-alist) nil)
+ (setq jabber-buffer-connection jc)
+ (use-local-map widget-keymap)
+
+ (insert (jabber-propertize "Compose Jabber message\n" 'face 'jabber-title-large))
+
+ (insert (substitute-command-keys "\\Completion available with \\[widget-complete].\n"))
+ (push (cons :recipients
+ (widget-create '(repeat :tag "Recipients" jid)
+ :value (when recipient
+ (list recipient))))
+ jabber-widget-alist)
+
+ (insert "\nSubject: ")
+ (push (cons :subject
+ (widget-create 'editable-field :value ""))
+ jabber-widget-alist)
+
+ (insert "\nText:\n")
+ (push (cons :text
+ (widget-create 'text :value ""))
+ jabber-widget-alist)
+
+ (insert "\n")
+ (widget-create 'push-button :notify #'jabber-compose-send "Send")
+
+ (widget-setup)
+
+ (switch-to-buffer (current-buffer))
+ (goto-char (point-min))))
+
+(defun jabber-compose-send (&rest _ignore)
+ (let ((recipients (widget-value (cdr (assq :recipients jabber-widget-alist))))
+ (subject (widget-value (cdr (assq :subject jabber-widget-alist))))
+ (text (widget-value (cdr (assq :text jabber-widget-alist)))))
+ (when (null recipients)
+ (error "No recipients specified"))
+
+ (dolist (to recipients)
+ (jabber-send-message jabber-buffer-connection to subject text nil))
+
+ (bury-buffer)
+ (message "Message sent")))
diff --git a/jabber-conn.el b/jabber-conn.el
new file mode 100644
index 0000000..0f7ea4e
--- /dev/null
+++ b/jabber-conn.el
@@ -0,0 +1,377 @@
+;; Emacs 24 can be linked with GnuTLS
+(ignore-errors (require 'gnutls))
+
+;; Try two different TLS/SSL libraries, but don't fail if none available.
+(or (ignore-errors (require 'tls))
+ (ignore-errors (require 'ssl)))
+
+(ignore-errors (require 'starttls))
+
+(eval-and-compile
+ (or (ignore-errors (require 'srv))
+ (ignore-errors
+ (let ((load-path (cons (expand-file-name
+ "jabber-fallback-lib"
+ (file-name-directory (locate-library "jabber")))
+ load-path)))
+ (require 'srv)))
+ (error
+ "The srv library was not found in `load-path' or jabber-fallback-lib/ directory")))
+
+(defgroup jabber-conn nil "Jabber Connection Settings."
+ :group 'jabber)
+
+(defun jabber-have-starttls ()
+ "Return non-nil if we can use STARTTLS."
+ (or (and (fboundp 'gnutls-available-p)
+ (gnutls-available-p))
+ (and (featurep 'starttls)
+ (or (and (bound-and-true-p starttls-gnutls-program)
+ (executable-find starttls-gnutls-program))
+ (and (bound-and-true-p starttls-program)
+ (executable-find starttls-program))))))
+
+(defconst jabber-default-connection-type
+ (cond
+ ;; Use STARTTLS if we can...
+ ((jabber-have-starttls)
+ 'starttls)
+ ;; ...else default to unencrypted connection.
+ (t
+ 'network))
+ "Default connection type.
+See `jabber-connect-methods'.")
+
+(defcustom jabber-connection-ssl-program nil
+ "Program used for SSL/TLS connections.
+nil means prefer gnutls but fall back to openssl.
+'gnutls' means use gnutls (through `open-tls-stream').
+'openssl means use openssl (through `open-ssl-stream')."
+ :type '(choice (const :tag "Prefer gnutls, fall back to openssl" nil)
+ (const :tag "Use gnutls" gnutls)
+ (const :tag "Use openssl" openssl))
+ :group 'jabber-conn)
+
+(defcustom jabber-invalid-certificate-servers ()
+ "Jabber servers for which we accept invalid TLS certificates.
+This is a list of server names, each matching the hostname part
+of your JID.
+
+This option has effect only when using native GnuTLS in Emacs 24
+or later."
+ :type '(repeat string)
+ :group 'jabber-conn)
+
+(defvar jabber-connect-methods
+ `((network jabber-network-connect jabber-network-send)
+ (starttls
+ ,(if (and (fboundp 'gnutls-available-p)
+ (gnutls-available-p))
+ ;; With "native" TLS, we can use a normal connection.
+ 'jabber-network-connect
+ 'jabber-starttls-connect)
+ jabber-network-send)
+ (ssl jabber-ssl-connect jabber-ssl-send)
+ (virtual jabber-virtual-connect jabber-virtual-send))
+ "Alist of connection methods and functions.
+First item is the symbol naming the method.
+Second item is the connect function.
+Third item is the send function.")
+
+(defun jabber-get-connect-function (type)
+ "Get the connect function associated with TYPE.
+TYPE is a symbol; see `jabber-connection-type'."
+ (let ((entry (assq type jabber-connect-methods)))
+ (nth 1 entry)))
+
+(defun jabber-get-send-function (type)
+ "Get the send function associated with TYPE.
+TYPE is a symbol; see `jabber-connection-type'."
+ (let ((entry (assq type jabber-connect-methods)))
+ (nth 2 entry)))
+
+(defun jabber-srv-targets (server network-server port)
+ "Find host and port to connect to.
+If NETWORK-SERVER and/or PORT are specified, use them.
+If we can't find SRV records, use standard defaults."
+ ;; If the user has specified a host or a port, obey that.
+ (if (or network-server port)
+ (list (cons (or network-server server)
+ (or port 5222)))
+ (or (condition-case nil
+ (srv-lookup (concat "_xmpp-client._tcp." server))
+ (error nil))
+ (list (cons server 5222)))))
+
+;; Plain TCP/IP connection
+(defun jabber-network-connect (fsm server network-server port)
+ "Connect to a Jabber server with a plain network connection.
+Send a message of the form (:connected CONNECTION) to FSM if
+connection succeeds. Send a message (:connection-failed ERRORS) if
+connection fails."
+ (cond
+ ((featurep 'make-network-process '(:nowait t))
+ ;; We can connect asynchronously!
+ (jabber-network-connect-async fsm server network-server port))
+ (t
+ ;; Connecting to the server will block Emacs.
+ (jabber-network-connect-sync fsm server network-server port))))
+
+(defun jabber-network-connect-async (fsm server network-server port)
+ ;; Get all potential targets...
+ (let ((targets (jabber-srv-targets server network-server port))
+ errors
+ (fsm fsm))
+ ;; ...and connect to them one after another, asynchronously, until
+ ;; connection succeeds.
+ (cl-labels
+ ((connect
+ (target remaining-targets)
+ (let ((target target) (remaining-targets remaining-targets))
+ (cl-labels ((connection-successful
+ (c)
+ ;; This mustn't be `fsm-send-sync', because the FSM
+ ;; needs to change the sentinel, which cannot be done
+ ;; from inside the sentinel.
+ (fsm-send fsm (list :connected c)))
+ (connection-failed
+ (c status)
+ (when (and (> (length status) 0)
+ (eq (aref status (1- (length status))) ?\n))
+ (setq status (substring status 0 -1)))
+ (let ((err
+ (format "Couldn't connect to %s:%s: %s"
+ (car target) (cdr target) status)))
+ (message "%s" err)
+ (push err errors))
+ (when c (delete-process c))
+ (if remaining-targets
+ (progn
+ (message
+ "Connecting to %s:%s..."
+ (caar remaining-targets) (cdar remaining-targets))
+ (connect (car remaining-targets) (cdr remaining-targets)))
+ (fsm-send fsm (list :connection-failed (nreverse errors))))))
+ (condition-case e
+ (make-network-process
+ :name "jabber"
+ :buffer (generate-new-buffer jabber-process-buffer)
+ :host (car target) :service (cdr target)
+ :coding 'utf-8
+ :nowait t
+ :sentinel
+ (let ((_target target) (_remaining-targets remaining-targets))
+ (lambda (connection status)
+ (cond
+ ((string-match "^open" status)
+ (connection-successful connection))
+ ((string-match "^failed" status)
+ (connection-failed connection status))
+ ((string-match "^deleted" status)
+ ;; This happens when we delete a process in the
+ ;; "failed" case above.
+ nil)
+ (t
+ (message "Unknown sentinel status `%s'" status))))))
+ (file-error
+ ;; A file-error has the error message in the third list
+ ;; element.
+ (connection-failed nil (car (cddr e))))
+ (error
+ ;; Not sure if we ever get anything but file-errors,
+ ;; but let's make sure we report them:
+ (connection-failed nil (error-message-string e))))))))
+ (message "Connecting to %s:%s..." (caar targets) (cdar targets))
+ (connect (car targets) (cdr targets)))))
+
+(defun jabber-network-connect-sync (fsm server network-server port)
+ ;; This code will AFAIK only be used on Windows. Apologies in
+ ;; advance for any bit rot...
+ (let ((coding-system-for-read 'utf-8)
+ (coding-system-for-write 'utf-8)
+ (targets (jabber-srv-targets server network-server port))
+ errors)
+ (catch 'connected
+ (dolist (target targets)
+ (condition-case e
+ (let ((process-buffer (generate-new-buffer jabber-process-buffer))
+ connection)
+ (unwind-protect
+ (setq connection (open-network-stream
+ "jabber"
+ process-buffer
+ (car target)
+ (cdr target)))
+
+ (unless (or connection jabber-debug-keep-process-buffers)
+ (kill-buffer process-buffer)))
+
+ (when connection
+ (fsm-send fsm (list :connected connection))
+ (throw 'connected connection)))
+ (file-error
+ ;; A file-error has the error message in the third list
+ ;; element.
+ (let ((err (format "Couldn't connect to %s:%s: %s"
+ (car target) (cdr target)
+ (car (cddr e)))))
+ (message "%s" err)
+ (push err errors)))
+ (error
+ ;; Not sure if we ever get anything but file-errors,
+ ;; but let's make sure we report them:
+ (let ((err (format "Couldn't connect to %s:%s: %s"
+ (car target) (cdr target)
+ (error-message-string e))))
+ (message "%s" err)
+ (push err errors)))))
+ (fsm-send fsm (list :connection-failed (nreverse errors))))))
+
+(defun jabber-network-send (connection string)
+ "Send a string via a plain TCP/IP connection to the Jabber Server."
+ (process-send-string connection string))
+
+;; SSL connection, we use openssl's s_client function for encryption
+;; of the link
+;; TODO: make this configurable
+(defun jabber-ssl-connect (fsm server network-server port)
+ "Connect via OpenSSL or GnuTLS to a Jabber Server.
+Send a message of the form (:connected CONNECTION) to FSM if
+connection succeeds. Send a message (:connection-failed ERRORS) if
+connection fails."
+ (let ((coding-system-for-read 'utf-8)
+ (coding-system-for-write 'utf-8)
+ (connect-function
+ (cond
+ ((and (memq jabber-connection-ssl-program '(nil gnutls))
+ (fboundp 'open-tls-stream))
+ 'open-tls-stream)
+ ((and (memq jabber-connection-ssl-program '(nil openssl))
+ (fboundp 'open-ssl-stream))
+ 'open-ssl-stream)
+ (t
+ (error "Neither TLS nor SSL connect functions available"))))
+ error-msg)
+ (let ((process-buffer (generate-new-buffer jabber-process-buffer))
+ connection)
+ (setq network-server (or network-server server))
+ (setq port (or port 5223))
+ (condition-case e
+ (setq connection (funcall connect-function
+ "jabber"
+ process-buffer
+ network-server
+ port))
+ (error
+ (setq error-msg
+ (format "Couldn't connect to %s:%d: %s" network-server port
+ (error-message-string e)))
+ (message "%s" error-msg)))
+ (unless (or connection jabber-debug-keep-process-buffers)
+ (kill-buffer process-buffer))
+ (if connection
+ (fsm-send fsm (list :connected connection))
+ (fsm-send fsm (list :connection-failed
+ (when error-msg (list error-msg))))))))
+
+(defun jabber-ssl-send (connection string)
+ "Send a string via an SSL-encrypted connection to the Jabber Server."
+ ;; It seems we need to send a linefeed afterwards.
+ (process-send-string connection string)
+ (process-send-string connection "\n"))
+
+(defun jabber-starttls-connect (fsm server network-server port)
+ "Connect via an external GnuTLS process to a Jabber Server.
+Send a message of the form (:connected CONNECTION) to FSM if
+connection succeeds. Send a message (:connection-failed ERRORS) if
+connection fails."
+ (let ((coding-system-for-read 'utf-8)
+ (coding-system-for-write 'utf-8)
+ (targets (jabber-srv-targets server network-server port))
+ errors)
+ (unless (fboundp 'starttls-open-stream)
+ (error "The starttls.el library is not available"))
+ (catch 'connected
+ (dolist (target targets)
+ (condition-case e
+ (let ((process-buffer (generate-new-buffer jabber-process-buffer))
+ connection)
+ (unwind-protect
+ (setq connection
+ (starttls-open-stream
+ "jabber"
+ process-buffer
+ (car target)
+ (cdr target)))
+ (unless (or connection jabber-debug-keep-process-buffers)
+ (kill-buffer process-buffer)))
+ (if (null connection)
+ ;; It seems we don't actually get an error if we
+ ;; can't connect. Let's try to convey some useful
+ ;; information to the user at least.
+ (let ((err (format "Couldn't connect to %s:%s"
+ (car target) (cdr target))))
+ (message "%s" err)
+ (push err errors))
+ (fsm-send fsm (list :connected connection))
+ (throw 'connected connection)))
+ (error
+ (let ((err (format "Couldn't connect to %s: %s" target
+ (error-message-string e))))
+ (message "%s" err)
+ (push err errors)))))
+ (fsm-send fsm (list :connection-failed (nreverse errors))))))
+
+(defun jabber-starttls-initiate (fsm)
+ "Initiate a starttls connection."
+ (jabber-send-sexp fsm
+ '(starttls ((xmlns . "urn:ietf:params:xml:ns:xmpp-tls")))))
+
+(defun jabber-starttls-process-input (fsm xml-data)
+ "Process result of starttls request.
+On failure, signal error.
+
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (cond
+ ((eq (car xml-data) 'proceed)
+ (let* ((state-data (fsm-get-state-data fsm))
+ (connection (plist-get state-data :connection)))
+ ;; Did we use open-network-stream or starttls-open-stream? We
+ ;; can tell by process-type.
+ (cl-case (process-type connection)
+ (network
+ (let* ((hostname (plist-get state-data :server))
+ (verifyp (not (member hostname jabber-invalid-certificate-servers))))
+ ;; gnutls-negotiate might signal an error, which is caught
+ ;; by our caller
+ (gnutls-negotiate
+ :process connection
+ ;; This is the hostname that the certificate should be valid for:
+ :hostname hostname
+ :verify-hostname-error verifyp
+ :verify-error verifyp)))
+ (real
+ (or
+ (starttls-negotiate connection)
+ (error "Negotiation failure"))))))
+ ((eq (car xml-data) 'failure)
+ (error "Command rejected by server"))))
+
+(defvar *jabber-virtual-server-function* nil
+ "Function to use for sending stanzas on a virtual connection.
+The function should accept two arguments, the connection object
+and a string that the connection wants to send.")
+
+(defun jabber-virtual-connect (fsm _server _network-server _port)
+ "Connect to a virtual \"server\".
+Use `*jabber-virtual-server-function*' as send function.
+FSM is the finite state machine created in jabber.el library."
+ (unless (functionp *jabber-virtual-server-function*)
+ (error "No virtual server function specified"))
+ ;; We pass the fsm itself as "connection object", as that is what a
+ ;; virtual server needs to send stanzas.
+ (fsm-send fsm (list :connected fsm)))
+
+(defun jabber-virtual-send (connection string)
+ (funcall *jabber-virtual-server-function* connection string))
diff --git a/jabber-console.el b/jabber-console.el
new file mode 100644
index 0000000..3c83392
--- /dev/null
+++ b/jabber-console.el
@@ -0,0 +1,122 @@
+(require 'ewoc)
+(require 'sgml-mode) ;we base on this mode to hightlight XML
+
+(defcustom jabber-debug-log-xml nil
+ "Set to non-nil to log all XML i/o in *-jabber-console-JID-* buffer.
+Set to string to also dump XML i/o in specified file."
+ :type '(choice (const :tag "Do not dump XML i/o" nil)
+ (const :tag "Dump XML i/o in console" t)
+ (string :tag "Dump XML i/o in console and this file"))
+ :group 'jabber-debug)
+
+(defcustom jabber-console-name-format "*-jabber-console-%s-*"
+ "Format for console buffer name. %s mean connection jid."
+ :type 'string
+ :group 'jabber-debug)
+
+(defcustom jabber-console-truncate-lines 3000
+ "Maximum number of lines in console buffer.
+Not truncate if set to 0."
+ :type 'integer
+ :group 'jabber-debug)
+
+(defvar jabber-point-insert nil
+ "Position where the message being composed starts.")
+
+(defvar jabber-send-function nil
+ "Function for sending a message from a chat buffer.")
+
+(defvar jabber-console-mode-hook nil
+ "Hook called at the end of `jabber-console-mode'.
+Note that functions in this hook have no way of knowing
+what kind of chat buffer is being created.")
+
+(defvar jabber-console-ewoc nil
+ "The ewoc showing the XML elements of this stream buffer.")
+
+(defvar jabber-console-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map jabber-common-keymap)
+ (define-key map "\r" 'jabber-chat-buffer-send)
+ map))
+
+(defun jabber-console-create-buffer (jc)
+ (with-current-buffer
+ (get-buffer-create (format jabber-console-name-format (jabber-connection-bare-jid jc)))
+ (unless (eq major-mode 'jabber-console-mode)
+ (jabber-console-mode))
+ ;; Make sure the connection variable is up to date.
+ (setq jabber-buffer-connection jc)
+ (current-buffer)))
+
+(defun jabber-console-send (jc data)
+ ;; Put manual string into buffers ewoc
+ (jabber-process-console jc "raw" data)
+ ;; ...than sent it to server
+ (jabber-send-string jc data))
+
+(defun jabber-console-comment (str)
+ "Insert comment into console buffer."
+ (let ((string (concat
+ comment-start str "@" (jabber-encode-time (current-time)) ":"
+ comment-end "\n")))
+ (when (stringp jabber-debug-log-xml)
+ (jabber-append-string-to-file string jabber-debug-log-xml))
+ (insert string)))
+
+(defun jabber-console-pp (data)
+ "Pretty Printer for XML-sexp and raw data."
+ (let ((direction (car data))
+ (xml-list (cdr data))
+ (raw (cadr data)))
+ (jabber-console-comment direction)
+ (if (stringp raw)
+ ;; raw code input
+ (progn
+ (insert raw)
+ (when (stringp jabber-debug-log-xml)
+ (jabber-append-string-to-file raw jabber-debug-log-xml)))
+ ;; receive/sending
+ (progn
+ (xml-print xml-list)
+ (when (stringp jabber-debug-log-xml)
+ (jabber-append-string-to-file
+ "\n" jabber-debug-log-xml 'xml-print xml-list))))))
+
+(define-derived-mode jabber-console-mode sgml-mode "Jabber Console"
+ "Major mode for debug XMPP protocol."
+ ;; Make sure to set this variable somewhere
+ (make-local-variable 'jabber-send-function)
+ (make-local-variable 'jabber-point-insert)
+ (make-local-variable 'jabber-console-ewoc)
+
+ (setq jabber-send-function 'jabber-console-send)
+
+ (unless jabber-console-ewoc
+ (setq jabber-console-ewoc
+ (ewoc-create #'jabber-console-pp nil ""))
+ (goto-char (point-max))
+ (put-text-property (point-min) (point) 'read-only t)
+ (let ((inhibit-read-only t))
+ (put-text-property (point-min) (point) 'front-sticky t)
+ (put-text-property (point-min) (point) 'rear-nonsticky t))
+ (setq jabber-point-insert (point-marker))))
+
+(put 'jabber-console-mode 'mode-class 'special)
+
+(defun jabber-console-sanitize (xml-data)
+ "Sanitize XML-DATA for `jabber-process-console'."
+ (if (listp xml-data)
+ (jabber-tree-map (lambda (x) (if (numberp x) (format "%s" x) x)) xml-data)
+ xml-data))
+
+;;;###autoload
+(defun jabber-process-console (jc direction xml-data)
+ "Log XML-DATA i/o as XML in \"*-jabber-console-JID-*\" buffer."
+ (let ((buffer (get-buffer-create (jabber-console-create-buffer jc))))
+ (with-current-buffer buffer
+ (progn
+ (ewoc-enter-last jabber-console-ewoc (list direction (jabber-console-sanitize xml-data)))
+ (when (< 1 jabber-console-truncate-lines)
+ (let ((_jabber-log-lines-to-keep jabber-console-truncate-lines))
+ (jabber-truncate-top buffer jabber-console-ewoc)))))))
diff --git a/jabber-core.el b/jabber-core.el
new file mode 100644
index 0000000..daaf1cf
--- /dev/null
+++ b/jabber-core.el
@@ -0,0 +1,968 @@
+(eval-and-compile
+ (or (ignore-errors (require 'fsm))
+ (ignore-errors
+ (let ((load-path (cons (expand-file-name
+ "jabber-fallback-lib"
+ (file-name-directory (locate-library "jabber")))
+ load-path)))
+ (require 'fsm)))
+ (error
+ "The fsm library was not found in `load-path' or jabber-fallback-lib/ directory")))
+
+(defvar jabber-connections nil
+ "List of jabber-connection FSMs.")
+
+(defvar *jabber-roster* nil
+ "The roster list.")
+
+(defvar jabber-jid-obarray (make-vector 127 0)
+ "Obarray for keeping JIDs.")
+
+(defvar *jabber-disconnecting* nil
+ "Boolean - are we in the process of disconnecting by free will.")
+
+(defvar jabber-message-chain nil
+ "Incoming messages are sent to these functions, in order.")
+
+(defvar jabber-iq-chain nil
+ "Incoming infoqueries are sent to these functions, in order.")
+
+(defvar jabber-presence-chain nil
+ "Incoming presence notifications are sent to these functions, in order.")
+
+(defvar jabber-namespace-prefixes nil
+ "XML namespace prefixes used for the current connection.")
+(make-variable-buffer-local 'jabber-namespace-prefixes)
+
+(defgroup jabber-core nil "customize core functionality."
+ :group 'jabber)
+
+(defcustom jabber-post-connect-hooks '(jabber-send-current-presence
+ jabber-muc-autojoin
+ jabber-whitespace-ping-start
+ jabber-vcard-avatars-find-current)
+ "*Hooks run after successful connection and authentication.
+The functions should accept one argument, the connection object."
+ :type 'hook
+ :options '(jabber-send-current-presence
+ jabber-muc-autojoin
+ jabber-whitespace-ping-start
+ jabber-keepalive-start
+ jabber-vcard-avatars-find-current
+ jabber-autoaway-start)
+ :group 'jabber-core)
+
+(defcustom jabber-pre-disconnect-hook nil
+ "*Hooks run just before voluntary disconnection.
+This might be due to failed authentication."
+ :type 'hook
+ :group 'jabber-core)
+
+(defcustom jabber-lost-connection-hooks nil
+ "*Hooks run after involuntary disconnection.
+The functions are called with one argument: the connection object."
+ :type 'hook
+ :group 'jabber-core)
+
+(defcustom jabber-post-disconnect-hook nil
+ "*Hooks run after disconnection."
+ :type 'hook
+ :group 'jabber-core)
+
+(defcustom jabber-auto-reconnect nil
+ "Reconnect automatically after losing connection?
+This will be of limited use unless you have the password library
+installed, and have configured it to cache your password
+indefinitely. See `password-cache' and `password-cache-expiry'."
+ :type 'boolean
+ :group 'jabber-core)
+
+(defcustom jabber-reconnect-delay 5
+ "Seconds to wait before reconnecting."
+ :type 'integer
+ :group 'jabber-core)
+
+(defcustom jabber-roster-buffer "*-jabber-roster-*"
+ "The name of the roster buffer."
+ :type 'string
+ :group 'jabber-core)
+
+(defcustom jabber-use-sasl t
+ "If non-nil, use SASL if possible.
+SASL will still not be used if the library for it is missing or
+if the server doesn't support it.
+
+Disabling this shouldn't be necessary, but it may solve certain
+problems."
+ :type 'boolean
+ :group 'jabber-core)
+
+(defsubst jabber-have-sasl-p ()
+ "Return non-nil if SASL functions are available."
+ (featurep 'sasl))
+
+(defvar jabber-account-history ()
+ "Keeps track of previously used jabber accounts.")
+
+(defvar jabber-connection-type-history ()
+ "Keeps track of previously used connection types.")
+
+;;;###autoload (autoload 'jabber-connect-all "jabber" "Connect to all configured Jabber accounts.\nSee `jabber-account-list'.\nIf no accounts are configured (or ARG supplied), call `jabber-connect' interactively." t)
+(defun jabber-connect-all (&optional arg)
+ "Connect to all configured Jabber accounts.
+See `jabber-account-list'.
+If no accounts are configured (or with prefix argument), call `jabber-connect'
+interactively.
+With many prefix arguments, one less is passed to `jabber-connect'."
+ (interactive "P")
+ (let ((accounts
+ (cl-remove-if (lambda (account)
+ (cdr (assq :disabled (cdr account))))
+ jabber-account-list)))
+ (if (or (null accounts) arg)
+ (let ((current-prefix-arg
+ (cond
+ ;; A number of C-u's; remove one, so to speak.
+ ((consp arg)
+ (if (> (car arg) 4)
+ (list (/ (car arg) 4))
+ nil))
+ ;; Otherwise, we just don't care.
+ (t
+ arg))))
+ (call-interactively 'jabber-connect))
+ ;; Only connect those accounts that are not yet connected.
+ (let ((already-connected (mapcar #'jabber-connection-original-jid jabber-connections))
+ (connected-one nil))
+ (dolist (account accounts)
+ (unless (member (jabber-jid-user (car account)) already-connected)
+ (let* ((jid (car account))
+ (alist (cdr account))
+ (password (cdr (assq :password alist)))
+ (network-server (cdr (assq :network-server alist)))
+ (port (cdr (assq :port alist)))
+ (connection-type (cdr (assq :connection-type alist))))
+ (jabber-connect
+ (jabber-jid-username jid)
+ (jabber-jid-server jid)
+ (jabber-jid-resource jid)
+ nil password network-server
+ port connection-type)
+ (setq connected-one t))))
+ (unless connected-one
+ (message "All configured Jabber accounts are already connected"))))))
+
+;;;###autoload (autoload 'jabber-connect "jabber" "Connect to the Jabber server and start a Jabber XML stream.\nWith prefix argument, register a new account.\nWith double prefix argument, specify more connection details." t)
+(defun jabber-connect (username server resource &optional
+ registerp password network-server
+ port connection-type)
+ "Connect to the Jabber server and start a Jabber XML stream.
+With prefix argument, register a new account.
+With double prefix argument, specify more connection details."
+ (interactive
+ (let* ((jid (completing-read "Enter your JID: " jabber-account-list nil nil nil 'jabber-account-history))
+ (entry (assoc jid jabber-account-list))
+ (alist (cdr entry))
+ password network-server port connection-type registerp)
+ (when (zerop (length jid))
+ (error "No JID specified"))
+ (unless (jabber-jid-username jid)
+ (error "Missing username part in JID"))
+ (when entry
+ ;; If the user entered the JID of one of the preconfigured
+ ;; accounts, use that data.
+ (setq password (cdr (assq :password alist)))
+ (setq network-server (cdr (assq :network-server alist)))
+ (setq port (cdr (assq :port alist)))
+ (setq connection-type (cdr (assq :connection-type alist))))
+ (when (equal current-prefix-arg '(16))
+ ;; Double prefix arg: ask about everything.
+ ;; (except password, which is asked about later anyway)
+ (setq password nil)
+ (setq network-server
+ (read-string (format "Network server: (default `%s') " network-server)
+ nil nil network-server))
+ (when (zerop (length network-server))
+ (setq network-server nil))
+ (setq port
+ (car
+ (read-from-string
+ (read-string (format "Port: (default `%s') " port)
+ nil nil (if port (number-to-string port) "nil")))))
+ (setq connection-type
+ (car
+ (read-from-string
+ (let ((default (symbol-name (or connection-type jabber-default-connection-type))))
+ (completing-read
+ (format "Connection type: (default `%s') " default)
+ (mapcar (lambda (type)
+ (cons (symbol-name (car type)) nil))
+ jabber-connect-methods)
+ nil t nil 'jabber-connection-type-history default)))))
+ (setq registerp (or jabber-silent-mode (yes-or-no-p "Register new account? "))))
+ (when (equal current-prefix-arg '(4))
+ (setq registerp t))
+
+ (list (jabber-jid-username jid)
+ (jabber-jid-server jid)
+ (jabber-jid-resource jid)
+ registerp password network-server port connection-type)))
+
+ (if (member (list username
+ server)
+ (mapcar
+ (lambda (c)
+ (let ((data (fsm-get-state-data c)))
+ (list (plist-get data :username)
+ (plist-get data :server))))
+ jabber-connections))
+ (message "Already connected to %s@%s"
+ username server)
+ ;;(jabber-clear-roster)
+
+ (push (start-jabber-connection username server resource
+ registerp password
+ network-server port connection-type)
+ jabber-connections)))
+
+(define-state-machine jabber-connection
+ :start ((username server resource registerp password network-server port connection-type)
+ "Start a Jabber connection."
+ (let* ((connection-type
+ (or connection-type jabber-default-connection-type))
+ (send-function
+ (jabber-get-send-function connection-type)))
+
+ (list :connecting
+ (list :send-function send-function
+ ;; Save the JID we originally connected with.
+ :original-jid (concat username "@" server)
+ :username username
+ :server server
+ :resource resource
+ :password password
+ :registerp registerp
+ :connection-type connection-type
+ :encrypted (eq connection-type 'ssl)
+ :network-server network-server
+ :port port)))))
+
+(define-enter-state jabber-connection nil
+ (fsm state-data)
+ ;; `nil' is the error state.
+
+ ;; Close the network connection.
+ (let ((connection (plist-get state-data :connection)))
+ (when (processp connection)
+ (let ((process-buffer (process-buffer connection)))
+ (delete-process connection)
+ (when (and (bufferp process-buffer)
+ (not jabber-debug-keep-process-buffers))
+ (kill-buffer process-buffer)))))
+ (setq state-data (plist-put state-data :connection nil))
+ ;; Clear MUC data
+ (jabber-muc-connection-closed (jabber-connection-bare-jid fsm))
+ ;; Remove lost connections from the roster buffer.
+ (jabber-display-roster)
+ (let ((expected (plist-get state-data :disconnection-expected))
+ (reason (plist-get state-data :disconnection-reason))
+ (ever-session-established (plist-get state-data :ever-session-established)))
+ (unless expected
+ (run-hook-with-args 'jabber-lost-connection-hooks fsm)
+ (message "%s@%s%s: connection lost: `%s'"
+ (plist-get state-data :username)
+ (plist-get state-data :server)
+ (if (plist-get state-data :resource)
+ (concat "/" (plist-get state-data :resource))
+ "")
+ reason))
+
+ (if (and jabber-auto-reconnect (not expected) ever-session-established)
+ ;; Reconnect after a short delay?
+ (list state-data jabber-reconnect-delay)
+ ;; Else the connection is really dead. Remove it from the list
+ ;; of connections.
+ (setq jabber-connections
+ (delq fsm jabber-connections))
+ (when jabber-mode-line-mode
+ (jabber-mode-line-presence-update))
+ (jabber-display-roster)
+ ;; And let the FSM sleep...
+ (list state-data nil))))
+
+(define-state jabber-connection nil
+ (fsm state-data event callback)
+ ;; In the `nil' state, the connection is dead. We wait for a
+ ;; :timeout message, meaning to reconnect, or :do-disconnect,
+ ;; meaning to cancel reconnection.
+ (cl-case event
+ (:timeout
+ (list :connecting state-data))
+ (:do-disconnect
+ (setq jabber-connections
+ (delq fsm jabber-connections))
+ (list nil state-data nil))))
+
+(define-enter-state jabber-connection :connecting
+ (fsm state-data)
+ (let* ((connection-type (plist-get state-data :connection-type))
+ (connect-function (jabber-get-connect-function connection-type))
+ (server (plist-get state-data :server))
+ (network-server (plist-get state-data :network-server))
+ (port (plist-get state-data :port)))
+ (funcall connect-function fsm server network-server port))
+ (list state-data nil))
+
+(define-state jabber-connection :connecting
+ (fsm state-data event callback)
+ (cl-case (or (car-safe event) event)
+ (:connected
+ (let ((connection (cadr event))
+ (registerp (plist-get state-data :registerp)))
+
+ (setq state-data (plist-put state-data :connection connection))
+
+ (when (processp connection)
+ ;; TLS connections leave data in the process buffer, which
+ ;; the XML parser will choke on.
+ (with-current-buffer (process-buffer connection)
+ (erase-buffer))
+
+ (set-process-filter connection (fsm-make-filter fsm))
+ (set-process-sentinel connection (fsm-make-sentinel fsm)))
+
+ (list :connected state-data)))
+
+ (:connection-failed
+ (message "Jabber connection failed")
+ (plist-put state-data :disconnection-reason
+ (mapconcat #'identity (cadr event) "; "))
+ (list nil state-data))
+
+ (:do-disconnect
+ ;; We don't have the connection object, so defer the disconnection.
+ :defer)))
+
+(defsubst jabber-fsm-handle-sentinel (state-data event)
+ "Handle sentinel event for jabber fsm."
+ ;; We do the same thing for every state, so avoid code duplication.
+ (let* ((string (car (cddr event)))
+ ;; The event string sometimes (always?) has a trailing
+ ;; newline, that we don't care for.
+ (trimmed-string
+ (if (eq ?\n (aref string (1- (length string))))
+ (substring string 0 -1)
+ string))
+ (new-state-data
+ ;; If we already know the reason (e.g. a stream error), don't
+ ;; overwrite it.
+ (if (plist-get state-data :disconnection-reason)
+ state-data
+ (plist-put state-data :disconnection-reason trimmed-string))))
+ (list nil new-state-data)))
+
+(define-enter-state jabber-connection :connected
+ (fsm state-data)
+
+ (jabber-send-stream-header fsm)
+
+ ;; Next thing happening is the server sending its own start tag.
+
+ (list state-data nil))
+
+(define-state jabber-connection :connected
+ (fsm state-data event callback)
+ (cl-case (or (car-safe event) event)
+ (:filter
+ (let ((process (cadr event))
+ (string (car (cddr event))))
+ (jabber-pre-filter process string fsm)
+ (list :connected state-data)))
+
+ (:sentinel
+ (jabber-fsm-handle-sentinel state-data event))
+
+ (:stream-start
+ (let ((session-id (cadr event))
+ (stream-version (car (cddr event))))
+ (setq state-data
+ (plist-put state-data :session-id session-id))
+ ;; the stream feature is only sent if the initiating entity has
+ ;; sent 1.0 in the stream header. if sasl is not supported then
+ ;; we don't send 1.0 in the header and therefore we shouldn't wait
+ ;; even if 1.0 is present in the receiving stream.
+ (cond
+ ;; Wait for stream features?
+ ((and stream-version
+ (>= (string-to-number stream-version) 1.0)
+ jabber-use-sasl
+ (jabber-have-sasl-p))
+ ;; Stay in same state...
+ (list :connected state-data))
+ ;; Register account?
+ ((plist-get state-data :registerp)
+ ;; XXX: require encryption for registration?
+ (list :register-account state-data))
+ ;; Legacy authentication?
+ (t
+ (list :legacy-auth state-data)))))
+
+ (:stanza
+ (let ((stanza (cadr event)))
+ (cond
+ ;; At this stage, we only expect a stream:features stanza.
+ ((not (eq (jabber-xml-node-name stanza) 'features))
+ (list nil (plist-put state-data
+ :disconnection-reason
+ (format "Unexpected stanza %s" stanza))))
+ ((and (jabber-xml-get-children stanza 'starttls)
+ (eq (plist-get state-data :connection-type) 'starttls))
+ (list :starttls state-data))
+ ;; XXX: require encryption for registration?
+ ((plist-get state-data :registerp)
+ ;; We could check for the element in stream
+ ;; features, but as a client we would only lose by doing
+ ;; that.
+ (list :register-account state-data))
+ (t
+ (list :sasl-auth (plist-put state-data :stream-features stanza))))))
+
+ (:do-disconnect
+ (jabber-send-string fsm "")
+ (list nil (plist-put state-data
+ :disconnection-expected t)))))
+
+(define-enter-state jabber-connection :starttls
+ (fsm state-data)
+ (jabber-starttls-initiate fsm)
+ (list state-data nil))
+
+(define-state jabber-connection :starttls
+ (fsm state-data event callback)
+ (cl-case (or (car-safe event) event)
+ (:filter
+ (let ((process (cadr event))
+ (string (car (cddr event))))
+ (jabber-pre-filter process string fsm)
+ (list :starttls state-data)))
+
+ (:sentinel
+ (jabber-fsm-handle-sentinel state-data event))
+
+ (:stanza
+ (condition-case e
+ (progn
+ (jabber-starttls-process-input fsm (cadr event))
+ ;; Connection is encrypted. Send a stream tag again.
+ (list :connected (plist-put state-data :encrypted t)))
+ (error
+ (let* ((msg (concat "STARTTLS negotiation failed: "
+ (error-message-string e)))
+ (new-state-data (plist-put state-data :disconnection-reason msg)))
+ (list nil new-state-data)))))
+
+ (:do-disconnect
+ (jabber-send-string fsm "")
+ (list nil (plist-put state-data
+ :disconnection-expected t)))))
+
+(define-enter-state jabber-connection :register-account
+ (fsm state-data)
+ (jabber-get-register fsm nil)
+ (list state-data nil))
+
+(define-state jabber-connection :register-account
+ (fsm state-data event callback)
+ ;; The connection will be closed in jabber-register
+ (cl-case (or (car-safe event) event)
+ (:filter
+ (let ((process (cadr event))
+ (string (car (cddr event))))
+ (jabber-pre-filter process string fsm)
+ (list :register-account state-data)))
+
+ (:sentinel
+ (jabber-fsm-handle-sentinel state-data event))
+
+ (:stanza
+ (or
+ (jabber-process-stream-error (cadr event) state-data)
+ (progn
+ (jabber-process-input fsm (cadr event))
+ (list :register-account state-data))))
+
+ (:do-disconnect
+ (jabber-send-string fsm "")
+ (list nil (plist-put state-data
+ :disconnection-expected t)))))
+
+(define-enter-state jabber-connection :legacy-auth
+ (fsm state-data)
+ (jabber-get-auth fsm (plist-get state-data :server)
+ (plist-get state-data :session-id))
+ (list state-data nil))
+
+(define-state jabber-connection :legacy-auth
+ (fsm state-data event callback)
+ (cl-case (or (car-safe event) event)
+ (:filter
+ (let ((process (cadr event))
+ (string (car (cddr event))))
+ (jabber-pre-filter process string fsm)
+ (list :legacy-auth state-data)))
+
+ (:sentinel
+ (jabber-fsm-handle-sentinel state-data event))
+
+ (:stanza
+ (or
+ (jabber-process-stream-error (cadr event) state-data)
+ (progn
+ (jabber-process-input fsm (cadr event))
+ (list :legacy-auth state-data))))
+
+ (:authentication-success
+ (jabber-cache-password (jabber-connection-bare-jid fsm) (cdr event))
+ (list :session-established state-data))
+
+ (:authentication-failure
+ (jabber-uncache-password (jabber-connection-bare-jid fsm))
+ ;; jabber-logon has already displayed a message
+ (list nil (plist-put state-data
+ :disconnection-expected t)))
+
+ (:do-disconnect
+ (jabber-send-string fsm "")
+ (list nil (plist-put state-data
+ :disconnection-expected t)))))
+
+(define-enter-state jabber-connection :sasl-auth
+ (fsm state-data)
+ (let ((new-state-data
+ (plist-put state-data
+ :sasl-data
+ (jabber-sasl-start-auth
+ fsm
+ (plist-get state-data
+ :stream-features)))))
+ (list new-state-data nil)))
+
+(define-state jabber-connection :sasl-auth
+ (fsm state-data event callback)
+ (cl-case (or (car-safe event) event)
+ (:filter
+ (let ((process (cadr event))
+ (string (car (cddr event))))
+ (jabber-pre-filter process string fsm)
+ (list :sasl-auth state-data)))
+
+ (:sentinel
+ (jabber-fsm-handle-sentinel state-data event))
+
+ (:stanza
+ (let ((new-sasl-data
+ (jabber-sasl-process-input
+ fsm (cadr event)
+ (plist-get state-data :sasl-data))))
+ (list :sasl-auth (plist-put state-data :sasl-data new-sasl-data))))
+
+ (:use-legacy-auth-instead
+ (list :legacy-auth (plist-put state-data :sasl-data nil)))
+
+ (:authentication-success
+ (jabber-cache-password (jabber-connection-bare-jid fsm) (cdr event))
+ (list :bind (plist-put state-data :sasl-data nil)))
+
+ (:authentication-failure
+ (jabber-uncache-password (jabber-connection-bare-jid fsm))
+ ;; jabber-sasl has already displayed a message
+ (list nil (plist-put state-data
+ :disconnection-expected t)))
+
+ (:do-disconnect
+ (jabber-send-string fsm "")
+ (list nil (plist-put state-data
+ :disconnection-expected t)))))
+
+(define-enter-state jabber-connection :bind
+ (fsm state-data)
+ (jabber-send-stream-header fsm)
+ (list state-data nil))
+
+(define-state jabber-connection :bind
+ (fsm state-data event callback)
+ (cl-case (or (car-safe event) event)
+ (:filter
+ (let ((process (cadr event))
+ (string (car (cddr event))))
+ (jabber-pre-filter process string fsm)
+ (list :bind state-data)))
+
+ (:sentinel
+ (jabber-fsm-handle-sentinel state-data event))
+
+ (:stream-start
+ ;; we wait for stream features...
+ (list :bind state-data))
+
+ (:stanza
+ (let ((stanza (cadr event)))
+ (cond
+ ((eq (jabber-xml-node-name stanza) 'features)
+ ;; Record stream features, discarding earlier data:
+ (setq state-data (plist-put state-data :stream-features stanza))
+ (if (jabber-xml-get-children stanza 'bind)
+ (let ((handle-bind
+ (lambda (jc xml-data success)
+ (fsm-send jc (list
+ (if success :bind-success :bind-failure)
+ xml-data))))
+ ;; So let's bind a resource. We can either pick a resource ourselves,
+ ;; or have the server pick one for us.
+ (resource (plist-get state-data :resource)))
+ (jabber-send-iq fsm nil "set"
+ `(bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind"))
+ ,@(when resource
+ `((resource () ,resource))))
+ handle-bind t
+ handle-bind nil)
+ (list :bind state-data))
+ (message "Server doesn't permit resource binding")
+ (list nil state-data)))
+ (t
+ (or
+ (jabber-process-stream-error (cadr event) state-data)
+ (progn
+ (jabber-process-input fsm (cadr event))
+ (list :bind state-data)))))))
+
+ (:bind-success
+ (let ((jid (jabber-xml-path (cadr event) '(bind jid ""))))
+ ;; Maybe this isn't the JID we asked for.
+ (plist-put state-data :username (jabber-jid-username jid))
+ (plist-put state-data :server (jabber-jid-server jid))
+ (plist-put state-data :resource (jabber-jid-resource jid)))
+
+ ;; If the server follows the older RFCs 3920 and 3921, it may
+ ;; offer session initiation here. If it follows RFCs 6120 and
+ ;; 6121, it might not offer it, and we should just skip it.
+ (if (jabber-xml-get-children (plist-get state-data :stream-features) 'session)
+ (let ((handle-session
+ (lambda (jc xml-data success)
+ (fsm-send jc (list
+ (if success :session-success :session-failure)
+ xml-data)))))
+ (jabber-send-iq fsm nil "set"
+ '(session ((xmlns . "urn:ietf:params:xml:ns:xmpp-session")))
+ handle-session t
+ handle-session nil)
+ (list :bind state-data))
+ ;; Session establishment not offered - assume not necessary.
+ (list :session-established state-data)))
+
+ (:session-success
+ ;; We have a session
+ (list :session-established state-data))
+
+ (:bind-failure
+ (message "Resource binding failed: %s"
+ (jabber-parse-error
+ (jabber-iq-error (cadr event))))
+ (list nil state-data))
+
+ (:session-failure
+ (message "Session establishing failed: %s"
+ (jabber-parse-error
+ (jabber-iq-error (cadr event))))
+ (list nil state-data))
+
+ (:do-disconnect
+ (jabber-send-string fsm "")
+ (list nil (plist-put state-data
+ :disconnection-expected t)))))
+
+(defvar jabber-pending-presence-timeout 0.5
+ "Wait this long before doing presence packet batch processing.")
+
+(define-enter-state jabber-connection :session-established
+ (fsm state-data)
+ (jabber-send-iq fsm nil
+ "get"
+ '(query ((xmlns . "jabber:iq:roster")))
+ #'jabber-process-roster 'initial
+ #'jabber-initial-roster-failure nil)
+ (list (plist-put state-data :ever-session-established t) nil))
+
+(define-state jabber-connection :session-established
+ (fsm state-data event callback)
+ (cl-case (or (car-safe event) event)
+ (:filter
+ (let ((process (cadr event))
+ (string (car (cddr event))))
+ (jabber-pre-filter process string fsm)
+ (list :session-established state-data :keep)))
+
+ (:sentinel
+ (jabber-fsm-handle-sentinel state-data event))
+
+ (:stanza
+ (or
+ (jabber-process-stream-error (cadr event) state-data)
+ (progn
+ (jabber-process-input fsm (cadr event))
+ (list :session-established state-data :keep))))
+
+ (:roster-update
+ ;; Batch up roster updates
+ (let* ((jid-symbol-to-update (cdr event))
+ (pending-updates (plist-get state-data :roster-pending-updates)))
+ ;; If there are pending updates, there is a timer running
+ ;; already; just add the new symbol and wait.
+ (if pending-updates
+ (progn
+ (unless (memq jid-symbol-to-update pending-updates)
+ (nconc pending-updates (list jid-symbol-to-update)))
+ (list :session-established state-data :keep))
+ ;; Otherwise, we need to create the list and start the timer.
+ (setq state-data
+ (plist-put state-data
+ :roster-pending-updates
+ (list jid-symbol-to-update)))
+ (list :session-established state-data jabber-pending-presence-timeout))))
+
+ (:timeout
+ ;; Update roster
+ (let ((pending-updates (plist-get state-data :roster-pending-updates)))
+ (setq state-data (plist-put state-data :roster-pending-updates nil))
+ (jabber-roster-update fsm nil pending-updates nil)
+ (list :session-established state-data)))
+
+ (:send-if-connected
+ ;; This is the only state in which we respond to such messages.
+ ;; This is to make sure we don't send anything inappropriate
+ ;; during authentication etc.
+ (jabber-send-sexp fsm (cdr event))
+ (list :session-established state-data :keep))
+
+ (:do-disconnect
+ (jabber-send-string fsm "")
+ (list nil (plist-put state-data
+ :disconnection-expected t)))))
+
+(defun jabber-disconnect (&optional arg)
+ "Disconnect from all Jabber servers. If ARG supplied, disconnect one account."
+ (interactive "P")
+ (if arg
+ (jabber-disconnect-one (jabber-read-account))
+ (unless *jabber-disconnecting* ; avoid reentry
+ (let ((*jabber-disconnecting* t))
+ (if (null jabber-connections)
+ (message "Already disconnected")
+ (run-hooks 'jabber-pre-disconnect-hook)
+ (dolist (c jabber-connections)
+ (jabber-disconnect-one c t))
+ (setq jabber-connections nil)
+
+ (jabber-disconnected)
+ (when (called-interactively-p 'interactive)
+ (message "Disconnected from Jabber server(s)")))))))
+
+(defun jabber-disconnect-one (jc &optional dont-redisplay)
+ "Disconnect from one Jabber server.
+If DONT-REDISPLAY is non-nil, don't update roster buffer.
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)))
+ (fsm-send-sync jc :do-disconnect)
+ (when (called-interactively-p 'interactive)
+ (message "Disconnected from %s"
+ (jabber-connection-jid jc)))
+ (unless dont-redisplay
+ (jabber-display-roster)))
+
+(defun jabber-disconnected ()
+ "Re-initialise jabber package variables.
+Call this function after disconnection."
+ (when (get-buffer jabber-roster-buffer)
+ (with-current-buffer (get-buffer jabber-roster-buffer)
+ (let ((inhibit-read-only t))
+ (erase-buffer))))
+
+ (jabber-clear-roster)
+ (run-hooks 'jabber-post-disconnect-hook))
+
+(defun jabber-log-xml (fsm direction data)
+ "Print DATA to XML console (and, optionally, in file).
+If `jabber-debug-log-xml' is nil, do nothing.
+FSM is the connection that is sending/receiving.
+DIRECTION is a string, either \"sending\" or \"receive\".
+DATA is any sexp."
+ (when jabber-debug-log-xml
+ (jabber-process-console fsm direction data)))
+
+(defun jabber-pre-filter (process string fsm)
+ (with-current-buffer (process-buffer process)
+ ;; Append new data
+ (goto-char (point-max))
+ (insert string)
+
+ (unless (boundp 'jabber-filtering)
+ (let (jabber-filtering)
+ (jabber-filter process fsm)))))
+
+(defun jabber-filter (process fsm)
+ "The filter function for the jabber process."
+ (with-current-buffer (process-buffer process)
+ ;; Start from the beginning
+ (goto-char (point-min))
+ (let (xml-data)
+ (cl-loop
+ do
+ ;; Skip whitespace
+ (unless (zerop (skip-chars-forward " \t\r\n"))
+ (delete-region (point-min) (point)))
+ ;; Skip processing directive
+ (when (looking-at "<\\?xml[^?]*\\?>")
+ (delete-region (match-beginning 0) (match-end 0)))
+
+ ;; Stream end?
+ (when (looking-at "")
+ (cl-return (fsm-send fsm :stream-end)))
+
+ ;; Stream header?
+ (when (looking-at "]*\\(>\\)")
+ ;; Let's pretend that the stream header is a closed tag,
+ ;; and parse it as such.
+ (replace-match "/>" t t nil 1)
+ (let* ((ending-at (point))
+ (stream-header (car (xml-parse-region (point-min) ending-at)))
+ (session-id (jabber-xml-get-attribute stream-header 'id))
+ (stream-version (jabber-xml-get-attribute stream-header 'version)))
+
+ ;; Need to keep any namespace attributes on the stream
+ ;; header, as they can affect any stanza in the
+ ;; stream...
+ (setq jabber-namespace-prefixes
+ (jabber-xml-merge-namespace-declarations
+ (jabber-xml-node-attributes stream-header)
+ nil))
+ (jabber-log-xml fsm "receive" stream-header)
+ (fsm-send fsm (list :stream-start session-id stream-version))
+ (delete-region (point-min) ending-at)))
+
+ ;; Normal tag
+
+ ;; XXX: do these checks make sense? If so, reinstate them.
+ ;;(if (active-minibuffer-window)
+ ;; (run-with-idle-timer 0.01 nil #'jabber-filter process string)
+
+ ;; This check is needed for xml.el of Emacs 21, as it chokes on
+ ;; empty attribute values.
+ (save-excursion
+ (while (search-forward-regexp " \\w+=''" nil t)
+ (replace-match "")))
+
+ (setq xml-data (jabber-xml-parse-next-stanza))
+
+ while xml-data
+ do
+ ;; If there's a problem with writing the XML log,
+ ;; make sure the stanza is delivered, at least.
+ (condition-case e
+ (jabber-log-xml fsm "receive" (car xml-data))
+ (error
+ (ding)
+ (message "Couldn't write XML log: %s" (error-message-string e))
+ (sit-for 2)))
+ (delete-region (point-min) (point))
+
+ (fsm-send fsm (list :stanza
+ (jabber-xml-resolve-namespace-prefixes
+ (car xml-data) nil jabber-namespace-prefixes)))
+ ;; XXX: move this logic elsewhere
+ ;; We explicitly don't catch errors in jabber-process-input,
+ ;; to facilitate debugging.
+ ;; (jabber-process-input (car xml-data))
+ ))))
+
+(defun jabber-process-input (jc xml-data)
+ "Process an incoming parsed tag.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let* ((tag (jabber-xml-node-name xml-data))
+ (functions (eval (cdr (assq tag '((iq . jabber-iq-chain)
+ (presence . jabber-presence-chain)
+ (message . jabber-message-chain)))))))
+ (dolist (f functions)
+ (condition-case e
+ (funcall f jc xml-data)
+ ((debug error)
+ (fsm-debug-output "Error %S while processing %S with function %s" e xml-data f))))))
+
+(defun jabber-process-stream-error (xml-data state-data)
+ "Process an incoming stream error.
+Return nil if XML-DATA is not a stream:error stanza.
+Return an fsm result list if it is."
+ (when (and (eq (jabber-xml-node-name xml-data) 'error)
+ (equal (jabber-xml-get-xmlns xml-data) "http://etherx.jabber.org/streams"))
+ (let ((condition (jabber-stream-error-condition xml-data))
+ (text (jabber-parse-stream-error xml-data)))
+ (setq state-data (plist-put state-data :disconnection-reason
+ (format "Stream error: %s" text)))
+ ;; Special case: when the error is `conflict', we have been
+ ;; forcibly disconnected by the same user. Don't reconnect
+ ;; automatically.
+ (when (eq condition 'conflict)
+ (setq state-data (plist-put state-data :disconnection-expected t)))
+ (list nil state-data))))
+
+;; XXX: This function should probably die. The roster is stored
+;; inside the connection plists, and the obarray shouldn't be so big
+;; that we need to clean it.
+(defun jabber-clear-roster ()
+ "Clean up the roster."
+ ;; This is made complicated by the fact that the JIDs are symbols with properties.
+ (mapatoms #'(lambda (x)
+ (unintern x jabber-jid-obarray))
+ jabber-jid-obarray)
+ (setq *jabber-roster* nil))
+
+(defun jabber-send-sexp (jc sexp)
+ "Send the xml corresponding to SEXP to connection JC."
+ (condition-case e
+ (jabber-log-xml jc "sending" sexp)
+ (error
+ (ding)
+ (message "Couldn't write XML log: %s" (error-message-string e))
+ (sit-for 2)))
+ (jabber-send-string jc (jabber-sexp2xml sexp)))
+
+(defun jabber-send-sexp-if-connected (jc sexp)
+ "Send the stanza SEXP only if JC has established a session."
+ (fsm-send-sync jc (cons :send-if-connected sexp)))
+
+(defun jabber-send-stream-header (jc)
+ "Send stream header to connection JC."
+ (let ((stream-header
+ (concat "
+")))
+ (jabber-log-xml jc "sending" stream-header)
+ (jabber-send-string jc stream-header)))
+
+(defun jabber-send-string (jc string)
+ "Send STRING through the connection JC."
+ (let* ((state-data (fsm-get-state-data jc))
+ (connection (plist-get state-data :connection))
+ (send-function (plist-get state-data :send-function)))
+ (unless connection
+ (error "%s has no connection" (jabber-connection-jid jc)))
+ (funcall send-function connection string)))
diff --git a/jabber-disco.el b/jabber-disco.el
new file mode 100644
index 0000000..4aba681
--- /dev/null
+++ b/jabber-disco.el
@@ -0,0 +1,634 @@
+;;;###autoload
+(eval-after-load "jabber-core"
+ '(add-to-list 'jabber-presence-chain #'jabber-process-caps))
+
+(defvar jabber-caps-cache (make-hash-table :test 'equal))
+
+(defconst jabber-caps-hash-names
+ (if (fboundp 'secure-hash)
+ '(("sha-1" . sha1)
+ ("sha-224" . sha224)
+ ("sha-256" . sha256)
+ ("sha-384" . sha384)
+ ("sha-512" . sha512))
+ ;; `secure-hash' was introduced in Emacs 24. For Emacs 23, fall
+ ;; back to the `sha1' function, handled specially in
+ ;; `jabber-caps--secure-hash'.
+ '(("sha-1" . sha1)))
+ "Hash function name map.
+Maps names defined in http://www.iana.org/assignments/hash-function-text-names
+to symbols accepted by `secure-hash'.
+
+XEP-0115 currently recommends SHA-1, but let's be future-proof.")
+
+(defun jabber-caps-get-cached (jid)
+ "Get disco info from Entity Capabilities cache.
+JID should be a string containing a full JID.
+Return (IDENTITIES FEATURES), or nil if not in cache."
+ (let* ((symbol (jabber-jid-symbol jid))
+ (resource (or (jabber-jid-resource jid) ""))
+ (resource-plist (cdr (assoc resource (get symbol 'resources))))
+ (key (plist-get resource-plist 'caps)))
+ (when key
+ (let ((cache-entry (gethash key jabber-caps-cache)))
+ (when (and (consp cache-entry) (not (floatp (car cache-entry))))
+ cache-entry)))))
+
+;;;###autoload
+(defun jabber-process-caps (jc xml-data)
+ "Look for entity capabilities in presence stanzas.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let* ((from (jabber-xml-get-attribute xml-data 'from))
+ (type (jabber-xml-get-attribute xml-data 'type))
+ (c (jabber-xml-path xml-data '(("http://jabber.org/protocol/caps" . "c")))))
+ (when (and (null type) c)
+ (jabber-xml-let-attributes
+ (ext hash node ver) c
+ (cond
+ (hash
+ ;; If the element has a hash attribute, it follows the
+ ;; "modern" version of XEP-0115.
+ (jabber-process-caps-modern jc from hash node ver))
+ (t
+ ;; No hash attribute. Use legacy version of XEP-0115.
+ ;; TODO: do something clever here.
+ ))))))
+
+(defun jabber-process-caps-modern (jc jid hash node ver)
+ (when (assoc hash jabber-caps-hash-names)
+ ;; We support the hash function used.
+ (let* ((key (cons hash ver))
+ (cache-entry (gethash key jabber-caps-cache)))
+ ;; Remember the hash in the JID symbol.
+ (let* ((symbol (jabber-jid-symbol jid))
+ (resource (or (jabber-jid-resource jid) ""))
+ (resource-entry (assoc resource (get symbol 'resources)))
+ (new-resource-plist (plist-put (cdr resource-entry) 'caps key)))
+ (if resource-entry
+ (setf (cdr resource-entry) new-resource-plist)
+ (push (cons resource new-resource-plist) (get symbol 'resources))))
+
+ (cl-flet ((request-disco-info
+ ()
+ (jabber-send-iq
+ jc jid
+ "get"
+ `(query ((xmlns . "http://jabber.org/protocol/disco#info")
+ (node . ,(concat node "#" ver))))
+ #'jabber-process-caps-info-result (list hash node ver)
+ #'jabber-process-caps-info-error (list hash node ver))))
+ (cond
+ ((and (consp cache-entry)
+ (floatp (car cache-entry)))
+ ;; We have a record of asking someone about this hash.
+ (if (< (- (float-time) (car cache-entry)) 10.0)
+ ;; We asked someone about this hash less than 10 seconds ago.
+ ;; Let's add the new JID to the entry, just in case that
+ ;; doesn't work out.
+ (cl-pushnew jid (cdr cache-entry) :test #'string=)
+ ;; We asked someone about it more than 10 seconds ago.
+ ;; They're probably not going to answer. Let's ask
+ ;; this contact about it instead.
+ (setf (car cache-entry) (float-time))
+ (request-disco-info)))
+ ((null cache-entry)
+ ;; We know nothing about this hash. Let's note the
+ ;; fact that we tried to get information about it.
+ (puthash key (list (float-time)) jabber-caps-cache)
+ (request-disco-info))
+ (t
+ ;; We already know what this hash represents, so we
+ ;; can cache info for this contact.
+ (puthash (cons jid nil) cache-entry jabber-disco-info-cache)))))))
+
+(defun jabber-process-caps-info-result (jc xml-data closure-data)
+ (cl-destructuring-bind (hash node ver) closure-data
+ (let* ((key (cons hash ver))
+ (query (jabber-iq-query xml-data))
+ (verification-string (jabber-caps-ver-string query hash)))
+ (if (string= ver verification-string)
+ ;; The hash is correct; save info.
+ (puthash key (jabber-disco-parse-info xml-data) jabber-caps-cache)
+ ;; The hash is incorrect.
+ (jabber-caps-try-next jc hash node ver)))))
+
+(defun jabber-process-caps-info-error (jc xml-data closure-data)
+ (cl-destructuring-bind (hash node ver) closure-data
+ (jabber-caps-try-next jc hash node ver)))
+
+(defun jabber-caps-try-next (jc hash node ver)
+ (let* ((key (cons hash ver))
+ (cache-entry (gethash key jabber-caps-cache)))
+ (when (floatp (car-safe cache-entry))
+ (let ((next-jid (pop (cdr cache-entry))))
+ ;; Do we know someone else we could ask about this hash?
+ (if next-jid
+ (progn
+ (setf (car cache-entry) (float-time))
+ (jabber-send-iq
+ jc next-jid
+ "get"
+ `(query ((xmlns . "http://jabber.org/protocol/disco#info")
+ (node . ,(concat node "#" ver))))
+ #'jabber-process-caps-info-result (list hash node ver)
+ #'jabber-process-caps-info-error (list hash node ver)))
+ ;; No, forget about it for now.
+ (remhash key jabber-caps-cache))))))
+
+(defun jabber-caps-ver-string (query hash)
+ ;; XEP-0115, section 5.1
+ ;; 1. Initialize an empty string S.
+ (with-temp-buffer
+ (let* ((identities (jabber-xml-get-children query 'identity))
+ (disco-features (mapcar (lambda (f) (jabber-xml-get-attribute f 'var))
+ (jabber-xml-get-children query 'feature)))
+ (maybe-forms (jabber-xml-get-children query 'x))
+ (forms (cl-remove-if-not
+ (lambda (x)
+ ;; Keep elements that are forms and have a FORM_TYPE,
+ ;; according to XEP-0128.
+ (and (string= (jabber-xml-get-xmlns x) "jabber:x:data")
+ (jabber-xdata-formtype x)))
+ maybe-forms)))
+ ;; 2. Sort the service discovery identities [15] by category
+ ;; and then by type and then by xml:lang (if it exists),
+ ;; formatted as CATEGORY '/' [TYPE] '/' [LANG] '/'
+ ;; [NAME]. [16] Note that each slash is included even if the
+ ;; LANG or NAME is not included (in accordance with XEP-0030,
+ ;; the category and type MUST be included.
+ (setq identities (sort identities #'jabber-caps-identity-<))
+ ;; 3. For each identity, append the 'category/type/lang/name' to
+ ;; S, followed by the '<' character.
+ (dolist (identity identities)
+ (jabber-xml-let-attributes (category type xml:lang name) identity
+ ;; Use `concat' here instead of passing everything to
+ ;; `insert', since `concat' tolerates nil values.
+ (insert (concat category "/" type "/" xml:lang "/" name "<"))))
+ ;; 4. Sort the supported service discovery features. [17]
+ (setq disco-features (sort disco-features #'string<))
+ ;; 5. For each feature, append the feature to S, followed by the
+ ;; '<' character.
+ (dolist (f disco-features)
+ (insert f "<"))
+ ;; 6. If the service discovery information response includes
+ ;; XEP-0128 data forms, sort the forms by the FORM_TYPE (i.e.,
+ ;; by the XML character data of the element).
+ (setq forms (sort forms (lambda (a b)
+ (string< (jabber-xdata-formtype a)
+ (jabber-xdata-formtype b)))))
+ ;; 7. For each extended service discovery information form:
+ (dolist (form forms)
+ ;; Append the XML character data of the FORM_TYPE field's
+ ;; element, followed by the '<' character.
+ (insert (jabber-xdata-formtype form) "<")
+ ;; Sort the fields by the value of the "var" attribute.
+ (let ((fields (sort (jabber-xml-get-children form 'field)
+ (lambda (a b)
+ (string< (jabber-xml-get-attribute a 'var)
+ (jabber-xml-get-attribute b 'var))))))
+ (dolist (field fields)
+ ;; For each field other than FORM_TYPE:
+ (unless (string= (jabber-xml-get-attribute field 'var) "FORM_TYPE")
+ ;; Append the value of the "var" attribute, followed by the '<' character.
+ (insert (jabber-xml-get-attribute field 'var) "<")
+ ;; Sort values by the XML character data of the element.
+ (let ((values (sort (mapcar (lambda (value)
+ (car (jabber-xml-node-children value)))
+ (jabber-xml-get-children field 'value))
+ #'string<)))
+ ;; For each element, append the XML character
+ ;; data, followed by the '<' character.
+ (dolist (value values)
+ (insert value "<"))))))))
+
+ ;; 8. Ensure that S is encoded according to the UTF-8 encoding
+ ;; (RFC 3269 [18]).
+ (let ((s (encode-coding-string (buffer-string) 'utf-8 t))
+ (algorithm (cdr (assoc hash jabber-caps-hash-names))))
+ ;; 9. Compute the verification string by hashing S using the
+ ;; algorithm specified in the 'hash' attribute (e.g., SHA-1 as
+ ;; defined in RFC 3174 [19]). The hashed data MUST be generated
+ ;; with binary output and encoded using Base64 as specified in
+ ;; Section 4 of RFC 4648 [20] (note: the Base64 output MUST NOT
+ ;; include whitespace and MUST set padding bits to zero). [21]
+ (base64-encode-string (jabber-caps--secure-hash algorithm s) t))))
+
+(defun jabber-caps--secure-hash (algorithm string)
+ (cond
+ ;; `secure-hash' was introduced in Emacs 24
+ ((fboundp 'secure-hash)
+ (secure-hash algorithm string nil nil t))
+ ((eq algorithm 'sha1)
+ ;; For SHA-1, we can use the `sha1' function.
+ (sha1 string nil nil t))
+ (t
+ (error "Cannot use hash algorithm %s!" algorithm))))
+
+(defun jabber-caps-identity-< (a b)
+ (let ((a-category (jabber-xml-get-attribute a 'category))
+ (b-category (jabber-xml-get-attribute b 'category)))
+ (or (string< a-category b-category)
+ (and (string= a-category b-category)
+ (let ((a-type (jabber-xml-get-attribute a 'type))
+ (b-type (jabber-xml-get-attribute b 'type)))
+ (or (string< a-type b-type)
+ (and (string= a-type b-type)
+ (let ((a-xml:lang (jabber-xml-get-attribute a 'xml:lang))
+ (b-xml:lang (jabber-xml-get-attribute b 'xml:lang)))
+ (string< a-xml:lang b-xml:lang)))))))))
+
+(defvar jabber-caps-default-hash-function "sha-1"
+ "Hash function to use when sending caps in presence stanzas.
+The value should be a key in `jabber-caps-hash-names'.")
+
+(defvar jabber-caps-current-hash nil
+ "The current disco hash we're sending out in presence stanzas.")
+
+(defconst jabber-caps-node "http://emacs-jabber.sourceforge.net")
+
+;;;###autoload
+(defun jabber-disco-advertise-feature (feature)
+ (unless (member feature jabber-advertised-features)
+ (push feature jabber-advertised-features)
+ (when jabber-caps-current-hash
+ (jabber-caps-recalculate-hash)
+ ;; If we're already connected, we need to send updated presence
+ ;; for the new feature.
+ (mapc #'jabber-send-current-presence jabber-connections))))
+
+(defun jabber-caps-recalculate-hash ()
+ "Update `jabber-caps-current-hash' for feature list change.
+Also update `jabber-disco-info-nodes', so we return results for
+the right node."
+ (let* ((old-hash jabber-caps-current-hash)
+ (old-node (and old-hash (concat jabber-caps-node "#" old-hash)))
+ (new-hash
+ (jabber-caps-ver-string `(query () ,@(jabber-disco-return-client-info))
+ jabber-caps-default-hash-function))
+ (new-node (concat jabber-caps-node "#" new-hash)))
+ (when old-node
+ (let ((old-entry (assoc old-node jabber-disco-info-nodes)))
+ (when old-entry
+ (setq jabber-disco-info-nodes (delq old-entry jabber-disco-info-nodes)))))
+ (push (list new-node #'jabber-disco-return-client-info nil)
+ jabber-disco-info-nodes)
+ (setq jabber-caps-current-hash new-hash)))
+
+;;;###autoload
+(defun jabber-caps-presence-element (_jc)
+ (unless jabber-caps-current-hash
+ (jabber-caps-recalculate-hash))
+
+ (list
+ `(c ((xmlns . "http://jabber.org/protocol/caps")
+ (hash . ,jabber-caps-default-hash-function)
+ (node . ,jabber-caps-node)
+ (ver . ,jabber-caps-current-hash)))))
+
+;;;###autoload
+(eval-after-load "jabber-presence"
+ '(add-to-list 'jabber-presence-element-functions #'jabber-caps-presence-element))
+
+(defvar jabber-advertised-features
+ (list "http://jabber.org/protocol/disco#info")
+ "Features advertised on service discovery requests.
+
+Don't add your feature to this list directly. Instead, call
+`jabber-disco-advertise-feature'.")
+
+(defvar jabber-disco-items-nodes
+ (list
+ (list "" nil nil))
+ "Alist of node names and information about returning disco item data.
+Key is node name as a string, or \"\" for no node specified. Value is
+a list of two items.
+
+First item is data to return. If it is a function, that function is
+called and its return value is used; if it is a list, that list is
+used. The list should be the XML data to be returned inside the
+ element, like this:
+
+\((item ((name . \"Name of first item\")
+ (jid . \"first.item\")
+ (node . \"node\"))))
+
+Second item is access control function. That function is passed the
+JID, and returns non-nil if access is granted. If the second item is
+nil, access is always granted.")
+
+(defvar jabber-disco-info-nodes
+ (list
+ (list "" #'jabber-disco-return-client-info nil))
+ "Alist of node names and information returning disco info data.
+Key is node name as a string, or \"\" for no node specified. Value is
+a list of two items.
+
+First item is data to return. If it is a function, that function is
+called and its return value is used; if it is a list, that list is
+used. The list should be the XML data to be returned inside the
+ element, like this:
+
+\((identity ((category . \"client\")
+ (type . \"pc\")
+ (name . \"Jabber client\")))
+ (feature ((var . \"some-feature\"))))
+
+Second item is access control function. That function is passed the
+JID, and returns non-nil if access is granted. If the second item is
+nil, access is always granted.")
+
+(add-to-list 'jabber-iq-get-xmlns-alist
+ (cons "http://jabber.org/protocol/disco#info" 'jabber-return-disco-info))
+(add-to-list 'jabber-iq-get-xmlns-alist
+ (cons "http://jabber.org/protocol/disco#items" 'jabber-return-disco-info))
+(defun jabber-return-disco-info (jc xml-data)
+ "Respond to a service discovery request.
+See XEP-0030.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let* ((to (jabber-xml-get-attribute xml-data 'from))
+ (id (jabber-xml-get-attribute xml-data 'id))
+ (xmlns (jabber-iq-xmlns xml-data))
+ (which-alist (eval (cdr (assoc xmlns
+ (list
+ (cons "http://jabber.org/protocol/disco#info" 'jabber-disco-info-nodes)
+ (cons "http://jabber.org/protocol/disco#items" 'jabber-disco-items-nodes))))))
+ (node (or
+ (jabber-xml-get-attribute (jabber-iq-query xml-data) 'node)
+ ""))
+ (return-list (cdr (assoc node which-alist)))
+ (func (nth 0 return-list))
+ (access-control (nth 1 return-list)))
+ (if return-list
+ (if (and (functionp access-control)
+ (not (funcall access-control jc to)))
+ (jabber-signal-error "Cancel" 'not-allowed)
+ ;; Access control passed
+ (let ((result (if (functionp func)
+ (funcall func jc xml-data)
+ func)))
+ (jabber-send-iq jc to "result"
+ `(query ((xmlns . ,xmlns)
+ ,@(when node
+ (list (cons 'node node))))
+ ,@result)
+ nil nil nil nil id)))
+
+ ;; No such node
+ (jabber-signal-error "Cancel" 'item-not-found))))
+
+(defun jabber-disco-return-client-info (&optional jc xml-data)
+ `(
+ ;; If running under a window system, this is
+ ;; a GUI client. If not, it is a console client.
+ (identity ((category . "client")
+ (name . "Emacs Jabber client")
+ (type . ,(if (memq window-system
+ '(x w32 mac ns))
+ "pc"
+ "console"))))
+ ,@(mapcar
+ #'(lambda (featurename)
+ `(feature ((var . ,featurename))))
+ jabber-advertised-features)))
+
+(add-to-list 'jabber-jid-info-menu
+ (cons "Send items disco query" 'jabber-get-disco-items))
+(defun jabber-get-disco-items (jc to &optional node)
+ "Send a service discovery request for items.
+
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "Send items disco request to: " nil nil nil 'full t)
+ (jabber-read-node "Node (or leave empty): ")))
+ (jabber-send-iq jc to
+ "get"
+ (list 'query (append (list (cons 'xmlns "http://jabber.org/protocol/disco#items"))
+ (if (> (length node) 0)
+ (list (cons 'node node)))))
+ #'jabber-process-data #'jabber-process-disco-items
+ #'jabber-process-data "Item discovery failed"))
+
+(add-to-list 'jabber-jid-info-menu
+ (cons "Send info disco query" 'jabber-get-disco-info))
+(defun jabber-get-disco-info (jc to &optional node)
+ "Send a service discovery request for info.
+
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "Send info disco request to: " nil nil nil 'full t)
+ (jabber-read-node "Node (or leave empty): ")))
+ (jabber-send-iq jc to
+ "get"
+ (list 'query (append (list (cons 'xmlns "http://jabber.org/protocol/disco#info"))
+ (if (> (length node) 0)
+ (list (cons 'node node)))))
+ #'jabber-process-data #'jabber-process-disco-info
+ #'jabber-process-data "Info discovery failed"))
+
+(defun jabber-process-disco-info (jc xml-data)
+ "Handle results from info disco requests.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+
+ (let ((beginning (point)))
+ (dolist (x (jabber-xml-node-children (jabber-iq-query xml-data)))
+ (cond
+ ((eq (jabber-xml-node-name x) 'identity)
+ (let ((name (jabber-xml-get-attribute x 'name))
+ (category (jabber-xml-get-attribute x 'category))
+ (type (jabber-xml-get-attribute x 'type)))
+ (insert (jabber-propertize (if name
+ name
+ "Unnamed")
+ 'face 'jabber-title-medium)
+ "\n\nCategory:\t" category "\n")
+ (if type
+ (insert "Type:\t\t" type "\n"))
+ (insert "\n")))
+ ((eq (jabber-xml-node-name x) 'feature)
+ (let ((var (jabber-xml-get-attribute x 'var)))
+ (insert "Feature:\t" var "\n")))))
+ (put-text-property beginning (point)
+ 'jabber-jid (jabber-xml-get-attribute xml-data 'from))
+ (put-text-property beginning (point)
+ 'jabber-account jc)))
+
+(defun jabber-process-disco-items (jc xml-data)
+ "Handle results from items disco requests.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+
+ (let ((items (jabber-xml-get-children (jabber-iq-query xml-data) 'item)))
+ (if items
+ (dolist (item items)
+ (let ((jid (jabber-xml-get-attribute item 'jid))
+ (name (jabber-xml-get-attribute item 'name))
+ (node (jabber-xml-get-attribute item 'node)))
+ (insert
+ (jabber-propertize
+ (concat
+ (jabber-propertize
+ (concat jid "\n" (if node (format "Node: %s\n" node)))
+ 'face 'jabber-title-medium)
+ name "\n\n")
+ 'jabber-jid jid
+ 'jabber-account jc
+ 'jabber-node node))))
+ (insert "No items found.\n"))))
+
+;; Keys are ("jid" . "node"), where "node" is nil if appropriate.
+;; Values are (identities features), where each identity is ["name"
+;; "category" "type"], and each feature is a string.
+(defvar jabber-disco-info-cache (make-hash-table :test 'equal))
+
+;; Keys are ("jid" . "node"). Values are (items), where each
+;; item is ["name" "jid" "node"] (some values may be nil).
+(defvar jabber-disco-items-cache (make-hash-table :test 'equal))
+
+(defun jabber-disco-get-info (jc jid node callback closure-data &optional force)
+ "Get disco info for JID and NODE, using connection JC.
+Call CALLBACK with JC and CLOSURE-DATA as first and second
+arguments and result as third argument when result is available.
+On success, result is (IDENTITIES FEATURES), where each identity is [\"name\"
+\"category\" \"type\"], and each feature is a string.
+On error, result is the error node, recognizable by (eq (car result) 'error).
+
+If CALLBACK is nil, just fetch data. If FORCE is non-nil,
+invalidate cache and get fresh data."
+ (when force
+ (remhash (cons jid node) jabber-disco-info-cache))
+ (let ((result (unless force (jabber-disco-get-info-immediately jid node))))
+ (if result
+ (and callback (run-with-timer 0 nil callback jc closure-data result))
+ (jabber-send-iq jc jid
+ "get"
+ `(query ((xmlns . "http://jabber.org/protocol/disco#info")
+ ,@(when node `((node . ,node)))))
+ #'jabber-disco-got-info (cons callback closure-data)
+ (lambda (jc xml-data callback-data)
+ (when (car callback-data)
+ (funcall (car callback-data) jc (cdr callback-data) (jabber-iq-error xml-data))))
+ (cons callback closure-data)))))
+
+(defun jabber-disco-got-info (jc xml-data callback-data)
+ (let ((jid (jabber-xml-get-attribute xml-data 'from))
+ (node (jabber-xml-get-attribute (jabber-iq-query xml-data)
+ 'node))
+ (result (jabber-disco-parse-info xml-data)))
+ (puthash (cons jid node) result jabber-disco-info-cache)
+ (when (car callback-data)
+ (funcall (car callback-data) jc (cdr callback-data) result))))
+
+(defun jabber-disco-parse-info (xml-data)
+ "Extract data from an stanza containing a disco#info result.
+See `jabber-disco-get-info' for a description of the return value.
+
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (list
+ (mapcar
+ #'(lambda (id)
+ (vector (jabber-xml-get-attribute id 'name)
+ (jabber-xml-get-attribute id 'category)
+ (jabber-xml-get-attribute id 'type)))
+ (jabber-xml-get-children (jabber-iq-query xml-data) 'identity))
+ (mapcar
+ #'(lambda (feature)
+ (jabber-xml-get-attribute feature 'var))
+ (jabber-xml-get-children (jabber-iq-query xml-data) 'feature))))
+
+(defun jabber-disco-get-info-immediately (jid node)
+ "Get cached disco info for JID and NODE.
+Return nil if no info available.
+
+Fill the cache with `jabber-disco-get-info'."
+ (or
+ ;; Check "normal" cache...
+ (gethash (cons jid node) jabber-disco-info-cache)
+ ;; And then check Entity Capabilities.
+ (and (null node) (jabber-caps-get-cached jid))))
+
+(defun jabber-disco-get-items (jc jid node callback closure-data &optional force)
+ "Get disco items for JID and NODE, using connection JC.
+Call CALLBACK with JC and CLOSURE-DATA as first and second
+arguments and items result as third argument when result is
+available.
+On success, result is a list of items, where each
+item is [\"name\" \"jid\" \"node\"] (some values may be nil).
+On error, result is the error node, recognizable by (eq (car result) 'error).
+
+If CALLBACK is nil, just fetch data. If FORCE is non-nil,
+invalidate cache and get fresh data."
+ (when force
+ (remhash (cons jid node) jabber-disco-items-cache))
+ (let ((result (gethash (cons jid node) jabber-disco-items-cache)))
+ (if result
+ (and callback (run-with-timer 0 nil callback jc closure-data result))
+ (jabber-send-iq jc jid
+ "get"
+ `(query ((xmlns . "http://jabber.org/protocol/disco#items")
+ ,@(when node `((node . ,node)))))
+ #'jabber-disco-got-items (cons callback closure-data)
+ (lambda (jc xml-data callback-data)
+ (when (car callback-data)
+ (funcall (car callback-data) jc (cdr callback-data) (jabber-iq-error xml-data))))
+ (cons callback closure-data)))))
+
+(defun jabber-disco-got-items (jc xml-data callback-data)
+ (let ((jid (jabber-xml-get-attribute xml-data 'from))
+ (node (jabber-xml-get-attribute (jabber-iq-query xml-data)
+ 'node))
+ (result
+ (mapcar
+ #'(lambda (item)
+ (vector
+ (jabber-xml-get-attribute item 'name)
+ (jabber-xml-get-attribute item 'jid)
+ (jabber-xml-get-attribute item 'node)))
+ (jabber-xml-get-children (jabber-iq-query xml-data) 'item))))
+ (puthash (cons jid node) result jabber-disco-items-cache)
+ (when (car callback-data)
+ (funcall (car callback-data) jc (cdr callback-data) result))))
+
+(defun jabber-disco-get-items-immediately (jid node)
+ (gethash (cons jid node) jabber-disco-items-cache))
+
+(defun jabber-disco-publish (jc node item-name item-jid item-node)
+ "Publish the given item under disco node NODE."
+ (jabber-send-iq jc nil
+ "set"
+ `(query ((xmlns . "http://jabber.org/protocol/disco#items")
+ ,@(when node `((node . ,node))))
+ (item ((action . "update")
+ (jid . ,item-jid)
+ ,@(when item-name
+ `((name . ,item-name)))
+ ,@(when item-node
+ `((node . ,item-node))))))
+ 'jabber-report-success "Disco publish"
+ 'jabber-report-success "Disco publish"))
+
+(defun jabber-disco-publish-remove (jc node item-jid item-node)
+ "Remove the given item from published disco items.
+
+JC is the Jabber connection."
+ (jabber-send-iq jc nil
+ "set"
+ `(query ((xmlns . "http://jabber.org/protocol/disco#items")
+ ,@(when node `((node . ,node))))
+ (item ((action . "remove")
+ (jid . ,item-jid)
+ ,@(when item-node
+ `((node . ,item-node))))))
+ 'jabber-report-success "Disco removal"
+ 'jabber-report-success "Disco removal"))
diff --git a/jabber-events.el b/jabber-events.el
new file mode 100644
index 0000000..1dc9228
--- /dev/null
+++ b/jabber-events.el
@@ -0,0 +1,208 @@
+(defgroup jabber-events nil
+ "Message events and notifications."
+ :group 'jabber)
+
+(defcustom jabber-events-request-these '(offline
+ delivered
+ displayed
+ composing)
+ "Request these kinds of event notifications from others."
+ :type '(set (const :tag "Delivered to offline storage" offline)
+ (const :tag "Delivered to user's client" delivered)
+ (const :tag "Displayed to user" displayed)
+ (const :tag "User is typing a reply" composing))
+ :group 'jabber-events)
+
+(defvar jabber-events-composing-p nil
+ "Is the other person composing a message?")
+(make-variable-buffer-local 'jabber-events-composing-p)
+
+(defvar jabber-events-arrived nil
+ "In what way has the message reached the recipient?
+Possible values are nil (no information available), offline
+\(queued for delivery when recipient is online), delivered
+\(message has reached the client) and displayed (user is
+probably reading the message).")
+(make-variable-buffer-local 'jabber-events-arrived)
+
+(defvar jabber-events-message ""
+ "Human-readable presentation of event information.")
+(make-variable-buffer-local 'jabber-events-message)
+
+(defun jabber-events-update-message ()
+ (setq jabber-events-message
+ (concat (cdr (assq jabber-events-arrived
+ '((offline . "In offline storage")
+ (delivered . "Delivered")
+ (displayed . "Displayed"))))
+ (when jabber-events-composing-p
+ " (typing a message)"))))
+
+(add-hook 'jabber-chat-send-hooks 'jabber-events-when-sending)
+(defun jabber-events-when-sending (text id)
+ (setq jabber-events-arrived nil)
+ (jabber-events-update-message)
+ `((x ((xmlns . "jabber:x:event"))
+ ,@(mapcar #'list jabber-events-request-these))))
+
+(defcustom jabber-events-confirm-delivered t
+ "Send delivery confirmation if requested?"
+ :group 'jabber-events
+ :type 'boolean)
+
+(defcustom jabber-events-confirm-displayed t
+ "Send display confirmation if requested?"
+ :group 'jabber-events
+ :type 'boolean)
+
+(defcustom jabber-events-confirm-composing t
+ "Send notifications about typing a reply?"
+ :group 'jabber-events
+ :type 'boolean)
+
+(defvar jabber-events-requested ()
+ "List of events requested.")
+(make-variable-buffer-local 'jabber-events-requested)
+
+(defvar jabber-events-last-id nil
+ "Id of last message received, or nil if none.")
+(make-variable-buffer-local 'jabber-events-last-id)
+
+(defvar jabber-events-delivery-confirmed nil
+ "Has delivery confirmation been sent?")
+(make-variable-buffer-local 'jabber-events-delivery-confirmed)
+
+(defvar jabber-events-display-confirmed nil
+ "Has display confirmation been sent?")
+(make-variable-buffer-local 'jabber-events-display-confirmed)
+
+(defvar jabber-events-composing-sent nil
+ "Has composing notification been sent?
+It can be sent and cancelled several times.")
+
+(add-hook 'window-configuration-change-hook
+ 'jabber-events-confirm-display)
+(defun jabber-events-confirm-display ()
+ "Send display confirmation if appropriate.
+That is, if user allows it, if the other user requested it,
+and it hasn't been sent before."
+ (walk-windows #'jabber-events-confirm-display-in-window))
+
+(defun jabber-events-confirm-display-in-window (window)
+ (with-current-buffer (window-buffer window)
+ (when (and jabber-events-confirm-displayed
+ (not jabber-events-display-confirmed)
+ (memq 'displayed jabber-events-requested)
+ ;; XXX: if jabber-events-requested is non-nil, how can
+ ;; jabber-chatting-with be nil? See
+ ;; http://sourceforge.net/tracker/index.php?func=detail&aid=1872560&group_id=88346&atid=586350
+ jabber-chatting-with
+ ;; don't send to bare jids
+ (jabber-jid-resource jabber-chatting-with))
+ (jabber-send-sexp
+ jabber-buffer-connection
+ `(message
+ ((to . ,jabber-chatting-with))
+ (x ((xmlns . "jabber:x:event"))
+ (displayed)
+ (id () ,jabber-events-last-id))))
+ (setq jabber-events-display-confirmed t))))
+
+(defun jabber-events-after-change ()
+ (let ((composing-now (not (= (point-max) jabber-point-insert))))
+ (when (and jabber-events-confirm-composing
+ jabber-chatting-with
+ (not (eq composing-now jabber-events-composing-sent)))
+ (jabber-send-sexp
+ jabber-buffer-connection
+ `(message
+ ((to . ,jabber-chatting-with))
+ (x ((xmlns . "jabber:x:event"))
+ ,@(if composing-now '((composing)) nil)
+ (id () ,jabber-events-last-id))))
+ (setq jabber-events-composing-sent composing-now))))
+
+(add-to-list 'jabber-message-chain 'jabber-handle-incoming-message-events t)
+
+(defun jabber-handle-incoming-message-events (jc xml-data)
+ (when (and (not (jabber-muc-message-p xml-data))
+ (get-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from))))
+ (with-current-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from))
+ (let ((x (cl-find "jabber:x:event"
+ (jabber-xml-get-children xml-data 'x)
+ :key #'(lambda (x) (jabber-xml-get-attribute x 'xmlns))
+ :test #'string=)))
+ (cond
+ ;; If we get an error message, we shouldn't report any
+ ;; events, as the requests are mirrored from us.
+ ((string= (jabber-xml-get-attribute xml-data 'type) "error")
+ (remove-hook 'post-command-hook 'jabber-events-after-change t)
+ (setq jabber-events-requested nil))
+
+ ;; If there's a body, it's not an incoming message event.
+ ((jabber-xml-get-children xml-data 'body)
+ ;; User is done composing, obviously.
+ (setq jabber-events-composing-p nil)
+ (jabber-events-update-message)
+
+ ;; Reset variables
+ (setq jabber-events-display-confirmed nil)
+ (setq jabber-events-delivery-confirmed nil)
+
+ ;; User requests message events
+ (setq jabber-events-requested
+ ;; There might be empty strings in the XML data,
+ ;; which car chokes on. Having nil values in
+ ;; the list won't hurt, therefore car-safe.
+ (mapcar #'car-safe
+ (jabber-xml-node-children x)))
+ (setq jabber-events-last-id (jabber-xml-get-attribute
+ xml-data 'id))
+
+ ;; Send notifications we already know about
+ (cl-flet ((send-notification
+ (type)
+ (jabber-send-sexp
+ jc
+ `(message
+ ((to . ,(jabber-xml-get-attribute xml-data 'from)))
+ (x ((xmlns . "jabber:x:event"))
+ (,type)
+ (id () ,jabber-events-last-id))))))
+ ;; Send delivery confirmation if appropriate
+ (when (and jabber-events-confirm-delivered
+ (memq 'delivered jabber-events-requested))
+ (send-notification 'delivered)
+ (setq jabber-events-delivery-confirmed t))
+
+ ;; Send display confirmation if appropriate
+ (when (and jabber-events-confirm-displayed
+ (get-buffer-window (current-buffer) 'visible)
+ (memq 'displayed jabber-events-requested))
+ (send-notification 'displayed)
+ (setq jabber-events-display-confirmed t))
+
+ ;; Set up hooks for composition notification
+ (when (and jabber-events-confirm-composing
+ (memq 'composing jabber-events-requested))
+ (add-hook 'post-command-hook 'jabber-events-after-change
+ nil t))))
+ (t
+ ;; So it has no body. If it's a message event,
+ ;; the node should be the only child of the
+ ;; message, and it should contain an node.
+ ;; We check the latter.
+ (when (and x (jabber-xml-get-children x 'id))
+ ;; Currently we don't care about the node.
+
+ ;; There's only one node except for the id.
+ (unless
+ (dolist (possible-node '(offline delivered displayed))
+ (when (jabber-xml-get-children x possible-node)
+ (setq jabber-events-arrived possible-node)
+ (jabber-events-update-message)
+ (cl-return t)))
+ ;; Or maybe even zero, which is a negative composing node.
+ (setq jabber-events-composing-p
+ (not (null (jabber-xml-get-children x 'composing))))
+ (jabber-events-update-message)))))))))
diff --git a/jabber-export.el b/jabber-export.el
new file mode 100644
index 0000000..290df0a
--- /dev/null
+++ b/jabber-export.el
@@ -0,0 +1,224 @@
+(defvar jabber-export-roster-widget nil)
+
+(defvar jabber-import-subscription-p-widget nil)
+
+;;;###autoload
+(defun jabber-export-roster (jc)
+ "Export roster for connection JC."
+ (interactive (list (jabber-read-account)))
+ (let ((state-data (fsm-get-state-data jc)))
+ (jabber-export-roster-do-it
+ (jabber-roster-to-sexp (plist-get state-data :roster)))))
+
+(defun jabber-export-roster-do-it (roster)
+ "Create buffer from which ROSTER can be exported to a file."
+ (interactive)
+ (with-current-buffer (get-buffer-create "Export roster")
+ (jabber-init-widget-buffer nil)
+
+ (widget-insert (jabber-propertize "Export roster\n"
+ 'face 'jabber-title-large))
+ (widget-insert "You are about to save your roster to a file. Here
+you can edit it before saving. Changes done here will
+not affect your actual roster.
+
+")
+
+ (widget-create 'push-button :notify #'jabber-export-save "Save to file")
+ (widget-insert " ")
+ (widget-create 'push-button :notify #'jabber-export-remove-regexp "Remove by regexp")
+ (widget-insert "\n\n")
+ (make-local-variable 'jabber-export-roster-widget)
+
+ (jabber-export-display roster)
+
+ (widget-setup)
+ (widget-minor-mode 1)
+ (goto-char (point-min))
+ (switch-to-buffer (current-buffer))))
+
+;;;###autoload
+(defun jabber-import-roster (jc file)
+ "Create buffer for roster import for connection JC from FILE."
+ (interactive (list (jabber-read-account)
+ (read-file-name "Import roster from file: ")))
+ (let ((roster
+ (with-temp-buffer
+ (let ((coding-system-for-read 'utf-8))
+ (jabber-roster-xml-to-sexp
+ (car (xml-parse-file file)))))))
+ (with-current-buffer (get-buffer-create "Import roster")
+ (setq jabber-buffer-connection jc)
+
+ (jabber-init-widget-buffer nil)
+
+ (widget-insert (jabber-propertize "Import roster\n"
+ 'face 'jabber-title-large))
+ (widget-insert "You are about to import the contacts below to your roster.
+
+")
+
+ (make-local-variable 'jabber-import-subscription-p-widget)
+ (setq jabber-import-subscription-p-widget
+ (widget-create 'checkbox))
+ (widget-insert " Adjust subscriptions\n")
+
+ (widget-create 'push-button :notify #'jabber-import-doit "Import to roster")
+ (widget-insert " ")
+ (widget-create 'push-button :notify #'jabber-export-remove-regexp "Remove by regexp")
+ (widget-insert "\n\n")
+ (make-local-variable 'jabber-export-roster-widget)
+
+ (jabber-export-display roster)
+
+ (widget-setup)
+ (widget-minor-mode 1)
+ (goto-char (point-min))
+ (switch-to-buffer (current-buffer)))))
+
+(defun jabber-export-remove-regexp (&rest _ignore)
+ (let* ((value (widget-value jabber-export-roster-widget))
+ (length-before (length value))
+ (regexp (read-string "Remove JIDs matching regexp: ")))
+ (setq value (cl-delete-if
+ #'(lambda (a)
+ (string-match regexp (nth 0 a)))
+ value))
+ (widget-value-set jabber-export-roster-widget value)
+ (widget-setup)
+ (message "%d items removed" (- length-before (length value)))))
+
+(defun jabber-export-save (&rest _ignore)
+ "Export roster to file."
+ (let ((items (mapcar #'jabber-roster-sexp-to-xml (widget-value jabber-export-roster-widget)))
+ (coding-system-for-write 'utf-8))
+ (with-temp-file (read-file-name "Export roster to file: ")
+ (insert "\n")
+ (dolist (item items)
+ (insert (jabber-sexp2xml item) "\n"))
+ (insert "\n"))
+ (message "Roster saved")))
+
+(defun jabber-import-doit (&rest _ignore)
+ "Import roster being edited in widget."
+ (let* ((state-data (fsm-get-state-data jabber-buffer-connection))
+ (jabber-roster (plist-get state-data :roster))
+ roster-delta)
+
+ (dolist (n (widget-value jabber-export-roster-widget))
+ (let* ((jid (nth 0 n))
+ (name (and (not (zerop (length (nth 1 n))))
+ (nth 1 n)))
+ (subscription (nth 2 n))
+ (groups (nth 3 n))
+ (jid-symbol (jabber-jid-symbol jid))
+ (in-roster-p (memq jid-symbol jabber-roster))
+ (jid-name (and in-roster-p (get jid-symbol 'name)))
+ (jid-subscription (and in-roster-p (get jid-symbol 'subscription)))
+ (jid-groups (and in-roster-p (get jid-symbol 'groups))))
+ ;; Do we need to change the roster?
+ (when (or
+ ;; If the contact is not in the roster already,
+ (not in-roster-p)
+ ;; or if the import introduces a name,
+ (and name (not jid-name))
+ ;; or changes a name,
+ (and name jid-name (not (string= name jid-name)))
+ ;; or introduces new groups.
+ (cl-set-difference groups jid-groups :test #'string=))
+ (push (jabber-roster-sexp-to-xml
+ (list jid (or name jid-name) nil (cl-union groups jid-groups :test #'string=))
+ t)
+ roster-delta))
+ ;; And adujst subscription.
+ (when (widget-value jabber-import-subscription-p-widget)
+ (let ((want-to (member subscription '("to" "both")))
+ (want-from (member subscription '("from" "both")))
+ (have-to (member jid-subscription '("to" "both")))
+ (have-from (member jid-subscription '("from" "both"))))
+ (cl-flet ((request-subscription
+ (type)
+ (jabber-send-sexp jabber-buffer-connection
+ `(presence ((to . ,jid)
+ (type . ,type))))))
+ (cond
+ ((and want-to (not have-to))
+ (request-subscription "subscribe"))
+ ((and have-to (not want-to))
+ (request-subscription "unsubscribe")))
+ (cond
+ ((and want-from (not have-from))
+ ;; not much to do here
+ )
+ ((and have-from (not want-from))
+ (request-subscription "unsubscribed"))))))))
+ (when roster-delta
+ (jabber-send-iq jabber-buffer-connection
+ nil "set"
+ `(query ((xmlns . "jabber:iq:roster")) ,@roster-delta)
+ #'jabber-report-success "Roster import"
+ #'jabber-report-success "Roster import"))))
+
+(defun jabber-roster-to-sexp (roster)
+ "Convert ROSTER to simpler sexp format.
+Return a list, where each item is a vector:
+\[jid name subscription groups]
+where groups is a list of strings."
+ (mapcar
+ #'(lambda (n)
+ (list
+ (symbol-name n)
+ (or (get n 'name) "")
+ (get n 'subscription)
+ (get n 'groups)))
+ roster))
+
+(defun jabber-roster-sexp-to-xml (sexp &optional omit-subscription)
+ "Convert SEXP to XML format.
+Return an XML node."
+ `(item ((jid . ,(nth 0 sexp))
+ ,@(let ((name (nth 1 sexp)))
+ (unless (zerop (length name))
+ `((name . ,name))))
+ ,@(unless omit-subscription
+ `((subscription . ,(nth 2 sexp)))))
+ ,@(mapcar
+ #'(lambda (g)
+ (list 'group nil g))
+ (nth 3 sexp))))
+
+(defun jabber-roster-xml-to-sexp (xml-data)
+ "Convert XML-DATA to simpler sexp format.
+XML-DATA is an node with a child.
+See `jabber-roster-to-sexp' for description of output format."
+ (cl-assert (eq (jabber-xml-node-name xml-data) 'iq))
+ (let ((query (car (jabber-xml-get-children xml-data 'query))))
+ (cl-assert query)
+ (mapcar
+ #'(lambda (n)
+ (list
+ (jabber-xml-get-attribute n 'jid)
+ (or (jabber-xml-get-attribute n 'name) "")
+ (jabber-xml-get-attribute n 'subscription)
+ (mapcar
+ #'(lambda (g)
+ (car (jabber-xml-node-children g)))
+ (jabber-xml-get-children n 'group))))
+ (jabber-xml-get-children query 'item))))
+
+(defun jabber-export-display (roster)
+ (setq jabber-export-roster-widget
+ (widget-create
+ '(repeat
+ :tag "Roster"
+ (list :format "%v"
+ (string :tag "JID")
+ (string :tag "Name")
+ (choice :tag "Subscription"
+ (const "none")
+ (const "both")
+ (const "to")
+ (const "from"))
+ (repeat :tag "Groups"
+ (string :tag "Group"))))
+ :value roster)))
diff --git a/jabber-feature-neg.el b/jabber-feature-neg.el
new file mode 100644
index 0000000..d0206a2
--- /dev/null
+++ b/jabber-feature-neg.el
@@ -0,0 +1,97 @@
+(jabber-disco-advertise-feature "http://jabber.org/protocol/feature-neg")
+
+(defun jabber-fn-parse (xml-data type)
+ "Parse a Feature Negotiation request, return alist representation.
+XML-DATA should have one child element, , in the jabber:x:data
+namespace.
+
+TYPE is either 'request or 'response.
+
+Returned alist has field name as key, and value is a list of offered
+alternatives."
+ (let ((x (car (jabber-xml-get-children xml-data 'x))))
+ (unless (and x
+ (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data"))
+ (jabber-signal-error "Modify" 'bad-request "Malformed Feature Negotiation"))
+
+ (let (alist
+ (fields (jabber-xml-get-children x 'field)))
+ (dolist (field fields)
+ (let ((var (jabber-xml-get-attribute field 'var))
+ (value (car (jabber-xml-get-children field 'value)))
+ (options (jabber-xml-get-children field 'option)))
+ (setq alist (cons
+ (cons var
+ (cond
+ ((eq type 'request)
+ (mapcar #'(lambda (option)
+ (car (jabber-xml-node-children
+ (car (jabber-xml-get-children
+ option 'value)))))
+ options))
+ ((eq type 'response)
+ (jabber-xml-node-children value))
+ (t
+ (error "Incorrect Feature Negotiation type: %s" type))))
+ alist))))
+ ;; return alist
+ alist)))
+
+(defun jabber-fn-encode (alist type)
+ "Transform a feature alist into an node int the jabber:x:data namespace.
+Note that this is not the reverse of `jabber-fn-parse'.
+
+TYPE is either 'request or 'response."
+ (let ((requestp (eq type 'request)))
+ `(x ((xmlns . "jabber:x:data")
+ (type . ,(if requestp "form" "submit")))
+ ,@(mapcar #'(lambda (field)
+ `(field
+ ((type . "list-single")
+ (var . ,(car field)))
+ ,@(if requestp
+ (mapcar
+ #'(lambda (option)
+ `(option nil (value nil ,option)))
+ (cdr field))
+ (list `(value nil ,(cadr field))))))
+ alist))))
+
+(defun jabber-fn-intersection (mine theirs)
+ "Find values acceptable to both parties.
+
+MINE and THEIRS are alists, as returned by `jabber-fn-parse'.
+
+An alist is returned, where the keys are the negotiated variables,
+and the values are lists containing the preferred option. If
+negotiation is impossible, an error is signalled. The errors are as
+specified in XEP-0020, and not necessarily the ones of higher-level
+protocols."
+
+ (let ((vars (mapcar #'car mine))
+ (their-vars (mapcar #'car theirs)))
+
+ ;; are the same variables being negotiated?
+ (sort vars 'string-lessp)
+ (sort their-vars 'string-lessp)
+ (let ((mine-but-not-theirs (cl-set-difference vars their-vars :test 'string=))
+ (theirs-but-not-mine (cl-set-difference their-vars vars :test 'string=)))
+ (when mine-but-not-theirs
+ (jabber-signal-error "Modify" 'not-acceptable (car mine-but-not-theirs)))
+ (when theirs-but-not-mine
+ (jabber-signal-error "Cancel" 'feature-not-implemented (car theirs-but-not-mine))))
+
+ (let (alist)
+ (dolist (var vars)
+ (let ((my-options (cdr (assoc var mine)))
+ (their-options (cdr (assoc var theirs))))
+ (let ((common-options (cl-intersection my-options their-options :test 'string=)))
+ (if common-options
+ ;; we have a match; but which one to use?
+ ;; the first one will probably work
+ (setq alist
+ (cons (list var (car common-options))
+ alist))
+ ;; no match
+ (jabber-signal-error "Modify" 'not-acceptable var)))))
+ alist)))
diff --git a/jabber-history.el b/jabber-history.el
new file mode 100644
index 0000000..e678633
--- /dev/null
+++ b/jabber-history.el
@@ -0,0 +1,303 @@
+(defgroup jabber-history nil "Customization options for Emacs
+Jabber history files."
+ :group 'jabber)
+
+(defcustom jabber-history-enabled nil
+ "Non-nil means message logging is enabled."
+ :type 'boolean
+ :group 'jabber-history)
+
+(defcustom jabber-history-muc-enabled nil
+ "Non-nil means MUC logging is enabled.
+Default is nil, cause MUC logging may be i/o-intensive."
+ :type 'boolean
+ :group 'jabber-history)
+
+(defcustom jabber-history-dir
+ (locate-user-emacs-file "jabber-history" ".emacs-jabber")
+ "Base directory where per-contact history files are stored.
+Used only when `jabber-use-global-history' is nil."
+ :type 'directory
+ :group 'jabber-history)
+
+(defcustom jabber-global-history-filename
+ (locate-user-emacs-file "jabber-global-message-log" ".jabber_global_message_log")
+ "Global file where all messages are logged.
+Used when `jabber-use-global-history' is non-nil."
+ :type 'file
+ :group 'jabber-history)
+
+(defcustom jabber-use-global-history
+ ;; Using a global history file by default was a bad idea. Let's
+ ;; default to per-user files unless the global history file already
+ ;; exists, to avoid breaking existing installations.
+ (file-exists-p jabber-global-history-filename)
+ "Whether to use a global file for message history.
+If non-nil, `jabber-global-history-filename' is used, otherwise,
+messages are stored in per-user files under the
+`jabber-history-dir' directory."
+ :type 'boolean
+ :group 'jabber-history)
+
+(defcustom jabber-history-enable-rotation nil
+ "Whether history files should be renamed when reach certain kilobytes.
+Whether history files should be renamed when reach
+`jabber-history-size-limit' kilobytes. If nil, history files
+will grow indefinitely, otherwise they'll be renamed to
+-, where is 1 or the smallest
+number after the last rotation."
+ :type 'boolean
+ :group 'jabber-history)
+
+(defcustom jabber-history-size-limit 1024
+ "Maximum history file size in kilobytes.
+When history file reaches this limit, it is renamed to
+-, where is 1 or the smallest
+number after the last rotation."
+ :type 'integer
+ :group 'jabber-history)
+
+(defvar jabber-history-inhibit-received-message-functions nil
+ "Functions determining whether to log an incoming message stanza.
+The functions in this list are called with two arguments,
+the connection and the full message stanza.
+If any of the functions returns non-nil, the stanza is not logged
+in the message history.")
+
+(defun jabber-rotate-history-p (history-file)
+ "Return non-nil if HISTORY-FILE should be rotated."
+ (when (and jabber-history-enable-rotation
+ (file-exists-p history-file))
+ (> (/ (nth 7 (file-attributes history-file)) 1024)
+ jabber-history-size-limit)))
+
+(defun jabber-history-rotate (history-file &optional try)
+ "Rename HISTORY-FILE to HISTORY-FILE-TRY."
+ (let ((suffix (number-to-string (or try 1))))
+ (if (file-exists-p (concat history-file "-" suffix))
+ (jabber-history-rotate history-file (if try (1+ try) 1))
+ (rename-file history-file (concat history-file "-" suffix)))))
+
+(add-to-list 'jabber-message-chain 'jabber-message-history)
+(defun jabber-message-history (jc xml-data)
+ "Log message to log file.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (when (and (not jabber-use-global-history)
+ (not (file-directory-p jabber-history-dir)))
+ (make-directory jabber-history-dir))
+ (let ((is-muc (jabber-muc-message-p xml-data)))
+ (when (and jabber-history-enabled
+ (or
+ (not is-muc) ;chat message or private MUC message
+ (and jabber-history-muc-enabled is-muc))) ;muc message and muc logging active
+ (unless (run-hook-with-args-until-success
+ 'jabber-history-inhibit-received-message-functions
+ jc xml-data)
+ (let ((from (jabber-xml-get-attribute xml-data 'from))
+ (text (car (jabber-xml-node-children
+ (car (jabber-xml-get-children xml-data 'body)))))
+ (timestamp (jabber-message-timestamp xml-data)))
+ (when (and from text)
+ (jabber-history-log-message "in" from nil text timestamp)))))))
+
+(add-hook 'jabber-chat-send-hooks 'jabber-history-send-hook)
+
+(defun jabber-history-send-hook (body id)
+ "Log outgoing message to log file."
+ (when (and (not jabber-use-global-history)
+ (not (file-directory-p jabber-history-dir)))
+ (make-directory jabber-history-dir))
+ ;; This function is called from a chat buffer, so jabber-chatting-with
+ ;; contains the desired value.
+ (if jabber-history-enabled
+ (jabber-history-log-message "out" nil jabber-chatting-with body (current-time))))
+
+(defun jabber-history-filename (contact)
+ "Return a history filename for CONTACT.
+Return a history filename for CONTACT if the per-user file
+loggin strategy is used or the global history filename."
+ (if jabber-use-global-history
+ jabber-global-history-filename
+ ;; jabber-jid-symbol is the best canonicalization we have.
+ (concat jabber-history-dir
+ "/" (symbol-name (jabber-jid-symbol contact)))))
+
+(defun jabber-history-log-message (direction from to body timestamp)
+ "Log a message."
+ (with-temp-buffer
+ ;; Remove properties
+ (set-text-properties 0 (length body) nil body)
+ ;; Encode text as Lisp string - get decoding for free
+ (setq body (prin1-to-string body))
+ ;; Encode LF and CR
+ (while (string-match "\n" body)
+ (setq body (replace-match "\\n" nil t body nil)))
+ (while (string-match "\r" body)
+ (setq body (replace-match "\\r" nil t body nil)))
+ (insert (format "[\"%s\" \"%s\" %s %s %s]\n"
+ (jabber-encode-time (or timestamp (current-time)))
+ (or direction
+ "in")
+ (or (when from
+ (prin1-to-string from))
+ "\"me\"")
+ (or (when to
+ (prin1-to-string to))
+ "\"me\"")
+ body))
+ (let ((coding-system-for-write 'utf-8)
+ (history-file (jabber-history-filename (or from to))))
+ (when (and (not jabber-use-global-history)
+ (not (file-directory-p jabber-history-dir)))
+ (make-directory jabber-history-dir))
+ (when (jabber-rotate-history-p history-file)
+ (jabber-history-rotate history-file))
+ (condition-case e
+ (write-region (point-min) (point-max) history-file t 'quiet)
+ (error
+ (message "Unable to write history: %s" (error-message-string e)))))))
+
+(defun jabber-history-query (start-time
+ end-time
+ number
+ direction
+ jid-regexp
+ history-file)
+ "Return a list of vectors, one for each message matching the criteria.
+START-TIME and END-TIME are floats as obtained from `float-time'.
+Either or both may be nil, meaning no restriction.
+NUMBER is the maximum number of messages to return, or t for
+unlimited.
+DIRECTION is either \"in\" or \"out\", or t for no limit on direction.
+JID-REGEXP is a regexp which must match the JID.
+HISTORY-FILE is the file in which to search.
+
+Currently jabber-history-query performs a linear search from the end
+of the log file."
+ (when (file-readable-p history-file)
+ (with-temp-buffer
+ (let ((coding-system-for-read 'utf-8))
+ (if jabber-use-global-history
+ (insert-file-contents history-file)
+ (let* ((lines-collected nil)
+ (matched-files
+ (directory-files jabber-history-dir t
+ (concat "^"
+ (regexp-quote (file-name-nondirectory
+ history-file)))))
+ (matched-files
+ (cons (car matched-files)
+ (sort (cdr matched-files) 'string>-numerical))))
+ (while (not lines-collected)
+ (if (null matched-files)
+ (setq lines-collected t)
+ (let ((file (pop matched-files)))
+ (progn
+ (insert-file-contents file)
+ (when (numberp number)
+ (if (>= (count-lines (point-min) (point-max)) number)
+ (setq lines-collected t))))))))))
+ (let (collected current-line)
+ (goto-char (point-max))
+ (catch 'beginning-of-file
+ (while (progn
+ (backward-sexp)
+ (setq current-line (car (read-from-string
+ (buffer-substring
+ (point)
+ (save-excursion
+ (forward-sexp)
+ (point))))))
+ (and (or (null start-time)
+ (> (jabber-float-time (jabber-parse-time
+ (aref current-line 0)))
+ start-time))
+ (or (eq number t)
+ (< (length collected) number))))
+ (if (and (or (eq direction t)
+ (string= direction (aref current-line 1)))
+ (or (null end-time)
+ (> end-time (jabber-float-time (jabber-parse-time
+ (aref current-line 0)))))
+ (string-match
+ jid-regexp
+ (car
+ (remove "me"
+ (list (aref current-line 2)
+ (aref current-line 3))))))
+ (push current-line collected))
+ (when (bobp)
+ (throw 'beginning-of-file nil))))
+ collected))))
+
+(defcustom jabber-backlog-days 3.0
+ "Age limit on messages in chat buffer backlog, in days."
+ :group 'jabber
+ :type '(choice (number :tag "Number of days")
+ (const :tag "No limit" nil)))
+
+(defcustom jabber-backlog-number 10
+ "Maximum number of messages in chat buffer backlog."
+ :group 'jabber
+ :type 'integer)
+
+(defun jabber-history-backlog (jid &optional before)
+ "Fetch context from previous chats with JID.
+Return a list of history entries (vectors), limited by
+`jabber-backlog-days' and `jabber-backlog-number'.
+If BEFORE is non-nil, it should be a float-time after which
+no entries will be fetched. `jabber-backlog-days' still
+applies, though."
+ (jabber-history-query
+ (and jabber-backlog-days
+ (- (jabber-float-time) (* jabber-backlog-days 86400.0)))
+ before
+ jabber-backlog-number
+ t ; both incoming and outgoing
+ (concat "^" (regexp-quote (jabber-jid-user jid)) "\\(/.*\\)?$")
+ (jabber-history-filename jid)))
+
+(defun jabber-history-move-to-per-user ()
+ "Migrate global history to per-user files."
+ (interactive)
+ (when (file-directory-p jabber-history-dir)
+ (error "Per-user history directory already exists"))
+ (make-directory jabber-history-dir)
+ (let ((jabber-use-global-history nil))
+ (with-temp-buffer
+ (let ((coding-system-for-read 'utf-8))
+ (insert-file-contents jabber-global-history-filename))
+ (let ((progress-reporter
+ (when (fboundp 'make-progress-reporter)
+ (make-progress-reporter "Migrating history..."
+ (point-min) (point-max))))
+ ;;(file-table (make-hash-table :test 'equal))
+ ;; Keep track of blocks of entries pertaining to the same JID.
+ current-jid jid-start)
+ (while (not (eobp))
+ (let* ((start (point))
+ (end (progn (forward-line) (point)))
+ (line (buffer-substring start end))
+ (parsed (car (read-from-string line)))
+ (jid (if (string= (aref parsed 2) "me")
+ (aref parsed 3)
+ (aref parsed 2))))
+ ;; Whenever there is a change in JID...
+ (when (not (equal jid current-jid))
+ (when current-jid
+ ;; ...save data for previous JID...
+ (let ((history-file (jabber-history-filename current-jid)))
+ (write-region jid-start start history-file t 'quiet)))
+ ;; ...and switch to new JID.
+ (setq current-jid jid)
+ (setq jid-start start))
+ (when (fboundp 'progress-reporter-update)
+ (progress-reporter-update progress-reporter (point)))))
+ ;; Finally, save the last block, if any.
+ (when current-jid
+ (let ((history-file (jabber-history-filename current-jid)))
+ (write-region jid-start (point-max) history-file t 'quiet))))))
+ (message "Done. Please change `jabber-use-global-history' now."))
diff --git a/jabber-iq.el b/jabber-iq.el
new file mode 100644
index 0000000..4af8d80
--- /dev/null
+++ b/jabber-iq.el
@@ -0,0 +1,199 @@
+(defvar *jabber-open-info-queries* nil
+ "An alist of open query id and their callback functions.")
+
+(defvar jabber-iq-get-xmlns-alist nil
+ "Mapping from XML namespace to handler for IQ GET requests.")
+
+(defvar jabber-iq-set-xmlns-alist nil
+ "Mapping from XML namespace to handler for IQ SET requests.")
+
+(defvar jabber-browse-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map jabber-common-keymap)
+ (define-key map [mouse-2] 'jabber-popup-combined-menu)
+ map))
+
+(defcustom jabber-browse-mode-hook nil
+ "Hook run when entering Browse mode."
+ :group 'jabber
+ :type 'hook)
+
+(defgroup jabber-browse nil "browse display options"
+ :group 'jabber)
+
+(defcustom jabber-browse-buffer-format "*-jabber-browse:-%n-*"
+ "The format specification for the name of browse buffers.
+
+These fields are available at this moment:
+
+%n JID to browse"
+ :type 'string
+ :group 'jabber-browse)
+
+(defun jabber-browse-mode ()
+"Jabber browse mode.
+\\{jabber-browse-mode-map}"
+ (kill-all-local-variables)
+ (setq major-mode 'jabber-browse-mode
+ mode-name "jabber-browse")
+ (use-local-map jabber-browse-mode-map)
+ (setq buffer-read-only t)
+ (if (fboundp 'run-mode-hooks)
+ (run-mode-hooks 'jabber-browse-mode-hook)
+ (run-hooks 'jabber-browse-mode-hook)))
+
+(put 'jabber-browse-mode 'mode-class 'special)
+
+(add-to-list 'jabber-iq-chain 'jabber-process-iq)
+(defun jabber-process-iq (jc xml-data)
+ "Process an incoming iq stanza.
+
+JC is the Jabber Connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let* ((id (jabber-xml-get-attribute xml-data 'id))
+ (type (jabber-xml-get-attribute xml-data 'type))
+ (from (jabber-xml-get-attribute xml-data 'from))
+ (query (jabber-iq-query xml-data))
+ (callback (assoc id *jabber-open-info-queries*)))
+ (cond
+ ;; if type is "result" or "error", this is a response to a query we sent.
+ ((or (string= type "result")
+ (string= type "error"))
+ (let ((callback-cons (nth (cdr (assoc type '(("result" . 0)
+ ("error" . 1)))) (cdr callback))))
+ (if (consp callback-cons)
+ (funcall (car callback-cons) jc xml-data (cdr callback-cons))))
+ (setq *jabber-open-info-queries* (delq callback *jabber-open-info-queries*)))
+
+ ;; if type is "get" or "set", correct action depends on namespace of request.
+ ((and (listp query)
+ (or (string= type "get")
+ (string= type "set")))
+ (let* ((which-alist (eval (cdr (assoc type
+ (list
+ (cons "get" 'jabber-iq-get-xmlns-alist)
+ (cons "set" 'jabber-iq-set-xmlns-alist))))))
+ (handler (cdr (assoc (jabber-xml-get-attribute query 'xmlns) which-alist))))
+ (if handler
+ (condition-case error-var
+ (funcall handler jc xml-data)
+ (jabber-error
+ (apply 'jabber-send-iq-error jc from id query (cdr error-var)))
+ (error (jabber-send-iq-error jc from id query "wait" 'internal-server-error (error-message-string error-var))))
+ (jabber-send-iq-error jc from id query "cancel" 'feature-not-implemented)))))))
+
+(defun jabber-send-iq (jc to type query success-callback success-closure-data
+ error-callback error-closure-data &optional result-id)
+ "Send an iq stanza to the specified entity, and optionally set up a callback.
+JC is the Jabber connection.
+TO is the addressee.
+TYPE is one of \"get\", \"set\", \"result\" or \"error\".
+QUERY is a list containing the child of the iq node in the format
+`jabber-sexp2xml' accepts.
+SUCCESS-CALLBACK is the function to be called when a successful result arrives.
+SUCCESS-CLOSURE-DATA is an extra argument to SUCCESS-CALLBACK.
+ERROR-CALLBACK is the function to be called when an error arrives.
+ERROR-CLOSURE-DATA is an extra argument to ERROR-CALLBACK.
+RESULT-ID is the id to be used for a response to a received iq message.
+`jabber-report-success' and `jabber-process-data' are common callbacks.
+
+The callback functions are called like this:
+\(funcall CALLBACK JC XML-DATA CLOSURE-DATA)
+with XML-DATA being the IQ stanza received in response."
+ (let ((id (or result-id (apply 'format "emacs-iq-%d.%d.%d" (current-time)))))
+ (if (or success-callback error-callback)
+ (setq *jabber-open-info-queries* (cons (list id
+ (cons success-callback success-closure-data)
+ (cons error-callback error-closure-data))
+
+ *jabber-open-info-queries*)))
+ (jabber-send-sexp jc
+ (list 'iq (append
+ (if to (list (cons 'to to)))
+ (list (cons 'type type))
+ (list (cons 'id id)))
+ query))))
+
+(defun jabber-send-iq-error (jc to id original-query error-type condition
+ &optional text app-specific)
+ "Send an error iq stanza in response to a previously sent iq stanza.
+Send an error iq stanza to the specified entity in response to a
+previously sent iq stanza.
+TO is the addressee.
+ID is the id of the iq stanza that caused the error.
+ORIGINAL-QUERY is the original query, which should be included in the
+error, or nil.
+ERROR-TYPE is one of \"cancel\", \"continue\", \"modify\", \"auth\"
+and \"wait\".
+CONDITION is a symbol denoting a defined XMPP condition.
+TEXT is a string to be sent in the error message, or nil for no text.
+APP-SPECIFIC is a list of extra XML tags.
+JC is the Jabber connection.
+
+See section 9.3 of XMPP Core."
+ (jabber-send-sexp
+ jc
+ `(iq (,@(when to `((to . ,to)))
+ (type . "error")
+ (id . ,(or id "")))
+ ,original-query
+ (error ((type . ,error-type))
+ (,condition ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))
+ ,(if text
+ `(text ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))
+ ,text))
+ ,@app-specific))))
+
+(defun jabber-process-data (jc xml-data closure-data)
+ "Process random results from various requests.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let ((from (or (jabber-xml-get-attribute xml-data 'from) (plist-get (fsm-get-state-data jc) :server)))
+ (xmlns (jabber-iq-xmlns xml-data))
+ (type (jabber-xml-get-attribute xml-data 'type)))
+ (with-current-buffer (get-buffer-create (format-spec jabber-browse-buffer-format
+ (list (cons ?n from))))
+ (if (not (eq major-mode 'jabber-browse-mode))
+ (jabber-browse-mode))
+
+ (setq buffer-read-only nil)
+ (goto-char (point-max))
+
+ (insert (jabber-propertize from
+ 'face 'jabber-title-large) "\n\n")
+
+ ;; Put point at beginning of data
+ (save-excursion
+ ;; If closure-data is a function, call it. If it is a string,
+ ;; output it along with a description of the error. For other
+ ;; values (e.g. nil), just dump the XML.
+ (cond
+ ((functionp closure-data)
+ (funcall closure-data jc xml-data))
+ ((stringp closure-data)
+ (insert closure-data ": " (jabber-parse-error (jabber-iq-error xml-data)) "\n\n"))
+ (t
+ (insert (format "%S\n\n" xml-data))))
+
+ (dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks))
+ (run-hook-with-args hook 'browse (current-buffer) (funcall jabber-alert-info-message-function 'browse (current-buffer))))))))
+
+(defun jabber-silent-process-data (jc xml-data closure-data)
+ "Process random results from various requests to only alert hooks.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let ((text (cond
+ ((functionp closure-data)
+ (funcall closure-data jc xml-data))
+ ((stringp closure-data)
+ (concat closure-data ": " (jabber-parse-error (jabber-iq-error xml-data))))
+ (t
+ (format "%S" xml-data)))))
+ (dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks))
+ (run-hook-with-args hook 'browse (current-buffer)
+ text))))
diff --git a/jabber-keepalive.el b/jabber-keepalive.el
new file mode 100644
index 0000000..c323057
--- /dev/null
+++ b/jabber-keepalive.el
@@ -0,0 +1,136 @@
+;;;###autoload
+(defgroup jabber-keepalive nil
+ "Keepalive functions try to detect lost connection"
+ :group 'jabber)
+
+(defcustom jabber-keepalive-interval 600
+ "Interval in seconds between connection checks."
+ :type 'integer
+ :group 'jabber-keepalive)
+
+(defcustom jabber-keepalive-timeout 20
+ "Seconds to wait for response from server."
+ :type 'integer
+ :group 'jabber-keepalive)
+
+(defvar jabber-keepalive-timer nil
+ "Timer object for keepalive function.")
+
+(defvar jabber-keepalive-timeout-timer nil
+ "Timer object for keepalive timeout function.")
+
+(defvar jabber-keepalive-pending nil
+ "List of outstanding keepalive connections.")
+
+(defvar jabber-keepalive-debug nil
+ "Log keepalive traffic when non-nil.")
+
+;;;###autoload
+(defun jabber-keepalive-start (&optional jc)
+ "Activate keepalive.
+That is, regularly send a ping request to the server, and
+disconnect it if it doesn't answer. See variable `jabber-keepalive-interval'
+and variable `jabber-keepalive-timeout'.
+
+The JC argument makes it possible to add this function to
+`jabber-post-connect-hooks'; it is ignored. Keepalive is activated
+for all accounts regardless of the argument."
+ (interactive)
+
+ (when jabber-keepalive-timer
+ (jabber-keepalive-stop))
+
+ (setq jabber-keepalive-timer
+ (run-with-timer 5
+ jabber-keepalive-interval
+ 'jabber-keepalive-do))
+ (add-hook 'jabber-post-disconnect-hook 'jabber-keepalive-stop))
+
+(defun jabber-keepalive-stop ()
+ "Deactivate keepalive."
+ (interactive)
+
+ (when jabber-keepalive-timer
+ (jabber-cancel-timer jabber-keepalive-timer)
+ (setq jabber-keepalive-timer nil)))
+
+(defun jabber-keepalive-do ()
+ (when jabber-keepalive-debug
+ (message "%s: sending keepalive packet(s)" (current-time-string)))
+ (setq jabber-keepalive-timeout-timer
+ (run-with-timer jabber-keepalive-timeout
+ nil
+ 'jabber-keepalive-timeout))
+ (setq jabber-keepalive-pending jabber-connections)
+ (dolist (c jabber-connections)
+ ;; Whether we get an error or not is not interesting.
+ ;; Getting a response at all is.
+ (jabber-ping-send c nil 'jabber-keepalive-got-response nil nil)))
+
+(defun jabber-keepalive-got-response (jc &rest args)
+ (when jabber-keepalive-debug
+ (message "%s: got keepalive response from %s"
+ (current-time-string)
+ (plist-get (fsm-get-state-data jc) :server)))
+ (setq jabber-keepalive-pending (remq jc jabber-keepalive-pending))
+ (when (and (null jabber-keepalive-pending) (timerp jabber-keepalive-timeout-timer))
+ (jabber-cancel-timer jabber-keepalive-timeout-timer)
+ (setq jabber-keepalive-timeout-timer nil)))
+
+(defun jabber-keepalive-timeout ()
+ (jabber-cancel-timer jabber-keepalive-timer)
+ (setq jabber-keepalive-timer nil)
+
+ (dolist (c jabber-keepalive-pending)
+ (message "%s: keepalive timeout, connection to %s considered lost"
+ (current-time-string)
+ (plist-get (fsm-get-state-data c) :server))
+
+ (run-hook-with-args 'jabber-lost-connection-hooks c)
+ (jabber-disconnect-one c nil)))
+
+(defcustom jabber-whitespace-ping-interval 30
+ "Send a space character to the server with this interval, in seconds.
+
+This is a traditional remedy for a number of problems: to keep NAT
+boxes from considering the connection dead, to have the OS discover
+earlier that the connection is lost, and to placate servers which rely
+on the client doing this, e.g. Openfire.
+
+If you want to verify that the server is able to answer, see
+`jabber-keepalive-start' for another mechanism."
+ :type '(integer :tag "Interval in seconds")
+ :group 'jabber-core)
+
+(defvar jabber-whitespace-ping-timer nil
+ "Timer object for whitespace pings.")
+
+;;;###autoload
+(defun jabber-whitespace-ping-start (&optional jc)
+ "Start sending whitespace pings at regular intervals.
+See `jabber-whitespace-ping-interval'.
+
+The JC argument is ignored; whitespace pings are enabled for all
+accounts."
+ (interactive)
+
+ (when jabber-whitespace-ping-timer
+ (jabber-whitespace-ping-stop))
+
+ (setq jabber-whitespace-ping-timer
+ (run-with-timer 5
+ jabber-whitespace-ping-interval
+ 'jabber-whitespace-ping-do))
+ (add-hook 'jabber-post-disconnect-hook 'jabber-whitespace-ping-stop))
+
+(defun jabber-whitespace-ping-stop ()
+ "Deactivate whitespace pings."
+ (interactive)
+
+ (when jabber-whitespace-ping-timer
+ (jabber-cancel-timer jabber-whitespace-ping-timer)
+ (setq jabber-whitespace-ping-timer nil)))
+
+(defun jabber-whitespace-ping-do ()
+ (dolist (c jabber-connections)
+ (ignore-errors (jabber-send-string c " "))))
diff --git a/jabber-keymap.el b/jabber-keymap.el
new file mode 100644
index 0000000..6edba3e
--- /dev/null
+++ b/jabber-keymap.el
@@ -0,0 +1,33 @@
+(require 'button)
+
+(defvar jabber-common-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-c\C-c" 'jabber-popup-chat-menu)
+ (define-key map "\C-c\C-r" 'jabber-popup-roster-menu)
+ (define-key map "\C-c\C-i" 'jabber-popup-info-menu)
+ (define-key map "\C-c\C-m" 'jabber-popup-muc-menu)
+ (define-key map "\C-c\C-s" 'jabber-popup-service-menu)
+ ;; note that {forward,backward}-button are not autoloaded.
+ ;; thus the `require' above.
+ (when (fboundp 'forward-button)
+ (define-key map [?\t] 'forward-button)
+ (define-key map [backtab] 'backward-button))
+ map))
+
+;;;###autoload
+(defvar jabber-global-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-c" 'jabber-connect-all)
+ (define-key map "\C-d" 'jabber-disconnect)
+ (define-key map "\C-r" 'jabber-switch-to-roster-buffer)
+ (define-key map "\C-j" 'jabber-chat-with)
+ (define-key map "\C-l" 'jabber-activity-switch-to)
+ (define-key map "\C-a" 'jabber-send-away-presence)
+ (define-key map "\C-o" 'jabber-send-default-presence)
+ (define-key map "\C-x" 'jabber-send-xa-presence)
+ (define-key map "\C-p" 'jabber-send-presence)
+ map)
+ "Global Jabber keymap (usually under C-x C-j).")
+
+;;;###autoload
+(define-key ctl-x-map "\C-j" jabber-global-keymap)
diff --git a/jabber-legacy-socks5.el b/jabber-legacy-socks5.el
new file mode 100644
index 0000000..c1ab902
--- /dev/null
+++ b/jabber-legacy-socks5.el
@@ -0,0 +1,646 @@
+(eval-when-compile (require 'cl))
+
+(defvar jabber-socks5-pending-sessions nil
+ "List of pending sessions.
+
+Each entry is a list, containing:
+ * Stream ID
+ * Full JID of initiator
+ * State machine managing the session")
+
+(defvar jabber-socks5-active-sessions nil
+ "List of active sessions.
+
+Each entry is a list, containing:
+ * Network connection
+ * Stream ID
+ * Full JID of initiator
+ * Profile data function")
+
+(defcustom jabber-socks5-proxies nil
+ "JIDs of XEP-0065 proxies to use for file transfer.
+Put preferred ones first."
+ :type '(repeat string)
+ :group 'jabber
+; :set 'jabber-socks5-set-proxies)
+ )
+
+(defvar jabber-socks5-proxies-data nil
+ "Alist containing information about proxies.
+Keys of the alist are strings, the JIDs of the proxies.
+Values are \"streamhost\" XML nodes.")
+
+(jabber-disco-advertise-feature "http://jabber.org/protocol/bytestreams")
+
+(add-to-list 'jabber-si-stream-methods
+ (list "http://jabber.org/protocol/bytestreams"
+ 'jabber-socks5-client-1
+ 'jabber-socks5-accept))
+
+(defun jabber-socks5-set-proxies (symbol value)
+ "Set `jabber-socks5-proxies' and query proxies.
+This is the set function of `jabber-socks5-proxies-data'."
+ (set-default symbol value)
+ (when jabber-connections
+ (jabber-socks5-query-all-proxies)))
+
+(defun jabber-socks5-query-all-proxies (jc &optional callback)
+ "Ask all proxies in `jabber-socks5-proxies' for connection information.
+If CALLBACK is non-nil, call it with no arguments when all
+proxies have answered."
+ (interactive (list (jabber-read-account)))
+ (setq jabber-socks5-proxies-data nil)
+ (dolist (proxy jabber-socks5-proxies)
+ (jabber-socks5-query-proxy jc proxy callback)))
+
+(defun jabber-socks5-query-proxy (jc jid &optional callback)
+ "Query the SOCKS5 proxy specified by JID for IP and port number."
+ (jabber-send-iq jc jid "get"
+ '(query ((xmlns . "http://jabber.org/protocol/bytestreams")))
+ #'jabber-socks5-process-proxy-response (list callback t)
+ #'jabber-socks5-process-proxy-response (list callback nil)))
+
+(defun jabber-socks5-process-proxy-response (jc xml-data closure-data)
+ "Process response from proxy query."
+ (let* ((query (jabber-iq-query xml-data))
+ (from (jabber-xml-get-attribute xml-data 'from))
+ (streamhosts (jabber-xml-get-children query 'streamhost)))
+
+ (let ((existing-entry (assoc from jabber-socks5-proxies-data)))
+ (when existing-entry
+ (setq jabber-socks5-proxies-data
+ (delq existing-entry jabber-socks5-proxies-data))))
+
+ (destructuring-bind (callback successp) closure-data
+ (when successp
+ (setq jabber-socks5-proxies-data
+ (cons (cons from streamhosts)
+ jabber-socks5-proxies-data)))
+ (message "%s from %s. %d of %d proxies have answered."
+ (if successp "Response" "Error") from
+ (length jabber-socks5-proxies-data) (length jabber-socks5-proxies))
+ (when (and callback (= (length jabber-socks5-proxies-data) (length jabber-socks5-proxies)))
+ (funcall callback)))))
+
+(define-state-machine jabber-socks5
+ :start ((jc jid sid profile-function role)
+ "Start XEP-0065 bytestream with JID.
+SID is the session ID used.
+PROFILE-FUNCTION is the function to call upon success. See `jabber-si-stream-methods'.
+ROLE is either :initiator or :target. The initiator sends an IQ
+set; the target waits for one."
+ (let ((new-state-data (list :jc jc
+ :jid jid
+ :sid sid
+ :profile-function profile-function
+ :role role))
+ (new-state
+ ;; We want information about proxies; it might be needed in
+ ;; various situations.
+ (cond
+ ((null jabber-socks5-proxies)
+ ;; We know no proxy addresses. Try to find them by disco.
+ 'seek-proxies)
+ ((null jabber-socks5-proxies-data)
+ ;; We need to query the proxies for addresses.
+ 'query-proxies)
+ ;; So, we have our proxies.
+ (t
+ 'initiate))))
+ (list new-state new-state-data nil))))
+
+(defun jabber-socks5-accept (jc jid sid profile-function)
+ "Remember that we are waiting for connection from JID, with stream id SID"
+ ;; asking the user for permission is done in the profile
+ (add-to-list 'jabber-socks5-pending-sessions
+ (list sid jid (start-jabber-socks5 jc jid sid profile-function :target))))
+
+(define-enter-state jabber-socks5 seek-proxies (fsm state-data)
+ ;; Look for items at the server.
+ (let* ((jc (plist-get state-data :jc))
+ (server (jabber-jid-server (jabber-connection-jid jc))))
+ (jabber-disco-get-items jc
+ server
+ nil
+ (lambda (jc fsm result)
+ (fsm-send-sync fsm (cons :items result)))
+ fsm))
+ ;; Spend no more than five seconds looking for a proxy.
+ (list state-data 5))
+
+(define-state jabber-socks5 seek-proxies (fsm state-data event callback)
+ "Collect disco results, looking for a bytestreams proxy."
+ ;; We put the number of outstanding requests as :remaining-info in
+ ;; the state-data plist.
+ (cond
+ ;; We're not ready to handle the IQ stanza yet
+ ((eq (car-safe event) :iq)
+ :defer)
+
+ ;; Got list of items at the server.
+ ((eq (car-safe event) :items)
+ (dolist (entry (cdr event))
+ ;; Each entry is ["name" "jid" "node"]. We send a disco info
+ ;; request to everything without a node.
+ (when (null (aref entry 2))
+ (lexical-let ((jid (aref entry 1)))
+ (jabber-disco-get-info
+ (plist-get state-data :jc)
+ jid nil
+ (lambda (jc fsm result)
+ (fsm-send-sync fsm (list :info jid result)))
+ fsm))))
+ ;; Remember number of requests sent. But if none, we just go on.
+ (if (cdr event)
+ (list 'seek-proxies (plist-put state-data :remaining-info (length (cdr event))) :keep)
+ (list 'initiate state-data nil)))
+
+ ;; Got disco info from an item at the server.
+ ((eq (car-safe event) :info)
+ (fsm-debug-output "got disco event")
+ ;; Count the response.
+ (plist-put state-data :remaining-info (1- (plist-get state-data :remaining-info)))
+ (unless (eq (first (third event)) 'error)
+ (let ((identities (first (third event))))
+ ;; Is it a bytestream proxy?
+ (when (dolist (identity identities)
+ (when (and (string= (aref identity 1) "proxy")
+ (string= (aref identity 2) "bytestreams"))
+ (return t)))
+ ;; Yes, it is. Add it to the list.
+ (push (second event) jabber-socks5-proxies))))
+
+ ;; Wait for more responses, if any are to be expected.
+ (if (zerop (plist-get state-data :remaining-info))
+ ;; No more... go on to querying the proxies.
+ (list 'query-proxies state-data nil)
+ ;; We expect more responses...
+ (list 'seek-proxies state-data :keep)))
+
+ ((eq event :timeout)
+ ;; We can't wait anymore...
+ (list 'query-proxies state-data nil))))
+
+(define-enter-state jabber-socks5 query-proxies (fsm state-data)
+ (jabber-socks5-query-all-proxies
+ (plist-get state-data :jc)
+ (lexical-let ((fsm fsm))
+ (lambda () (fsm-send-sync fsm :proxies))))
+ (list state-data 5))
+
+(define-state jabber-socks5 query-proxies (fsm state-data event callback)
+ "Query proxies in `jabber-socks5-proxies'."
+ (cond
+ ;; Can't handle the iq stanza yet...
+ ((eq (car-safe event) :iq)
+ :defer)
+
+ ((eq (car-safe event) :info)
+ ;; stray event... do nothing
+ (list 'query-proxies state-data :keep))
+
+ ;; Got response/error from all proxies, or timeout
+ ((memq event '(:proxies :timeout))
+ (list 'initiate state-data nil))))
+
+(define-enter-state jabber-socks5 initiate (fsm state-data)
+ ;; Sort the alist jabber-socks5-proxies-data such that the
+ ;; keys are in the same order as in jabber-socks5-proxies.
+ (setq jabber-socks5-proxies-data
+ (sort jabber-socks5-proxies-data
+ #'(lambda (a b)
+ (> (length (member (car a) jabber-socks5-proxies))
+ (length (member (car b) jabber-socks5-proxies))))))
+
+ ;; If we're the initiator, send initiation stanza.
+ (when (eq (plist-get state-data :role) :initiator)
+ ;; This is where initiation of server sockets would go
+
+ (jabber-send-iq
+ (plist-get state-data :jc)
+ (plist-get state-data :jid) "set"
+ `(query ((xmlns . "http://jabber.org/protocol/bytestreams")
+ (sid . ,(plist-get state-data :sid)))
+ ,@(mapcar
+ #'(lambda (proxy)
+ (mapcar
+ #'(lambda (streamhost)
+ (list 'streamhost
+ (list (cons 'jid (jabber-xml-get-attribute streamhost 'jid))
+ (cons 'host (jabber-xml-get-attribute streamhost 'host))
+ (cons 'port (jabber-xml-get-attribute streamhost 'port)))
+ ;; (proxy ((xmlns . "http://affinix.com/jabber/stream")))
+ ))
+ (cdr proxy)))
+ jabber-socks5-proxies-data)
+ ;; (fast ((xmlns . "http://affinix.com/jabber/stream")))
+ )
+ (lexical-let ((fsm fsm))
+ (lambda (jc xml-data closure-data)
+ (fsm-send-sync fsm (list :iq xml-data))))
+ nil
+ ;; TODO: error handling
+ #'jabber-report-success "SOCKS5 negotiation"))
+
+ ;; If we're the target, we just wait for an incoming stanza.
+ (list state-data nil))
+
+(add-to-list 'jabber-iq-set-xmlns-alist
+ (cons "http://jabber.org/protocol/bytestreams" 'jabber-socks5-process))
+(defun jabber-socks5-process (jc xml-data)
+ "Accept IQ get for SOCKS5 bytestream"
+ (let* ((jid (jabber-xml-get-attribute xml-data 'from))
+ (id (jabber-xml-get-attribute xml-data 'id))
+ (query (jabber-iq-query xml-data))
+ (sid (jabber-xml-get-attribute query 'sid))
+ (session (dolist (pending-session jabber-socks5-pending-sessions)
+ (when (and (equal sid (nth 0 pending-session))
+ (equal jid (nth 1 pending-session)))
+ (return pending-session)))))
+ ;; check that we really are expecting this session
+ (unless session
+ (jabber-signal-error "auth" 'not-acceptable))
+
+ (setq jabber-socks5-pending-sessions (delq session jabber-socks5-pending-sessions))
+ (fsm-send-sync (nth 2 session) (list :iq xml-data))
+
+ ;; find streamhost to connect to
+;; (let* ((streamhosts (jabber-xml-get-children query 'streamhost))
+;; (streamhost (dolist (streamhost streamhosts)
+;; (let ((connection (jabber-socks5-connect streamhost sid jid (concat jabber-username "@" jabber-server "/" jabber-resource))))
+;; (when connection
+;; ;; We select the first streamhost that we are able to connect to.
+;; (push (list connection sid jid profile-data-function)
+;; jabber-socks5-active-sessions)
+;; ;; Now set the filter, for the rest of the output
+;; (set-process-filter connection #'jabber-socks5-filter)
+;; (set-process-sentinel connection #'jabber-socks5-sentinel)
+;; (return streamhost))))))
+;; (unless streamhost
+;; (jabber-signal-error "cancel" 'item-not-found))
+
+;; ;; tell initiator which streamhost we use
+;; (jabber-send-iq jid "result"
+;; `(query ((xmlns . "http://jabber.org/protocol/bytestreams"))
+;; (streamhost-used ((jid . ,(jabber-xml-get-attribute streamhost 'jid)))))
+;; nil nil nil nil id)
+;; ;; now, as data is sent, it will be passed to the profile.
+;; )
+ ))
+
+(define-state jabber-socks5 initiate (fsm state-data event callback)
+ (let* ((jc (plist-get state-data :jc))
+ (jc-data (fsm-get-state-data jc))
+ (our-jid (concat (plist-get jc-data :username) "@"
+ (plist-get jc-data :server) "/"
+ (plist-get jc-data :resource)))
+ (their-jid (plist-get state-data :jid))
+ (initiator-jid (if (eq (plist-get state-data :role) :initiator) our-jid their-jid))
+ (target-jid (if (eq (plist-get state-data :role) :initiator) their-jid our-jid)))
+ (cond
+ ;; Stray event...
+ ((memq (car-safe event) '(:proxy :info))
+ (list 'initiate state-data :keep))
+
+ ;; Incoming IQ
+ ((eq (car-safe event) :iq)
+ (let ((xml-data (second event)))
+ ;; This is either type "set" (with a list of streamhosts to
+ ;; use), or a "result" (indicating the streamhost finally used
+ ;; by the other party).
+ (cond
+ ((string= (jabber-xml-get-attribute xml-data 'type) "set")
+ ;; A "set" makes sense if we're the initiator and offered
+ ;; Psi's "fast mode". We don't yet, though, so this is only
+ ;; for target.
+ (dolist (streamhost (jabber-xml-get-children (jabber-iq-query xml-data) 'streamhost))
+ (jabber-xml-let-attributes
+ (jid host port) streamhost
+ ;; This is where we would attempt to support zeroconf
+ (when (and jid host port)
+ (start-jabber-socks5-connection
+ jc initiator-jid target-jid jid
+ (plist-get state-data :sid) host port fsm))))
+
+ (list 'wait-for-connection (plist-put state-data :iq-id (jabber-xml-get-attribute xml-data 'id)) 30))
+
+ ((string= (jabber-xml-get-attribute xml-data 'type) "result")
+ ;; The other party has decided what streamhost to use.
+ (let* ((proxy-used (jabber-xml-get-attribute (jabber-xml-path xml-data '(query streamhost-used)) 'jid))
+ ;; If JID is our own JID, we have probably already detected
+ ;; what connection to use. But that is a later problem...
+ (streamhosts (cdr (assoc proxy-used jabber-socks5-proxies-data))))
+ ;; Try to connect to all addresses of this proxy...
+ (dolist (streamhost streamhosts)
+ (jabber-xml-let-attributes
+ (jid host port) streamhost
+ (when (and jid host port)
+ (start-jabber-socks5-connection
+ jc initiator-jid target-jid jid
+ (plist-get state-data :sid) host port fsm)))))
+
+ (list 'wait-for-connection state-data 30))))))))
+
+(define-state-machine jabber-socks5-connection
+ :start
+ ((jc initiator-jid target-jid streamhost-jid sid host port socks5-fsm)
+ "Connect to a single XEP-0065 streamhost."
+ (let ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary))
+ ;; make-network-process, which we really want, for asynchronous
+ ;; connection and such, was introduced in Emacs 22.
+ (if (fboundp 'make-network-process)
+ (let ((connection
+ (make-network-process
+ :name "socks5"
+ :buffer nil
+ :host host
+ :service (string-to-number port)
+ :nowait t
+ :filter (fsm-make-filter fsm)
+ :sentinel (fsm-make-sentinel fsm))))
+ (list 'wait-for-connection
+ (list :jc jc
+ :connection connection
+ :initiator-jid initiator-jid
+ :target-jid target-jid
+ :streamhost-jid streamhost-jid
+ :sid sid
+ :socks5-fsm socks5-fsm)
+ 30))
+ ;; So we open a stream, and wait for the connection to succeed.
+ (condition-case nil
+ (let ((connection
+ (open-network-stream "socks5" nil
+ host (string-to-number port))))
+ (set-process-filter connection (fsm-make-filter fsm))
+ (set-process-sentinel connection (fsm-make-sentinel fsm))
+ (list 'authenticate
+ (list :jc jc
+ :connection connection
+ :initiator-jid initiator-jid
+ :target-jid target-jid
+ :streamhost-jid streamhost-jid
+ :sid sid
+ :socks5-fsm socks5-fsm)
+ nil))
+ (error (list 'fail '() nil)))))))
+
+(define-state jabber-socks5-connection wait-for-connection
+ (fsm state-data event callback)
+ (cond
+ ((eq (car-safe event) :sentinel)
+ (let ((string (third event)))
+ (cond
+ ;; Connection succeeded
+ ((string= (substring string 0 4) "open")
+ (list 'authenticate state-data nil))
+ ;; Connection failed
+ (t
+ (list 'fail state-data nil)))))))
+
+(define-enter-state jabber-socks5-connection authenticate
+ (fsm state-data)
+ "Send authenticate command."
+ ;; version: 5. number of auth methods supported: 1.
+ ;; which one: no authentication.
+ (process-send-string (plist-get state-data :connection) (string 5 1 0))
+ (list state-data 30))
+
+(define-state jabber-socks5-connection authenticate
+ (fsm state-data event callback)
+ "Receive response to authenticate command."
+ (cond
+ ((eq (car-safe event) :filter)
+ (let ((string (third event)))
+ ;; should return:
+ ;; version: 5. auth method to use: none
+ (if (string= string (string 5 0))
+ ;; Authenticated. Send connect command.
+ (list 'connect state-data nil)
+ ;; Authentication failed...
+ (delete-process (second event))
+ (list 'fail state-data nil))))
+
+ ((eq (car-safe event) :sentinel)
+ (list 'fail state-data nil))))
+
+(define-enter-state jabber-socks5-connection connect (fsm state-data)
+ "Send connect command."
+ (let* ((sid (plist-get state-data :sid))
+ (initiator (plist-get state-data :initiator-jid))
+ (target (plist-get state-data :target-jid))
+ (hash (sha1 (concat sid initiator target))))
+ (process-send-string
+ (plist-get state-data :connection)
+ (concat (string 5 1 0 3 (length hash))
+ hash
+ (string 0 0)))
+ (list state-data 30)))
+
+(define-state jabber-socks5-connection connect
+ (fsm state-data event callback)
+ "Receive response to connect command."
+ (cond
+ ((eq (car-safe event) :filter)
+ (let ((string (third event)))
+ (if (string= (substring string 0 2) (string 5 0))
+ ;; connection established
+ (progn
+ (fsm-send (plist-get state-data :socks5-fsm)
+ (list :connected
+ (plist-get state-data :connection)
+ (plist-get state-data :streamhost-jid)))
+ ;; Our work is done
+ (list 'done nil))
+ (list 'fail state-data nil))))
+ ((eq (car-safe event) :sentinel)
+ (list 'fail state-data nil))))
+
+(define-state jabber-socks5-connection done
+ (fsm state-data event callback)
+ ;; ignore all events
+ (list 'done nil nil))
+
+(define-enter-state jabber-socks5-connection fail (fsm state-data)
+ ;; Notify parent fsm about failure
+ (fsm-send (plist-get state-data :socks5-fsm)
+ :not-connected)
+ (list nil nil))
+
+(define-state jabber-socks5-connection fail
+ (fsm state-data event callback)
+ ;; ignore all events
+ (list 'fail nil nil))
+
+(define-state jabber-socks5 wait-for-connection
+ (fsm state-data event callback)
+ (cond
+ ((eq (car-safe event) :connected)
+ (destructuring-bind (ignored connection streamhost-jid) event
+ (setq state-data (plist-put state-data :connection connection))
+ ;; If we are expected to tell which streamhost we chose, do so.
+ (let ((iq-id (plist-get state-data :iq-id)))
+ (when iq-id
+ (jabber-send-iq
+ (plist-get state-data :jc)
+ (plist-get state-data :jid) "result"
+ `(query ((xmlns . "http://jabber.org/protocol/bytestreams"))
+ (streamhost-used ((jid . ,streamhost-jid))))
+ nil nil nil nil
+ iq-id)))
+
+ ;; If we are the initiator, we should activate the bytestream.
+ (if (eq (plist-get state-data :role) :initiator)
+ (progn
+ (jabber-send-iq
+ (plist-get state-data :jc)
+ streamhost-jid "set"
+ `(query ((xmlns . "http://jabber.org/protocol/bytestreams")
+ (sid . ,(plist-get state-data :sid)))
+ (activate nil ,(plist-get state-data :jid)))
+ (lambda (jc xml-data fsm) (fsm-send-sync fsm :activated)) fsm
+ (lambda (jc xml-data fsm) (fsm-send-sync fsm :activation-failed)) fsm)
+ (list 'wait-for-activation state-data 10))
+ ;; Otherwise, we just let the data flow.
+ (list 'stream-activated state-data nil))))
+
+ ((eq event :not-connected)
+ ;; If we were counting the streamhosts, we would know when there
+ ;; are no more chances left.
+ (list 'wait-for-connection state-data :keep))
+
+ ((eq event :timeout)
+ (list 'fail (plist-put state-data :error "Timeout when connecting to streamhosts") nil))))
+
+(define-state jabber-socks5 wait-for-activation
+ (fsm state-data event callback)
+ (cond
+ ((eq event :activated)
+ (list 'stream-activated state-data nil))
+ ((eq event :activation-failed)
+ (list 'fail (plist-put state-data :error "Proxy activation failed") nil))
+
+ ;; Stray events from earlier state
+ ((eq (car-safe event) :connected)
+ ;; We just close the connection
+ (delete-process (second event))
+ (list 'wait-for-activation state-data :keep))
+ ((eq event :not-connected)
+ (list 'wait-for-activation state-data :keep))))
+
+(define-enter-state jabber-socks5 stream-activated
+ (fsm state-data)
+ (let ((connection (plist-get state-data :connection))
+ (jc (plist-get state-data :jc))
+ (jid (plist-get state-data :jid))
+ (sid (plist-get state-data :sid))
+ (profile-function (plist-get state-data :profile-function)))
+ (set-process-filter connection (fsm-make-filter fsm))
+ (set-process-sentinel connection (fsm-make-sentinel fsm))
+ ;; Call the profile function, passing the data send function, and
+ ;; receiving the data receiving function. Put the data receiving
+ ;; function in the plist.
+ (list (plist-put state-data
+ :profile-data-function
+ (funcall profile-function
+ jc jid sid
+ (lexical-let ((fsm fsm))
+ (lambda (data)
+ (fsm-send fsm (list :send data))))))
+ nil)))
+
+
+(define-state jabber-socks5 stream-activated
+ (fsm state-data event callback)
+ (let ((jc (plist-get state-data :jc))
+ (connection (plist-get state-data :connection))
+ (profile-data-function (plist-get state-data :profile-data-function))
+ (sid (plist-get state-data :sid))
+ (jid (plist-get state-data :jid)))
+ (cond
+ ((eq (car-safe event) :send)
+ (process-send-string connection (second event))
+ (list 'stream-activated state-data nil))
+
+ ((eq (car-safe event) :filter)
+ ;; Pass data from connection to profile data function
+ ;; If the data function requests it, tear down the connection.
+ (unless (funcall profile-data-function jc jid sid (third event))
+ (fsm-send fsm (list :sentinel (second event) "shutdown")))
+
+ (list 'stream-activated state-data nil))
+
+ ((eq (car-safe event) :sentinel)
+ ;; Connection terminated. Shuffle together the remaining data,
+ ;; and kill the buffer.
+ (delete-process (second event))
+ (funcall profile-data-function jc jid sid nil)
+ (list 'closed nil nil))
+
+ ;; Stray events from earlier state
+ ((eq (car-safe event) :connected)
+ ;; We just close the connection
+ (delete-process (second event))
+ (list 'stream-activated state-data nil))
+ ((eq event :not-connected)
+ (list 'stream-activated state-data nil)))))
+
+(define-enter-state jabber-socks5 fail (fsm state-data)
+ "Tell our caller that we failed."
+ (let ((jc (plist-get state-data :jc))
+ (jid (plist-get state-data :jid))
+ (sid (plist-get state-data :sid))
+ (profile-function (plist-get state-data :profile-function))
+ (iq-id (plist-get state-data :iq-id)))
+ (funcall profile-function jc jid sid (plist-get state-data :error))
+
+ (when iq-id
+ (jabber-send-iq-error jc jid iq-id nil "cancel"
+ 'remote-server-not-found)))
+ (list nil nil))
+
+(defun jabber-socks5-client-1 (jc jid sid profile-function)
+ "Negotiate a SOCKS5 connection with JID.
+This function simply starts a state machine."
+ (add-to-list 'jabber-socks5-pending-sessions
+ (list sid jid (start-jabber-socks5 jc jid sid profile-function :initiator))))
+
+;; (defun jabber-socks5-client-2 (xml-data jid sid profile-function)
+;; "Contact has selected a streamhost to use. Connect to the proxy."
+;; (let* ((query (jabber-iq-query xml-data))
+;; (streamhost-used (car (jabber-xml-get-children query 'streamhost-used)))
+;; (proxy-used (jabber-xml-get-attribute streamhost-used 'jid))
+;; connection)
+;; (let ((streamhosts-left (cdr (assoc proxy-used jabber-socks5-proxies-data))))
+;; (while (and streamhosts-left (not connection))
+;; (setq connection
+;; (jabber-socks5-connect (car streamhosts-left)
+;; sid
+;; (concat jabber-username "@" jabber-server "/" jabber-resource)
+;; jid))
+;; (setq streamhosts-left (cdr streamhosts-left))))
+;; (unless connection
+;; (error "Couldn't connect to proxy %s" proxy-used))
+
+;; ;; Activation is only needed for proxies.
+;; (jabber-send-iq proxy-used "set"
+;; `(query ((xmlns . "http://jabber.org/protocol/bytestreams")
+;; (sid . ,sid))
+;; (activate () ,jid))
+;; (lexical-let ((jid jid) (sid sid) (profile-function profile-function)
+;; (connection connection))
+;; (lambda (xml-data closure-data)
+;; (jabber-socks5-client-3 xml-data jid sid profile-function connection))) nil
+;; ;; TODO: report error to contact?
+;; #'jabber-report-success "Proxy activation")))
+
+;; (defun jabber-socks5-client-3 (xml-data jid sid profile-function proxy-connection)
+;; "Proxy is activated. Start the transfer."
+;; ;; The response from the proxy does not contain any interesting
+;; ;; information, beyond success confirmation.
+
+;; (funcall profile-function jid sid
+;; (lexical-let ((proxy-connection proxy-connection))
+;; (lambda (data)
+;; (process-send-string proxy-connection data)))))
diff --git a/jabber-logon.el b/jabber-logon.el
new file mode 100644
index 0000000..3cff226
--- /dev/null
+++ b/jabber-logon.el
@@ -0,0 +1,59 @@
+(unless (fboundp 'sha1)
+ (require 'sha1))
+
+(defun jabber-get-auth (jc to session-id)
+ "Send IQ get request in namespace \"jabber:iq:auth\".
+JC is the Jabber connection."
+ (jabber-send-iq jc to
+ "get"
+ `(query ((xmlns . "jabber:iq:auth"))
+ (username () ,(plist-get (fsm-get-state-data jc) :username)))
+ #'jabber-do-logon session-id
+ #'jabber-report-success "Impossible error - auth field request"))
+
+(defun jabber-do-logon (jc xml-data session-id)
+ "Send username and password in logon attempt.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let* ((digest-allowed (jabber-xml-get-children (jabber-iq-query xml-data) 'digest))
+ (passwd (when
+ (or digest-allowed
+ (plist-get (fsm-get-state-data jc) :encrypted)
+ (yes-or-no-p "Jabber server only allows cleartext password transmission! Continue? "))
+ (or (plist-get (fsm-get-state-data jc) :password)
+ (jabber-read-password (jabber-connection-bare-jid jc)))))
+ auth)
+ (if (null passwd)
+ (fsm-send jc :authentication-failure)
+ (if digest-allowed
+ (setq auth `(digest () ,(sha1 (concat session-id passwd))))
+ (setq auth `(password () ,passwd)))
+ ;; For legacy authentication we must specify a resource.
+ (unless (plist-get (fsm-get-state-data jc) :resource)
+ ;; Yes, this is ugly. Where is my encapsulation?
+ (plist-put (fsm-get-state-data jc) :resource "emacs-jabber"))
+ (jabber-send-iq jc (plist-get (fsm-get-state-data jc) :server)
+ "set"
+ `(query ((xmlns . "jabber:iq:auth"))
+ (username () ,(plist-get (fsm-get-state-data jc) :username))
+ ,auth
+ (resource () ,(plist-get (fsm-get-state-data jc) :resource)))
+ #'jabber-process-logon passwd
+ #'jabber-process-logon nil))))
+
+(defun jabber-process-logon (jc xml-data closure-data)
+ "Receive login success or failure, and request roster.
+CLOSURE-DATA should be the password on success and nil on failure.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (if closure-data
+ ;; Logon success
+ (fsm-send jc (cons :authentication-success closure-data))
+
+ ;; Logon failure
+ (jabber-report-success jc xml-data "Logon")
+ (fsm-send jc :authentication-failure)))
diff --git a/jabber-menu.el b/jabber-menu.el
new file mode 100644
index 0000000..f00f5b6
--- /dev/null
+++ b/jabber-menu.el
@@ -0,0 +1,175 @@
+;;;###autoload
+(defvar jabber-menu
+ (let ((map (make-sparse-keymap "jabber-menu")))
+ (define-key-after map
+ [jabber-menu-connect]
+ '("Connect" . jabber-connect-all))
+
+ (define-key-after map
+ [jabber-menu-disconnect]
+ '(menu-item "Disconnect" jabber-disconnect
+ :enable (bound-and-true-p jabber-connections)))
+
+ (define-key-after map
+ [jabber-menu-status]
+ `(menu-item "Set Status" ,(make-sparse-keymap "set-status")
+ :enable (bound-and-true-p jabber-connections)))
+
+ (define-key map
+ [jabber-menu-status jabber-menu-status-chat]
+ '(menu-item
+ "Chatty"
+ (lambda ()
+ (interactive)
+ (jabber-send-presence "chat"
+ (jabber-read-with-input-method "status message: " *jabber-current-status* '*jabber-status-history*)
+ *jabber-current-priority*))
+ :button (:radio . (and (boundp '*jabber-current-show*)
+ (equal *jabber-current-show* "chat")))))
+ (define-key map
+ [jabber-menu-status jabber-menu-status-dnd]
+ '(menu-item
+ "Do not Disturb"
+ (lambda ()
+ (interactive)
+ (jabber-send-presence "dnd"
+ (jabber-read-with-input-method "status message: " *jabber-current-status* '*jabber-status-history*)
+ *jabber-current-priority*))
+ :button (:radio . (and (boundp '*jabber-current-show*)
+ (equal *jabber-current-show* "dnd")))))
+ (define-key map
+ [jabber-menu-status jabber-menu-status-xa]
+ '(menu-item "Extended Away" jabber-send-xa-presence
+ :button (:radio . (and (boundp '*jabber-current-show*)
+ (equal *jabber-current-show* "xa")))))
+ (define-key map
+ [jabber-menu-status jabber-menu-status-away]
+ '(menu-item "Away" jabber-send-away-presence
+ :button (:radio . (and (boundp '*jabber-current-show*)
+ (equal *jabber-current-show* "away")))))
+ (define-key map
+ [jabber-menu-status jabber-menu-status-online]
+ '(menu-item "Online" jabber-send-default-presence
+ :button (:radio . (and (boundp '*jabber-current-show*)
+ (equal *jabber-current-show* "")))))
+
+ (define-key-after map
+ [separator]
+ '(menu-item "--"))
+
+ (define-key-after map
+ [jabber-menu-chat-with]
+ '(menu-item "Chat with..." jabber-chat-with
+ :enable (bound-and-true-p jabber-connections)))
+
+ (define-key-after map
+ [jabber-menu-nextmsg]
+ '(menu-item "Next unread message" jabber-activity-switch-to
+ :enable (bound-and-true-p jabber-activity-jids)))
+
+ (define-key-after map
+ [jabber-menu-send-subscription-request]
+ '(menu-item "Send subscription request" jabber-send-subscription-request
+ :enable (bound-and-true-p jabber-connections)))
+
+ (define-key-after map
+ [jabber-menu-roster]
+ '("Switch to roster" . jabber-switch-to-roster-buffer))
+
+ (define-key-after map
+ [separator2]
+ '(menu-item "--"))
+
+ (define-key-after map
+ [jabber-menu-customize]
+ '("Customize" . jabber-customize))
+
+ (define-key-after map
+ [jabber-menu-info]
+ '("Help" . jabber-info))
+
+ map))
+
+;;;###autoload
+(defcustom jabber-display-menu 'maybe
+ "Decide whether the \"Jabber\" menu is displayed in the menu bar.
+If t, always display.
+If nil, never display.
+If maybe, display if jabber.el is installed under `package-user-dir', or
+if any of `jabber-account-list' or `jabber-connections' is non-nil."
+ :group 'jabber
+ :type '(choice (const :tag "Never" nil)
+ (const :tag "Always" t)
+ (const :tag "When installed by user, or when any accounts have been configured or connected" maybe)))
+
+ (defun jabber-menu (&optional remove)
+ "Put \"Jabber\" menu on menubar.
+ With prefix argument, remove it."
+ (interactive "P")
+ (setq jabber-display-menu (if remove nil t))
+ (force-mode-line-update))
+ (make-obsolete 'jabber-menu "set the variable `jabber-display-menu' instead." "27.2")
+
+;;;###autoload
+(define-key-after (lookup-key global-map [menu-bar])
+ [jabber-menu]
+ (list 'menu-item "Jabber" jabber-menu
+ :visible
+ '(or (eq jabber-display-menu t)
+ (and (eq jabber-display-menu 'maybe)
+ (or (bound-and-true-p jabber-account-list)
+ (bound-and-true-p jabber-connections))))))
+
+(defvar jabber-jid-chat-menu nil
+ "Menu items for chat menu.")
+
+(defvar jabber-jid-info-menu nil
+ "Menu item for info menu.")
+
+(defvar jabber-jid-roster-menu nil
+ "Menu items for roster menu.")
+
+(defvar jabber-jid-muc-menu nil
+ "Menu items for MUC menu.")
+
+(defvar jabber-jid-service-menu nil
+ "Menu items for service menu.")
+
+(defun jabber-popup-menu (which-menu)
+ "Popup specified menu."
+ (let* ((mouse-event (and (listp last-input-event) last-input-event))
+ (choice (widget-choose "Actions" which-menu mouse-event)))
+ (if mouse-event
+ (mouse-set-point mouse-event))
+ (if choice
+ (call-interactively choice))))
+
+(defun jabber-popup-chat-menu ()
+ "Popup chat menu."
+ (interactive)
+ (jabber-popup-menu jabber-jid-chat-menu))
+
+(defun jabber-popup-info-menu ()
+ "Popup info menu."
+ (interactive)
+ (jabber-popup-menu jabber-jid-info-menu))
+
+(defun jabber-popup-roster-menu ()
+ "Popup roster menu."
+ (interactive)
+ (jabber-popup-menu jabber-jid-roster-menu))
+
+(defun jabber-popup-muc-menu ()
+ "Popup MUC menu."
+ (interactive)
+ (jabber-popup-menu jabber-jid-muc-menu))
+
+(defun jabber-popup-service-menu ()
+ "Popup service menu."
+ (interactive)
+ (jabber-popup-menu jabber-jid-service-menu))
+
+(defun jabber-popup-combined-menu ()
+ "Popup combined menu."
+ (interactive)
+ (jabber-popup-menu (append jabber-jid-chat-menu jabber-jid-info-menu jabber-jid-roster-menu jabber-jid-muc-menu)))
diff --git a/jabber-modeline.el b/jabber-modeline.el
new file mode 100644
index 0000000..366ecd7
--- /dev/null
+++ b/jabber-modeline.el
@@ -0,0 +1,72 @@
+(defgroup jabber-mode-line nil
+ "Display Jabber status in mode line"
+ :group 'jabber)
+
+(defcustom jabber-mode-line-compact t
+ "Count contacts in fewer categories for compact view."
+ :group 'jabber-mode-line
+ :type 'boolean)
+
+(defvar jabber-mode-line-string nil)
+
+(defvar jabber-mode-line-presence nil)
+
+(defvar jabber-mode-line-contacts nil)
+
+(defadvice jabber-send-presence (after jsp-update-mode-line
+ (show status priority))
+ (jabber-mode-line-presence-update))
+
+(defun jabber-mode-line-presence-update ()
+ (setq jabber-mode-line-presence (if (and jabber-connections (not *jabber-disconnecting*))
+ (cdr (assoc *jabber-current-show* jabber-presence-strings))
+ "Offline")))
+
+(defun jabber-mode-line-count-contacts (&rest _ignore)
+ (let ((count (list (cons "chat" 0)
+ (cons "" 0)
+ (cons "away" 0)
+ (cons "xa" 0)
+ (cons "dnd" 0)
+ (cons nil 0))))
+ (dolist (jc jabber-connections)
+ (dolist (buddy (plist-get (fsm-get-state-data jc) :roster))
+ (when (assoc (get buddy 'show) count)
+ (cl-incf (cdr (assoc (get buddy 'show) count))))))
+ (setq jabber-mode-line-contacts
+ (if jabber-mode-line-compact
+ (format "(%d/%d/%d)"
+ (+ (cdr (assoc "chat" count))
+ (cdr (assoc "" count)))
+ (+ (cdr (assoc "away" count))
+ (cdr (assoc "xa" count))
+ (cdr (assoc "dnd" count)))
+ (cdr (assoc nil count)))
+ (apply 'format "(%d/%d/%d/%d/%d/%d)"
+ (mapcar 'cdr count))))))
+
+(define-minor-mode jabber-mode-line-mode
+ "Toggle display of Jabber status in mode lines.
+Display consists of your own status, and six numbers
+meaning the number of chatty, online, away, xa, dnd
+and offline contacts, respectively."
+ :global t :group 'jabber-mode-line
+ (setq jabber-mode-line-string "")
+ (or global-mode-string (setq global-mode-string '("")))
+ (if jabber-mode-line-mode
+ (progn
+ (add-to-list 'global-mode-string 'jabber-mode-line-string t)
+
+ (setq jabber-mode-line-string (list " "
+ 'jabber-mode-line-presence
+ " "
+ 'jabber-mode-line-contacts))
+ (put 'jabber-mode-line-string 'risky-local-variable t)
+ (put 'jabber-mode-line-presence 'risky-local-variable t)
+ (jabber-mode-line-presence-update)
+ (jabber-mode-line-count-contacts)
+ (ad-activate 'jabber-send-presence)
+ (add-hook 'jabber-post-disconnect-hook
+ 'jabber-mode-line-presence-update)
+ (add-hook 'jabber-presence-hooks
+ 'jabber-mode-line-count-contacts))))
diff --git a/jabber-muc-nick-coloring.el b/jabber-muc-nick-coloring.el
new file mode 100644
index 0000000..cdc2e25
--- /dev/null
+++ b/jabber-muc-nick-coloring.el
@@ -0,0 +1,57 @@
+;; we need hexrgb-hsv-to-hex:
+(eval-and-compile
+ (or (ignore-errors (require 'hexrgb))
+ ;; jabber-fallback-lib/ from jabber/lisp/jabber-fallback-lib
+ (ignore-errors
+ (let* ((source (or (locate-library "jabber")
+ load-file-name))
+ (load-path (cons (expand-file-name
+ "jabber-fallback-lib"
+ (file-name-directory source))
+ load-path)))
+ (require 'hexrgb)))
+ (error
+ "The hexrgb library was not found in `load-path' or jabber-fallback-lib/ directory")))
+
+(defcustom jabber-muc-participant-colors nil
+ "Alist of used colors.
+Format is (nick . color). Color may be
+in #RGB or textual (like red or blue) notation. Colors will be
+added in #RGB notation for unknown nicks."
+ :type '(alist :key-type string :value-type color)
+ :group 'jabber-chat)
+
+(defcustom jabber-muc-colorize-local nil
+ "Colorize MUC messages from you."
+ :type 'boolean
+ :group 'jabber-chat)
+
+(defcustom jabber-muc-colorize-foreign nil
+ "Colorize MUC messages not from you."
+ :type 'boolean
+ :group 'jabber-chat)
+
+(defcustom jabber-muc-nick-saturation 1.0
+ "Default saturation for nick coloring."
+ :type 'float
+ :group 'jabber-chat)
+
+(defcustom jabber-muc-nick-value 1.0
+ "Default value for nick coloring."
+ :type 'float
+ :group 'jabber-chat)
+
+(defun jabber-muc-nick-gen-color (nick)
+ "Return a good enough color from the available pool."
+ (let ((hue (/ (mod (string-to-number (substring (md5 nick) 0 6) 16) 360) 360.0)))
+ (hexrgb-hsv-to-hex hue jabber-muc-nick-saturation jabber-muc-nick-value)))
+
+(defun jabber-muc-nick-get-color (nick)
+ "Get NICKs color."
+ (let ((color (cdr (assoc nick jabber-muc-participant-colors))))
+ (if color
+ color
+ (progn
+ (unless jabber-muc-participant-colors)
+ (push (cons nick (jabber-muc-nick-gen-color nick)) jabber-muc-participant-colors)
+ (cdr (assoc nick jabber-muc-participant-colors))))))
diff --git a/jabber-muc-nick-completion.el b/jabber-muc-nick-completion.el
new file mode 100644
index 0000000..2c02a33
--- /dev/null
+++ b/jabber-muc-nick-completion.el
@@ -0,0 +1,157 @@
+(defcustom jabber-muc-completion-delimiter ": "
+ "String to add to end of completion line."
+ :type 'string
+ :group 'jabber-chat)
+
+(defcustom jabber-muc-looks-personaling-symbols '("," ":" ">")
+ "Symbols for personaling messages."
+ :type '(repeat string)
+ :group 'jabber-chat)
+
+(defcustom jabber-muc-personal-message-bonus (* 60 20)
+ "Bonus for personal message, in seconds."
+ :type 'integer
+ :group 'jabber-chat)
+
+(defcustom jabber-muc-all-string "all"
+ "String meaning all conference members (to insert in completion).
+Note that \":\" or alike not needed (it appended in other string)"
+ :type 'string
+ :group 'jabber-chat)
+
+;;; History:
+;;
+
+;;; Code:
+
+(require 'hippie-exp)
+
+(defvar *jabber-muc-participant-last-speaking* nil
+ "Global alist in form (group . ((member . time-of-last-speaking) ...) ...).")
+
+(defun jabber-my-nick (&optional group)
+ "Return my jabber nick in GROUP."
+ (let ((room (or group jabber-group)))
+ (cdr (or (assoc room *jabber-active-groupchats*)
+ (assoc room jabber-muc-default-nicknames)))))
+
+;;;###autoload
+(defun jabber-muc-looks-like-personal-p (message &optional group)
+ "Return non-nil if jabber MESSAGE is addresed to me.
+Optional argument GROUP to look."
+ (if message (string-match (concat
+ "^"
+ (jabber-my-nick group)
+ (regexp-opt jabber-muc-looks-personaling-symbols))
+ message)
+ nil))
+
+(defun jabber-muc-nicknames ()
+ "List of conference participants, excluding self, or nil if we not in conference."
+ (cl-delete-if '(lambda (nick)
+ (string= nick (jabber-my-nick)))
+ (append (mapcar 'car (cdr (assoc jabber-group jabber-muc-participants))) (list jabber-muc-all-string))))
+
+(defun jabber-muc-participant-update-activity (group nick time)
+ "Update NICK's time of last speaking in GROUP to TIME."
+ (let* ((room (assoc group *jabber-muc-participant-last-speaking*))
+ (room-activity (cdr room))
+ (entry (assoc nick room-activity))
+ (old-time (or (cdr entry) 0)))
+ (when (> time old-time)
+ ;; don't use put-alist for speed
+ (progn
+ (if entry (setcdr entry time)
+ (setq room-activity
+ (cons (cons nick time) room-activity)))
+ (if room (setcdr room room-activity)
+ (setq *jabber-muc-participant-last-speaking*
+ (cons (cons group room-activity)
+ *jabber-muc-participant-last-speaking*)))))))
+
+(defun jabber-muc-track-message-time (nick group buffer text &optional title)
+ "Tracks time of NICK's last speaking in GROUP."
+ (when nick
+ (let ((time (float-time)))
+ (jabber-muc-participant-update-activity
+ group
+ nick
+ (if (jabber-muc-looks-like-personal-p text group)
+ (+ time jabber-muc-personal-message-bonus)
+ time)))))
+
+ (defun jabber-sort-nicks (nicks group)
+ "Return list of NICKS in GROUP, sorted."
+ (cl-letf* ((times (cdr (assoc group *jabber-muc-participant-last-speaking*)))
+ ((symbol-function 'fetch-time) (lambda (nick) (or (assoc nick times)
+ (cons nick 0))))
+ ((symbol-function 'cmp) (lambda (nt1 nt2)
+ (let ((t1 (cdr nt1))
+ (t2 (cdr nt2)))
+ (if (and (zerop t1) (zerop t2))
+ (string< (car nt1)
+ (car nt2))
+ (> t1 t2))))))
+ (mapcar #'car (sort (mapcar #'fetch-time nicks) #'cmp))))
+
+(defun jabber-muc-beginning-of-line ()
+ "Return position of line begining."
+ (save-excursion
+ (if (looking-back jabber-muc-completion-delimiter)
+ (backward-char (+ (length jabber-muc-completion-delimiter) 1)))
+ (skip-syntax-backward "^-")
+ (point)))
+
+;;; One big hack:
+(defun jabber-muc-completion-delete-last-tried ()
+ "Delete last tried competion variand from line."
+ (let ((last-tried (car he-tried-table)))
+ (when last-tried
+ (goto-char he-string-beg)
+ (delete-char (length last-tried))
+ (ignore-errors (delete-char (length jabber-muc-completion-delimiter))))))
+
+(defun try-expand-jabber-muc (old)
+ "Try to expand target nick in MUC according to last speaking time.
+OLD is last tried nickname."
+ (unless jabber-chatting-with
+ (unless old
+ (let ((nicknames (jabber-muc-nicknames)))
+ (he-init-string (jabber-muc-beginning-of-line) (point))
+ (setq he-expand-list
+ (jabber-sort-nicks (all-completions he-search-string
+ (mapcar 'list nicknames))
+ jabber-group))))
+
+ (setq he-expand-list
+ (cl-delete-if '(lambda (x)
+ (he-string-member x he-tried-table))
+ he-expand-list))
+ (if (null he-expand-list)
+ (progn
+ (when old
+ ;; here and later : its hack to workaround
+ ;; he-substitute-string work which cant substitute empty
+ ;; lines
+ (if (string= he-search-string "")
+ (jabber-muc-completion-delete-last-tried)
+ (he-reset-string)))
+ ())
+ (let ((subst (if (eq (line-beginning-position) (jabber-muc-beginning-of-line))
+ (concat (car he-expand-list) jabber-muc-completion-delimiter)
+ (car he-expand-list))))
+ (if (not (string= he-search-string ""))
+ (he-substitute-string subst)
+ (jabber-muc-completion-delete-last-tried)
+ (progn
+ (insert subst)
+ (if (looking-back (concat "^" (regexp-quote (car he-expand-list))))
+ (unless (looking-back (concat "^" (regexp-quote (car he-expand-list)) jabber-muc-completion-delimiter))
+ (insert jabber-muc-completion-delimiter))))))
+ (setq he-tried-table (cons (car he-expand-list) (cdr he-tried-table)))
+ (setq he-expand-list (cdr he-expand-list))
+ t)))
+
+(add-hook 'jabber-muc-hooks 'jabber-muc-track-message-time)
+(fset 'jabber-muc-completion (make-hippie-expand-function '(try-expand-jabber-muc)))
+(define-key jabber-chat-mode-map [?\t] 'jabber-muc-completion)
diff --git a/jabber-muc.el b/jabber-muc.el
new file mode 100644
index 0000000..f5619a4
--- /dev/null
+++ b/jabber-muc.el
@@ -0,0 +1,1180 @@
+;; we need jabber-bookmarks for jabber-muc-autojoin (via
+;; jabber-get-bookmarks and jabber-parse-conference-bookmark):
+
+;;;###autoload
+(defvar *jabber-active-groupchats* nil
+ "Alist of groupchats and nicknames.
+Keys are strings, the bare JID of the room.
+Values are strings.")
+
+(defvar jabber-pending-groupchats (make-hash-table)
+ "Hash table of groupchats and nicknames.
+Keys are JID symbols; values are strings.
+This table records the last nickname used to join the particular
+chat room. Items are thus never removed.")
+
+(defvar jabber-muc-participants nil
+ "Alist of groupchats and participants.
+Keys are strings, the bare JID of the room.
+Values are lists of nickname strings.")
+
+(defvar jabber-group nil
+ "The groupchat you are participating in.")
+
+(defvar jabber-muc-topic ""
+ "The topic of the current MUC room.")
+
+(defvar jabber-role-history ()
+ "Keeps track of previously used roles.")
+
+(defvar jabber-affiliation-history ()
+ "Keeps track of previously used affiliations.")
+
+(defvar jabber-muc-nickname-history ()
+ "Keeps track of previously referred-to nicknames.")
+
+(defcustom jabber-muc-default-nicknames nil
+ "Default nickname for specific MUC rooms."
+ :group 'jabber-chat
+ :type '(repeat
+ (cons :format "%v"
+ (string :tag "JID of room")
+ (string :tag "Nickname"))))
+
+(defcustom jabber-muc-autojoin nil
+ "List of MUC rooms to automatically join on connection.
+This list is saved in your Emacs customizations. You can also store
+such a list on the Jabber server, where it is available to every
+client; see `jabber-edit-bookmarks'."
+ :group 'jabber-chat
+ :type '(repeat (string :tag "JID of room")))
+
+(defcustom jabber-muc-disable-disco-check nil
+ "If non-nil, disable checking disco#info of rooms before joining them.
+Disco information can tell whether the room exists and whether it is
+password protected, but some servers do not support it. If you want
+to join chat rooms on such servers, set this variable to t."
+ :group 'jabber-chat
+ :type 'boolean)
+
+(defcustom jabber-groupchat-buffer-format "*-jabber-groupchat-%n-*"
+ "The format specification for the name of groupchat buffers.
+
+These fields are available (all are about the group you are chatting
+in):
+
+%n Roster name of group, or JID if no nickname set
+%b Name of group from bookmarks or roster name or JID if none set
+%j Bare JID (without resource)"
+ :type 'string
+ :group 'jabber-chat)
+
+(defcustom jabber-groupchat-prompt-format "[%t] %n> "
+ "The format specification for lines in groupchat.
+
+These fields are available:
+
+%t Time, formatted according to `jabber-chat-time-format'
+%n, %u, %r
+ Nickname in groupchat
+%j Full JID (room@server/nick)"
+ :type 'string
+ :group 'jabber-chat)
+
+(defcustom jabber-muc-header-line-format
+ '(" " (:eval (jabber-jid-displayname jabber-group))
+ "\t" jabber-muc-topic)
+ "The specification for the header line of MUC buffers.
+
+The format is that of `mode-line-format' and `header-line-format'."
+ :type 'sexp
+ :group 'jabber-chat)
+
+(defcustom jabber-muc-private-buffer-format "*-jabber-muc-priv-%g-%n-*"
+ "The format specification for the buffer name for private MUC messages.
+
+These fields are available:
+
+%g Roster name of group, or JID if no nickname set
+%n Nickname of the group member you're chatting with"
+ :type 'string
+ :group 'jabber-chat)
+
+(defcustom jabber-muc-private-foreign-prompt-format "[%t] %g/%n> "
+ "The format specification for lines others type in a private MUC buffer.
+
+These fields are available:
+
+%t Time, formatted according to `jabber-chat-time-format'
+%n Nickname in room
+%g Short room name (either roster name or username part of JID)"
+ :type 'string
+ :group 'jabber-chat)
+
+(defcustom jabber-muc-print-names-format " %n %a %j\n"
+ "The format specification for MUC list lines.
+
+Fields available:
+
+%n Nickname in room
+%a Affiliation status
+%j Full JID (room@server/nick)"
+ :type 'string
+ :group 'jabber-chat)
+
+(defcustom jabber-muc-private-header-line-format
+ '(" " (:eval (jabber-jid-resource jabber-chatting-with))
+ " in " (:eval (jabber-jid-displayname (jabber-jid-user jabber-chatting-with)))
+ "\t" jabber-events-message
+ "\t" jabber-chatstates-message)
+ "The specification for the header line of private MUC chat buffers.
+
+The format is that of `mode-line-format' and `header-line-format'."
+ :type 'sexp
+ :group 'jabber-chat)
+
+;;;###autoload
+(defvar jabber-muc-printers '()
+ "List of functions that may be able to print part of a MUC message.
+This gets prepended to `jabber-chat-printers', which see.")
+
+;;;###autoload
+(defun jabber-muc-get-buffer (group)
+ "Return the chat buffer for chatroom GROUP.
+Either a string or a buffer is returned, so use `get-buffer' or
+`get-buffer-create'."
+ (format-spec jabber-groupchat-buffer-format
+ (list
+ (cons ?n (jabber-jid-displayname group))
+ (cons ?b (jabber-jid-bookmarkname group))
+ (cons ?j (jabber-jid-user group)))))
+
+(defun jabber-muc-create-buffer (jc group)
+ "Prepare a buffer for chatroom GROUP.
+This function is idempotent.
+
+JC is the Jabber connection."
+ (with-current-buffer (get-buffer-create (jabber-muc-get-buffer group))
+ (unless (eq major-mode 'jabber-chat-mode)
+ (jabber-chat-mode jc #'jabber-chat-pp))
+ ;; Make sure the connection variable is up to date.
+ (setq jabber-buffer-connection jc)
+
+ (set (make-local-variable 'jabber-group) group)
+ (make-local-variable 'jabber-muc-topic)
+ (setq jabber-send-function 'jabber-muc-send)
+ (setq header-line-format jabber-muc-header-line-format)
+ (current-buffer)))
+
+;;;###autoload
+(defun jabber-muc-private-get-buffer (group nickname)
+ "Return the chat buffer for private chat with NICKNAME in GROUP.
+Either a string or a buffer is returned, so use `get-buffer' or
+`get-buffer-create'."
+ (format-spec jabber-muc-private-buffer-format
+ (list
+ (cons ?g (jabber-jid-displayname group))
+ (cons ?n nickname))))
+
+(defun jabber-muc-private-create-buffer (jc group nickname)
+ "Prepare a buffer for chatting with NICKNAME in GROUP.
+This function is idempotent.
+
+JC is the Jabber connection."
+ (with-current-buffer (get-buffer-create (jabber-muc-private-get-buffer group nickname))
+ (unless (eq major-mode 'jabber-chat-mode)
+ (jabber-chat-mode jc #'jabber-chat-pp))
+
+ (set (make-local-variable 'jabber-chatting-with) (concat group "/" nickname))
+ (setq jabber-send-function 'jabber-chat-send)
+ (setq header-line-format jabber-muc-private-header-line-format)
+
+ (current-buffer)))
+
+(defun jabber-muc-send (jc body)
+ "Send BODY to MUC room in current buffer.
+
+JC is the Jabber connection."
+ ;; There is no need to display the sent message in the buffer, as
+ ;; we will get it back from the MUC server.
+ (jabber-send-sexp jc
+ `(message
+ ((to . ,jabber-group)
+ (type . "groupchat"))
+ (body () ,body))))
+
+(defun jabber-muc-add-groupchat (group nickname)
+ "Remember participating in GROUP under NICKNAME."
+ (let ((whichgroup (assoc group *jabber-active-groupchats*)))
+ (if whichgroup
+ (setcdr whichgroup nickname)
+ (add-to-list '*jabber-active-groupchats* (cons group nickname)))))
+
+(defun jabber-muc-remove-groupchat (group)
+ "Remove GROUP from internal bookkeeping."
+ (let ((whichgroup (assoc group *jabber-active-groupchats*))
+ (whichparticipants (assoc group jabber-muc-participants)))
+ (setq *jabber-active-groupchats*
+ (delq whichgroup *jabber-active-groupchats*))
+ (setq jabber-muc-participants
+ (delq whichparticipants jabber-muc-participants))))
+
+(defun jabber-muc-connection-closed (bare-jid)
+ "Remove MUC data for BARE-JID.
+Forget all information about rooms that had been entered with
+this JID. Suitable to call when the connection is closed."
+ (dolist (room-entry jabber-muc-participants)
+ (let* ((room (car room-entry))
+ (buffer (get-buffer (jabber-muc-get-buffer room))))
+ (when (bufferp buffer)
+ (with-current-buffer buffer
+ (when (string= bare-jid
+ (jabber-connection-bare-jid jabber-buffer-connection))
+ (setq *jabber-active-groupchats*
+ (cl-delete room *jabber-active-groupchats*
+ :key #'car :test #'string=))
+ (setq jabber-muc-participants
+ (delq room-entry jabber-muc-participants))))))))
+
+(defun jabber-muc-participant-plist (group nickname)
+ "Return plist associated with NICKNAME in GROUP.
+Return nil if nothing known about that combination."
+ (let ((whichparticipants (assoc group jabber-muc-participants)))
+ (when whichparticipants
+ (cdr (assoc nickname whichparticipants)))))
+
+(defun jabber-muc-modify-participant (group nickname new-plist)
+ "Assign properties in NEW-PLIST to NICKNAME in GROUP."
+ (let ((participants (assoc group jabber-muc-participants)))
+ ;; either we have a list of participants already...
+ (if participants
+ (let ((participant (assoc nickname participants)))
+ ;; and maybe this participant is already in the list
+ (if participant
+ ;; if so, just update role, affiliation, etc.
+ (setf (cdr participant) new-plist)
+ (push (cons nickname new-plist) (cdr participants))))
+ ;; or we don't
+ (push (cons group (list (cons nickname new-plist))) jabber-muc-participants))))
+
+(defun jabber-muc-report-delta (nickname old-plist new-plist reason actor)
+ "Compare OLD-PLIST and NEW-PLIST, and return a string explaining the change.
+Return nil if nothing noteworthy has happened.
+NICKNAME is the user experiencing the change. REASON and ACTOR, if non-nil,
+are the corresponding presence fields.
+
+This function is only concerned with presence stanzas resulting
+in the user entering/staying in the room."
+ ;; The keys in the plist are affiliation, role and jid.
+ (when (plist-get new-plist 'jid)
+ ;; nickname is only used for displaying, so we can modify it if we
+ ;; want to.
+ (setq nickname (concat nickname " <"
+ (jabber-jid-user (plist-get new-plist 'jid))
+ ">")))
+ (cond
+ ((null old-plist)
+ ;; User enters the room
+ (concat nickname " enters the room ("
+ (plist-get new-plist 'role)
+ (unless (string= (plist-get new-plist 'affiliation) "none")
+ (concat ", " (plist-get new-plist 'affiliation)))
+ ")"))
+
+ ;; If affiliation changes, the role change is usually the logical
+ ;; one, so don't report it separately.
+ ((not (string= (plist-get old-plist 'affiliation)
+ (plist-get new-plist 'affiliation)))
+ (let ((actor-reason (concat (when actor
+ (concat " by " actor))
+ (when reason
+ (concat ": " reason))))
+ (from (plist-get old-plist 'affiliation))
+ (to (plist-get new-plist 'affiliation)))
+ ;; There are many ways to express these transitions in English.
+ ;; This one favors eloquence over regularity and consistency.
+ (cond
+ ;; Higher affiliation
+ ((or (and (member from '("outcast" "none" "member"))
+ (member to '("admin" "owner")))
+ (and (string= from "admin") (string= to "owner")))
+ (concat nickname " has been promoted to " to actor-reason))
+ ;; Lower affiliation
+ ((or (and (member from '("owner" "admin"))
+ (string= to "member"))
+ (and (string= from "owner") (string= to "admin")))
+ (concat nickname " has been demoted to " to actor-reason))
+ ;; Become member
+ ((string= to "member")
+ (concat nickname " has been granted membership" actor-reason))
+ ;; Lose membership
+ ((string= to "none")
+ (concat nickname " has been deprived of membership" actor-reason)))))
+
+ ;; Role changes
+ ((not (string= (plist-get old-plist 'role)
+ (plist-get new-plist 'role)))
+ (let ((actor-reason (concat (when actor
+ (concat " by " actor))
+ (when reason
+ (concat ": " reason))))
+ (from (plist-get old-plist 'role))
+ (to (plist-get new-plist 'role)))
+ ;; Possible roles are "none" (not in room, hence not of interest
+ ;; in this function), "visitor" (no voice), "participant" (has
+ ;; voice), and "moderator".
+ (cond
+ ((string= to "moderator")
+ (concat nickname " has been granted moderator privileges" actor-reason))
+ ((and (string= from "moderator")
+ (string= to "participant"))
+ (concat nickname " had moderator privileges revoked" actor-reason))
+ ((string= to "participant")
+ (concat nickname " has been granted voice" actor-reason))
+ ((string= to "visitor")
+ (concat nickname " has been denied voice" actor-reason)))))))
+
+(defun jabber-muc-remove-participant (group nickname)
+ "Forget everything about NICKNAME in GROUP."
+ (let ((participants (assoc group jabber-muc-participants)))
+ (when participants
+ (let ((participant (assoc nickname (cdr participants))))
+ (setf (cdr participants) (delq participant (cdr participants)))))))
+
+(defmacro jabber-muc-argument-list (&optional args)
+ "Prepend connection and group name to ARGS.
+If the current buffer is not an MUC buffer, signal an error.
+This macro is meant for use as an argument to `interactive'."
+ `(if (null jabber-group)
+ (error "Not in MUC buffer")
+ (nconc (list jabber-buffer-connection jabber-group) ,args)))
+
+(defun jabber-muc-read-completing (prompt &optional allow-not-joined)
+ "Read the name of a joined chatroom, or use chatroom of current buffer if any.
+If ALLOW-NOT-JOINED is provided and non-nil, permit choosing any
+JID; only provide completion as a guide."
+ (or jabber-group
+ (jabber-read-jid-completing prompt
+ (if (null *jabber-active-groupchats*)
+ (error "You haven't joined any group")
+ (mapcar (lambda (x) (jabber-jid-symbol (car x)))
+ *jabber-active-groupchats*))
+ (not allow-not-joined)
+ jabber-group)))
+
+(defun jabber-muc-read-nickname (group prompt)
+ "Read the nickname of a participant in GROUP."
+ (let ((nicknames (cdr (assoc group jabber-muc-participants))))
+ (unless nicknames
+ (error "Unknown group: %s" group))
+ (completing-read prompt nicknames nil t nil 'jabber-muc-nickname-history)))
+
+(add-to-list 'jabber-jid-muc-menu
+ (cons "Request vcard" 'jabber-muc-vcard-get))
+
+;;;###autoload
+(defun jabber-muc-vcard-get (jc group nickname)
+ "Request vcard from chat with NICKNAME in GROUP.
+
+JC is the Jabber connection."
+ (interactive
+ (jabber-muc-argument-list
+ (list (jabber-muc-read-nickname jabber-group "Nickname: "))))
+ (let ((muc-name (format "%s/%s" group nickname)))
+ (jabber-vcard-get jc muc-name)))
+
+(defun jabber-muc-instant-config (jc group)
+ "Accept default configuration for GROUP.
+This can be used for a newly created room, as an alternative to
+filling out the configuration form with `jabber-muc-get-config'.
+Both of these methods unlock the room, so that other users can
+enter it.
+
+JC is the Jabber connection."
+ (interactive (jabber-muc-argument-list))
+ (jabber-send-iq jc group
+ "set"
+ '(query ((xmlns . "http://jabber.org/protocol/muc#owner"))
+ (x ((xmlns . "jabber:x:data") (type . "submit"))))
+ #'jabber-report-success "MUC instant configuration"
+ #'jabber-report-success "MUC instant configuration"))
+
+(add-to-list 'jabber-jid-muc-menu
+ (cons "Configure groupchat" 'jabber-muc-get-config))
+
+(defun jabber-muc-get-config (jc group)
+ "Ask for MUC configuration form.
+
+JC is the Jabber connection."
+ (interactive (jabber-muc-argument-list))
+ (jabber-send-iq jc group
+ "get"
+ '(query ((xmlns . "http://jabber.org/protocol/muc#owner")))
+ #'jabber-process-data #'jabber-muc-render-config
+ #'jabber-process-data "MUC configuration request failed"))
+
+(defalias 'jabber-groupchat-get-config 'jabber-muc-get-config
+ "Deprecated. See `jabber-muc-get-config' instead.")
+
+(defun jabber-muc-render-config (jc xml-data)
+ "Render MUC configuration form.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+
+ (let ((query (jabber-iq-query xml-data))
+ xdata)
+ (dolist (x (jabber-xml-get-children query 'x))
+ (if (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data")
+ (setq xdata x)))
+ (if (not xdata)
+ (insert "No configuration possible.\n")
+
+ (jabber-init-widget-buffer (jabber-xml-get-attribute xml-data 'from))
+ (setq jabber-buffer-connection jc)
+
+ (jabber-render-xdata-form xdata)
+
+ (widget-create 'push-button :notify #'jabber-muc-submit-config "Submit")
+ (widget-insert "\t")
+ (widget-create 'push-button :notify #'jabber-muc-cancel-config "Cancel")
+ (widget-insert "\n")
+
+ (widget-setup)
+ (widget-minor-mode 1))))
+
+(defalias 'jabber-groupchat-render-config 'jabber-muc-render-config
+ "Deprecated. See `jabber-muc-render-config' instead.")
+
+(defun jabber-muc-submit-config (&rest ignore)
+ "Submit MUC configuration form."
+
+ (jabber-send-iq jabber-buffer-connection jabber-submit-to
+ "set"
+ `(query ((xmlns . "http://jabber.org/protocol/muc#owner"))
+ ,(jabber-parse-xdata-form))
+ #'jabber-report-success "MUC configuration"
+ #'jabber-report-success "MUC configuration"))
+
+(defalias 'jabber-groupchat-submit-config 'jabber-muc-submit-config
+ "Deprecated. See `jabber-muc-submit-config' instead.")
+
+(defun jabber-muc-cancel-config (&rest ignore)
+ "Cancel MUC configuration form."
+
+ (jabber-send-iq jabber-buffer-connection jabber-submit-to
+ "set"
+ '(query ((xmlns . "http://jabber.org/protocol/muc#owner"))
+ (x ((xmlns . "jabber:x:data") (type . "cancel"))))
+ nil nil nil nil))
+
+(defalias 'jabber-groupchat-cancel-config 'jabber-muc-cancel-config
+ "Deprecated. See `jabber-muc-cancel-config' instead.")
+
+(add-to-list 'jabber-jid-muc-menu
+ (cons "Join groupchat" 'jabber-muc-join))
+
+(defun jabber-muc-join (jc group nickname &optional popup)
+ "Join a groupchat, or change nick.
+In interactive calls, or if POPUP is non-nil, switch to the
+groupchat buffer.
+
+JC is the Jabber connection."
+ (interactive
+ (let ((account (jabber-read-account))
+ (group (jabber-read-jid-completing "group: ")))
+ (list account group (jabber-muc-read-my-nickname account group) t)))
+
+ ;; If the user is already in the room, we don't need as many checks.
+ (if (or (assoc group *jabber-active-groupchats*)
+ ;; Or if the users asked us not to check disco info.
+ jabber-muc-disable-disco-check)
+ (jabber-muc-join-3 jc group nickname nil popup)
+ ;; Else, send a disco request to find out what we are connecting
+ ;; to.
+ (jabber-disco-get-info jc group nil #'jabber-muc-join-2
+ (list group nickname popup))))
+
+(defalias 'jabber-groupchat-join 'jabber-muc-join
+ "Deprecated. Use `jabber-muc-join' instead.")
+
+(defun jabber-muc-join-2 (jc closure result)
+ (cl-destructuring-bind (group nickname popup) closure
+ (let* ( ;; Either success...
+ (identities (car result))
+ (features (cadr result))
+ ;; ...or error
+ (condition (when (eq identities 'error) (jabber-error-condition result))))
+ (cond
+ ;; Maybe the room doesn't exist yet.
+ ((eq condition 'item-not-found)
+ (unless (or jabber-silent-mode
+ (y-or-n-p (format "%s doesn't exist. Create it? "
+ (jabber-jid-displayname group))))
+ (error "Non-existent groupchat")))
+
+ ;; Maybe the room doesn't support disco.
+ ((eq condition 'feature-not-implemented)
+ t ;whatever... we will ignore it later
+ )
+ ;; Maybe another error occurred. Report it to user
+ (condition
+ (message "Couldn't query groupchat: %s" (jabber-parse-error result)))
+
+ ;; Bad stanza? Without NS, for example
+ ((and (eq identities 'error) (not condition))
+ (message "Bad error stanza received")))
+
+ ;; Continue only if it is really chat room. If there was an
+ ;; error, give the chat room the benefit of the doubt. (Needed
+ ;; for ejabberd's mod_irc, for example)
+ (when (or condition
+ (cl-find "conference" (if (sequencep identities) identities nil)
+ :key (lambda (i) (aref i 1))
+ :test #'string=))
+ (let ((password
+ ;; Is the room password-protected?
+ (when (member "muc_passwordprotected" features)
+ (or
+ (jabber-get-conference-data jc group nil :password)
+ (read-passwd (format "Password for %s: " (jabber-jid-displayname group)))))))
+
+ (jabber-muc-join-3 jc group nickname password popup))))))
+
+(defalias 'jabber-groupchat-join-2 'jabber-muc-join-2
+ "Deprecated. See `jabber-muc-join-2' instead.")
+
+(defun jabber-muc-join-3 (jc group nickname password popup)
+
+ ;; Remember that this is a groupchat _before_ sending the stanza.
+ ;; The response might come quicker than you think.
+
+ (puthash (jabber-jid-symbol group) nickname jabber-pending-groupchats)
+
+ (jabber-send-sexp jc
+ `(presence ((to . ,(format "%s/%s" group nickname)))
+ (x ((xmlns . "http://jabber.org/protocol/muc"))
+ ,@(when password
+ `((password () ,password))))
+ ,@(jabber-presence-children jc)))
+
+ ;; There, stanza sent. Now we just wait for the MUC service to
+ ;; mirror the stanza. This is handled in
+ ;; `jabber-muc-process-presence', where a buffer will be created for
+ ;; the room.
+
+ ;; But if the user interactively asked to join, he/she probably
+ ;; wants the buffer to pop up right now.
+ (when popup
+ (let ((buffer (jabber-muc-create-buffer jc group)))
+ (switch-to-buffer buffer))))
+
+(defalias 'jabber-groupchat-join-3 'jabber-muc-join-3
+ "Deprecated. See `jabber-muc-join-3' instead.")
+
+(defun jabber-muc-read-my-nickname (jc group &optional default)
+ "Read nickname for joining GROUP.
+If DEFAULT is non-nil, return default nick without prompting.
+
+JC is the Jabber connection."
+ (let ((default-nickname (or
+ (jabber-get-conference-data jc group nil :nick)
+ (cdr (assoc group jabber-muc-default-nicknames))
+ (plist-get (fsm-get-state-data jc) :username))))
+ (if default
+ default-nickname
+ (jabber-read-with-input-method (format "Nickname: (default %s) "
+ default-nickname)
+ nil nil default-nickname))))
+
+(add-to-list 'jabber-jid-muc-menu
+ (cons "Change nickname" 'jabber-muc-nick))
+
+(defalias 'jabber-muc-nick 'jabber-muc-join)
+
+(add-to-list 'jabber-jid-muc-menu
+ (cons "Leave groupchat" 'jabber-muc-leave))
+
+(defun jabber-muc-leave (jc group)
+ "Leave a groupchat.
+
+JC is the Jabber connection."
+ (interactive (jabber-muc-argument-list))
+ (let ((whichgroup (assoc group *jabber-active-groupchats*)))
+ ;; send unavailable presence to our own nick in room
+ (jabber-send-sexp jc
+ `(presence ((to . ,(format "%s/%s" group (cdr whichgroup)))
+ (type . "unavailable"))))))
+
+(defalias 'jabber-groupchat-leave 'jabber-muc-leave
+ "Deprecated. Use `jabber-muc-leave' instead.")
+
+(add-to-list 'jabber-jid-muc-menu
+ (cons "List participants" 'jabber-muc-names))
+
+(defun jabber-muc-names ()
+ "Print names, affiliations, and roles of participants in current buffer."
+ (interactive)
+ (ewoc-enter-last jabber-chat-ewoc (list :notice
+ (jabber-muc-print-names
+ (cdr (assoc jabber-group jabber-muc-participants)))
+ :time (current-time))))
+
+(defun jabber-muc-format-names (participant)
+ "Format one participant name."
+ (format-spec jabber-muc-print-names-format
+ (list
+ (cons ?n (car participant))
+ (cons ?a (plist-get (cdr participant) 'affiliation))
+ (cons ?j (or (plist-get (cdr participant) 'jid) "")))))
+
+(defun jabber-muc-print-names (participants)
+ "Format and return data in PARTICIPANTS."
+ (let ((mlist) (plist) (vlist) (nlist))
+ (mapcar (lambda (x)
+ (let ((role (plist-get (cdr x) 'role)))
+ (cond ((string= role "moderator")
+ (add-to-list 'mlist x))
+ ((string= role "participant")
+ (add-to-list 'plist x))
+ ((string= role "visitor")
+ (add-to-list 'vlist x))
+ ((string= role "none")
+ (add-to-list 'nlist x)))))
+ participants)
+ (concat
+ (apply 'concat "\nModerators:\n" (mapcar 'jabber-muc-format-names mlist))
+ (apply 'concat "\nParticipants:\n" (mapcar 'jabber-muc-format-names plist))
+ (apply 'concat "\nVisitors:\n" (mapcar 'jabber-muc-format-names vlist))
+ (apply 'concat "\nNones:\n" (mapcar 'jabber-muc-format-names nlist)))))
+
+(add-to-list 'jabber-jid-muc-menu
+ (cons "Set topic" 'jabber-muc-set-topic))
+
+(defun jabber-muc-set-topic (jc group topic)
+ "Set topic of GROUP to TOPIC.
+
+JC is the Jabber connection."
+ (interactive
+ (jabber-muc-argument-list
+ (list (jabber-read-with-input-method "New topic: " jabber-muc-topic))))
+ (jabber-send-message jc group topic nil "groupchat"))
+
+(defun jabber-muc-snarf-topic (xml-data)
+ "Record subject (topic) of the given , if any.
+
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let ((new-topic (jabber-xml-path xml-data '(subject ""))))
+ (when new-topic
+ (setq jabber-muc-topic new-topic))))
+
+(add-to-list 'jabber-jid-muc-menu
+ (cons "Set role (kick, voice, op)" 'jabber-muc-set-role))
+
+(defun jabber-muc-set-role (jc group nickname role reason)
+ "Set role of NICKNAME in GROUP to ROLE, specifying REASON.
+
+JC is the Jabber connection."
+ (interactive
+ (jabber-muc-argument-list
+ (let ((nickname (jabber-muc-read-nickname jabber-group "Nickname: ")))
+ (list nickname
+ (completing-read "New role: " '(("none") ("visitor") ("participant") ("moderator")) nil t nil 'jabber-role-history)
+ (read-string "Reason: ")))))
+ (unless (or (zerop (length nickname)) (zerop (length role)))
+ (jabber-send-iq jc group "set"
+ `(query ((xmlns . "http://jabber.org/protocol/muc#admin"))
+ (item ((nick . ,nickname)
+ (role . ,role))
+ ,(unless (zerop (length reason))
+ `(reason () ,reason))))
+ 'jabber-report-success "Role change"
+ 'jabber-report-success "Role change")))
+
+(add-to-list 'jabber-jid-muc-menu
+ (cons "Set affiliation (ban, member, admin)" 'jabber-muc-set-affiliation))
+
+(defun jabber-muc-set-affiliation (jc group nickname-or-jid nickname-p affiliation reason)
+ "Set affiliation of NICKNAME-OR-JID in GROUP to AFFILIATION.
+If NICKNAME-P is non-nil, NICKNAME-OR-JID is a nickname in the
+group, else it is a JID.
+
+JC is the Jabber connection."
+ (interactive
+ (jabber-muc-argument-list
+ (let ((nickname-p (y-or-n-p "Specify user by room nickname? ")))
+ (list
+ (if nickname-p
+ (jabber-muc-read-nickname jabber-group "Nickname: ")
+ (jabber-read-jid-completing "User: "))
+ nickname-p
+ (completing-read "New affiliation: "
+ '(("none") ("outcast") ("member") ("admin") ("owner")) nil t nil 'jabber-affiliation-history)
+ (read-string "Reason: ")))))
+ (let ((jid
+ (if nickname-p
+ (let ((participants (cdr (assoc group jabber-muc-participants))))
+ (unless participants
+ (error "Couldn't find group %s" group))
+ (let ((participant (cdr (assoc nickname-or-jid participants))))
+ (unless participant
+ (error "Couldn't find %s in group %s" nickname-or-jid group))
+ (or (plist-get participant 'jid)
+ (error "JID of %s in group %s is unknown" nickname-or-jid group))))
+ nickname-or-jid)))
+ (jabber-send-iq jc group "set"
+ `(query ((xmlns . "http://jabber.org/protocol/muc#admin"))
+ (item ((jid . ,jid)
+ (affiliation . ,affiliation))
+ ,(unless (zerop (length reason))
+ `(reason () ,reason))))
+ 'jabber-report-success "Affiliation change"
+ 'jabber-report-success "Affiliation change")))
+
+(add-to-list 'jabber-jid-muc-menu
+ (cons "Invite someone to chatroom" 'jabber-muc-invite))
+
+(defun jabber-muc-invite (jc jid group reason)
+ "Invite JID to GROUP, stating REASON.
+
+JC is the Jabber connection."
+ (interactive
+ (list (jabber-read-account)
+ (jabber-read-jid-completing
+ "Invite whom: "
+ ;; The current room is _not_ a good default for whom to invite.
+ (remq (jabber-jid-symbol jabber-group) (jabber-concat-rosters)))
+ (jabber-muc-read-completing "To group: ")
+ (jabber-read-with-input-method "Reason: ")))
+ (jabber-send-sexp
+ jc
+ `(message ((to . ,group))
+ (x ((xmlns . "http://jabber.org/protocol/muc#user"))
+ (invite ((to . ,jid))
+ ,(unless (zerop (length reason))
+ `(reason nil ,reason)))))))
+
+(add-to-list 'jabber-body-printers 'jabber-muc-print-invite)
+
+(defun jabber-muc-print-invite (xml-data who mode)
+ "Print MUC invitation.
+
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (dolist (x (jabber-xml-get-children xml-data 'x))
+ (when (string= (jabber-xml-get-attribute x 'xmlns) "http://jabber.org/protocol/muc#user")
+ (let ((invitation (car (jabber-xml-get-children x 'invite))))
+ (when invitation
+ (when (eql mode :insert)
+ (let ((group (jabber-xml-get-attribute xml-data 'from))
+ (inviter (jabber-xml-get-attribute invitation 'from))
+ (reason (car (jabber-xml-node-children (car (jabber-xml-get-children invitation 'reason))))))
+ ;; XXX: password
+ (insert "You have been invited to MUC room " (jabber-jid-displayname group))
+ (when inviter
+ (insert " by " (jabber-jid-displayname inviter)))
+ (insert ".")
+ (when reason
+ (insert " Reason: " reason))
+ (insert "\n\n")
+
+ (let ((action
+ `(lambda (&rest ignore) (interactive)
+ (jabber-muc-join jabber-buffer-connection ,group
+ (jabber-muc-read-my-nickname jabber-buffer-connection ,group)))))
+ (if (fboundp 'insert-button)
+ (insert-button "Accept"
+ 'action action)
+ ;; Simple button replacement
+ (let ((keymap (make-keymap)))
+ (define-key keymap "\r" action)
+ (insert (jabber-propertize "Accept"
+ 'keymap keymap
+ 'face 'highlight))))
+
+ (insert "\t")
+
+ (let ((action
+ `(lambda (&rest ignore) (interactive)
+ (let ((reason
+ (jabber-read-with-input-method
+ "Reason: ")))
+ (jabber-send-sexp
+ jabber-buffer-connection
+ (list 'message
+ (list (cons 'to ,group))
+ (list 'x
+ (list (cons 'xmlns "http://jabber.org/protocol/muc#user"))
+ (list 'decline
+ (list (cons 'to ,inviter))
+ (unless (zerop (length reason))
+ (list 'reason nil reason))))))))))
+ (if (fboundp 'insert-button)
+ (insert-button "Decline"
+ 'action action)
+ ;; Simple button replacement
+ (let ((keymap (make-keymap)))
+ (define-key keymap "\r" action)
+ (insert (jabber-propertize "Decline"
+ 'keymap keymap
+ 'face 'highlight))))))))
+ (cl-return t))))))
+
+(defun jabber-muc-autojoin (jc)
+ "Join rooms specified in account bookmarks and global `jabber-muc-autojoin'.
+
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)))
+ (let ((nickname (plist-get (fsm-get-state-data jc) :username)))
+ (when (bound-and-true-p jabber-muc-autojoin)
+ (dolist (group jabber-muc-autojoin)
+ (jabber-muc-join jc group (or
+ (cdr (assoc group jabber-muc-default-nicknames))
+ (plist-get (fsm-get-state-data jc) :username)))))
+ (jabber-get-bookmarks
+ jc
+ (lambda (jc bookmarks)
+ (dolist (bookmark bookmarks)
+ (setq bookmark (jabber-parse-conference-bookmark bookmark))
+ (when (and bookmark (plist-get bookmark :autojoin))
+ (jabber-muc-join jc (plist-get bookmark :jid)
+ (or (plist-get bookmark :nick)
+ (plist-get (fsm-get-state-data jc) :username)))))))))
+
+;;;###autoload
+(defun jabber-muc-message-p (message)
+ "Return non-nil if MESSAGE is a groupchat message.
+That does not include private messages in a groupchat, but does
+include groupchat invites."
+ ;; Public groupchat messages have type "groupchat" and are from
+ ;; room@server/nick. Public groupchat errors have type "error" and
+ ;; are from room@server.
+ (let ((from (jabber-xml-get-attribute message 'from))
+ (type (jabber-xml-get-attribute message 'type)))
+ (or
+ (string= type "groupchat")
+ (and (string= type "error")
+ (gethash (jabber-jid-symbol from) jabber-pending-groupchats))
+ (jabber-xml-path message '(("http://jabber.org/protocol/muc#user" . "x") invite)))))
+
+;;;###autoload
+(defun jabber-muc-sender-p (jid)
+ "Return non-nil if JID is a full JID of an MUC participant."
+ (and (assoc (jabber-jid-user jid) *jabber-active-groupchats*)
+ (jabber-jid-resource jid)))
+
+;;;###autoload
+(defun jabber-muc-private-message-p (message)
+ "Return non-nil if MESSAGE is a private message in a groupchat."
+ (let ((from (jabber-xml-get-attribute message 'from))
+ (type (jabber-xml-get-attribute message 'type)))
+ (and
+ (not (string= type "groupchat"))
+ (jabber-muc-sender-p from))))
+
+(add-to-list 'jabber-jid-muc-menu
+ (cons "Open private chat" 'jabber-muc-private))
+
+(defun jabber-muc-private (jc group nickname)
+ "Open private chat with NICKNAME in GROUP.
+
+JC is the Jabber connection."
+ (interactive
+ (jabber-muc-argument-list
+ (list (jabber-muc-read-nickname jabber-group "Nickname: "))))
+ (switch-to-buffer (jabber-muc-private-create-buffer jabber-buffer-connection group nickname)))
+
+(defun jabber-muc-presence-p (presence)
+ "Return non-nil if PRESENCE is presence from groupchat."
+ (let ((from (jabber-xml-get-attribute presence 'from))
+ (type (jabber-xml-get-attribute presence 'type))
+ (muc-marker (cl-find-if
+ (lambda (x) (equal (jabber-xml-get-attribute x 'xmlns)
+ "http://jabber.org/protocol/muc#user"))
+ (jabber-xml-get-children presence 'x))))
+ ;; This is MUC presence if it has an MUC-namespaced tag...
+ (or muc-marker
+ ;; ...or if it is error presence from a room we tried to join.
+ (and (string= type "error")
+ (gethash (jabber-jid-symbol from) jabber-pending-groupchats)))))
+
+(defun jabber-muc-parse-affiliation (x-muc)
+ "Parse X-MUC in the muc#user namespace and return a plist.
+Return nil if X-MUC is nil."
+ ;; XXX: parse and tags? or maybe elsewhere?
+ (apply 'nconc (mapcar (lambda (prop) (list (car prop) (cdr prop)))
+ (jabber-xml-node-attributes
+ (car (jabber-xml-get-children x-muc 'item))))))
+
+(defun jabber-muc-print-prompt (xml-data &optional local dont-print-nick-p)
+ "Print MUC prompt for message in XML-DATA."
+ (let ((nick (jabber-jid-resource (jabber-xml-get-attribute xml-data 'from)))
+ (timestamp (jabber-message-timestamp xml-data)))
+ (if (stringp nick)
+ (insert (jabber-propertize
+ (format-spec jabber-groupchat-prompt-format
+ (list
+ (cons ?t (format-time-string
+ (if timestamp
+ jabber-chat-delayed-time-format
+ jabber-chat-time-format)
+ timestamp))
+ (cons ?n (if dont-print-nick-p "" nick))
+ (cons ?u nick)
+ (cons ?r nick)
+ (cons ?j (concat jabber-group "/" nick))))
+ 'face (if local ;Message from you.
+ (if jabber-muc-colorize-local ;; If colorization enable...
+ ;; ...colorize nick
+ (list ':foreground (jabber-muc-nick-get-color nick))
+ ;; otherwise, use default face.
+ 'jabber-chat-prompt-local)
+ ;; Message from other participant.
+ (if jabber-muc-colorize-foreign ;If colorization enable...
+ ;; ... colorize nick
+ (list ':foreground (jabber-muc-nick-get-color nick))
+ ;; otherwise, use default face.
+ 'jabber-chat-prompt-foreign))
+ 'help-echo (concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from " nick " in " jabber-group)))
+ (jabber-muc-system-prompt))))
+
+(defun jabber-muc-private-print-prompt (xml-data)
+ "Print prompt for private MUC message in XML-DATA."
+ (let ((nick (jabber-jid-resource (jabber-xml-get-attribute xml-data 'from)))
+ (group (jabber-jid-user (jabber-xml-get-attribute xml-data 'from)))
+ (timestamp (jabber-message-timestamp xml-data)))
+ (insert (jabber-propertize
+ (format-spec jabber-muc-private-foreign-prompt-format
+ (list
+ (cons ?t (format-time-string
+ (if timestamp
+ jabber-chat-delayed-time-format
+ jabber-chat-time-format)
+ timestamp))
+ (cons ?n nick)
+ (cons ?g (or (jabber-jid-rostername group)
+ (jabber-jid-username group)))))
+ 'face 'jabber-chat-prompt-foreign
+ 'help-echo (concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from " nick " in " jabber-group)))))
+
+(defun jabber-muc-system-prompt (&rest ignore)
+ "Print system prompt for MUC."
+ (insert (jabber-propertize
+ (format-spec jabber-groupchat-prompt-format
+ (list
+ (cons ?t (format-time-string jabber-chat-time-format))
+ (cons ?n "")
+ (cons ?u "")
+ (cons ?r "")
+ (cons ?j jabber-group)))
+ 'face 'jabber-chat-prompt-system
+ 'help-echo (format-time-string "System message on %Y-%m-%d %H:%M:%S"))))
+
+(add-to-list 'jabber-message-chain 'jabber-muc-process-message)
+
+(defun jabber-muc-process-message (jc xml-data)
+ "If XML-DATA is a groupchat message, handle it as such.
+
+JC is the Jabber connection."
+ (when (jabber-muc-message-p xml-data)
+ (defvar printers nil)
+ (let* ((from (jabber-xml-get-attribute xml-data 'from))
+ (group (jabber-jid-user from))
+ (nick (jabber-jid-resource from))
+ (error-p (jabber-xml-get-children xml-data 'error))
+ (type (cond
+ (error-p :muc-error)
+ ((string= nick (cdr (assoc group *jabber-active-groupchats*)))
+ :muc-local)
+ (t :muc-foreign)))
+ (body-text (car (jabber-xml-node-children
+ (car (jabber-xml-get-children
+ xml-data 'body)))))
+
+ (printers (append jabber-muc-printers jabber-chat-printers)))
+
+ (with-current-buffer (jabber-muc-create-buffer jc group)
+ (jabber-muc-snarf-topic xml-data)
+ ;; Call alert hooks only when something is output
+ (when (or error-p
+ (run-hook-with-args-until-success 'printers xml-data type :printp))
+ (jabber-maybe-print-rare-time
+ (ewoc-enter-last jabber-chat-ewoc (list type xml-data :time (current-time))))
+
+ ;; ...except if the message is part of history, in which
+ ;; case we don't want an alert.
+ (let ((children-namespaces (mapcar (lambda (x) (when (listp x) (jabber-xml-get-attribute x 'xmlns)))
+ (jabber-xml-node-children xml-data))))
+ (unless (or (member "urn:xmpp:delay" children-namespaces)
+ (member "jabber:x:delay" children-namespaces))
+ (dolist (hook '(jabber-muc-hooks jabber-alert-muc-hooks))
+ (run-hook-with-args hook
+ nick group (current-buffer) body-text
+ (funcall jabber-alert-muc-function
+ nick group (current-buffer) body-text))))))))))
+
+(defun jabber-muc-process-presence (jc presence)
+ (let* ((from (jabber-xml-get-attribute presence 'from))
+ (type (jabber-xml-get-attribute presence 'type))
+ (x-muc (cl-find-if
+ (lambda (x) (equal (jabber-xml-get-attribute x 'xmlns)
+ "http://jabber.org/protocol/muc#user"))
+ (jabber-xml-get-children presence 'x)))
+ (group (jabber-jid-user from))
+ (nickname (jabber-jid-resource from))
+ (symbol (jabber-jid-symbol from))
+ (our-nickname (gethash symbol jabber-pending-groupchats))
+ (item (car (jabber-xml-get-children x-muc 'item)))
+ (actor (jabber-xml-get-attribute (car (jabber-xml-get-children item 'actor)) 'jid))
+ (reason (car (jabber-xml-node-children (car (jabber-xml-get-children item 'reason)))))
+ (error-node (car (jabber-xml-get-children presence 'error)))
+ (status-codes (if error-node
+ (list (jabber-xml-get-attribute error-node 'code))
+ (mapcar
+ (lambda (status-element)
+ (jabber-xml-get-attribute status-element 'code))
+ (jabber-xml-get-children x-muc 'status)))))
+ ;; handle leaving a room
+ (cond
+ ((or (string= type "unavailable") (string= type "error"))
+ ;; error from room itself? or are we leaving?
+ (if (or (null nickname)
+ (member "110" status-codes)
+ (string= nickname our-nickname))
+ ;; Assume that an error means that we were thrown out of the
+ ;; room...
+ (let* ((leavingp t)
+ (message (cond
+ ((string= type "error")
+ (cond
+ ;; ...except for certain cases.
+ ((or (member "406" status-codes)
+ (member "409" status-codes))
+ (setq leavingp nil)
+ (concat "Nickname change not allowed"
+ (when error-node
+ (concat ": " (jabber-parse-error error-node)))))
+ (t
+ (concat "Error entering room"
+ (when error-node
+ (concat ": " (jabber-parse-error error-node)))))))
+ ((member "301" status-codes)
+ (concat "You have been banned"
+ (when actor (concat " by " actor))
+ (when reason (concat " - '" reason "'"))))
+ ((member "307" status-codes)
+ (concat "You have been kicked"
+ (when actor (concat " by " actor))
+ (when reason (concat " - '" reason "'"))))
+ (t
+ "You have left the chatroom"))))
+ (when leavingp
+ (jabber-muc-remove-groupchat group))
+ ;; If there is no buffer for this groupchat, don't bother
+ ;; creating one just to tell that user left the room.
+ (let ((buffer (get-buffer (jabber-muc-get-buffer group))))
+ (if buffer
+ (with-current-buffer buffer
+ (jabber-maybe-print-rare-time
+ (ewoc-enter-last jabber-chat-ewoc
+ (list (if (string= type "error")
+ :muc-error
+ :muc-notice)
+ message
+ :time (current-time)))))
+ (message "%s: %s" (jabber-jid-displayname group) message))))
+ ;; or someone else?
+ (let* ((plist (jabber-muc-participant-plist group nickname))
+ (jid (plist-get plist 'jid))
+ (name (concat nickname
+ (when jid
+ (concat " <"
+ (jabber-jid-user jid)
+ ">")))))
+ (jabber-muc-remove-participant group nickname)
+ (with-current-buffer (jabber-muc-create-buffer jc group)
+ (jabber-maybe-print-rare-time
+ (ewoc-enter-last
+ jabber-chat-ewoc
+ (list :muc-notice
+ (cond
+ ((member "301" status-codes)
+ (concat name " has been banned"
+ (when actor (concat " by " actor))
+ (when reason (concat " - '" reason "'"))))
+ ((member "307" status-codes)
+ (concat name " has been kicked"
+ (when actor (concat " by " actor))
+ (when reason (concat " - '" reason "'"))))
+ ((member "303" status-codes)
+ (concat name " changes nickname to "
+ (jabber-xml-get-attribute item 'nick)))
+ (t
+ (concat name " has left the chatroom")))
+ :time (current-time))))))))
+ (t
+ ;; someone is entering
+
+ (when (or (member "110" status-codes) (string= nickname our-nickname))
+ ;; This is us. We just succeeded in entering the room.
+ ;;
+ ;; The MUC server is supposed to send a 110 code whenever this
+ ;; is our presence ("self-presence"), but at least one
+ ;; (ejabberd's mod_irc) doesn't, so check the nickname as well.
+ ;;
+ ;; This check might give incorrect results if the server
+ ;; changed our nickname to avoid collision with an existing
+ ;; participant, but even in this case the window where we have
+ ;; incorrect information should be very small, as we should be
+ ;; getting our own 110+210 presence shortly.
+ (let ((whichgroup (assoc group *jabber-active-groupchats*)))
+ (if whichgroup
+ (setcdr whichgroup nickname)
+ (add-to-list '*jabber-active-groupchats* (cons group nickname))))
+ ;; The server may have changed our nick. Record the new one.
+ (puthash symbol nickname jabber-pending-groupchats))
+
+ ;; Whoever enters, we create a buffer (if it didn't already
+ ;; exist), and print a notice. This is where autojoined MUC
+ ;; rooms have buffers created for them. We also remember some
+ ;; metadata.
+ (let ((old-plist (jabber-muc-participant-plist group nickname))
+ (new-plist (jabber-muc-parse-affiliation x-muc)))
+ (jabber-muc-modify-participant group nickname new-plist)
+ (let ((report (jabber-muc-report-delta nickname old-plist new-plist
+ reason actor)))
+ (when report
+ (with-current-buffer (jabber-muc-create-buffer jc group)
+ (jabber-maybe-print-rare-time
+ (ewoc-enter-last
+ jabber-chat-ewoc
+ (list :muc-notice report
+ :time (current-time))))
+ ;; Did the server change our nick?
+ (when (member "210" status-codes)
+ (ewoc-enter-last
+ jabber-chat-ewoc
+ (list :muc-notice
+ (concat "Your nick was changed to " nickname " by the server")
+ :time (current-time))))
+ ;; Was this room just created? If so, it's a locked
+ ;; room. Notify the user.
+ (when (member "201" status-codes)
+ (ewoc-enter-last
+ jabber-chat-ewoc
+ (list :muc-notice
+ (with-temp-buffer
+ (insert "This room was just created, and is locked to other participants.\n"
+ "To unlock it, ")
+ (insert-text-button
+ "configure the room"
+ 'action (apply-partially 'call-interactively 'jabber-muc-get-config))
+ (insert " or ")
+ (insert-text-button
+ "accept the default configuration"
+ 'action (apply-partially 'call-interactively 'jabber-muc-instant-config))
+ (insert ".")
+ (buffer-string))
+ :time (current-time))))))))))))
diff --git a/jabber-ping.el b/jabber-ping.el
new file mode 100644
index 0000000..e603a62
--- /dev/null
+++ b/jabber-ping.el
@@ -0,0 +1,42 @@
+(add-to-list 'jabber-jid-info-menu (cons "Ping" 'jabber-ping))
+
+(defun jabber-ping-send (jc to process-func on-success on-error)
+ "Send XEP-0199 ping IQ stanza.
+JC is connection to use, TO is full JID, PROCESS-FUNC is fucntion to call to
+process result, ON-SUCCESS and ON-ERROR is arg for this function depending on
+result."
+ (jabber-send-iq jc to "get"
+ '(ping ((xmlns . "urn:xmpp:ping")))
+ process-func on-success
+ process-func on-error))
+
+(defun jabber-ping (to)
+ "Ping XMPP entity.
+TO is full JID. All connected JIDs is used."
+ (interactive (list (jabber-read-jid-completing "Send ping to: " nil nil nil 'full)))
+ (dolist (jc jabber-connections)
+ (jabber-ping-send jc to 'jabber-silent-process-data 'jabber-process-ping "Ping is unsupported")))
+
+;; called by jabber-process-data
+(defun jabber-process-ping (jc xml-data)
+ "Handle results from ping requests.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let ((to (jabber-xml-get-attribute xml-data 'from)))
+ (format "%s is alive" to)))
+
+(add-to-list 'jabber-iq-get-xmlns-alist (cons "urn:xmpp:ping" 'jabber-pong))
+(jabber-disco-advertise-feature "urn:xmpp:ping")
+
+(defun jabber-pong (jc xml-data)
+ "Return pong as defined in XEP-0199.
+Sender and Id are determined from the incoming packet passed in XML-DATA.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let ((to (jabber-xml-get-attribute xml-data 'from))
+ (id (jabber-xml-get-attribute xml-data 'id)))
+ (jabber-send-iq jc to "result" nil nil nil nil nil id)))
diff --git a/jabber-presence.el b/jabber-presence.el
new file mode 100644
index 0000000..c78e44d
--- /dev/null
+++ b/jabber-presence.el
@@ -0,0 +1,554 @@
+(defvar jabber-presence-element-functions nil
+ "List of functions returning extra elements for stanzas.
+Each function takes one argument, the connection, and returns a
+possibly empty list of extra child element of the
+stanza.")
+
+(defvar jabber-presence-history ()
+ "Keeps track of previously used presence status types.")
+
+(add-to-list 'jabber-iq-set-xmlns-alist
+ (cons "jabber:iq:roster" (function (lambda (jc x) (jabber-process-roster jc x nil)))))
+(defun jabber-process-roster (jc xml-data closure-data)
+ "Process an incoming roster infoquery result.
+CLOSURE-DATA should be 'initial if initial roster push, nil otherwise.
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let ((roster (plist-get (fsm-get-state-data jc) :roster))
+ (from (jabber-xml-get-attribute xml-data 'from))
+ (type (jabber-xml-get-attribute xml-data 'type))
+ (id (jabber-xml-get-attribute xml-data 'id))
+ (username (plist-get (fsm-get-state-data jc) :username))
+ (server (plist-get (fsm-get-state-data jc) :server))
+ (resource (plist-get (fsm-get-state-data jc) :resource))
+ new-items changed-items deleted-items)
+ ;; Perform sanity check on "from" attribute: it should be either absent
+ ;; match our own JID, or match the server's JID (the latter is what
+ ;; Facebook does).
+ (if (not (or (null from)
+ (string= from server)
+ (string= from (concat username "@" server))
+ (string= from (concat username "@" server "/" resource))))
+ (message "Roster push with invalid \"from\": \"%s\" (expected \"%s\", \"%s@%s\" or \"%s@%s/%s\")"
+ from
+ server username server username server resource)
+
+ (dolist (item (jabber-xml-get-children (car (jabber-xml-get-children xml-data 'query)) 'item))
+ (let (roster-item
+ (jid (jabber-jid-symbol (jabber-xml-get-attribute item 'jid))))
+
+ ;; If subscripton="remove", contact is to be removed from roster
+ (if (string= (jabber-xml-get-attribute item 'subscription) "remove")
+ (progn
+ (if (jabber-jid-rostername jid)
+ (message "%s (%s) removed from roster" (jabber-jid-rostername jid) jid)
+ (message "%s removed from roster" jid))
+ (push jid deleted-items))
+
+ ;; Find contact if already in roster
+ (setq roster-item (car (memq jid roster)))
+
+ (if roster-item
+ (push roster-item changed-items)
+ ;; If not found, create a new roster item.
+ (unless (eq closure-data 'initial)
+ (if (jabber-xml-get-attribute item 'name)
+ (message "%s (%s) added to roster" (jabber-xml-get-attribute item 'name) jid)
+ (message "%s added to roster" jid)))
+ (setq roster-item jid)
+ (push roster-item new-items))
+
+ ;; If this is an initial push, we want to forget
+ ;; everything we knew about this contact before - e.g. if
+ ;; the contact was online when we disconnected and offline
+ ;; when we reconnect, we don't want to see stale presence
+ ;; information. This assumes that no contacts are shared
+ ;; between accounts.
+ (when (eq closure-data 'initial)
+ (setplist roster-item nil))
+
+ ;; Now, get all data associated with the contact.
+ (put roster-item 'name (jabber-xml-get-attribute item 'name))
+ (put roster-item 'subscription (jabber-xml-get-attribute item 'subscription))
+ (put roster-item 'ask (jabber-xml-get-attribute item 'ask))
+
+ ;; Since roster items can't be changed incrementally, we
+ ;; save the original XML to be able to modify it, instead of
+ ;; having to reproduce it. This is for forwards
+ ;; compatibility.
+ (put roster-item 'xml item)
+
+ (put roster-item 'groups
+ (mapcar (lambda (foo) (nth 2 foo))
+ (jabber-xml-get-children item 'group)))))))
+ ;; This is the function that does the actual updating and
+ ;; redrawing of the roster.
+ (jabber-roster-update jc new-items changed-items deleted-items)
+
+ (if (and id (string= type "set"))
+ (jabber-send-iq jc nil "result" nil
+ nil nil nil nil id)))
+
+ ;; After initial roster push, run jabber-post-connect-hooks. We do
+ ;; it here and not before since we want to have the entire roster
+ ;; before we receive any presence stanzas.
+ (when (eq closure-data 'initial)
+ (run-hook-with-args 'jabber-post-connect-hooks jc)))
+
+(defun jabber-initial-roster-failure (jc xml-data _closure-data)
+ "Report the initial roster failure.
+If the initial roster request fails, let's report it, but run
+`jabber-post-connect-hooks' anyway. According to the spec, there
+is nothing exceptional about the server not returning a roster.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (jabber-report-success jc xml-data "Initial roster retrieval")
+ (run-hook-with-args 'jabber-post-connect-hooks jc))
+
+(add-to-list 'jabber-presence-chain 'jabber-process-presence)
+(defun jabber-process-presence (jc xml-data)
+ "Process incoming presence tags.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ ;; XXX: use JC argument
+ (let ((roster (plist-get (fsm-get-state-data jc) :roster))
+ (from (jabber-xml-get-attribute xml-data 'from))
+ (to (jabber-xml-get-attribute xml-data 'to))
+ (type (jabber-xml-get-attribute xml-data 'type))
+ (presence-show (car (jabber-xml-node-children
+ (car (jabber-xml-get-children xml-data 'show)))))
+ (presence-status (car (jabber-xml-node-children
+ (car (jabber-xml-get-children xml-data 'status)))))
+ (error (car (jabber-xml-get-children xml-data 'error)))
+ (priority (string-to-number (or (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'priority))))
+ "0"))))
+ (cond
+ ((string= type "subscribe")
+ (run-with-idle-timer 0.01 nil #'jabber-process-subscription-request jc from presence-status))
+
+ ((jabber-muc-presence-p xml-data)
+ (jabber-muc-process-presence jc xml-data))
+
+ (t
+ ;; XXX: Think about what to do about out-of-roster presences.
+ (let ((buddy (jabber-jid-symbol from)))
+ (if (memq buddy roster)
+ (let* ((oldstatus (get buddy 'show))
+ (resource (or (jabber-jid-resource from) ""))
+ (resource-plist (cdr (assoc resource
+ (get buddy 'resources))))
+ newstatus)
+ (cond
+ ((and (string= resource "") (member type '("unavailable" "error")))
+ ;; 'unavailable' or 'error' from bare JID means that all resources
+ ;; are offline.
+ (setq resource-plist nil)
+ (setq newstatus (if (string= type "error") "error" nil))
+ (let ((new-message (if error
+ (jabber-parse-error error)
+ presence-status)))
+ ;; erase any previous information
+ (put buddy 'resources nil)
+ (put buddy 'connected nil)
+ (put buddy 'show newstatus)
+ (put buddy 'status new-message)))
+
+ ((string= type "unavailable")
+ (setq resource-plist
+ (plist-put resource-plist 'connected nil))
+ (setq resource-plist
+ (plist-put resource-plist 'show nil))
+ (setq resource-plist
+ (plist-put resource-plist 'status
+ presence-status)))
+
+ ((string= type "error")
+ (setq newstatus "error")
+ (setq resource-plist
+ (plist-put resource-plist 'connected nil))
+ (setq resource-plist
+ (plist-put resource-plist 'show "error"))
+ (setq resource-plist
+ (plist-put resource-plist 'status
+ (if error
+ (jabber-parse-error error)
+ presence-status))))
+ ((or
+ (string= type "unsubscribe")
+ (string= type "subscribed")
+ (string= type "unsubscribed"))
+ ;; Do nothing, except letting the user know. The Jabber protocol
+ ;; places all this complexity on the server.
+ (setq newstatus type))
+ (t
+ (setq resource-plist
+ (plist-put resource-plist 'connected t))
+ (setq resource-plist
+ (plist-put resource-plist 'show (or presence-show "")))
+ (setq resource-plist
+ (plist-put resource-plist 'status
+ presence-status))
+ (setq resource-plist
+ (plist-put resource-plist 'priority priority))
+ (setq newstatus (or presence-show ""))))
+
+ (when resource-plist
+ ;; this is for `assoc-set!' in guile
+ (if (assoc resource (get buddy 'resources))
+ (setcdr (assoc resource (get buddy 'resources)) resource-plist)
+ (put buddy 'resources (cons (cons resource resource-plist) (get buddy 'resources))))
+ (jabber-prioritize-resources buddy))
+
+ (fsm-send jc (cons :roster-update buddy))
+
+ (dolist (hook '(jabber-presence-hooks jabber-alert-presence-hooks))
+ (run-hook-with-args hook
+ buddy
+ oldstatus
+ newstatus
+ (plist-get resource-plist 'status)
+ (funcall jabber-alert-presence-message-function
+ buddy
+ oldstatus
+ newstatus
+ (plist-get resource-plist 'status)))))))))))
+
+(defun jabber-process-subscription-request (jc from presence-status)
+ "Process an incoming subscription request.
+JC is the Jabber connection."
+ (with-current-buffer (jabber-chat-create-buffer jc from)
+ (ewoc-enter-last jabber-chat-ewoc (list :subscription-request presence-status :time (current-time)))
+
+ (dolist (hook '(jabber-presence-hooks jabber-alert-presence-hooks))
+ (run-hook-with-args hook (jabber-jid-symbol from) nil "subscribe" presence-status (funcall jabber-alert-presence-message-function (jabber-jid-symbol from) nil "subscribe" presence-status)))))
+
+(defun jabber-subscription-accept-mutual (&rest ignored)
+ (message "Subscription accepted; reciprocal subscription request sent")
+ (jabber-subscription-reply "subscribed" "subscribe"))
+
+(defun jabber-subscription-accept-one-way (&rest ignored)
+ (message "Subscription accepted")
+ (jabber-subscription-reply "subscribed"))
+
+(defun jabber-subscription-decline (&rest ignored)
+ (message "Subscription declined")
+ (jabber-subscription-reply "unsubscribed"))
+
+(defun jabber-subscription-reply (&rest types)
+ (let ((to (jabber-jid-user jabber-chatting-with)))
+ (dolist (type types)
+ (jabber-send-sexp jabber-buffer-connection `(presence ((to . ,to) (type . ,type)))))))
+
+(defun jabber-prioritize-resources (buddy)
+ "Set connected, show and status properties for BUDDY.
+Show status properties from highest-priority resource."
+ (let ((resource-alist (get buddy 'resources))
+ (highest-priority nil))
+ ;; Reset to nil at first, for cases (a) resource-alist is nil
+ ;; and (b) all resources are disconnected.
+ (put buddy 'connected nil)
+ (put buddy 'show nil)
+ (put buddy 'status nil)
+ (mapc #'(lambda (resource)
+ (let* ((resource-plist (cdr resource))
+ (priority (plist-get resource-plist 'priority)))
+ (if (plist-get resource-plist 'connected)
+ (when (or (null highest-priority)
+ (and priority
+ (> priority highest-priority)))
+ ;; if no priority specified, interpret as zero
+ (setq highest-priority (or priority 0))
+ (put buddy 'connected (plist-get resource-plist 'connected))
+ (put buddy 'show (plist-get resource-plist 'show))
+ (put buddy 'status (plist-get resource-plist 'status))
+ (put buddy 'resource (car resource)))
+
+ ;; if we have not found a connected resource yet, but this
+ ;; disconnected resource has a status message, display it.
+ (when (not (get buddy 'connected))
+ (if (plist-get resource-plist 'status)
+ (put buddy 'status (plist-get resource-plist 'status)))
+ (if (plist-get resource-plist 'show)
+ (put buddy 'show (plist-get resource-plist 'show)))))))
+ resource-alist)))
+
+(defun jabber-count-connected-resources (buddy)
+ "Return the number of connected resources for BUDDY."
+ (let ((resource-alist (get buddy 'resources))
+ (count 0))
+ (dolist (resource resource-alist)
+ (if (plist-get (cdr resource) 'connected)
+ (setq count (1+ count))))
+ count))
+
+;;;###autoload
+(defun jabber-send-presence (show status priority)
+ "Set presence for all accounts."
+ (interactive
+ (list
+ (completing-read "show: " '("" "away" "xa" "dnd" "chat")
+ nil t nil 'jabber-presence-history)
+ (jabber-read-with-input-method "status message: " *jabber-current-status*
+ '*jabber-status-history*)
+ (read-string "priority: " (int-to-string (if *jabber-current-priority*
+ *jabber-current-priority*
+ jabber-default-priority)))))
+
+ (setq *jabber-current-show* show *jabber-current-status* status)
+ (setq *jabber-current-priority*
+ (if (numberp priority) priority (string-to-number priority)))
+
+ (let (subelements-map)
+ ;; For each connection, we use a different set of subelements. We
+ ;; cache them, to only generate them once.
+
+ ;; Ordinary presence, with no specified recipient
+ (dolist (jc jabber-connections)
+ (let ((subelements (jabber-presence-children jc)))
+ (push (cons jc subelements) subelements-map)
+ (jabber-send-sexp-if-connected jc `(presence () ,@subelements))))
+
+ ;; Then send presence to groupchats
+ (dolist (gc *jabber-active-groupchats*)
+ (let* ((buffer (get-buffer (jabber-muc-get-buffer (car gc))))
+ (jc (when buffer
+ (buffer-local-value 'jabber-buffer-connection buffer)))
+ (subelements (cdr (assq jc subelements-map))))
+ (when jc
+ (jabber-send-sexp-if-connected
+ jc `(presence ((to . ,(concat (car gc) "/" (cdr gc))))
+ ,@subelements))))))
+
+ (jabber-display-roster))
+
+(defun jabber-presence-children (jc)
+ "Return the children for a stanza.
+JC is the Jabber connection."
+ `(,(when (> (length *jabber-current-status*) 0)
+ `(status () ,*jabber-current-status*))
+ ,(when (> (length *jabber-current-show*) 0)
+ `(show () ,*jabber-current-show*))
+ ,(when *jabber-current-priority*
+ `(priority () ,(number-to-string *jabber-current-priority*)))
+ ,@(apply 'append (mapcar (lambda (f)
+ (funcall f jc))
+ jabber-presence-element-functions))))
+
+(defun jabber-send-directed-presence (jc jid type)
+ "Send a directed presence stanza to JID.
+TYPE is one of:
+\"online\", \"away\", \"xa\", \"dnd\", \"chatty\":
+ Appear as present with the given status.
+\"unavailable\":
+ Appear as offline.
+\"probe\":
+ Ask the contact's server for updated presence.
+\"subscribe\":
+ Ask for subscription to contact's presence.
+ (see also `jabber-send-subscription-request')
+\"unsubscribe\":
+ Cancel your subscription to contact's presence.
+\"subscribed\":
+ Accept contact's request for presence subscription.
+ (this is usually done within a chat buffer)
+\"unsubscribed\":
+ Cancel contact's subscription to your presence.
+
+JC is the Jabber connection."
+ (interactive
+ (list (jabber-read-account)
+ (jabber-read-jid-completing "Send directed presence to: ")
+ (completing-read "Type (default is online): "
+ '(("online")
+ ("away")
+ ("xa")
+ ("dnd")
+ ("chatty")
+ ("probe")
+ ("unavailable")
+ ("subscribe")
+ ("unsubscribe")
+ ("subscribed")
+ ("unsubscribed"))
+ nil t nil 'jabber-presence-history "online")))
+ (cond
+ ((member type '("probe" "unavailable"
+ "subscribe" "unsubscribe"
+ "subscribed" "unsubscribed"))
+ (jabber-send-sexp jc `(presence ((to . ,jid)
+ (type . ,type)))))
+
+ (t
+ (let ((*jabber-current-show*
+ (if (string= type "online")
+ ""
+ type))
+ (*jabber-current-status* nil))
+ (jabber-send-sexp jc `(presence ((to . ,jid))
+ ,@(jabber-presence-children jc)))))))
+
+(defun jabber-send-away-presence (&optional status)
+ "Set status to away.
+With prefix argument, ask for status message."
+ (interactive
+ (list
+ (when current-prefix-arg
+ (jabber-read-with-input-method
+ "status message: " *jabber-current-status* '*jabber-status-history*))))
+ (jabber-send-presence "away" (if status status *jabber-current-status*)
+ *jabber-current-priority*))
+
+;; XXX code duplication!
+(defun jabber-send-xa-presence (&optional status)
+ "Send extended away presence.
+With prefix argument, ask for status message."
+ (interactive
+ (list
+ (when current-prefix-arg
+ (jabber-read-with-input-method
+ "status message: " *jabber-current-status* '*jabber-status-history*))))
+ (jabber-send-presence "xa" (if status status *jabber-current-status*)
+ *jabber-current-priority*))
+
+;;;###autoload
+(defun jabber-send-default-presence (&optional _ignore)
+ "Send default presence.
+Default presence is specified by `jabber-default-show',
+`jabber-default-status', and `jabber-default-priority'."
+ (interactive)
+ (jabber-send-presence
+ jabber-default-show jabber-default-status jabber-default-priority))
+
+(defun jabber-send-current-presence (&optional _ignore)
+ "(Re-)send current presence.
+That is, if presence has already been sent, use current settings,
+otherwise send defaults (see `jabber-send-default-presence')."
+ (interactive)
+ (if *jabber-current-show*
+ (jabber-send-presence *jabber-current-show* *jabber-current-status*
+ *jabber-current-priority*)
+ (jabber-send-default-presence)))
+
+(add-to-list 'jabber-jid-roster-menu (cons "Send subscription request"
+ 'jabber-send-subscription-request))
+(defun jabber-send-subscription-request (jc to &optional request)
+ "Send a subscription request to jid.
+Show him your request text, if specified.
+
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "to: ")
+ (jabber-read-with-input-method "request: ")))
+ (jabber-send-sexp jc
+ `(presence
+ ((to . ,to)
+ (type . "subscribe"))
+ ,@(when (and request (> (length request) 0))
+ (list `(status () ,request))))))
+
+(defvar jabber-roster-group-history nil
+ "History of entered roster groups.")
+
+(add-to-list 'jabber-jid-roster-menu
+ (cons "Add/modify roster entry" 'jabber-roster-change))
+(defun jabber-roster-change (jc jid name groups)
+ "Add or change a roster item.
+JC is the Jabber connection."
+ (interactive (let* ((jid (jabber-jid-symbol
+ (jabber-read-jid-completing "Add/change JID: ")))
+ (account (jabber-read-account))
+ (name (get jid 'name))
+ (groups (get jid 'groups))
+ (all-groups
+ (apply #'append
+ (mapcar
+ (lambda (j) (get j 'groups))
+ (plist-get (fsm-get-state-data account) :roster)))))
+ (when (string< emacs-version "22")
+ ;; Older emacsen want the completion table to be an alist...
+ (setq all-groups (mapcar #'list all-groups)))
+ (list account
+ jid (jabber-read-with-input-method (format "Name: (default `%s') " name) nil nil name)
+ (delete ""
+ (completing-read-multiple
+ (format
+ "Groups, comma-separated: (default %s) "
+ (if groups
+ (mapconcat #'identity groups ",")
+ "none"))
+ all-groups
+ nil nil nil
+ 'jabber-roster-group-history
+ (mapconcat #'identity groups ",")
+ t)))))
+ ;; If new fields are added to the roster XML structure in a future standard,
+ ;; they will be clobbered by this function.
+ ;; XXX: specify account
+ (jabber-send-iq jc nil "set"
+ (list 'query (list (cons 'xmlns "jabber:iq:roster"))
+ (append
+ (list 'item (append
+ (list (cons 'jid (symbol-name jid)))
+ (if (and name (> (length name) 0))
+ (list (cons 'name name)))))
+ (mapcar #'(lambda (x) `(group () ,x))
+ groups)))
+ #'jabber-report-success "Roster item change"
+ #'jabber-report-success "Roster item change"))
+
+(add-to-list 'jabber-jid-roster-menu
+ (cons "Delete roster entry" 'jabber-roster-delete))
+(defun jabber-roster-delete (jc jid)
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "Delete from roster: ")))
+ (jabber-send-iq jc nil "set"
+ `(query ((xmlns . "jabber:iq:roster"))
+ (item ((jid . ,jid)
+ (subscription . "remove"))))
+ #'jabber-report-success "Roster item removal"
+ #'jabber-report-success "Roster item removal"))
+
+(defun jabber-roster-delete-jid-at-point ()
+ "Delete JID at point from roster.
+Signal an error if there is no JID at point."
+ (interactive)
+ (let ((jid-at-point (get-text-property (point)
+ 'jabber-jid))
+ (account (get-text-property (point) 'jabber-account)))
+ (if (and jid-at-point account
+ (or jabber-silent-mode (yes-or-no-p (format "Really delete %s from roster? " jid-at-point))))
+ (jabber-roster-delete account jid-at-point)
+ (error "No contact at point"))))
+
+(defun jabber-roster-delete-group-from-jids (jc jids group)
+ "Delete group `group' from all JIDs.
+JC is the Jabber connection."
+ (interactive)
+ (dolist (jid jids)
+ (jabber-roster-change
+ jc jid (get jid 'name)
+ (cl-remove-if-not (lambda (g) (not (string= g group)))
+ (get jid 'groups)))))
+
+(defun jabber-roster-edit-group-from-jids (jc jids group)
+ "Edit group `group' from all JIDs.
+JC is the Jabber connection."
+ (interactive)
+ (let ((new-group
+ (jabber-read-with-input-method
+ (format "New group: (default `%s') " group) nil nil group)))
+ (dolist (jid jids)
+ (jabber-roster-change
+ jc jid (get jid 'name)
+ (cl-remove-duplicates
+ (mapcar
+ (lambda (g) (if (string= g group)
+ new-group
+ g))
+ (get jid 'groups))
+ :test 'string=)))))
diff --git a/jabber-private.el b/jabber-private.el
new file mode 100644
index 0000000..da6ece1
--- /dev/null
+++ b/jabber-private.el
@@ -0,0 +1,38 @@
+;;;###autoload
+(defun jabber-private-get (jc node-name namespace success-callback error-callback)
+ "Retrieve an item from private XML storage.
+The item to retrieve is identified by NODE-NAME (a symbol) and
+NAMESPACE (a string).
+
+On success, SUCCESS-CALLBACK is called with JC and the retrieved
+XML fragment.
+
+On error, ERROR-CALLBACK is called with JC and the entire IQ
+result."
+ (jabber-send-iq jc nil "get"
+ `(query ((xmlns . "jabber:iq:private"))
+ (,node-name ((xmlns . ,namespace))))
+ #'jabber-private-get-1 success-callback
+ #'(lambda (jc xml-data error-callback)
+ (funcall error-callback jc xml-data))
+ error-callback))
+
+(defun jabber-private-get-1 (jc xml-data success-callback)
+ (funcall success-callback jc
+ (car (jabber-xml-node-children
+ (jabber-iq-query xml-data)))))
+
+;;;###autoload
+(defun jabber-private-set (jc fragment &optional
+ success-callback success-closure-data
+ error-callback error-closure-data)
+ "Store FRAGMENT in private XML storage.
+SUCCESS-CALLBACK, SUCCESS-CLOSURE-DATA, ERROR-CALLBACK and
+ERROR-CLOSURE-DATA are used as in `jabber-send-iq'.
+
+JC is the Jabber connection."
+ (jabber-send-iq jc nil "set"
+ `(query ((xmlns . "jabber:iq:private"))
+ ,fragment)
+ success-callback success-closure-data
+ error-callback error-closure-data))
diff --git a/jabber-register.el b/jabber-register.el
new file mode 100644
index 0000000..cbb0617
--- /dev/null
+++ b/jabber-register.el
@@ -0,0 +1,126 @@
+(add-to-list 'jabber-jid-service-menu
+ (cons "Register with service" 'jabber-get-register))
+(defun jabber-get-register (jc to)
+ "Send IQ get request in namespace \"jabber:iq:register\".
+
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "Register with: ")))
+ (jabber-send-iq jc to
+ "get"
+ '(query ((xmlns . "jabber:iq:register")))
+ #'jabber-process-data #'jabber-process-register-or-search
+ #'jabber-report-success "Registration"))
+
+(defun jabber-process-register-or-search (jc xml-data)
+ "Display results from jabber:iq:{register,search} query as a form.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+
+ (let ((query (jabber-iq-query xml-data))
+ (have-xdata nil)
+ (type (cond
+ ((string= (jabber-iq-xmlns xml-data) "jabber:iq:register")
+ 'register)
+ ((string= (jabber-iq-xmlns xml-data) "jabber:iq:search")
+ 'search)
+ (t
+ (error "Namespace %s not handled by jabber-process-register-or-search" (jabber-iq-xmlns xml-data)))))
+ (register-account
+ (plist-get (fsm-get-state-data jc) :registerp))
+ (username
+ (plist-get (fsm-get-state-data jc) :username))
+ (server
+ (plist-get (fsm-get-state-data jc) :server)))
+
+ (cond
+ ((eq type 'register)
+ ;; If there is no `from' attribute, we are registering with the server
+ (jabber-init-widget-buffer (or (jabber-xml-get-attribute xml-data 'from)
+ server)))
+
+ ((eq type 'search)
+ ;; no such thing here
+ (jabber-init-widget-buffer (jabber-xml-get-attribute xml-data 'from))))
+
+ (setq jabber-buffer-connection jc)
+
+ (widget-insert (if (eq type 'register) "Register with " "Search ") jabber-submit-to "\n\n")
+
+ (dolist (x (jabber-xml-get-children query 'x))
+ (when (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data")
+ (setq have-xdata t)
+ ;; If the registration form obeys XEP-0068, we know
+ ;; for sure how to put a default username in it.
+ (jabber-render-xdata-form x
+ (if (and register-account
+ (string= (jabber-xdata-formtype x) "jabber:iq:register"))
+ (list (cons "username" username))
+ nil))))
+ (if (not have-xdata)
+ (jabber-render-register-form query
+ (when register-account
+ username)))
+
+ (widget-create 'push-button :notify (if (eq type 'register)
+ #'jabber-submit-register
+ #'jabber-submit-search) "Submit")
+ (when (eq type 'register)
+ (widget-insert "\t")
+ (widget-create 'push-button :notify #'jabber-remove-register "Cancel registration"))
+ (widget-insert "\n")
+ (widget-setup)
+ (widget-minor-mode 1)))
+
+(defun jabber-submit-register (&rest ignore)
+ "Submit registration input. See `jabber-process-register-or-search'."
+
+ (let* ((registerp (plist-get (fsm-get-state-data jabber-buffer-connection) :registerp))
+ (handler (if registerp
+ #'jabber-process-register-secondtime
+ #'jabber-report-success))
+ (text (concat "Registration with " jabber-submit-to)))
+ (jabber-send-iq jabber-buffer-connection jabber-submit-to
+ "set"
+
+ (cond
+ ((eq jabber-form-type 'register)
+ `(query ((xmlns . "jabber:iq:register"))
+ ,@(jabber-parse-register-form)))
+ ((eq jabber-form-type 'xdata)
+ `(query ((xmlns . "jabber:iq:register"))
+ ,(jabber-parse-xdata-form)))
+ (t
+ (error "Unknown form type: %s" jabber-form-type)))
+ handler (if registerp 'success text)
+ handler (if registerp 'failure text)))
+
+ (message "Registration sent"))
+
+(defun jabber-process-register-secondtime (jc xml-data closure-data)
+ "Receive registration success or failure.
+CLOSURE-DATA is either 'success or 'error.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (cond
+ ((eq closure-data 'success)
+ (message "Registration successful. You may now connect to the server."))
+ (t
+ (jabber-report-success jc xml-data "Account registration")))
+ (sit-for 3)
+ (jabber-disconnect-one jc))
+
+(defun jabber-remove-register (&rest ignore)
+ "Cancel registration. See `jabber-process-register-or-search'."
+
+ (if (or jabber-silent-mode (yes-or-no-p (concat "Are you sure that you want to cancel your registration to " jabber-submit-to "? ")))
+ (jabber-send-iq jabber-buffer-connection jabber-submit-to
+ "set"
+ '(query ((xmlns . "jabber:iq:register"))
+ (remove))
+ #'jabber-report-success "Unregistration"
+ #'jabber-report-success "Unregistration")))
diff --git a/jabber-roster.el b/jabber-roster.el
new file mode 100644
index 0000000..005773b
--- /dev/null
+++ b/jabber-roster.el
@@ -0,0 +1,866 @@
+(require 'format-spec)
+
+(defgroup jabber-roster nil "roster display options"
+ :group 'jabber)
+
+(defcustom jabber-roster-line-format " %a %c %-25n %u %-8s %S"
+ "The format specification of the lines in the roster display.
+
+These fields are available:
+
+%a Avatar, if any
+%c \"*\" if the contact is connected, or \" \" if not
+%u sUbscription state - see below
+%n Nickname of contact, or JID if no nickname
+%j Bare JID of contact (without resource)
+%r Highest-priority resource of contact
+%s Availability of contact as string (\"Online\", \"Away\" etc)
+%S Status string specified by contact
+
+%u is replaced by one of the strings given by
+`jabber-roster-subscription-display'."
+ :type 'string
+ :group 'jabber-roster)
+
+(defcustom jabber-roster-subscription-display '(("none" . " ")
+ ("from" . "< ")
+ ("to" . " >")
+ ("both" . "<->"))
+ "Strings used for indicating subscription status of contacts.
+\"none\" means that there is no subscription between you and the
+contact.
+\"from\" means that the contact has a subscription to you, but you
+have no subscription to the contact.
+\"to\" means that you have a subscription to the contact, but the
+contact has no subscription to you.
+\"both\" means a mutual subscription.
+
+Having a \"presence subscription\" means being able to see the
+other person's presence.
+
+Some fancy arrows you might want to use, if your system can
+display them: ← → ⇄ ↔."
+ :type '(list (cons :format "%v" (const :format "" "none") (string :tag "None"))
+ (cons :format "%v" (const :format "" "from") (string :tag "From"))
+ (cons :format "%v" (const :format "" "to") (string :tag "To"))
+ (cons :format "%v" (const :format "" "both") (string :tag "Both")))
+ :group 'jabber-roster)
+
+(defcustom jabber-resource-line-format " %r - %s (%S), priority %p"
+ "The format specification of resource lines in the roster display.
+These are displayed when `jabber-show-resources' permits it.
+
+These fields are available:
+
+%c \"*\" if the contact is connected, or \" \" if not
+%n Nickname of contact, or JID if no nickname
+%j Bare JID of contact (without resource)
+%p Priority of this resource
+%r Name of this resource
+%s Availability of resource as string (\"Online\", \"Away\" etc)
+%S Status string specified by resource."
+ :type 'string
+ :group 'jabber-roster)
+
+(defcustom jabber-roster-sort-functions
+ '(jabber-roster-sort-by-status jabber-roster-sort-by-displayname)
+ "Sort roster according to these criteria.
+
+These functions should take two roster items A and B, and return:
+<0 if A < B
+0 if A = B
+>0 if A > B."
+ :type 'hook
+ :options '(jabber-roster-sort-by-status
+ jabber-roster-sort-by-displayname
+ jabber-roster-sort-by-group)
+ :group 'jabber-roster)
+
+(defcustom jabber-sort-order '("chat" "" "away" "dnd" "xa")
+ "Sort by status in this order. Anything not in list goes last.
+Offline is represented as nil."
+ :type '(repeat (restricted-sexp :match-alternatives (stringp nil)))
+ :group 'jabber-roster)
+
+(defcustom jabber-show-resources 'sometimes
+ "Show contacts' resources in roster?
+This can be one of the following symbols:
+
+nil Never show resources
+sometimes Show resources when there are more than one
+always Always show resources."
+ :type '(radio (const :tag "Never" nil)
+ (const :tag "When more than one connected resource" sometimes)
+ (const :tag "Always" always))
+ :group 'jabber-roster)
+
+(defcustom jabber-show-offline-contacts t
+ "Show offline contacts in roster when non-nil."
+ :type 'boolean
+ :group 'jabber-roster)
+
+(defcustom jabber-remove-newlines t
+ "Remove newlines in status messages?
+Newlines in status messages mess up the roster display. However,
+they are essential to status message poets. Therefore, you get to
+choose the behaviour.
+
+Trailing newlines are always removed, regardless of this variable."
+ :type 'boolean
+ :group 'jabber-roster)
+
+(defcustom jabber-roster-show-bindings t
+ "Show keybindings in roster buffer?."
+ :type 'boolean
+ :group 'jabber-roster)
+
+(defcustom jabber-roster-show-title t
+ "Show title in roster buffer?."
+ :type 'boolean
+ :group 'jabber-roster)
+
+(defcustom jabber-roster-mode-hook nil
+ "Hook run when entering Roster mode."
+ :group 'jabber-roster
+ :type 'hook)
+
+(defcustom jabber-roster-default-group-name "other"
+ "Default group name for buddies without groups."
+ :group 'jabber-roster
+ :type 'string
+ :get '(lambda (var)
+ (let ((val (symbol-value var)))
+ (when (stringp val)
+ (set-text-properties 0 (length val) nil val))
+ val))
+ :set '(lambda (var val)
+ (when (stringp val)
+ (set-text-properties 0 (length val) nil val))
+ (custom-set-default var val)))
+
+(defcustom jabber-roster-show-empty-group nil
+ "Show empty groups in roster?."
+ :group 'jabber-roster
+ :type 'boolean)
+
+(defcustom jabber-roster-roll-up-group nil
+ "Show empty groups in roster?."
+ :group 'jabber-roster
+ :type 'boolean)
+
+(defface jabber-roster-user-online
+ '((t (:foreground "blue" :weight bold :slant normal)))
+ "face for displaying online users."
+ :group 'jabber-roster)
+
+(defface jabber-roster-user-xa
+ '((((background dark)) (:foreground "magenta" :weight normal :slant italic))
+ (t (:foreground "black" :weight normal :slant italic)))
+ "face for displaying extended away users."
+ :group 'jabber-roster)
+
+(defface jabber-roster-user-dnd
+ '((t (:foreground "red" :weight normal :slant italic)))
+ "face for displaying do not disturb users."
+ :group 'jabber-roster)
+
+(defface jabber-roster-user-away
+ '((t (:foreground "dark green" :weight normal :slant italic)))
+ "face for displaying away users."
+ :group 'jabber-roster)
+
+(defface jabber-roster-user-chatty
+ '((t (:foreground "dark orange" :weight bold :slant normal)))
+ "face for displaying chatty users."
+ :group 'jabber-roster)
+
+(defface jabber-roster-user-error
+ '((t (:foreground "red" :weight light :slant italic)))
+ "face for displaying users sending presence errors."
+ :group 'jabber-roster)
+
+(defface jabber-roster-user-offline
+ '((t (:foreground "dark grey" :weight light :slant italic)))
+ "face for displaying offline users."
+ :group 'jabber-roster)
+
+(defvar jabber-roster-debug nil
+ "Debug roster draw.")
+
+(defvar jabber-roster-mode-map
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (set-keymap-parent map jabber-common-keymap)
+ (define-key map [mouse-2] 'jabber-roster-mouse-2-action-at-point)
+ (define-key map (kbd "TAB") 'jabber-go-to-next-roster-item)
+ (define-key map (kbd "S-TAB") 'jabber-go-to-previous-roster-item)
+ (define-key map (kbd "M-TAB") 'jabber-go-to-previous-roster-item)
+ (define-key map (kbd "") 'jabber-go-to-previous-roster-item)
+ (define-key map (kbd "RET") 'jabber-roster-ret-action-at-point)
+ (define-key map (kbd "C-k") 'jabber-roster-delete-at-point)
+
+ (define-key map "e" 'jabber-roster-edit-action-at-point)
+ (define-key map "s" 'jabber-send-subscription-request)
+ (define-key map "q" 'bury-buffer)
+ (define-key map "i" 'jabber-get-disco-items)
+ (define-key map "j" 'jabber-muc-join)
+ (define-key map "I" 'jabber-get-disco-info)
+ (define-key map "b" 'jabber-get-browse)
+ (define-key map "v" 'jabber-get-version)
+ (define-key map "a" 'jabber-send-presence)
+ (define-key map "g" 'jabber-display-roster)
+ (define-key map "S" 'jabber-ft-send)
+ (define-key map "o" 'jabber-roster-toggle-offline-display)
+ (define-key map "H" 'jabber-roster-toggle-binding-display)
+ ;;(define-key map "D" 'jabber-disconnect)
+ map))
+
+(defun jabber-roster-ret-action-at-point ()
+ "Action for ret.
+Before try to roll up/down group. Eval `chat-with-jid-at-point' is no group at
+point."
+ (interactive)
+ (let ((group-at-point (get-text-property (point)
+ 'jabber-group))
+ (account-at-point (get-text-property (point)
+ 'jabber-account))
+ (jid-at-point (get-text-property (point)
+ 'jabber-jid)))
+ (if (and group-at-point account-at-point)
+ (jabber-roster-roll-group account-at-point group-at-point)
+ ;; Is this a normal contact, or a groupchat? Let's ask it.
+ (jabber-disco-get-info
+ account-at-point (jabber-jid-user jid-at-point) nil
+ #'jabber-roster-ret-action-at-point-1
+ jid-at-point))))
+
+(defun jabber-roster-ret-action-at-point-1 (jc jid result)
+ ;; If we get an error, assume it's a normal contact.
+ (if (eq (car result) 'error)
+ (jabber-chat-with jc jid)
+ ;; Otherwise, let's check whether it has a groupchat identity.
+ (let ((identities (car result)))
+ (if (cl-find "conference" (if (sequencep identities) identities nil)
+ :key (lambda (i) (aref i 1))
+ :test #'string=)
+ ;; Yes! Let's join it.
+ (jabber-muc-join jc jid
+ (jabber-muc-read-my-nickname jc jid t)
+ t)
+ ;; No. Let's open a normal chat buffer.
+ (jabber-chat-with jc jid)))))
+
+(defun jabber-roster-mouse-2-action-at-point (e)
+ "Action for mouse 2.
+Before try to roll up/down group. Eval `chat-with-jid-at-point' is no group
+at point."
+ (interactive "e")
+ (mouse-set-point e)
+ (let ((group-at-point (get-text-property (point)
+ 'jabber-group))
+ (account-at-point (get-text-property (point)
+ 'jabber-account)))
+ (if (and group-at-point account-at-point)
+ (jabber-roster-roll-group account-at-point group-at-point)
+ (jabber-popup-combined-menu))))
+
+(defun jabber-roster-delete-at-point ()
+ "Delete at point from roster.
+Try to delete the group from all contaacs.
+Delete a jid if there is no group at point."
+ (interactive)
+ (let ((group-at-point (get-text-property (point)
+ 'jabber-group))
+ (account-at-point (get-text-property (point)
+ 'jabber-account)))
+ (if (and group-at-point account-at-point)
+ (let ((jids-with-group
+ (gethash group-at-point
+ (plist-get
+ (fsm-get-state-data account-at-point)
+ :roster-hash))))
+ (jabber-roster-delete-group-from-jids account-at-point
+ jids-with-group
+ group-at-point))
+ (jabber-roster-delete-jid-at-point))))
+
+(defun jabber-roster-edit-action-at-point ()
+ "Action for e. Before try to edit group name.
+Eval `jabber-roster-change' is no group at point."
+ (interactive)
+ (let ((group-at-point (get-text-property (point)
+ 'jabber-group))
+ (account-at-point (get-text-property (point)
+ 'jabber-account)))
+ (if (and group-at-point account-at-point)
+ (let ((jids-with-group
+ (gethash group-at-point
+ (plist-get
+ (fsm-get-state-data account-at-point)
+ :roster-hash))))
+ (jabber-roster-edit-group-from-jids account-at-point
+ jids-with-group
+ group-at-point))
+ (call-interactively 'jabber-roster-change))))
+
+(defun jabber-roster-roll-group (jc group-name &optional set)
+ "Roll up/down group in roster.
+If optional SET is t, roll up group.
+If SET is nor t or nil, roll down group."
+ (let* ((state-data (fsm-get-state-data jc))
+ (roll-groups (plist-get state-data :roster-roll-groups))
+ (new-roll-groups (if (cl-find group-name roll-groups :test 'string=)
+ ;; group is rolled up, roll it down if needed
+ (if (or (not set) (and set (not (eq set t))))
+ (cl-remove-if-not (lambda (group-name-in-list)
+ (not (string= group-name
+ group-name-in-list)))
+ roll-groups)
+ roll-groups)
+ ;; group is rolled down, roll it up if needed
+ (if (or (not set) (and set (eq set t)))
+ (append roll-groups (list group-name))
+ roll-groups))))
+ (unless (equal roll-groups new-roll-groups)
+ (plist-put
+ state-data :roster-roll-groups
+ new-roll-groups)
+ (jabber-display-roster))))
+
+(defun jabber-roster-mode ()
+ "Major mode for Jabber roster display.
+Use the keybindings (mnemonic as Chat, Roster, Info, MUC, Service) to
+bring up menus of actions.
+\\{jabber-roster-mode-map}"
+ (kill-all-local-variables)
+ (setq major-mode 'jabber-roster-mode
+ mode-name "jabber-roster")
+ (use-local-map jabber-roster-mode-map)
+ (setq buffer-read-only t)
+ (if (fboundp 'run-mode-hooks)
+ (run-mode-hooks 'jabber-roster-mode-hook)
+ (run-hooks 'jabber-roster-mode-hook)))
+
+(put 'jabber-roster-mode 'mode-class 'special)
+
+;;;###autoload
+(defun jabber-switch-to-roster-buffer (&optional _jc)
+ "Switch to roster buffer.
+Optional JC argument is ignored; it's there so this function can
+be used in `jabber-post-connection-hooks'."
+ (interactive)
+ (if (not (get-buffer jabber-roster-buffer))
+ (jabber-display-roster)
+ (switch-to-buffer jabber-roster-buffer)))
+
+(defun jabber-sort-roster (jc)
+ "Sort roster according to online status.
+JC is the Jabber connection."
+ (let ((state-data (fsm-get-state-data jc)))
+ (dolist (group (plist-get state-data :roster-groups))
+ (let ((group-name (car group)))
+ (puthash group-name
+ (sort
+ (gethash group-name
+ (plist-get state-data :roster-hash))
+ #'jabber-roster-sort-items)
+ (plist-get state-data :roster-hash))))))
+
+(defun jabber-roster-prepare-roster (jc)
+ "Make a hash based roster.
+JC is the Jabber connection."
+ (let* ((state-data (fsm-get-state-data jc))
+ (hash (make-hash-table :test 'equal))
+ (buddies (plist-get state-data :roster))
+ (all-groups '()))
+ (dolist (buddy buddies)
+ (let ((groups (get buddy 'groups)))
+ (if groups
+ (progn
+ (dolist (group groups)
+ (progn
+ (setq all-groups (append all-groups (list group)))
+ (puthash group
+ (append (gethash group hash)
+ (list buddy))
+ hash))))
+ (progn
+ (setq all-groups (append all-groups
+ (list jabber-roster-default-group-name)))
+ (puthash jabber-roster-default-group-name
+ (append (gethash jabber-roster-default-group-name hash)
+ (list buddy))
+ hash)))))
+
+ ;; remove duplicates name of group
+ (setq all-groups (sort
+ (cl-remove-duplicates all-groups
+ :test 'string=)
+ 'string<))
+
+ ;; put to state-data all-groups as list of list
+ (plist-put state-data :roster-groups
+ (mapcar #'list all-groups))
+
+ ;; put to state-data hash-roster
+ (plist-put state-data :roster-hash
+ hash)))
+
+(defun jabber-roster-sort-items (a b)
+ "Sort roster items A and B according to `jabber-roster-sort-functions'.
+Return t if A is less than B."
+ (let ((result nil))
+ (seq-find (lambda (fn)
+ (setq result (funcall fn a b))
+ (not (= result 0)))
+ jabber-roster-sort-functions)
+ (< result 0)))
+
+(defun jabber-roster-sort-by-status (a b)
+ "Sort roster items by online status.
+See `jabber-sort-order' for order used."
+ (cl-flet ((order (item) (length (member (get item 'show) jabber-sort-order))))
+ (let ((a-order (order a))
+ (b-order (order b)))
+ ;; Note reversed test. Items with longer X-order go first.
+ (cond
+ ((< a-order b-order)
+ 1)
+ ((> a-order b-order)
+ -1)
+ (t
+ 0)))))
+
+(defun jabber-roster-sort-by-displayname (a b)
+ "Sort roster items by displayed name."
+ (let ((a-name (jabber-jid-displayname a))
+ (b-name (jabber-jid-displayname b)))
+ (cond
+ ((string-lessp a-name b-name) -1)
+ ((string= a-name b-name) 0)
+ (t 1))))
+
+(defun jabber-roster-sort-by-group (a b)
+ "Sort roster items by group membership."
+ (cl-flet ((first-group (item) (or (car (get item 'groups)) "")))
+ (let ((a-group (first-group a))
+ (b-group (first-group b)))
+ (cond
+ ((string-lessp a-group b-group) -1)
+ ((string= a-group b-group) 0)
+ (t 1)))))
+
+(defun jabber-fix-status (status)
+ "Make status strings more readable."
+ (when status
+ (when (string-match "\n+$" status)
+ (setq status (replace-match "" t t status)))
+ (when jabber-remove-newlines
+ (while (string-match "\n" status)
+ (setq status (replace-match " " t t status))))
+ status))
+
+(defvar jabber-roster-ewoc nil
+ "Ewoc displaying the roster.
+There is only one; we don't rely on buffer-local variables or
+such.")
+
+(defun jabber-roster-filter-display (buddies)
+ "Filter BUDDIES for items to be displayed in the roster."
+ (cl-remove-if-not (lambda (buddy) (or jabber-show-offline-contacts
+ (get buddy 'connected)))
+ buddies))
+
+(defun jabber-roster-toggle-offline-display ()
+ "Toggle display of offline contacts.
+To change this permanently, customize the `jabber-show-offline-contacts'."
+ (interactive)
+ (setq jabber-show-offline-contacts
+ (not jabber-show-offline-contacts))
+ (jabber-display-roster))
+
+(defun jabber-roster-toggle-binding-display ()
+ "Toggle display of the roster binding text."
+ (interactive)
+ (setq jabber-roster-show-bindings
+ (not jabber-roster-show-bindings))
+ (jabber-display-roster))
+
+(defun jabber-display-roster ()
+ "Switch to the main jabber buffer and refresh it.
+Switch to the roster display and refresh it to reflect the current
+information."
+ (interactive)
+ (with-current-buffer (get-buffer-create jabber-roster-buffer)
+ (if (not (eq major-mode 'jabber-roster-mode))
+ (jabber-roster-mode))
+ (setq buffer-read-only nil)
+ ;; line-number-at-pos is in Emacs >= 21.4. Only used to avoid
+ ;; excessive scrolling when updating roster, so not absolutely
+ ;; necessary.
+ (let ((current-line (and (fboundp 'line-number-at-pos) (line-number-at-pos)))
+ (current-column (current-column)))
+ (erase-buffer)
+ (setq jabber-roster-ewoc nil)
+ (when jabber-roster-show-title
+ (insert (jabber-propertize "Jabber roster" 'face 'jabber-title-large) "\n"))
+ (when jabber-roster-show-bindings
+ (insert "RET Open chat buffer C-k Delete roster item
+e Edit item s Send subscription request
+q Bury buffer i Get disco items
+I Get disco info b Browse
+j Join groupchat (MUC) v Get client version
+a Send presence o Show offline contacts on/off
+C-c C-c Chat menu C-c C-m Multi-User Chat menu
+C-c C-i Info menu C-c C-r Roster menu
+C-c C-s Service menu
+
+H Toggle displaying this text
+"))
+ (insert "__________________________________\n\n")
+ (if (null jabber-connections)
+ (insert "Not connected\n")
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-2] #'jabber-send-presence)
+ (insert (jabber-propertize (concat (format " - %s"
+ (cdr (assoc *jabber-current-show* jabber-presence-strings)))
+ (if (not (zerop (length *jabber-current-status*)))
+ (format " (%s)"
+ (jabber-fix-status *jabber-current-status*)))
+ " -")
+ 'face (or (cdr (assoc *jabber-current-show* jabber-presence-faces))
+ 'jabber-roster-user-online)
+ ;;'mouse-face (cons 'background-color "light grey")
+ 'keymap map)
+ "\n")))
+
+ (dolist (jc jabber-connections)
+ ;; use a hash-based roster
+ (when (not (plist-get (fsm-get-state-data jc) :roster-hash))
+ (jabber-roster-prepare-roster jc))
+ ;; We sort everything before putting it in the ewoc
+ (jabber-sort-roster jc)
+ (let ((before-ewoc (point))
+ (ewoc (ewoc-create
+ (let ((jc jc))
+ (lambda (data)
+ (let* ((group (car data))
+ (group-name (car group))
+ (buddy (car (cdr data))))
+ (jabber-display-roster-entry jc group-name buddy))))
+ (concat
+ (jabber-propertize (concat
+ (plist-get (fsm-get-state-data jc) :username)
+ "@"
+ (plist-get (fsm-get-state-data jc) :server))
+ 'face 'jabber-title-medium)
+ "\n__________________________________\n")
+ "__________________________________"))
+ (new-groups '()))
+ (plist-put(fsm-get-state-data jc) :roster-ewoc ewoc)
+ (dolist (group (plist-get (fsm-get-state-data jc) :roster-groups))
+ (let* ((group-name (car group))
+ (buddies (jabber-roster-filter-display
+ (gethash group-name
+ (plist-get (fsm-get-state-data jc) :roster-hash)))))
+ (when (or jabber-roster-show-empty-group
+ (> (length buddies) 0))
+ (let ((group-node (ewoc-enter-last ewoc (list group nil))))
+ (if (not (cl-find
+ group-name
+ (plist-get (fsm-get-state-data jc) :roster-roll-groups)
+ :test 'string=))
+ (dolist (buddy (reverse buddies))
+ (ewoc-enter-after ewoc group-node (list group buddy))))))))
+ (goto-char (point-max))
+ (insert "\n")
+ (put-text-property before-ewoc (point)
+ 'jabber-account jc)))
+
+ (goto-char (point-min))
+ (setq buffer-read-only t)
+ (if (called-interactively-p 'interactive)
+ (dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks))
+ (run-hook-with-args hook 'roster (current-buffer) (funcall jabber-alert-info-message-function 'roster (current-buffer)))))
+ (when current-line
+ ;; Go back to previous line - don't use goto-line, since it
+ ;; sets the mark.
+ (goto-char (point-min))
+ (forward-line (1- current-line))
+ ;; ...and go back to previous column
+ (move-to-column current-column)))))
+
+(defun jabber-display-roster-entry (jc group-name buddy)
+ "Format and insert a roster entry for BUDDY at point.
+BUDDY is a JID symbol.
+JC is the Jabber connection."
+ (if buddy
+ (let ((buddy-str (format-spec
+ jabber-roster-line-format
+ (list
+ (cons ?a (jabber-propertize " " 'display (get buddy 'avatar)))
+ (cons ?c (if (get buddy 'connected) "*" " "))
+ (cons ?u (cdr (assoc
+ (or
+ (get buddy 'subscription) "none")
+ jabber-roster-subscription-display)))
+ (cons ?n (if (> (length (get buddy 'name)) 0)
+ (get buddy 'name)
+ (symbol-name buddy)))
+ (cons ?j (symbol-name buddy))
+ (cons ?r (or (get buddy 'resource) ""))
+ (cons ?s (or (cdr (assoc (get buddy 'show)
+ jabber-presence-strings))
+ (get buddy 'show)))
+ (cons ?S (if (get buddy 'status)
+ (jabber-fix-status (get buddy 'status))
+ ""))))))
+ (add-text-properties 0
+ (length buddy-str)
+ (list
+ 'face
+ (or (cdr (assoc (get buddy 'show) jabber-presence-faces))
+ 'jabber-roster-user-online)
+ ;;'mouse-face
+ ;;(cons 'background-color "light grey")
+ 'help-echo
+ (symbol-name buddy)
+ 'jabber-jid
+ (symbol-name buddy)
+ 'jabber-account
+ jc)
+ buddy-str)
+ (insert buddy-str)
+
+ (when (or (eq jabber-show-resources 'always)
+ (and (eq jabber-show-resources 'sometimes)
+ (> (jabber-count-connected-resources buddy) 1)))
+ (dolist (resource (get buddy 'resources))
+ (when (plist-get (cdr resource) 'connected)
+ (let ((resource-str (format-spec jabber-resource-line-format
+ (list
+ (cons ?c "*")
+ (cons ?n (if (>
+ (length
+ (get buddy 'name)) 0)
+ (get buddy 'name)
+ (symbol-name buddy)))
+ (cons ?j (symbol-name buddy))
+ (cons ?r (if (>
+ (length
+ (car resource)) 0)
+ (car resource)
+ "empty"))
+ (cons ?s (or
+ (cdr (assoc
+ (plist-get
+ (cdr resource) 'show)
+ jabber-presence-strings))
+ (plist-get
+ (cdr resource) 'show)))
+ (cons ?S (if (plist-get
+ (cdr resource) 'status)
+ (jabber-fix-status
+ (plist-get (cdr resource)
+ 'status))
+ ""))
+ (cons ?p (number-to-string
+ (plist-get (cdr resource)
+ 'priority)))))))
+ (add-text-properties 0
+ (length resource-str)
+ (list
+ 'face
+ (or (cdr (assoc (plist-get
+ (cdr resource)
+ 'show)
+ jabber-presence-faces))
+ 'jabber-roster-user-online)
+ 'jabber-jid
+ (format "%s/%s" (symbol-name buddy) (car resource))
+ 'jabber-account
+ jc)
+ resource-str)
+ (insert "\n" resource-str))))))
+ (let ((group-name (or group-name
+ jabber-roster-default-group-name)))
+ (add-text-properties 0
+ (length group-name)
+ (list
+ 'face 'jabber-title-small
+ 'jabber-group group-name
+ 'jabber-account jc)
+ group-name)
+ (insert group-name))))
+
+;;;###autoload
+(defun jabber-roster-update (jc new-items changed-items deleted-items)
+ "Update roster, in memory and on display.
+Add NEW-ITEMS, update CHANGED-ITEMS and remove DELETED-ITEMS, all
+three being lists of JID symbols.
+JC is the Jabber connection."
+ (let* ((roster (plist-get (fsm-get-state-data jc) :roster))
+ (hash (plist-get (fsm-get-state-data jc) :roster-hash))
+ (ewoc (plist-get (fsm-get-state-data jc) :roster-ewoc))
+ (all-groups (plist-get (fsm-get-state-data jc) :roster-groups))
+ (terminator
+ (lambda (deleted-items)
+ (dolist (delete-this deleted-items)
+ (let ((groups (get delete-this 'groups))
+ (terminator
+ (lambda (g)
+ (let*
+ ((group (or g jabber-roster-default-group-name))
+ (buddies (gethash group hash)))
+ (when (not buddies)
+ (setq new-groups (append new-groups (list group))))
+ (puthash group
+ (delq delete-this buddies)
+ hash)))))
+ (if groups
+ (dolist (group groups)
+ (terminator group))
+ (terminator groups)))))))
+
+ ;; fix a old-roster
+ (dolist (delete-this deleted-items)
+ (setq roster (delq delete-this roster)))
+ (setq roster (append new-items roster))
+ (plist-put (fsm-get-state-data jc) :roster roster)
+
+ ;; update a hash-roster
+ (if (not hash)
+ (jabber-roster-prepare-roster jc)
+
+ (when jabber-roster-debug
+ (message "update hash-based roster"))
+
+ ;; delete items
+ (dolist (delete-this (append deleted-items changed-items))
+ (let ((jid (symbol-name delete-this)))
+ (when jabber-roster-debug
+ (message (concat "delete jid: " jid)))
+ (dolist (group (mapcar (lambda (g) (car g)) all-groups))
+ (when jabber-roster-debug
+ (message (concat "try to delete jid: " jid " from group " group)))
+ (puthash group
+ (delq delete-this (gethash group hash))
+ hash))))
+
+ ;; insert changed-items
+ (dolist (insert-this (append changed-items new-items))
+ (let ((jid (symbol-name insert-this)))
+ (when jabber-roster-debug
+ (message (concat "insert jid: " jid)))
+ (dolist (group (or (get insert-this 'groups)
+ (list jabber-roster-default-group-name)))
+ (when jabber-roster-debug
+ (message (concat "insert jid: " jid " to group " group)))
+ (puthash group
+ (append (gethash group hash)
+ (list insert-this))
+ hash)
+ (setq all-groups (append all-groups (list (list group)))))))
+
+ (when jabber-roster-debug
+ (message "remove duplicates from new group"))
+ (setq all-groups (sort
+ (cl-remove-duplicates all-groups
+ :test (lambda (g1 g2)
+ (let ((g1-name (car g1))
+ (g2-name (car g2)))
+ (string= g1-name
+ g2-name))))
+ (lambda (g1 g2)
+ (let ((g1-name (car g1))
+ (g2-name (car g2)))
+ (string< g1-name
+ g2-name)))))
+
+ (plist-put (fsm-get-state-data jc) :roster-groups all-groups))
+
+ (when jabber-roster-debug
+ (message "re display roster"))
+
+ ;; recreate roster buffer
+ (jabber-display-roster)))
+
+(defalias 'jabber-presence-update-roster 'ignore)
+;;jabber-presence-update-roster is not needed anymore.
+;;Its work is done in `jabber-process-presence'."
+(make-obsolete 'jabber-presence-update-roster 'ignore "27.2")
+
+(defun jabber-next-property (&optional prev)
+ "Return position of next property appearence or nil if there is none.
+If optional PREV is non-nil, return position of previous property appearence."
+ (let ((pos (point))
+ (found nil)
+ (nextprev (if prev 'previous-single-property-change
+ 'next-single-property-change)))
+ (while (not found)
+ (setq pos
+ (let ((jid (funcall nextprev pos 'jabber-jid))
+ (group (funcall nextprev pos 'jabber-group)))
+ (cond
+ ((not jid) group)
+ ((not group) jid)
+ (t (funcall (if prev 'max 'min) jid group)))))
+ (if (not pos)
+ (setq found t)
+ (setq found (or (get-text-property pos 'jabber-jid)
+ (get-text-property pos 'jabber-group)))))
+ pos))
+
+(defun jabber-go-to-next-roster-item ()
+ "Move the cursor to the next jid/group in the buffer."
+ (interactive)
+ (let* ((next (jabber-next-property))
+ (next (if (not next)
+ (progn (goto-char (point-min))
+ (jabber-next-property)) next)))
+ (if next (goto-char next)
+ (goto-char (point-min)))))
+
+(defun jabber-go-to-previous-roster-item ()
+ "Move the cursor to the previous jid/group in the buffer."
+ (interactive)
+ (let* ((previous (jabber-next-property 'prev))
+ (previous (if (not previous)
+ (progn (goto-char (point-max))
+ (jabber-next-property 'prev)) previous)))
+ (if previous (goto-char previous)
+ (goto-char (point-max)))))
+
+(defun jabber-roster-restore-groups (jc)
+ "Restore roster's groups rolling state from private storage.
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)))
+ (jabber-private-get jc 'roster "emacs-jabber"
+ 'jabber-roster-restore-groups-1 'ignore))
+
+(defun jabber-roster-restore-groups-1 (jc xml-data)
+ "Parse roster groups and restore rolling state.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (when (string= (jabber-xml-get-xmlns xml-data) "emacs-jabber")
+ (let* ((data (car (last xml-data)))
+ (groups (if (stringp data) (split-string data "\n") nil)))
+ (dolist (group groups)
+ (jabber-roster-roll-group jc group t)))))
+
+(defun jabber-roster-save-groups ()
+ "Save roster's groups rolling state in private storage."
+ (interactive)
+ (dolist (jc jabber-connections)
+ (let* ((groups (plist-get (fsm-get-state-data jc) :roster-roll-groups))
+ (roll-groups
+ (if groups
+ (mapconcat (lambda (a) (substring-no-properties a)) groups "\n")
+ "")))
+ (jabber-private-set jc
+ `(roster ((xmlns . "emacs-jabber"))
+ ,roll-groups)
+ 'jabber-report-success "Roster groups saved"
+ 'jabber-report-success "Failed to save roster groups"))))
diff --git a/jabber-rtt.el b/jabber-rtt.el
new file mode 100644
index 0000000..65e8e47
--- /dev/null
+++ b/jabber-rtt.el
@@ -0,0 +1,285 @@
+;;;###autoload
+(eval-after-load "jabber-disco"
+ '(jabber-disco-advertise-feature "urn:xmpp:rtt:0"))
+
+(defvar jabber-rtt-ewoc-node nil)
+(make-variable-buffer-local 'jabber-rtt-ewoc-node)
+
+(defvar jabber-rtt-last-seq nil)
+(make-variable-buffer-local 'jabber-rtt-last-seq)
+
+(defvar jabber-rtt-message nil)
+(make-variable-buffer-local 'jabber-rtt-message)
+
+(defvar jabber-rtt-pending-events nil)
+(make-variable-buffer-local 'jabber-rtt-pending-events)
+
+(defvar jabber-rtt-timer nil)
+(make-variable-buffer-local 'jabber-rtt-timer)
+
+;;;###autoload
+(eval-after-load "jabber-core"
+ '(add-to-list 'jabber-message-chain #'jabber-rtt-handle-message t))
+
+;;;###autoload
+(defun jabber-rtt-handle-message (jc xml-data)
+ ;; We could support this for MUC as well, if useful.
+ (when (and (not (jabber-muc-message-p xml-data))
+ (get-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from))))
+ (with-current-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from))
+ (let* ((rtt (jabber-xml-path xml-data '(("urn:xmpp:rtt:0" . "rtt"))))
+ (body (jabber-xml-path xml-data '(body)))
+ (seq (when rtt (jabber-xml-get-attribute rtt 'seq)))
+ (event (when rtt (or (jabber-xml-get-attribute rtt 'event) "edit")))
+ (actions (when rtt (jabber-xml-node-children rtt)))
+ (inhibit-read-only t))
+ (cond
+ ((or body (string= event "cancel"))
+ ;; A element supersedes real time text.
+ (jabber-rtt--reset))
+ ((member event '("new" "reset"))
+ (jabber-rtt--reset)
+ (setq jabber-rtt-ewoc-node
+ (ewoc-enter-last jabber-chat-ewoc (list :notice "[typing...]"))
+ jabber-rtt-last-seq (string-to-number seq)
+ jabber-rtt-message ""
+ jabber-rtt-pending-events nil)
+ (jabber-rtt--enqueue-actions actions))
+ ((string= event "edit")
+ ;; TODO: check whether this works properly in 32-bit Emacs
+ (cond
+ ((and jabber-rtt-last-seq
+ (equal (1+ jabber-rtt-last-seq)
+ (string-to-number seq)))
+ ;; We are in sync.
+ (setq jabber-rtt-last-seq (string-to-number seq))
+ (jabber-rtt--enqueue-actions actions))
+ (t
+ ;; TODO: show warning when not in sync
+ (message "out of sync! %s vs %s"
+ seq jabber-rtt-last-seq))))
+ ;; TODO: handle event="init"
+ )))))
+
+(defun jabber-rtt--reset ()
+ (when jabber-rtt-ewoc-node
+ (ewoc-delete jabber-chat-ewoc jabber-rtt-ewoc-node))
+ (when (timerp jabber-rtt-timer)
+ (cancel-timer jabber-rtt-timer))
+ (setq jabber-rtt-ewoc-node nil
+ jabber-rtt-last-seq nil
+ jabber-rtt-message nil
+ jabber-rtt-pending-events nil
+ jabber-rtt-timer nil))
+
+(defun jabber-rtt--enqueue-actions (new-actions)
+ (setq jabber-rtt-pending-events
+ ;; Ensure that the queue never contains more than 700 ms worth
+ ;; of wait events.
+ (jabber-rtt--fix-waits (append jabber-rtt-pending-events new-actions)))
+ (unless jabber-rtt-timer
+ (jabber-rtt--process-actions (current-buffer))))
+
+(defun jabber-rtt--process-actions (buffer)
+ (with-current-buffer buffer
+ (setq jabber-rtt-timer nil)
+ (catch 'wait
+ (while jabber-rtt-pending-events
+ (let ((action (pop jabber-rtt-pending-events)))
+ (cl-case (jabber-xml-node-name action)
+ ((t)
+ ;; insert text
+ (let* ((p (jabber-xml-get-attribute action 'p))
+ (position (if p (string-to-number p) (length jabber-rtt-message))))
+ (setq position (max position 0))
+ (setq position (min position (length jabber-rtt-message)))
+ (setf (substring jabber-rtt-message position position)
+ (car (jabber-xml-node-children action)))
+
+ (ewoc-set-data jabber-rtt-ewoc-node (list :notice (concat "[typing...] " jabber-rtt-message)))
+ (let ((inhibit-read-only t))
+ (ewoc-invalidate jabber-chat-ewoc jabber-rtt-ewoc-node))))
+ ((e)
+ ;; erase text
+ (let* ((p (jabber-xml-get-attribute action 'p))
+ (position (if p (string-to-number p) (length jabber-rtt-message)))
+ (n (jabber-xml-get-attribute action 'n))
+ (number (if n (string-to-number n) 1)))
+ (setq position (max position 0))
+ (setq position (min position (length jabber-rtt-message)))
+ (setq number (max number 0))
+ (setq number (min number position))
+ ;; Now erase the NUMBER characters before POSITION.
+ (setf (substring jabber-rtt-message (- position number) position)
+ "")
+
+ (ewoc-set-data jabber-rtt-ewoc-node (list :notice (concat "[typing...] " jabber-rtt-message)))
+ (let ((inhibit-read-only t))
+ (ewoc-invalidate jabber-chat-ewoc jabber-rtt-ewoc-node))))
+ ((w)
+ (setq jabber-rtt-timer
+ (run-with-timer
+ (/ (string-to-number (jabber-xml-get-attribute action 'n)) 1000.0)
+ nil
+ #'jabber-rtt--process-actions
+ buffer))
+ (throw 'wait nil))))))))
+
+(defun jabber-rtt--fix-waits (actions)
+ ;; Ensure that the sum of all wait events is no more than 700 ms.
+ (let ((sum 0))
+ (dolist (action actions)
+ (when (eq (jabber-xml-node-name action) 'w)
+ (let ((n (jabber-xml-get-attribute action 'n)))
+ (setq n (string-to-number n))
+ (when (>= n 0)
+ (setq sum (+ sum n))))))
+
+ (if (<= sum 700)
+ actions
+ (let ((scale (/ 700.0 sum)))
+ (mapcar
+ (lambda (action)
+ (if (eq (jabber-xml-node-name action) 'w)
+ (let ((n (jabber-xml-get-attribute action 'n)))
+ (setq n (string-to-number n))
+ (setq n (max n 0))
+ `(w ((n . ,(number-to-string (* scale n)))) nil))
+ action))
+ actions)))))
+
+(defvar jabber-rtt-send-timer nil)
+(make-variable-buffer-local 'jabber-rtt-send-timer)
+
+(defvar jabber-rtt-send-seq nil)
+(make-variable-buffer-local 'jabber-rtt-send-seq)
+
+(defvar jabber-rtt-outgoing-events nil)
+(make-variable-buffer-local 'jabber-rtt-outgoing-events)
+
+(defvar jabber-rtt-send-last-timestamp nil)
+(make-variable-buffer-local 'jabber-rtt-send-last-timestamp)
+
+;;;###autoload
+(define-minor-mode jabber-rtt-send-mode
+ "Show text to recipient as it is being typed.
+This lets the recipient see every change made to the message up
+until it's sent. The recipient's client needs to implement
+XEP-0301, In-Band Real Time Text."
+ nil " Real-Time" nil
+ (if (null jabber-rtt-send-mode)
+ (progn
+ (remove-hook 'after-change-functions #'jabber-rtt--queue-update t)
+ (remove-hook 'jabber-chat-send-hooks #'jabber-rtt--message-sent t)
+ (jabber-rtt--cancel-send))
+ (unless (derived-mode-p 'jabber-chat-mode)
+ (error "Real Time Text only makes sense in chat buffers"))
+ (when (timerp jabber-rtt-send-timer)
+ (cancel-timer jabber-rtt-send-timer))
+ (setq jabber-rtt-send-timer nil
+ jabber-rtt-send-seq nil
+ jabber-rtt-outgoing-events nil
+ jabber-rtt-send-last-timestamp nil)
+ (jabber-rtt--send-current-text nil)
+ (add-hook 'after-change-functions #'jabber-rtt--queue-update nil t)
+ (add-hook 'jabber-chat-send-hooks #'jabber-rtt--message-sent nil t)))
+
+(defun jabber-rtt--cancel-send ()
+ (when (timerp jabber-rtt-send-timer)
+ (cancel-timer jabber-rtt-send-timer))
+ (setq jabber-rtt-send-seq (1+ jabber-rtt-send-seq))
+ (jabber-send-sexp jabber-buffer-connection
+ `(message ((to . ,jabber-chatting-with)
+ (type . "chat"))
+ (rtt ((xmlns . "urn:xmpp:rtt:0")
+ (seq . ,(number-to-string jabber-rtt-send-seq))
+ (event . "cancel"))
+ nil)))
+ (setq jabber-rtt-send-timer nil
+ jabber-rtt-send-seq nil
+ jabber-rtt-outgoing-events nil
+ jabber-rtt-send-last-timestamp nil))
+
+(defun jabber-rtt--send-current-text (resetp)
+ (let ((text (buffer-substring-no-properties jabber-point-insert (point-max))))
+ ;; This should give us enough room to avoid wrap-arounds, even
+ ;; with just 28 bits...
+ (setq jabber-rtt-send-seq (random 100000))
+ (jabber-send-sexp jabber-buffer-connection
+ `(message ((to . ,jabber-chatting-with)
+ (type . "chat"))
+ (rtt ((xmlns . "urn:xmpp:rtt:0")
+ (seq . ,(number-to-string jabber-rtt-send-seq))
+ (event . ,(if resetp "reset" "new")))
+ (t () ,text))))))
+
+(defun jabber-rtt--queue-update (beg end pre-change-length)
+ (unless (or (< beg jabber-point-insert)
+ (< end jabber-point-insert))
+ (let ((timestamp (current-time)))
+ (when jabber-rtt-send-last-timestamp
+ (let* ((time-difference (time-subtract timestamp jabber-rtt-send-last-timestamp))
+ (interval (truncate (* 1000 (float-time time-difference)))))
+ (when (and (> interval 0)
+ ;; Don't send too long intervals - this should have
+ ;; been sent by our timer already.
+ (< interval 1000))
+ (push `(w ((n . ,(number-to-string interval))) nil)
+ jabber-rtt-outgoing-events))))
+ (setq jabber-rtt-send-last-timestamp timestamp))
+
+ (when (> pre-change-length 0)
+ ;; Some text was deleted. Let's check if we can use a shorter
+ ;; tag:
+ (let ((at-end (= end (point-max)))
+ (erase-one (= pre-change-length 1)))
+ (push `(e (
+ ,@(unless at-end
+ `((p . ,(number-to-string
+ (+ beg
+ (- jabber-point-insert)
+ pre-change-length)))))
+ ,@(unless erase-one
+ `((n . ,(number-to-string pre-change-length))))))
+ jabber-rtt-outgoing-events)))
+
+ (when (/= beg end)
+ ;; Some text was inserted.
+ (let ((text (buffer-substring-no-properties beg end))
+ (at-end (= end (point-max))))
+ (push `(t (
+ ,@(unless at-end
+ `((p . ,(number-to-string (- beg jabber-point-insert))))))
+ ,text)
+ jabber-rtt-outgoing-events)))
+
+ (when (null jabber-rtt-send-timer)
+ (setq jabber-rtt-send-timer
+ (run-with-timer 0.7 nil #'jabber-rtt--send-queued-events (current-buffer))))))
+
+(defun jabber-rtt--send-queued-events (buffer)
+ (with-current-buffer buffer
+ (setq jabber-rtt-send-timer nil)
+ (when jabber-rtt-outgoing-events
+ (let ((event (if jabber-rtt-send-seq "edit" "new")))
+ (setq jabber-rtt-send-seq
+ (if jabber-rtt-send-seq
+ (1+ jabber-rtt-send-seq)
+ (random 100000)))
+ (jabber-send-sexp jabber-buffer-connection
+ `(message ((to . ,jabber-chatting-with)
+ (type . "chat"))
+ (rtt ((xmlns . "urn:xmpp:rtt:0")
+ (seq . ,(number-to-string jabber-rtt-send-seq))
+ (event . ,event))
+ ,@(nreverse jabber-rtt-outgoing-events))))
+ (setq jabber-rtt-outgoing-events nil)))))
+
+(defun jabber-rtt--message-sent (_text _id)
+ ;; We're sending a element; reset our state
+ (when (timerp jabber-rtt-send-timer)
+ (cancel-timer jabber-rtt-send-timer))
+ (setq jabber-rtt-send-timer nil
+ jabber-rtt-send-seq nil
+ jabber-rtt-outgoing-events nil
+ jabber-rtt-send-last-timestamp nil))
diff --git a/jabber-sasl.el b/jabber-sasl.el
new file mode 100644
index 0000000..0e92352
--- /dev/null
+++ b/jabber-sasl.el
@@ -0,0 +1,139 @@
+;;; This file uses sasl.el from FLIM or Gnus. If it can't be found,
+;;; jabber-core.el won't use the SASL functions.
+(eval-and-compile
+ (condition-case nil
+ (require 'sasl)
+ (error nil)))
+
+;;; Alternatives to FLIM would be the command line utility of GNU SASL,
+;;; or anything the Gnus people decide to use.
+
+;;; See XMPP-CORE and XMPP-IM for details about the protocol.
+
+(defun jabber-sasl-start-auth (jc stream-features)
+"Start the SASL authentication mechanism.
+JC is The Jabber Connection.
+STREAM-FEATURES the XML parsed \"stream features\" answer (it is used
+with `jabber-xml-get-chidlren')."
+ ;; Find a suitable common mechanism.
+ (let* ((mechanism-elements (car (jabber-xml-get-children stream-features 'mechanisms)))
+ (mechanisms (mapcar
+ (lambda (tag)
+ (car (jabber-xml-node-children tag)))
+ (jabber-xml-get-children mechanism-elements 'mechanism)))
+ (mechanism
+ (if (and (member "ANONYMOUS" mechanisms)
+ (or jabber-silent-mode (yes-or-no-p "Use anonymous authentication? ")))
+ (sasl-find-mechanism '("ANONYMOUS"))
+ (sasl-find-mechanism mechanisms))))
+
+ ;; No suitable mechanism?
+ (if (null mechanism)
+ ;; Maybe we can use legacy authentication
+ (let ((iq-auth (cl-find "http://jabber.org/features/iq-auth"
+ (jabber-xml-get-children stream-features 'auth)
+ :key #'jabber-xml-get-xmlns
+ :test #'string=))
+ ;; Or maybe we have to use STARTTLS, but can't
+ (starttls (cl-find "urn:ietf:params:xml:ns:xmpp-tls"
+ (jabber-xml-get-children stream-features 'starttls)
+ :key #'jabber-xml-get-xmlns
+ :test #'string=)))
+ (cond
+ (iq-auth
+ (fsm-send jc :use-legacy-auth-instead))
+ (starttls
+ (message "STARTTLS encryption required, but disabled/non-functional at our end")
+ (fsm-send jc :authentication-failure))
+ (t
+ (message "Authentication failure: no suitable SASL mechanism found")
+ (fsm-send jc :authentication-failure))))
+
+ ;; Watch for plaintext logins over unencrypted connections
+ (if (and (not (plist-get (fsm-get-state-data jc) :encrypted))
+ (member (sasl-mechanism-name mechanism)
+ '("PLAIN" "LOGIN"))
+ (not (yes-or-no-p "Jabber server only allows cleartext password transmission! Continue? ")))
+ (fsm-send jc :authentication-failure)
+
+ ;; Start authentication.
+ (let* (passphrase
+ (client (sasl-make-client mechanism
+ (plist-get (fsm-get-state-data jc) :username)
+ "xmpp"
+ (plist-get (fsm-get-state-data jc) :server)))
+ (sasl-read-passphrase (jabber-sasl-read-passphrase-closure
+ jc
+ (lambda (p) (setq passphrase (copy-sequence p)) p)))
+ (step (sasl-next-step client nil)))
+ (jabber-send-sexp
+ jc
+ `(auth ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl")
+ (mechanism . ,(sasl-mechanism-name mechanism)))
+ ,(when (sasl-step-data step)
+ (base64-encode-string (sasl-step-data step) t))))
+ (list client step passphrase))))))
+
+(defun jabber-sasl-read-passphrase-closure (jc remember)
+ "Return a lambda function suitable for `sasl-read-passphrase' for JC.
+Call REMEMBER with the password. REMEMBER is expected to return it as well."
+ (let ((password (plist-get (fsm-get-state-data jc) :password))
+ (bare-jid (jabber-connection-bare-jid jc))
+ (remember remember))
+ (if password
+ (lambda (_prompt) (funcall remember (copy-sequence password)))
+ (lambda (_prompt) (funcall remember (jabber-read-password bare-jid))))))
+
+(defun jabber-sasl-process-input (jc xml-data sasl-data)
+"SASL protocol input processing.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let* ((client (cl-first sasl-data))
+ (step (cl-second sasl-data))
+ (passphrase (cl-third sasl-data))
+ (sasl-read-passphrase (jabber-sasl-read-passphrase-closure
+ jc
+ (lambda (p) (setq passphrase (copy-sequence p)) p))))
+ (cond
+ ((eq (car xml-data) 'challenge)
+ (sasl-step-set-data step (base64-decode-string (car (jabber-xml-node-children xml-data))))
+ (setq step (sasl-next-step client step))
+ (jabber-send-sexp
+ jc
+ `(response ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl"))
+ ,(when (sasl-step-data step)
+ (base64-encode-string (sasl-step-data step) t)))))
+
+ ((eq (car xml-data) 'failure)
+ (message "%s: authentication failure: %s"
+ (jabber-connection-bare-jid jc)
+ (jabber-xml-node-name (car (jabber-xml-node-children xml-data))))
+ (fsm-send jc :authentication-failure))
+
+ ((eq (car xml-data) 'success)
+ ;; The server might, depending on the mechanism, send
+ ;; "additional data" (see RFC 4422) with the element.
+ ;; Since some SASL mechanisms perform mutual authentication, we
+ ;; need to pass this data to sasl.el - we're not necessarily
+ ;; done just because the server says we're done.
+ (let* ((data (car (jabber-xml-node-children xml-data)))
+ (decoded (if data
+ (base64-decode-string data)
+ "")))
+ (sasl-step-set-data step decoded)
+ (condition-case e
+ (progn
+ ;; Check that sasl-next-step doesn't signal an error.
+ ;; TODO: once sasl.el allows it, check that all steps have
+ ;; been completed.
+ (sasl-next-step client step)
+ (message "Authentication succeeded for %s" (jabber-connection-bare-jid jc))
+ (fsm-send jc (cons :authentication-success passphrase)))
+ (sasl-error
+ (message "%s: authentication failure: %s"
+ (jabber-connection-bare-jid jc)
+ (error-message-string e))
+ (fsm-send jc :authentication-failure))))))
+ (list client step passphrase)))
diff --git a/jabber-search.el b/jabber-search.el
new file mode 100644
index 0000000..eadc735
--- /dev/null
+++ b/jabber-search.el
@@ -0,0 +1,88 @@
+(add-to-list 'jabber-jid-service-menu
+ (cons "Search directory" 'jabber-get-search))
+(defun jabber-get-search (jc to)
+ "Send IQ get request in namespace \"jabber:iq:search\".
+
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "Search what database: ")))
+ (jabber-send-iq jc to
+ "get"
+ '(query ((xmlns . "jabber:iq:search")))
+ #'jabber-process-data #'jabber-process-register-or-search
+ #'jabber-report-success "Search field retrieval"))
+
+(defun jabber-submit-search (&rest ignore)
+ "Submit search. See `jabber-process-register-or-search'."
+
+ (let ((text (concat "Search at " jabber-submit-to)))
+ (jabber-send-iq jabber-buffer-connection jabber-submit-to
+ "set"
+
+ (cond
+ ((eq jabber-form-type 'register)
+ `(query ((xmlns . "jabber:iq:search"))
+ ,@(jabber-parse-register-form)))
+ ((eq jabber-form-type 'xdata)
+ `(query ((xmlns . "jabber:iq:search"))
+ ,(jabber-parse-xdata-form)))
+ (t
+ (error "Unknown form type: %s" jabber-form-type)))
+ #'jabber-process-data #'jabber-process-search-result
+ #'jabber-report-success text))
+
+ (message "Search sent"))
+
+(defun jabber-process-search-result (jc xml-data)
+ "Receive and display search results.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+
+ ;; This function assumes that all search results come in one packet,
+ ;; which is not necessarily the case.
+ (let ((query (jabber-iq-query xml-data))
+ (have-xdata nil)
+ xdata fields (jid-fields 0))
+
+ ;; First, check for results in jabber:x:data form.
+ (dolist (x (jabber-xml-get-children query 'x))
+ (when (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data")
+ (setq have-xdata t)
+ (setq xdata x)))
+
+ (if have-xdata
+ (jabber-render-xdata-search-results xdata)
+
+ (insert (jabber-propertize "Search results" 'face 'jabber-title-medium) "\n")
+
+ (setq fields '((first . (label "First name" column 0))
+ (last . (label "Last name" column 15))
+ (nick . (label "Nickname" column 30))
+ (jid . (label "JID" column 45))
+ (email . (label "E-mail" column 65))))
+ (setq jid-fields 1)
+
+ (dolist (field-cons fields)
+ (indent-to (plist-get (cdr field-cons) 'column) 1)
+ (insert (jabber-propertize (plist-get (cdr field-cons) 'label) 'face 'bold)))
+ (insert "\n\n")
+
+ ;; Now, the items
+ (dolist (item (jabber-xml-get-children query 'item))
+ (let ((start-of-line (point))
+ jid)
+
+ (dolist (field-cons fields)
+ (let ((field-plist (cdr field-cons))
+ (value (if (eq (car field-cons) 'jid)
+ (setq jid (jabber-xml-get-attribute item 'jid))
+ (car (jabber-xml-node-children (car (jabber-xml-get-children item (car field-cons))))))))
+ (indent-to (plist-get field-plist 'column) 1)
+ (if value (insert value))))
+
+ (if jid
+ (put-text-property start-of-line (point)
+ 'jabber-jid jid))
+ (insert "\n"))))))
diff --git a/jabber-socks5.el b/jabber-socks5.el
new file mode 100644
index 0000000..c1ab902
--- /dev/null
+++ b/jabber-socks5.el
@@ -0,0 +1,646 @@
+(eval-when-compile (require 'cl))
+
+(defvar jabber-socks5-pending-sessions nil
+ "List of pending sessions.
+
+Each entry is a list, containing:
+ * Stream ID
+ * Full JID of initiator
+ * State machine managing the session")
+
+(defvar jabber-socks5-active-sessions nil
+ "List of active sessions.
+
+Each entry is a list, containing:
+ * Network connection
+ * Stream ID
+ * Full JID of initiator
+ * Profile data function")
+
+(defcustom jabber-socks5-proxies nil
+ "JIDs of XEP-0065 proxies to use for file transfer.
+Put preferred ones first."
+ :type '(repeat string)
+ :group 'jabber
+; :set 'jabber-socks5-set-proxies)
+ )
+
+(defvar jabber-socks5-proxies-data nil
+ "Alist containing information about proxies.
+Keys of the alist are strings, the JIDs of the proxies.
+Values are \"streamhost\" XML nodes.")
+
+(jabber-disco-advertise-feature "http://jabber.org/protocol/bytestreams")
+
+(add-to-list 'jabber-si-stream-methods
+ (list "http://jabber.org/protocol/bytestreams"
+ 'jabber-socks5-client-1
+ 'jabber-socks5-accept))
+
+(defun jabber-socks5-set-proxies (symbol value)
+ "Set `jabber-socks5-proxies' and query proxies.
+This is the set function of `jabber-socks5-proxies-data'."
+ (set-default symbol value)
+ (when jabber-connections
+ (jabber-socks5-query-all-proxies)))
+
+(defun jabber-socks5-query-all-proxies (jc &optional callback)
+ "Ask all proxies in `jabber-socks5-proxies' for connection information.
+If CALLBACK is non-nil, call it with no arguments when all
+proxies have answered."
+ (interactive (list (jabber-read-account)))
+ (setq jabber-socks5-proxies-data nil)
+ (dolist (proxy jabber-socks5-proxies)
+ (jabber-socks5-query-proxy jc proxy callback)))
+
+(defun jabber-socks5-query-proxy (jc jid &optional callback)
+ "Query the SOCKS5 proxy specified by JID for IP and port number."
+ (jabber-send-iq jc jid "get"
+ '(query ((xmlns . "http://jabber.org/protocol/bytestreams")))
+ #'jabber-socks5-process-proxy-response (list callback t)
+ #'jabber-socks5-process-proxy-response (list callback nil)))
+
+(defun jabber-socks5-process-proxy-response (jc xml-data closure-data)
+ "Process response from proxy query."
+ (let* ((query (jabber-iq-query xml-data))
+ (from (jabber-xml-get-attribute xml-data 'from))
+ (streamhosts (jabber-xml-get-children query 'streamhost)))
+
+ (let ((existing-entry (assoc from jabber-socks5-proxies-data)))
+ (when existing-entry
+ (setq jabber-socks5-proxies-data
+ (delq existing-entry jabber-socks5-proxies-data))))
+
+ (destructuring-bind (callback successp) closure-data
+ (when successp
+ (setq jabber-socks5-proxies-data
+ (cons (cons from streamhosts)
+ jabber-socks5-proxies-data)))
+ (message "%s from %s. %d of %d proxies have answered."
+ (if successp "Response" "Error") from
+ (length jabber-socks5-proxies-data) (length jabber-socks5-proxies))
+ (when (and callback (= (length jabber-socks5-proxies-data) (length jabber-socks5-proxies)))
+ (funcall callback)))))
+
+(define-state-machine jabber-socks5
+ :start ((jc jid sid profile-function role)
+ "Start XEP-0065 bytestream with JID.
+SID is the session ID used.
+PROFILE-FUNCTION is the function to call upon success. See `jabber-si-stream-methods'.
+ROLE is either :initiator or :target. The initiator sends an IQ
+set; the target waits for one."
+ (let ((new-state-data (list :jc jc
+ :jid jid
+ :sid sid
+ :profile-function profile-function
+ :role role))
+ (new-state
+ ;; We want information about proxies; it might be needed in
+ ;; various situations.
+ (cond
+ ((null jabber-socks5-proxies)
+ ;; We know no proxy addresses. Try to find them by disco.
+ 'seek-proxies)
+ ((null jabber-socks5-proxies-data)
+ ;; We need to query the proxies for addresses.
+ 'query-proxies)
+ ;; So, we have our proxies.
+ (t
+ 'initiate))))
+ (list new-state new-state-data nil))))
+
+(defun jabber-socks5-accept (jc jid sid profile-function)
+ "Remember that we are waiting for connection from JID, with stream id SID"
+ ;; asking the user for permission is done in the profile
+ (add-to-list 'jabber-socks5-pending-sessions
+ (list sid jid (start-jabber-socks5 jc jid sid profile-function :target))))
+
+(define-enter-state jabber-socks5 seek-proxies (fsm state-data)
+ ;; Look for items at the server.
+ (let* ((jc (plist-get state-data :jc))
+ (server (jabber-jid-server (jabber-connection-jid jc))))
+ (jabber-disco-get-items jc
+ server
+ nil
+ (lambda (jc fsm result)
+ (fsm-send-sync fsm (cons :items result)))
+ fsm))
+ ;; Spend no more than five seconds looking for a proxy.
+ (list state-data 5))
+
+(define-state jabber-socks5 seek-proxies (fsm state-data event callback)
+ "Collect disco results, looking for a bytestreams proxy."
+ ;; We put the number of outstanding requests as :remaining-info in
+ ;; the state-data plist.
+ (cond
+ ;; We're not ready to handle the IQ stanza yet
+ ((eq (car-safe event) :iq)
+ :defer)
+
+ ;; Got list of items at the server.
+ ((eq (car-safe event) :items)
+ (dolist (entry (cdr event))
+ ;; Each entry is ["name" "jid" "node"]. We send a disco info
+ ;; request to everything without a node.
+ (when (null (aref entry 2))
+ (lexical-let ((jid (aref entry 1)))
+ (jabber-disco-get-info
+ (plist-get state-data :jc)
+ jid nil
+ (lambda (jc fsm result)
+ (fsm-send-sync fsm (list :info jid result)))
+ fsm))))
+ ;; Remember number of requests sent. But if none, we just go on.
+ (if (cdr event)
+ (list 'seek-proxies (plist-put state-data :remaining-info (length (cdr event))) :keep)
+ (list 'initiate state-data nil)))
+
+ ;; Got disco info from an item at the server.
+ ((eq (car-safe event) :info)
+ (fsm-debug-output "got disco event")
+ ;; Count the response.
+ (plist-put state-data :remaining-info (1- (plist-get state-data :remaining-info)))
+ (unless (eq (first (third event)) 'error)
+ (let ((identities (first (third event))))
+ ;; Is it a bytestream proxy?
+ (when (dolist (identity identities)
+ (when (and (string= (aref identity 1) "proxy")
+ (string= (aref identity 2) "bytestreams"))
+ (return t)))
+ ;; Yes, it is. Add it to the list.
+ (push (second event) jabber-socks5-proxies))))
+
+ ;; Wait for more responses, if any are to be expected.
+ (if (zerop (plist-get state-data :remaining-info))
+ ;; No more... go on to querying the proxies.
+ (list 'query-proxies state-data nil)
+ ;; We expect more responses...
+ (list 'seek-proxies state-data :keep)))
+
+ ((eq event :timeout)
+ ;; We can't wait anymore...
+ (list 'query-proxies state-data nil))))
+
+(define-enter-state jabber-socks5 query-proxies (fsm state-data)
+ (jabber-socks5-query-all-proxies
+ (plist-get state-data :jc)
+ (lexical-let ((fsm fsm))
+ (lambda () (fsm-send-sync fsm :proxies))))
+ (list state-data 5))
+
+(define-state jabber-socks5 query-proxies (fsm state-data event callback)
+ "Query proxies in `jabber-socks5-proxies'."
+ (cond
+ ;; Can't handle the iq stanza yet...
+ ((eq (car-safe event) :iq)
+ :defer)
+
+ ((eq (car-safe event) :info)
+ ;; stray event... do nothing
+ (list 'query-proxies state-data :keep))
+
+ ;; Got response/error from all proxies, or timeout
+ ((memq event '(:proxies :timeout))
+ (list 'initiate state-data nil))))
+
+(define-enter-state jabber-socks5 initiate (fsm state-data)
+ ;; Sort the alist jabber-socks5-proxies-data such that the
+ ;; keys are in the same order as in jabber-socks5-proxies.
+ (setq jabber-socks5-proxies-data
+ (sort jabber-socks5-proxies-data
+ #'(lambda (a b)
+ (> (length (member (car a) jabber-socks5-proxies))
+ (length (member (car b) jabber-socks5-proxies))))))
+
+ ;; If we're the initiator, send initiation stanza.
+ (when (eq (plist-get state-data :role) :initiator)
+ ;; This is where initiation of server sockets would go
+
+ (jabber-send-iq
+ (plist-get state-data :jc)
+ (plist-get state-data :jid) "set"
+ `(query ((xmlns . "http://jabber.org/protocol/bytestreams")
+ (sid . ,(plist-get state-data :sid)))
+ ,@(mapcar
+ #'(lambda (proxy)
+ (mapcar
+ #'(lambda (streamhost)
+ (list 'streamhost
+ (list (cons 'jid (jabber-xml-get-attribute streamhost 'jid))
+ (cons 'host (jabber-xml-get-attribute streamhost 'host))
+ (cons 'port (jabber-xml-get-attribute streamhost 'port)))
+ ;; (proxy ((xmlns . "http://affinix.com/jabber/stream")))
+ ))
+ (cdr proxy)))
+ jabber-socks5-proxies-data)
+ ;; (fast ((xmlns . "http://affinix.com/jabber/stream")))
+ )
+ (lexical-let ((fsm fsm))
+ (lambda (jc xml-data closure-data)
+ (fsm-send-sync fsm (list :iq xml-data))))
+ nil
+ ;; TODO: error handling
+ #'jabber-report-success "SOCKS5 negotiation"))
+
+ ;; If we're the target, we just wait for an incoming stanza.
+ (list state-data nil))
+
+(add-to-list 'jabber-iq-set-xmlns-alist
+ (cons "http://jabber.org/protocol/bytestreams" 'jabber-socks5-process))
+(defun jabber-socks5-process (jc xml-data)
+ "Accept IQ get for SOCKS5 bytestream"
+ (let* ((jid (jabber-xml-get-attribute xml-data 'from))
+ (id (jabber-xml-get-attribute xml-data 'id))
+ (query (jabber-iq-query xml-data))
+ (sid (jabber-xml-get-attribute query 'sid))
+ (session (dolist (pending-session jabber-socks5-pending-sessions)
+ (when (and (equal sid (nth 0 pending-session))
+ (equal jid (nth 1 pending-session)))
+ (return pending-session)))))
+ ;; check that we really are expecting this session
+ (unless session
+ (jabber-signal-error "auth" 'not-acceptable))
+
+ (setq jabber-socks5-pending-sessions (delq session jabber-socks5-pending-sessions))
+ (fsm-send-sync (nth 2 session) (list :iq xml-data))
+
+ ;; find streamhost to connect to
+;; (let* ((streamhosts (jabber-xml-get-children query 'streamhost))
+;; (streamhost (dolist (streamhost streamhosts)
+;; (let ((connection (jabber-socks5-connect streamhost sid jid (concat jabber-username "@" jabber-server "/" jabber-resource))))
+;; (when connection
+;; ;; We select the first streamhost that we are able to connect to.
+;; (push (list connection sid jid profile-data-function)
+;; jabber-socks5-active-sessions)
+;; ;; Now set the filter, for the rest of the output
+;; (set-process-filter connection #'jabber-socks5-filter)
+;; (set-process-sentinel connection #'jabber-socks5-sentinel)
+;; (return streamhost))))))
+;; (unless streamhost
+;; (jabber-signal-error "cancel" 'item-not-found))
+
+;; ;; tell initiator which streamhost we use
+;; (jabber-send-iq jid "result"
+;; `(query ((xmlns . "http://jabber.org/protocol/bytestreams"))
+;; (streamhost-used ((jid . ,(jabber-xml-get-attribute streamhost 'jid)))))
+;; nil nil nil nil id)
+;; ;; now, as data is sent, it will be passed to the profile.
+;; )
+ ))
+
+(define-state jabber-socks5 initiate (fsm state-data event callback)
+ (let* ((jc (plist-get state-data :jc))
+ (jc-data (fsm-get-state-data jc))
+ (our-jid (concat (plist-get jc-data :username) "@"
+ (plist-get jc-data :server) "/"
+ (plist-get jc-data :resource)))
+ (their-jid (plist-get state-data :jid))
+ (initiator-jid (if (eq (plist-get state-data :role) :initiator) our-jid their-jid))
+ (target-jid (if (eq (plist-get state-data :role) :initiator) their-jid our-jid)))
+ (cond
+ ;; Stray event...
+ ((memq (car-safe event) '(:proxy :info))
+ (list 'initiate state-data :keep))
+
+ ;; Incoming IQ
+ ((eq (car-safe event) :iq)
+ (let ((xml-data (second event)))
+ ;; This is either type "set" (with a list of streamhosts to
+ ;; use), or a "result" (indicating the streamhost finally used
+ ;; by the other party).
+ (cond
+ ((string= (jabber-xml-get-attribute xml-data 'type) "set")
+ ;; A "set" makes sense if we're the initiator and offered
+ ;; Psi's "fast mode". We don't yet, though, so this is only
+ ;; for target.
+ (dolist (streamhost (jabber-xml-get-children (jabber-iq-query xml-data) 'streamhost))
+ (jabber-xml-let-attributes
+ (jid host port) streamhost
+ ;; This is where we would attempt to support zeroconf
+ (when (and jid host port)
+ (start-jabber-socks5-connection
+ jc initiator-jid target-jid jid
+ (plist-get state-data :sid) host port fsm))))
+
+ (list 'wait-for-connection (plist-put state-data :iq-id (jabber-xml-get-attribute xml-data 'id)) 30))
+
+ ((string= (jabber-xml-get-attribute xml-data 'type) "result")
+ ;; The other party has decided what streamhost to use.
+ (let* ((proxy-used (jabber-xml-get-attribute (jabber-xml-path xml-data '(query streamhost-used)) 'jid))
+ ;; If JID is our own JID, we have probably already detected
+ ;; what connection to use. But that is a later problem...
+ (streamhosts (cdr (assoc proxy-used jabber-socks5-proxies-data))))
+ ;; Try to connect to all addresses of this proxy...
+ (dolist (streamhost streamhosts)
+ (jabber-xml-let-attributes
+ (jid host port) streamhost
+ (when (and jid host port)
+ (start-jabber-socks5-connection
+ jc initiator-jid target-jid jid
+ (plist-get state-data :sid) host port fsm)))))
+
+ (list 'wait-for-connection state-data 30))))))))
+
+(define-state-machine jabber-socks5-connection
+ :start
+ ((jc initiator-jid target-jid streamhost-jid sid host port socks5-fsm)
+ "Connect to a single XEP-0065 streamhost."
+ (let ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary))
+ ;; make-network-process, which we really want, for asynchronous
+ ;; connection and such, was introduced in Emacs 22.
+ (if (fboundp 'make-network-process)
+ (let ((connection
+ (make-network-process
+ :name "socks5"
+ :buffer nil
+ :host host
+ :service (string-to-number port)
+ :nowait t
+ :filter (fsm-make-filter fsm)
+ :sentinel (fsm-make-sentinel fsm))))
+ (list 'wait-for-connection
+ (list :jc jc
+ :connection connection
+ :initiator-jid initiator-jid
+ :target-jid target-jid
+ :streamhost-jid streamhost-jid
+ :sid sid
+ :socks5-fsm socks5-fsm)
+ 30))
+ ;; So we open a stream, and wait for the connection to succeed.
+ (condition-case nil
+ (let ((connection
+ (open-network-stream "socks5" nil
+ host (string-to-number port))))
+ (set-process-filter connection (fsm-make-filter fsm))
+ (set-process-sentinel connection (fsm-make-sentinel fsm))
+ (list 'authenticate
+ (list :jc jc
+ :connection connection
+ :initiator-jid initiator-jid
+ :target-jid target-jid
+ :streamhost-jid streamhost-jid
+ :sid sid
+ :socks5-fsm socks5-fsm)
+ nil))
+ (error (list 'fail '() nil)))))))
+
+(define-state jabber-socks5-connection wait-for-connection
+ (fsm state-data event callback)
+ (cond
+ ((eq (car-safe event) :sentinel)
+ (let ((string (third event)))
+ (cond
+ ;; Connection succeeded
+ ((string= (substring string 0 4) "open")
+ (list 'authenticate state-data nil))
+ ;; Connection failed
+ (t
+ (list 'fail state-data nil)))))))
+
+(define-enter-state jabber-socks5-connection authenticate
+ (fsm state-data)
+ "Send authenticate command."
+ ;; version: 5. number of auth methods supported: 1.
+ ;; which one: no authentication.
+ (process-send-string (plist-get state-data :connection) (string 5 1 0))
+ (list state-data 30))
+
+(define-state jabber-socks5-connection authenticate
+ (fsm state-data event callback)
+ "Receive response to authenticate command."
+ (cond
+ ((eq (car-safe event) :filter)
+ (let ((string (third event)))
+ ;; should return:
+ ;; version: 5. auth method to use: none
+ (if (string= string (string 5 0))
+ ;; Authenticated. Send connect command.
+ (list 'connect state-data nil)
+ ;; Authentication failed...
+ (delete-process (second event))
+ (list 'fail state-data nil))))
+
+ ((eq (car-safe event) :sentinel)
+ (list 'fail state-data nil))))
+
+(define-enter-state jabber-socks5-connection connect (fsm state-data)
+ "Send connect command."
+ (let* ((sid (plist-get state-data :sid))
+ (initiator (plist-get state-data :initiator-jid))
+ (target (plist-get state-data :target-jid))
+ (hash (sha1 (concat sid initiator target))))
+ (process-send-string
+ (plist-get state-data :connection)
+ (concat (string 5 1 0 3 (length hash))
+ hash
+ (string 0 0)))
+ (list state-data 30)))
+
+(define-state jabber-socks5-connection connect
+ (fsm state-data event callback)
+ "Receive response to connect command."
+ (cond
+ ((eq (car-safe event) :filter)
+ (let ((string (third event)))
+ (if (string= (substring string 0 2) (string 5 0))
+ ;; connection established
+ (progn
+ (fsm-send (plist-get state-data :socks5-fsm)
+ (list :connected
+ (plist-get state-data :connection)
+ (plist-get state-data :streamhost-jid)))
+ ;; Our work is done
+ (list 'done nil))
+ (list 'fail state-data nil))))
+ ((eq (car-safe event) :sentinel)
+ (list 'fail state-data nil))))
+
+(define-state jabber-socks5-connection done
+ (fsm state-data event callback)
+ ;; ignore all events
+ (list 'done nil nil))
+
+(define-enter-state jabber-socks5-connection fail (fsm state-data)
+ ;; Notify parent fsm about failure
+ (fsm-send (plist-get state-data :socks5-fsm)
+ :not-connected)
+ (list nil nil))
+
+(define-state jabber-socks5-connection fail
+ (fsm state-data event callback)
+ ;; ignore all events
+ (list 'fail nil nil))
+
+(define-state jabber-socks5 wait-for-connection
+ (fsm state-data event callback)
+ (cond
+ ((eq (car-safe event) :connected)
+ (destructuring-bind (ignored connection streamhost-jid) event
+ (setq state-data (plist-put state-data :connection connection))
+ ;; If we are expected to tell which streamhost we chose, do so.
+ (let ((iq-id (plist-get state-data :iq-id)))
+ (when iq-id
+ (jabber-send-iq
+ (plist-get state-data :jc)
+ (plist-get state-data :jid) "result"
+ `(query ((xmlns . "http://jabber.org/protocol/bytestreams"))
+ (streamhost-used ((jid . ,streamhost-jid))))
+ nil nil nil nil
+ iq-id)))
+
+ ;; If we are the initiator, we should activate the bytestream.
+ (if (eq (plist-get state-data :role) :initiator)
+ (progn
+ (jabber-send-iq
+ (plist-get state-data :jc)
+ streamhost-jid "set"
+ `(query ((xmlns . "http://jabber.org/protocol/bytestreams")
+ (sid . ,(plist-get state-data :sid)))
+ (activate nil ,(plist-get state-data :jid)))
+ (lambda (jc xml-data fsm) (fsm-send-sync fsm :activated)) fsm
+ (lambda (jc xml-data fsm) (fsm-send-sync fsm :activation-failed)) fsm)
+ (list 'wait-for-activation state-data 10))
+ ;; Otherwise, we just let the data flow.
+ (list 'stream-activated state-data nil))))
+
+ ((eq event :not-connected)
+ ;; If we were counting the streamhosts, we would know when there
+ ;; are no more chances left.
+ (list 'wait-for-connection state-data :keep))
+
+ ((eq event :timeout)
+ (list 'fail (plist-put state-data :error "Timeout when connecting to streamhosts") nil))))
+
+(define-state jabber-socks5 wait-for-activation
+ (fsm state-data event callback)
+ (cond
+ ((eq event :activated)
+ (list 'stream-activated state-data nil))
+ ((eq event :activation-failed)
+ (list 'fail (plist-put state-data :error "Proxy activation failed") nil))
+
+ ;; Stray events from earlier state
+ ((eq (car-safe event) :connected)
+ ;; We just close the connection
+ (delete-process (second event))
+ (list 'wait-for-activation state-data :keep))
+ ((eq event :not-connected)
+ (list 'wait-for-activation state-data :keep))))
+
+(define-enter-state jabber-socks5 stream-activated
+ (fsm state-data)
+ (let ((connection (plist-get state-data :connection))
+ (jc (plist-get state-data :jc))
+ (jid (plist-get state-data :jid))
+ (sid (plist-get state-data :sid))
+ (profile-function (plist-get state-data :profile-function)))
+ (set-process-filter connection (fsm-make-filter fsm))
+ (set-process-sentinel connection (fsm-make-sentinel fsm))
+ ;; Call the profile function, passing the data send function, and
+ ;; receiving the data receiving function. Put the data receiving
+ ;; function in the plist.
+ (list (plist-put state-data
+ :profile-data-function
+ (funcall profile-function
+ jc jid sid
+ (lexical-let ((fsm fsm))
+ (lambda (data)
+ (fsm-send fsm (list :send data))))))
+ nil)))
+
+
+(define-state jabber-socks5 stream-activated
+ (fsm state-data event callback)
+ (let ((jc (plist-get state-data :jc))
+ (connection (plist-get state-data :connection))
+ (profile-data-function (plist-get state-data :profile-data-function))
+ (sid (plist-get state-data :sid))
+ (jid (plist-get state-data :jid)))
+ (cond
+ ((eq (car-safe event) :send)
+ (process-send-string connection (second event))
+ (list 'stream-activated state-data nil))
+
+ ((eq (car-safe event) :filter)
+ ;; Pass data from connection to profile data function
+ ;; If the data function requests it, tear down the connection.
+ (unless (funcall profile-data-function jc jid sid (third event))
+ (fsm-send fsm (list :sentinel (second event) "shutdown")))
+
+ (list 'stream-activated state-data nil))
+
+ ((eq (car-safe event) :sentinel)
+ ;; Connection terminated. Shuffle together the remaining data,
+ ;; and kill the buffer.
+ (delete-process (second event))
+ (funcall profile-data-function jc jid sid nil)
+ (list 'closed nil nil))
+
+ ;; Stray events from earlier state
+ ((eq (car-safe event) :connected)
+ ;; We just close the connection
+ (delete-process (second event))
+ (list 'stream-activated state-data nil))
+ ((eq event :not-connected)
+ (list 'stream-activated state-data nil)))))
+
+(define-enter-state jabber-socks5 fail (fsm state-data)
+ "Tell our caller that we failed."
+ (let ((jc (plist-get state-data :jc))
+ (jid (plist-get state-data :jid))
+ (sid (plist-get state-data :sid))
+ (profile-function (plist-get state-data :profile-function))
+ (iq-id (plist-get state-data :iq-id)))
+ (funcall profile-function jc jid sid (plist-get state-data :error))
+
+ (when iq-id
+ (jabber-send-iq-error jc jid iq-id nil "cancel"
+ 'remote-server-not-found)))
+ (list nil nil))
+
+(defun jabber-socks5-client-1 (jc jid sid profile-function)
+ "Negotiate a SOCKS5 connection with JID.
+This function simply starts a state machine."
+ (add-to-list 'jabber-socks5-pending-sessions
+ (list sid jid (start-jabber-socks5 jc jid sid profile-function :initiator))))
+
+;; (defun jabber-socks5-client-2 (xml-data jid sid profile-function)
+;; "Contact has selected a streamhost to use. Connect to the proxy."
+;; (let* ((query (jabber-iq-query xml-data))
+;; (streamhost-used (car (jabber-xml-get-children query 'streamhost-used)))
+;; (proxy-used (jabber-xml-get-attribute streamhost-used 'jid))
+;; connection)
+;; (let ((streamhosts-left (cdr (assoc proxy-used jabber-socks5-proxies-data))))
+;; (while (and streamhosts-left (not connection))
+;; (setq connection
+;; (jabber-socks5-connect (car streamhosts-left)
+;; sid
+;; (concat jabber-username "@" jabber-server "/" jabber-resource)
+;; jid))
+;; (setq streamhosts-left (cdr streamhosts-left))))
+;; (unless connection
+;; (error "Couldn't connect to proxy %s" proxy-used))
+
+;; ;; Activation is only needed for proxies.
+;; (jabber-send-iq proxy-used "set"
+;; `(query ((xmlns . "http://jabber.org/protocol/bytestreams")
+;; (sid . ,sid))
+;; (activate () ,jid))
+;; (lexical-let ((jid jid) (sid sid) (profile-function profile-function)
+;; (connection connection))
+;; (lambda (xml-data closure-data)
+;; (jabber-socks5-client-3 xml-data jid sid profile-function connection))) nil
+;; ;; TODO: report error to contact?
+;; #'jabber-report-success "Proxy activation")))
+
+;; (defun jabber-socks5-client-3 (xml-data jid sid profile-function proxy-connection)
+;; "Proxy is activated. Start the transfer."
+;; ;; The response from the proxy does not contain any interesting
+;; ;; information, beyond success confirmation.
+
+;; (funcall profile-function jid sid
+;; (lexical-let ((proxy-connection proxy-connection))
+;; (lambda (data)
+;; (process-send-string proxy-connection data)))))
diff --git a/jabber-time.el b/jabber-time.el
new file mode 100644
index 0000000..0a81a79
--- /dev/null
+++ b/jabber-time.el
@@ -0,0 +1,196 @@
+(require 'time-date)
+
+(add-to-list 'jabber-jid-info-menu (cons "Request time" 'jabber-get-time))
+
+(defun jabber-get-time (jc to)
+ "Request time.
+
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "Request time of: "
+ nil nil nil 'full t)))
+
+ (jabber-send-iq jc to "get"
+ '(time ((xmlns . "urn:xmpp:time")))
+ 'jabber-silent-process-data 'jabber-process-time
+ 'jabber-silent-process-data
+ (lambda (jc xml-data)
+ (let ((from (jabber-xml-get-attribute xml-data 'from)))
+ (jabber-get-legacy-time jc from)))))
+
+(defun jabber-get-legacy-time (jc to)
+ "Request legacy time.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "Request time of: "
+ nil nil nil 'full t)))
+
+ (jabber-send-iq jc to
+ "get"
+ '(query ((xmlns . "jabber:iq:time")))
+ 'jabber-silent-process-data 'jabber-process-legacy-time
+ 'jabber-silent-process-data "Time request failed"))
+
+;; called by jabber-process-data
+(defun jabber-process-time (jc xml-data)
+ "Handle results from urn:xmpp:time requests.
+
+JC is the Jabber Connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let* ((from (jabber-xml-get-attribute xml-data 'from))
+ (time (or (car (jabber-xml-get-children xml-data 'time))
+ ;; adium response of qeury
+ (car (jabber-xml-get-children xml-data 'query))))
+ (tzo (car (jabber-xml-node-children
+ (car (jabber-xml-get-children time 'tzo)))))
+ (utc (car (jabber-xml-node-children
+ (car (jabber-xml-get-children time 'utc))))))
+ (when (and utc tzo)
+ (format "%s has time: %s %s"
+ from (format-time-string "%Y-%m-%d %T" (jabber-parse-time utc)) tzo))))
+
+(defun jabber-process-legacy-time (jc xml-data)
+ "Handle results from jabber:iq:time requests.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let* ((from (jabber-xml-get-attribute xml-data 'from))
+ (query (jabber-iq-query xml-data))
+ (display
+ (car (jabber-xml-node-children
+ (car (jabber-xml-get-children
+ query 'display)))))
+ (utc
+ (car (jabber-xml-node-children
+ (car (jabber-xml-get-children
+ query 'utc)))))
+ (tz
+ (car (jabber-xml-node-children
+ (car (jabber-xml-get-children
+ query 'tz))))))
+ (format "%s has time: %s" from
+ (cond
+ (display display)
+ (utc
+ (concat
+ (format-time-string "%Y-%m-%d %T" (jabber-parse-legacy-time utc))
+ (when tz
+ (concat " " tz))))))))
+
+(defun jabber-get-last-online (jc to)
+ "Request time since a user was last online, or uptime of a component.
+
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "Get last online for: "
+ nil nil nil 'bare-or-muc)))
+ (jabber-send-iq jc to
+ "get"
+ '(query ((xmlns . "jabber:iq:last")))
+ #'jabber-silent-process-data #'jabber-process-last
+ #'jabber-silent-process-data "Last online request failed"))
+
+(defun jabber-get-idle-time (jc to)
+ "Request idle time of user.
+
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "Get idle time for: "
+ nil nil nil 'full t)))
+ (jabber-send-iq jc to
+ "get"
+ '(query ((xmlns . "jabber:iq:last")))
+ #'jabber-silent-process-data #'jabber-process-last
+ #'jabber-silent-process-data "Idle time request failed"))
+
+(defun jabber-process-last (jc xml-data)
+ "Handle resultts from jabber:iq:last requests.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let* ((from (jabber-xml-get-attribute xml-data 'from))
+ (query (jabber-iq-query xml-data))
+ (seconds (jabber-xml-get-attribute query 'seconds))
+ (message (car (jabber-xml-node-children query))))
+ (cond
+ ((jabber-jid-resource from)
+ ;; Full JID: idle time
+ (format "%s idle for %s seconds" from seconds))
+ ((jabber-jid-username from)
+ ;; Bare JID with username: time since online
+ (concat
+ (format "%s last online %s seconds ago" from seconds)
+ (let ((seconds (condition-case nil
+ (string-to-number seconds)
+ (error nil))))
+ (when (numberp seconds)
+ (concat
+ " - that is, at "
+ (format-time-string "%Y-%m-%d %T"
+ (time-subtract (current-time)
+ (seconds-to-time seconds)))
+ "\n")))))
+ (t
+ ;; Only hostname: uptime
+ (format "%s uptime: %s seconds" from seconds)))))
+
+(add-to-list 'jabber-iq-get-xmlns-alist (cons "jabber:iq:time" 'jabber-return-legacy-time))
+(jabber-disco-advertise-feature "jabber:iq:time")
+
+(defun jabber-return-legacy-time (jc xml-data)
+ "Return client time as defined in XEP-0090.
+Sender and ID are determined from the incoming packet passed in XML-DATA.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let ((to (jabber-xml-get-attribute xml-data 'from))
+ (id (jabber-xml-get-attribute xml-data 'id)))
+ (jabber-send-iq jc to "result"
+ `(query ((xmlns . "jabber:iq:time"))
+ ;; what is ``human-readable'' format?
+ ;; the same way as formating using by tkabber
+ (display () ,(format-time-string "%a %b %d %H:%M:%S %Z %Y"))
+ (tz () ,(format-time-string "%Z"))
+ (utc () ,(jabber-encode-legacy-time nil)))
+ nil nil nil nil
+ id)))
+
+(add-to-list 'jabber-iq-get-xmlns-alist (cons "urn:xmpp:time" 'jabber-return-time))
+(jabber-disco-advertise-feature "urn:xmpp:time")
+
+(defun jabber-return-time (jc xml-data)
+ "Return client time as defined in XEP-0202.
+Sender and ID are determined from the incoming packet passed in XML-DATA.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let ((to (jabber-xml-get-attribute xml-data 'from))
+ (id (jabber-xml-get-attribute xml-data 'id)))
+ (jabber-send-iq jc to "result"
+ `(time ((xmlns . "urn:xmpp:time"))
+ (utc () ,(jabber-encode-time nil))
+ (tzo () ,(jabber-encode-timezone)))
+ nil nil nil nil
+ id)))
+
+(add-to-list 'jabber-iq-get-xmlns-alist (cons "jabber:iq:last" 'jabber-return-last))
+(jabber-disco-advertise-feature "jabber:iq:last")
+
+(defun jabber-return-last (jc xml-data)
+ (let ((to (jabber-xml-get-attribute xml-data 'from))
+ (id (jabber-xml-get-attribute xml-data 'id)))
+ (jabber-send-iq jc to "result"
+ `(time ((xmlns . "jabber:iq:last")
+ ;; XEP-0012 specifies that this is an integer.
+ (seconds . ,(number-to-string
+ (floor (jabber-autoaway-get-idle-time))))))
+ nil nil nil nil
+ id)))
diff --git a/jabber-truncate.el b/jabber-truncate.el
new file mode 100644
index 0000000..f85de50
--- /dev/null
+++ b/jabber-truncate.el
@@ -0,0 +1,46 @@
+(defvar jabber-log-lines-to-keep 1000
+ "Maximum number of lines in chat buffer.")
+
+(defun jabber-truncate-top (buffer &optional ewoc)
+ "Clean old history from a chat BUFFER.
+Optional EWOC is ewoc-widget to work. Default is `jabber-chat-ewoc'
+`jabber-log-lines-to-keep' specifies the number of lines to
+keep.
+
+Note that this might interfer with
+`jabber-chat-display-more-backlog': you ask for more history, you
+get it, and then it just gets deleted."
+ (interactive)
+ (let* ((inhibit-read-only t)
+ (work-ewoc (if ewoc ewoc jabber-chat-ewoc))
+ (delete-before
+ ;; go back one node, to make this function "idempotent"
+ (ewoc-prev
+ work-ewoc
+ (ewoc-locate work-ewoc
+ (save-excursion
+ (set-buffer buffer)
+ (goto-char (point-max))
+ (forward-line (- jabber-log-lines-to-keep))
+ (point))))))
+ (while delete-before
+ (setq delete-before
+ (prog1
+ (ewoc-prev work-ewoc delete-before)
+ (ewoc-delete work-ewoc delete-before))))))
+
+(defun jabber-truncate-muc (nick group buffer text proposed-alert)
+ "Clean old history from MUC buffers.
+`jabber-log-lines-to-keep' specifies the number of lines to
+keep."
+ (jabber-truncate-top buffer))
+
+(defun jabber-truncate-chat (from buffer text proposed-alert)
+ "Clean old history from chat buffers.
+`jabber-log-lines-to-keep' specifies the number of lines to
+keep.
+
+Note that this might interfer with
+`jabber-chat-display-more-backlog': you ask for more history, you
+get it, and then it just gets deleted."
+ (jabber-truncate-top buffer))
diff --git a/jabber-util.el b/jabber-util.el
new file mode 100644
index 0000000..9f54b04
--- /dev/null
+++ b/jabber-util.el
@@ -0,0 +1,719 @@
+(require 'password-cache)
+(condition-case nil
+ (require 'auth-source)
+ (error nil))
+
+(defvar jabber-jid-history nil
+ "History of entered JIDs.")
+
+(defalias 'jabber-propertize 'propertize)
+
+(defsubst jabber-read-with-input-method (prompt &optional initial-contents history default-value)
+ "Like `read-string', but always inheriting the current input method."
+ (read-string prompt initial-contents history default-value t))
+
+(unless (fboundp 'delete-and-extract-region)
+ (defsubst delete-and-extract-region (start end)
+ (prog1
+ (buffer-substring start end)
+ (delete-region start end))))
+
+(unless (fboundp 'access-file)
+ (defsubst access-file (filename error-message)
+ (unless (file-readable-p filename)
+ (error error-message))))
+
+ (defalias 'jabber-float-time 'float-time)
+
+(defalias 'jabber-cancel-timer 'cancel-timer)
+
+(defvar jabber-connections)
+(defun jabber-concat-rosters ()
+ "Concatenate the rosters of all connected accounts."
+ (apply #'append
+ (mapcar
+ (lambda (jc)
+ (plist-get (fsm-get-state-data jc) :roster))
+ jabber-connections)))
+
+(defun jabber-concat-rosters-full ()
+ "Concatenate the rosters of all connected accounts.
+Show full JIDs, with resources."
+ (let ((jids (apply #'append
+ (mapcar
+ (lambda (jc)
+ (plist-get (fsm-get-state-data jc) :roster))
+ jabber-connections))))
+ (apply #'append
+ (mapcar (lambda (jid)
+ (mapcar (lambda (res) (intern (format "%s/%s" jid (car res))))
+ (get (jabber-jid-symbol jid) 'resources)))
+ jids))))
+
+(defun jabber-connection-jid (jc)
+ "Return the full JID of connection JC."
+ (let ((sd (fsm-get-state-data jc)))
+ (concat (plist-get sd :username) "@"
+ (plist-get sd :server) "/"
+ (plist-get sd :resource))))
+
+(defun jabber-connection-bare-jid (jc)
+ "Return the bare JID of connection JC."
+ (let ((sd (fsm-get-state-data jc)))
+ (concat (plist-get sd :username) "@"
+ (plist-get sd :server))))
+
+(defun jabber-connection-original-jid (jc)
+ "Return the original JID of connection JC.
+The \"original JID\" is the JID we authenticated with. The
+server might subsequently assign us a different JID at resource
+binding."
+ (plist-get (fsm-get-state-data jc) :original-jid))
+
+(defun jabber-find-connection (bare-jid)
+ "Find the connection to the account named by BARE-JID.
+Return nil if none found."
+ (dolist (jc jabber-connections)
+ (when (string= bare-jid (jabber-connection-bare-jid jc))
+ (cl-return jc))))
+
+(defun jabber-find-active-connection (dead-jc)
+ "Find an active connection for dead connection DEAD-JC.
+Return nil if none found."
+ (let ((jid (jabber-connection-bare-jid dead-jc)))
+ (jabber-find-connection jid)))
+
+(defun jabber-jid-username (jid)
+ "Return the username portion of JID, or nil if none found.
+JID must be a string."
+ (when (string-match "\\(.*\\)@.*\\(/.*\\)?" jid)
+ (match-string 1 jid)))
+
+(defun jabber-jid-user (jid)
+ "Return the user portion (username@server) of JID.
+JID must be a string."
+ ;;transports don't have @, so don't require it
+ ;;(string-match ".*@[^/]*" jid)
+ (string-match "[^/]*" jid)
+ (match-string 0 jid))
+
+(defun jabber-jid-server (jid)
+ "Return the server portion of JID."
+ (string-match "^\\(.*@\\)?\\([^@/]+\\)\\(/.*\\)?$" jid)
+ (match-string 2 jid))
+
+(defun jabber-jid-rostername (user)
+ "Return the name of USER if present in roster, or nil."
+ (let ((user (jabber-jid-symbol user)))
+ (if (> (length (get user 'name)) 0)
+ (get user 'name))))
+
+(defun jabber-jid-displayname (string)
+ "Return the name of the user from STRING as in roster, else username@server."
+ (or (jabber-jid-rostername string)
+ (jabber-jid-user (if (symbolp string)
+ (symbol-name string)
+ string))))
+
+(defvar jabber-bookmarks)
+(defun jabber-jid-bookmarkname (string)
+ "Return from STRING the conference name from boomarks or displayname.
+Use the name according to roster or else the JID if none set."
+ (or (cl-loop for conference in (cl-first (cl-loop for value being the hash-values of jabber-bookmarks
+ collect value))
+ do (let ((ls (cadr conference)))
+ (if (string= (cdr (assoc 'jid ls)) string)
+ (cl-return (cdr (assoc 'name ls))))))
+ (jabber-jid-displayname string)))
+
+(defun jabber-jid-resource (jid)
+ "Return the resource portion of a JID, or nil if there is none.
+JID must be a string."
+ (when (string-match "^\\(\\([^/]*@\\)?[^/]*\\)/\\(.*\\)" jid)
+ (match-string 3 jid)))
+
+(defvar jabber-jid-obarray)
+(defun jabber-jid-symbol (jid)
+ "Return the symbol for JID, which must be a symbol or a string."
+ ;; If it's already a symbol, just return it.
+ (if (symbolp jid)
+ jid
+ ;; XXX: "downcase" is a poor man's nodeprep. See XMPP CORE.
+ (intern (downcase (jabber-jid-user jid)) jabber-jid-obarray)))
+
+(defvar jabber-account-list)
+(defun jabber-my-jid-p (jc jid)
+ "Return non-nil if the specified JID is in the `jabber-account-list'.
+Comment: (modulo resource).
+Also return non-nil if JID matches JC, modulo resource."
+ (or
+ (equal (jabber-jid-user jid)
+ (jabber-connection-bare-jid jc))
+ (member (jabber-jid-user jid) (mapcar (lambda (x) (jabber-jid-user (car x))) jabber-account-list))))
+
+(defvar *jabber-active-groupchats*)
+(defun jabber-read-jid-completing (prompt &optional subset require-match default resource fulljids)
+ "Read a jid out of the current roster from the minibuffer.
+If SUBSET is non-nil, it should be a list of symbols from which
+the JID is to be selected, instead of using the entire roster.
+If REQUIRE-MATCH is non-nil, the JID must be in the list used.
+If DEFAULT is non-nil, it's used as the default value, otherwise
+the default is inferred from context.
+RESOURCE is one of the following:
+
+nil Accept full or bare JID, as entered
+full Turn bare JIDs to full ones with highest-priority resource
+bare-or-muc Turn full JIDs to bare ones, except for in MUC
+
+If FULLJIDS is non-nil, complete jids with resources."
+ (let ((jid-at-point (or
+ (and default
+ ;; default can be either a symbol or a string
+ (if (symbolp default)
+ (symbol-name default)
+ default))
+ (let* ((jid (get-text-property (point) 'jabber-jid))
+ (res (get (jabber-jid-symbol jid) 'resource)))
+ (when jid
+ (if (and fulljids res (not (jabber-jid-resource jid)))
+ (format "%s/%s" jid res)
+ jid)))
+ (bound-and-true-p jabber-chatting-with)
+ (bound-and-true-p jabber-group)))
+ (completion-ignore-case t)
+ (jid-completion-table (mapcar #'(lambda (item)
+ (cons (symbol-name item) item))
+ (or subset (funcall (if fulljids
+ 'jabber-concat-rosters-full
+ 'jabber-concat-rosters)))))
+ chosen)
+ (dolist (item (or subset (jabber-concat-rosters)))
+ (if (get item 'name)
+ (push (cons (get item 'name) item) jid-completion-table)))
+ ;; if the default is not in the allowed subset, it's not a good default
+ (if (and subset (not (assoc jid-at-point jid-completion-table)))
+ (setq jid-at-point nil))
+ (let ((input
+ (completing-read (concat prompt
+ (if jid-at-point
+ (format "(default %s) " jid-at-point)))
+ jid-completion-table
+ nil require-match nil 'jabber-jid-history jid-at-point)))
+ (setq chosen
+ (if (and input (assoc-string input jid-completion-table t))
+ (symbol-name (cdr (assoc-string input jid-completion-table t)))
+ (and (not (zerop (length input)))
+ input))))
+
+ (when chosen
+ (cl-case resource
+ (full
+ ;; If JID is bare, add the highest-priority resource.
+ (if (jabber-jid-resource chosen)
+ chosen
+ (let ((highest-resource (get (jabber-jid-symbol chosen) 'resource)))
+ (if highest-resource
+ (concat chosen "/" highest-resource)
+ chosen))))
+ (bare-or-muc
+ ;; If JID is full and non-MUC, remove resource.
+ (if (null (jabber-jid-resource chosen))
+ chosen
+ (let ((bare (jabber-jid-user chosen)))
+ (if (assoc bare *jabber-active-groupchats*)
+ chosen
+ bare))))
+ (t
+ chosen)))))
+
+(defun jabber-read-node (prompt)
+ "Read node name, taking default from disco item at point."
+ (let ((node-at-point (get-text-property (point) 'jabber-node)))
+ (read-string (concat prompt
+ (if node-at-point
+ (format "(default %s) " node-at-point)))
+ node-at-point)))
+
+(defun jabber-password-key (bare-jid)
+ "Construct key for `password' library from BARE-JID."
+ (concat "xmpp:" bare-jid))
+
+(defun jabber-read-password (bare-jid)
+ "Read Jabber password from minibuffer."
+ (let ((found
+ (and (fboundp 'auth-source-search)
+ (nth 0 (auth-source-search
+ :user (jabber-jid-username bare-jid)
+ :host (jabber-jid-server bare-jid)
+ :port "xmpp"
+ :max 1
+ :require '(:secret))))))
+ (if found
+ (let ((secret (plist-get found :secret)))
+ (copy-sequence
+ (if (functionp secret)
+ (funcall secret)
+ secret)))
+ (let ((prompt (format "Jabber password for %s: " bare-jid)))
+ ;; Need to copy the password, as sasl.el wants to erase it.
+ (copy-sequence
+ (password-read prompt (jabber-password-key bare-jid)))))))
+
+(defun jabber-cache-password (bare-jid password)
+ "Cache PASSWORD for BARE-JID."
+ (password-cache-add (jabber-password-key bare-jid) password))
+
+(defun jabber-uncache-password (bare-jid)
+ "Uncache cached password for BARE-JID.
+Useful if the password proved to be wrong."
+ (interactive (list (jabber-jid-user
+ (completing-read "Forget password of account: " jabber-account-list nil nil nil 'jabber-account-history))))
+ (password-cache-remove (jabber-password-key bare-jid)))
+
+(defvar jabber-buffer-connection)
+(defun jabber-read-account (&optional always-ask contact-hint)
+ "Ask for which connected account to use.
+If ALWAYS-ASK is nil and there is only one account, return that
+account.
+If CONTACT-HINT is a string or a JID symbol, default to an account
+that has that contact in its roster."
+ (let ((completions
+ (mapcar (lambda (c)
+ (cons
+ (jabber-connection-bare-jid c)
+ c))
+ jabber-connections)))
+ (cond
+ ((null jabber-connections)
+ (error "Not connected to Jabber"))
+ ((and (null (cdr jabber-connections)) (not always-ask))
+ ;; only one account
+ (car jabber-connections))
+ (t
+ (or
+ ;; if there is a jabber-account property at point,
+ ;; present it as default value
+ (cdr (assoc (let ((at-point (get-text-property (point) 'jabber-account)))
+ (when (and at-point
+ (memq at-point jabber-connections))
+ (jabber-connection-bare-jid at-point))) completions))
+ (let* ((default
+ (or
+ (and contact-hint
+ (setq contact-hint (jabber-jid-symbol contact-hint))
+ (let ((matching
+ (cl-find-if
+ (lambda (jc)
+ (memq contact-hint (plist-get (fsm-get-state-data jc) :roster)))
+ jabber-connections)))
+ (when matching
+ (jabber-connection-bare-jid matching))))
+ ;; if the buffer is associated with a connection, use it
+ (when (and jabber-buffer-connection
+ (jabber-find-active-connection jabber-buffer-connection))
+ (jabber-connection-bare-jid jabber-buffer-connection))
+ ;; else, use the first connection in the list
+ (caar completions)))
+ (input (completing-read
+ (concat "Select Jabber account (default "
+ default
+ "): ")
+ completions nil t nil 'jabber-account-history
+ default)))
+ (cdr (assoc input completions))))))))
+
+(defun jabber-iq-query (xml-data)
+ "Return the query part of an IQ stanza.
+An IQ stanza may have zero or one query child, and zero or one child.
+The query child is often but not always .
+
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let (query)
+ (dolist (x (jabber-xml-node-children xml-data))
+ (if (and
+ (listp x)
+ (not (eq (jabber-xml-node-name x) 'error)))
+ (setq query x)))
+ query))
+
+(defun jabber-iq-error (xml-data)
+ "Return the part of an IQ stanza, if any.
+
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (car (jabber-xml-get-children xml-data 'error)))
+
+(defun jabber-iq-xmlns (xml-data)
+ "Return the namespace of an IQ stanza, i.e. the namespace of its query part.
+
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (jabber-xml-get-attribute (jabber-iq-query xml-data) 'xmlns))
+
+(defun jabber-message-timestamp (xml-data)
+ "Given a element, return its timestamp, or nil if none.
+
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (jabber-x-delay
+ (or
+ (jabber-xml-path xml-data '(("urn:xmpp:delay" . "delay")))
+ (jabber-xml-path xml-data '(("jabber:x:delay" . "x"))))))
+
+(defun jabber-x-delay (xml-data)
+ "Return timestamp given a delayed delivery element.
+This can be either a tag in namespace urn:xmpp:delay (XEP-0203), or
+a tag in namespace jabber:x:delay (XEP-0091).
+Return nil if no such data available.
+
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (cond
+ ((and (eq (jabber-xml-node-name xml-data) 'x)
+ (string= (jabber-xml-get-attribute xml-data 'xmlns) "jabber:x:delay"))
+ (let ((stamp (jabber-xml-get-attribute xml-data 'stamp)))
+ (if (and (stringp stamp)
+ (= (length stamp) 17))
+ (jabber-parse-legacy-time stamp))))
+ ((and (eq (jabber-xml-node-name xml-data) 'delay)
+ (string= (jabber-xml-get-attribute xml-data 'xmlns) "urn:xmpp:delay"))
+ (let ((stamp (jabber-xml-get-attribute xml-data 'stamp)))
+ (when (stringp stamp)
+ (jabber-parse-time stamp))))))
+
+(defun jabber-parse-legacy-time (timestamp)
+ "Parse timestamp in ccyymmddThh:mm:ss format (UTC) and return as internal
+time value."
+ (let ((year (string-to-number (substring timestamp 0 4)))
+ (month (string-to-number (substring timestamp 4 6)))
+ (day (string-to-number (substring timestamp 6 8)))
+ (hour (string-to-number (substring timestamp 9 11)))
+ (minute (string-to-number (substring timestamp 12 14)))
+ (second (string-to-number (substring timestamp 15 17))))
+ (encode-time second minute hour day month year 0)))
+
+(defun jabber-encode-legacy-time (timestamp)
+ "Parse TIMESTAMP as internal time value and encode as ccyymmddThh:mm:ss (UTC)."
+ (if (featurep 'xemacs)
+ ;; XEmacs doesn't have `universal' argument to format-time-string,
+ ;; so we have to do it ourselves.
+ (format-time-string "%Y%m%dT%H:%M:%S"
+ (time-subtract timestamp
+ (list 0 (car (current-time-zone)))))
+ (format-time-string "%Y%m%dT%H:%M:%S" timestamp t)))
+
+(defun jabber-encode-time (time)
+ "Convert TIME to a string by XEP-0082.
+TIME is in a format accepted by `format-time-string'."
+ (format-time-string "%Y-%m-%dT%H:%M:%SZ" time t))
+
+(defun jabber-encode-timezone ()
+ (let ((time-zone-offset (nth 0 (current-time-zone))))
+ (if (null time-zone-offset)
+ "Z"
+ (let* ((positivep (>= time-zone-offset 0))
+ (hours (/ (abs time-zone-offset) 3600))
+ (minutes (/ (% (abs time-zone-offset) 3600) 60)))
+ (format "%s%02d:%02d"(if positivep "+" "-") hours minutes)))))
+
+(defun jabber-parse-time (raw-time)
+ "Parse the DateTime encoded in TIME according to XEP-0082."
+ (let* ((time (if (string= (substring raw-time 4 5) "-")
+ raw-time
+ (concat
+ (substring raw-time 0 4) "-"
+ (substring raw-time 4 6) "-"
+ (substring raw-time 6 (length raw-time)))))
+ (year (string-to-number (substring time 0 4)))
+ (month (string-to-number (substring time 5 7)))
+ (day (string-to-number (substring time 8 10)))
+ (hour (string-to-number (substring time 11 13)))
+ (minute (string-to-number (substring time 14 16)))
+ (second (string-to-number (substring time 17 19)))
+ (timezone (if (eq (aref time 19) ?.)
+ ;; fractions are optional
+ (let ((timezone (cadr
+ (split-string (substring time 20)
+ "[-+Z]"))))
+ (if (string= "" timezone)
+ "Z"
+ timezone))
+ (substring time 19))))
+ ;; timezone is either Z (UTC) or [+-]HH:MM
+ (let ((timezone-seconds
+ (if (string= timezone "Z")
+ 0
+ (* (if (eq (aref timezone 0) ?+) 1 -1)
+ (* 60 (+ (* 60 (string-to-number (substring timezone 1 3)))
+ (string-to-number (substring timezone 4 6))))))))
+ (encode-time second minute hour day month year timezone-seconds))))
+
+(defun jabber-report-success (_jc xml-data context)
+ "IQ callback reporting success or failure of the operation.
+CONTEXT is a string describing the action.
+\"CONTEXT succeeded\" or \"CONTEXT failed: REASON\" is displayed in
+the echo area.
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let ((type (jabber-xml-get-attribute xml-data 'type)))
+ (message (concat context
+ (if (string= type "result")
+ " succeeded"
+ (concat
+ " failed: "
+ (let ((the-error (jabber-iq-error xml-data)))
+ (if the-error
+ (jabber-parse-error the-error)
+ "No error message given"))))))))
+
+(defconst jabber-error-messages
+ (list
+ (cons 'bad-request "Bad request")
+ (cons 'conflict "Conflict")
+ (cons 'feature-not-implemented "Feature not implemented")
+ (cons 'forbidden "Forbidden")
+ (cons 'gone "Gone")
+ (cons 'internal-server-error "Internal server error")
+ (cons 'item-not-found "Item not found")
+ (cons 'jid-malformed "JID malformed")
+ (cons 'not-acceptable "Not acceptable")
+ (cons 'not-allowed "Not allowed")
+ (cons 'not-authorized "Not authorized")
+ (cons 'payment-required "Payment required")
+ (cons 'recipient-unavailable "Recipient unavailable")
+ (cons 'redirect "Redirect")
+ (cons 'registration-required "Registration required")
+ (cons 'remote-server-not-found "Remote server not found")
+ (cons 'remote-server-timeout "Remote server timeout")
+ (cons 'resource-constraint "Resource constraint")
+ (cons 'service-unavailable "Service unavailable")
+ (cons 'subscription-required "Subscription required")
+ (cons 'undefined-condition "Undefined condition")
+ (cons 'unexpected-request "Unexpected request"))
+ "String descriptions of XMPP stanza errors.")
+
+(defconst jabber-legacy-error-messages
+ (list
+ (cons 302 "Redirect")
+ (cons 400 "Bad request")
+ (cons 401 "Unauthorized")
+ (cons 402 "Payment required")
+ (cons 403 "Forbidden")
+ (cons 404 "Not found")
+ (cons 405 "Not allowed")
+ (cons 406 "Not acceptable")
+ (cons 407 "Registration required")
+ (cons 408 "Request timeout")
+ (cons 409 "Conflict")
+ (cons 500 "Internal server error")
+ (cons 501 "Not implemented")
+ (cons 502 "Remote server error")
+ (cons 503 "Service unavailable")
+ (cons 504 "Remote server timeout")
+ (cons 510 "Disconnected"))
+ "String descriptions of legacy errors (XEP-0086).")
+
+(defun jabber-parse-error (error-xml)
+ "Parse the given tag and return a string fit for human consumption.
+See secton 9.3, Stanza Errors, of XMPP Core, and XEP-0086, Legacy Errors."
+ (let ((error-type (jabber-xml-get-attribute error-xml 'type))
+ (error-code (jabber-xml-get-attribute error-xml 'code))
+ condition text)
+ (if error-type
+ ;; If the tag has a type element, it is new-school.
+ (dolist (child (jabber-xml-node-children error-xml))
+ (when (string=
+ (jabber-xml-get-attribute child 'xmlns)
+ "urn:ietf:params:xml:ns:xmpp-stanzas")
+ (if (eq (jabber-xml-node-name child) 'text)
+ (setq text (car (jabber-xml-node-children child)))
+ (setq condition
+ (or (cdr (assq (jabber-xml-node-name child) jabber-error-messages))
+ (symbol-name (jabber-xml-node-name child)))))))
+ (setq condition (or (cdr (assq (string-to-number error-code) jabber-legacy-error-messages))
+ error-code))
+ (setq text (car (jabber-xml-node-children error-xml))))
+ (concat condition
+ (if text (format ": %s" text)))))
+
+(defun jabber-error-condition (error-xml)
+ "Parse the given tag and return the condition symbol."
+ (catch 'condition
+ (dolist (child (jabber-xml-node-children error-xml))
+ (when (string=
+ (jabber-xml-get-attribute child 'xmlns)
+ "urn:ietf:params:xml:ns:xmpp-stanzas")
+ (throw 'condition (jabber-xml-node-name child))))))
+
+(defvar jabber-stream-error-messages
+ (list
+ (cons 'bad-format "Bad XML format")
+ (cons 'bad-namespace-prefix "Bad namespace prefix")
+ (cons 'conflict "Conflict")
+ (cons 'connection-timeout "Connection timeout")
+ (cons 'host-gone "Host gone")
+ (cons 'host-unknown "Host unknown")
+ (cons 'improper-addressing "Improper addressing") ; actually only s2s
+ (cons 'internal-server-error "Internal server error")
+ (cons 'invalid-from "Invalid from")
+ (cons 'invalid-id "Invalid id")
+ (cons 'invalid-namespace "Invalid namespace")
+ (cons 'invalid-xml "Invalid XML")
+ (cons 'not-authorized "Not authorized")
+ (cons 'policy-violation "Policy violation")
+ (cons 'remote-connection-failed "Remote connection failed")
+ (cons 'resource-constraint "Resource constraint")
+ (cons 'restricted-xml "Restricted XML")
+ (cons 'see-other-host "See other host")
+ (cons 'system-shutdown "System shutdown")
+ (cons 'undefined-condition "Undefined condition")
+ (cons 'unsupported-encoding "Unsupported encoding")
+ (cons 'unsupported-stanza-type "Unsupported stanza type")
+ (cons 'unsupported-version "Unsupported version")
+ (cons 'xml-not-well-formed "XML not well formed"))
+ "String descriptions of XMPP stream errors.")
+
+(defun jabber-stream-error-condition (error-xml)
+ "Return the condition of a tag."
+ ;; as we don't know the node name of the condition, we have to
+ ;; search for it.
+ (dolist (node (jabber-xml-node-children error-xml))
+ (when (and (string= (jabber-xml-get-attribute node 'xmlns)
+ "urn:ietf:params:xml:ns:xmpp-streams")
+ (assq (jabber-xml-node-name node)
+ jabber-stream-error-messages))
+ (cl-return (jabber-xml-node-name node)))))
+
+(defun jabber-parse-stream-error (error-xml)
+ "Parse the given error tag and return a string fit for human consumption.
+ERROR-XML is a tag parsed with `xml-parse-region'."
+ (let ((text-node (car (jabber-xml-get-children error-xml 'text)))
+ (condition (jabber-stream-error-condition error-xml)))
+ (concat (if condition (cdr (assq condition jabber-stream-error-messages))
+ "Unknown stream error")
+ (if (and text-node (stringp (car (jabber-xml-node-children text-node))))
+ (concat ": " (car (jabber-xml-node-children text-node)))))))
+
+(put 'jabber-error
+ 'error-conditions
+ '(error jabber-error))
+(put 'jabber-error
+ 'error-message
+ "Jabber error")
+
+(defun jabber-signal-error (error-type condition &optional text app-specific)
+ "Signal an error to be sent by Jabber.
+ERROR-TYPE is one of \"Cancel\", \"Continue\", \"Mmodify\", \"Auth\"
+and \"Wait\" (lowercase versions make `checkdoc' to throw errors).
+CONDITION is a symbol denoting a defined XMPP condition.
+TEXT is a string to be sent in the error message, or nil for no text.
+APP-SPECIFIC is a list of extra XML tags.
+
+See section 9.3 of XMPP Core (RFC 3920).
+See section 8.3 of XMPP Core (RFC 6120)."
+ (signal 'jabber-error
+ (list (downcase error-type) condition text app-specific)))
+
+(defun jabber-unhex (string)
+ "Convert a hex-encoded UTF-8 string to Emacs representation.
+For example, \"ji%C5%99i@%C4%8Dechy.example/v%20Praze\" becomes
+\"jiři@čechy.example/v Praze\"."
+ (decode-coding-string (url-unhex-string string) 'utf-8))
+
+(defun jabber-handle-uri (uri &rest _ignored-args)
+ "Handle XMPP links according to draft-saintandre-xmpp-iri-04.
+See Info node `(jabber)XMPP URIs'.
+URI is a string with the \"xmpp://\" link to handle.
+IGNORED-ARGS are ignored arguments the handler may pass. "
+ (interactive "sEnter XMPP URI: ")
+
+ (when (string-match "//" uri)
+ (error "URIs with authority part are not supported"))
+
+ ;; This regexp handles three cases:
+ ;; xmpp:romeo@montague.net
+ ;; xmpp:romeo@montague.net?roster
+ ;; xmpp:romeo@montague.net?roster;name=Romeo%20Montague;group=Lovers
+ (unless (string-match "^xmpp:\\([^?]+\\)\\(\\?\\([a-z]+\\)\\(;\\(.*\\)\\)?\\)?" uri)
+ (error "Invalid XMPP URI '%s'" uri))
+
+ ;; We start by raising the Emacs frame.
+ (raise-frame)
+
+ (let ((jid (jabber-unhex (match-string 1 uri)))
+ (method (match-string 3 uri))
+ (args (let ((text (match-string 5 uri)))
+ ;; If there are arguments...
+ (when text
+ ;; ...split the pairs by ';'...
+ (let ((pairs (split-string text ";")))
+ (mapcar (lambda (pair)
+ ;; ...and split keys from values by '='.
+ (cl-destructuring-bind (key value)
+ (split-string pair "=")
+ ;; Values can be hex-coded.
+ (cons key (jabber-unhex value))))
+ pairs))))))
+ ;; The full list of methods is at
+ ;; .
+ (cond
+ ;; Join an MUC.
+ ((string= method "join")
+ (let ((account (jabber-read-account)))
+ (jabber-muc-join
+ account jid (jabber-muc-read-my-nickname account jid) t)))
+ ;; Register with a service.
+ ((string= method "register")
+ (jabber-get-register (jabber-read-account) jid))
+ ;; Run an ad-hoc command
+ ((string= method "command")
+ ;; XXX: does the 'action' attribute make sense?
+ (jabber-ahc-execute-command
+ (jabber-read-account) jid (cdr (assoc "node" args))))
+ ;; Everything else: open a chat buffer.
+ (t
+ (jabber-chat-with (jabber-read-account) jid)))))
+
+(defun url-xmpp (url)
+ "Handle XMPP URLs from internal Emacs functions."
+ ;; XXX: This parsing roundtrip is redundant, and the parser of the
+ ;; url package might lose information.
+ (jabber-handle-uri (url-recreate-url url)))
+
+(defun string>-numerical (s1 s2)
+ "Return t if first arg string is more than second in numerical order."
+ (cond ((string= s1 s2) nil)
+ ((> (length s1) (length s2)) t)
+ ((< (length s1) (length s2)) nil)
+ ((< (string-to-number (substring s1 0 1)) (string-to-number (substring s2 0 1))) nil)
+ ((> (string-to-number (substring s1 0 1)) (string-to-number (substring s2 0 1))) t)
+ (t (string>-numerical (substring s1 1) (substring s2 1)))))
+
+(defun jabber-append-string-to-file (string file &optional func &rest args)
+ "Append STRING (may be nil) to FILE. Create FILE if needed.
+If FUNC is non-nil, then call FUNC with ARGS at beginning of
+temporaly buffer _before_ inserting STRING."
+ (when (or (stringp string) (functionp func))
+ (with-temp-buffer
+ (when (functionp func) (apply func args))
+ (when (stringp string) (insert string))
+ (write-region (point-min) (point-max) file t (list t)))))
+
+(defun jabber-tree-map (fn tree)
+ "Apply FN to all nodes in the TREE starting with root.
+FN is applied to the node and not to the data itself."
+ (let ((result (cons nil nil)))
+ (cl-do ((tail tree (cdr tail))
+ (prev result end)
+ (end result (let* ((x (car tail))
+ (val (if (atom x)
+ (funcall fn x)
+ (jabber-tree-map fn x))))
+ (setf (car end) val (cdr end) (cons nil
+ nil)))))
+ ((atom tail)
+ (progn
+ (setf (cdr prev) (if tail (funcall fn tail) nil))
+ result)))))
diff --git a/jabber-vcard-avatars.el b/jabber-vcard-avatars.el
new file mode 100644
index 0000000..f02fd03
--- /dev/null
+++ b/jabber-vcard-avatars.el
@@ -0,0 +1,113 @@
+(defcustom jabber-vcard-avatars-retrieve (and (fboundp 'display-images-p)
+ (display-images-p))
+ "Automatically download vCard avatars?"
+ :group 'jabber-avatar
+ :type 'boolean)
+
+(defcustom jabber-vcard-avatars-publish t
+ "Publish your vCard photo as avatar?"
+ :group 'jabber-avatar
+ :type 'boolean)
+
+(defvar jabber-vcard-avatars-current-hash
+ (make-hash-table :test 'equal)
+ "For each connection, SHA1 hash of current avatar.
+Keys are full JIDs.")
+
+(add-to-list 'jabber-presence-chain 'jabber-vcard-avatars-presence)
+(defun jabber-vcard-avatars-presence (jc xml-data)
+ "Look for vCard avatar mark in stanza.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ ;; Only look at ordinary presence
+ (when (and jabber-vcard-avatars-retrieve
+ (null (jabber-xml-get-attribute xml-data 'type)))
+ (let* ((from (jabber-jid-user (jabber-xml-get-attribute xml-data 'from)))
+ (photo (jabber-xml-path xml-data '(("vcard-temp:x:update" . "x") photo)))
+ (sha1-hash (car (jabber-xml-node-children photo))))
+ (cond
+ ((null sha1-hash)
+ ;; User has removed avatar
+ (jabber-avatar-set from nil))
+ ((string= sha1-hash (get (jabber-jid-symbol from) 'avatar-hash))
+ ;; Same avatar as before; do nothing
+ )
+ ((jabber-avatar-find-cached sha1-hash)
+ ;; Avatar is cached
+ (jabber-avatar-set from sha1-hash))
+ (t
+ ;; Avatar is not cached; retrieve it
+ (jabber-vcard-avatars-fetch jc from sha1-hash))))))
+
+(defun jabber-vcard-avatars-fetch (jc who sha1-hash)
+ "Fetch WHO's vCard, and extract avatar.
+
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "Fetch whose vCard avatar: ")
+ nil))
+ (jabber-send-iq jc who "get" '(vCard ((xmlns . "vcard-temp")))
+ #'jabber-vcard-avatars-vcard (cons who sha1-hash)
+ #'ignore nil))
+
+(defun jabber-vcard-avatars-vcard (jc iq closure)
+ "Get the photo from the vCard, and set the avatar."
+ (let ((from (car closure))
+ (sha1-hash (cdr closure))
+ (photo (assq 'PHOTO (jabber-vcard-parse (jabber-iq-query iq)))))
+ (if photo
+ (let ((avatar (jabber-avatar-from-base64-string (nth 2 photo)
+ (nth 1 photo))))
+ (unless (or (null sha1-hash)
+ (string= sha1-hash (avatar-sha1-sum avatar)))
+ (when jabber-avatar-verbose
+ (message "%s's avatar should have SHA1 sum %s, but has %s"
+ (jabber-jid-displayname from)
+ sha1-hash
+ (avatar-sha1-sum avatar))))
+ (jabber-avatar-cache avatar)
+ (jabber-avatar-set from avatar))
+ (jabber-avatar-set from nil))))
+
+(defun jabber-vcard-avatars-find-current (jc)
+ "Request our own vCard, to find hash of avatar.
+
+JC is the Jabber connection."
+ (when jabber-vcard-avatars-publish
+ (jabber-send-iq jc nil "get" '(vCard ((xmlns . "vcard-temp")))
+ #'jabber-vcard-avatars-find-current-1 t
+ #'jabber-vcard-avatars-find-current-1 nil)))
+
+(defun jabber-vcard-avatars-find-current-1 (jc xml-data success)
+ (jabber-vcard-avatars-update-current
+ jc
+ (and success
+ (let ((photo (assq 'PHOTO (jabber-vcard-parse (jabber-iq-query xml-data)))))
+ (when photo
+ (let ((avatar (jabber-avatar-from-base64-string (nth 2 photo)
+ (nth 1 photo))))
+ (avatar-sha1-sum avatar)))))))
+
+(defun jabber-vcard-avatars-update-current (jc new-hash)
+ (let ((old-hash (gethash
+ (jabber-connection-bare-jid jc)
+ jabber-vcard-avatars-current-hash)))
+ (when (not (string= old-hash new-hash))
+ (puthash (jabber-connection-bare-jid jc)
+ new-hash jabber-vcard-avatars-current-hash)
+ (jabber-send-current-presence jc))))
+
+(add-to-list 'jabber-presence-element-functions 'jabber-vcard-avatars-presence-element)
+(defun jabber-vcard-avatars-presence-element (jc)
+ (when jabber-vcard-avatars-publish
+ (let ((hash (gethash
+ (jabber-connection-bare-jid jc)
+ jabber-vcard-avatars-current-hash)))
+ (list
+ `(x ((xmlns . "vcard-temp:x:update"))
+ ;; if "not yet ready to advertise image", don't.
+ ;; that is, we haven't yet checked what avatar we have.
+ ,(when hash
+ `(photo () ,hash)))))))
diff --git a/jabber-vcard.el b/jabber-vcard.el
new file mode 100644
index 0000000..1046362
--- /dev/null
+++ b/jabber-vcard.el
@@ -0,0 +1,485 @@
+(defvar jabber-vcard-photo nil
+ "The avatar structure for the photo in the vCard edit buffer.")
+(make-variable-buffer-local 'jabber-vcard-photo)
+
+(defun jabber-vcard-parse (vcard)
+ "Parse the vCard XML structure given in VCARD.
+The top node should be the `vCard' node."
+ ;; Hm... stpeter has a as top node...
+ ;;(unless (eq (jabber-xml-node-name vcard) 'vCard)
+ ;; (error "Invalid vCard"))
+ (let (result)
+ (dolist (verbatim-node '(FN NICKNAME BDAY JABBERID MAILER TZ
+ TITLE ROLE NOTE PRODID REV SORT-STRING
+ UID URL DESC))
+ ;; There should only be one of each of these. They are
+ ;; used verbatim.
+ (let ((node (car (jabber-xml-get-children vcard
+ verbatim-node))))
+ ;; Some clients include the node, but without data
+ (when (car (jabber-xml-node-children node))
+ (push (cons (jabber-xml-node-name node)
+ (car (jabber-xml-node-children node)))
+ result))))
+
+ ;; Name components
+ (let ((node (car (jabber-xml-get-children vcard 'N))))
+ ;; Subnodes are FAMILY, GIVEN, MIDDLE, PREFIX, SUFFIX
+ (push (cons 'N
+ (let (name)
+ (dolist (subnode (jabber-xml-node-children node))
+ (when (and (memq (jabber-xml-node-name subnode)
+ '(FAMILY GIVEN MIDDLE PREFIX SUFFIX))
+ (not (zerop (length
+ (car (jabber-xml-node-children
+ subnode))))))
+ (push (cons (jabber-xml-node-name subnode)
+ (car (jabber-xml-node-children
+ subnode)))
+ name)))
+ name))
+ result))
+
+ ;; There can be several addresses
+ (let (addresses)
+ (dolist (adr (jabber-xml-get-children vcard 'ADR))
+ ;; Find address type(s)
+ (let (types)
+ (dolist (possible-type '(HOME WORK POSTAL PARCEL DOM INTL PREF))
+ (when (jabber-xml-get-children adr possible-type)
+ (push possible-type types)))
+
+ (let (components)
+ (dolist (component (jabber-xml-node-children adr))
+ (when (and (memq (jabber-xml-node-name component)
+ '(POBOX EXTADD STREET LOCALITY REGION
+ PCODE CTRY))
+ (not (zerop (length
+ (car (jabber-xml-node-children
+ component))))))
+ (push (cons (jabber-xml-node-name component)
+ (car (jabber-xml-node-children component)))
+ components)))
+
+ (push (cons types components) addresses))))
+
+ (when addresses
+ (push (cons 'ADR addresses) result)))
+
+ ;; Likewise for phone numbers
+ (let (phone-numbers)
+ (dolist (tel (jabber-xml-get-children vcard 'TEL))
+ ;; Find phone type(s)
+ (let ((number (car (jabber-xml-node-children
+ (car (jabber-xml-get-children tel 'NUMBER)))))
+ types)
+ ;; Some clients put no NUMBER node. Avoid that.
+ (when number
+ (dolist (possible-type '(HOME WORK VOICE FAX PAGER MSG CELL
+ VIDEO BBS MODEM ISDN PCS PREF))
+ (when (jabber-xml-get-children tel possible-type)
+ (push possible-type types)))
+
+ (push (cons types number) phone-numbers))))
+
+ (when phone-numbers
+ (push (cons 'TEL phone-numbers) result)))
+
+ ;; And for e-mail addresses
+ (let (e-mails)
+ (dolist (email (jabber-xml-get-children vcard 'EMAIL))
+ (let ((userid (car (jabber-xml-node-children
+ (car (jabber-xml-get-children email 'USERID)))))
+ types)
+ ;; Some clients put no USERID node. Avoid that.
+ (when userid
+ (dolist (possible-type '(HOME WORK INTERNET PREF X400))
+ (when (jabber-xml-get-children email possible-type)
+ (push possible-type types)))
+ (unless (or (memq 'INTERNET types)
+ (memq 'X400 types))
+ (push 'INTERNET types))
+
+ (push (cons types userid) e-mails))))
+
+ (when e-mails
+ (push (cons 'EMAIL e-mails) result)))
+
+ ;; XEP-0153: vCard-based avatars
+ (let ((photo-tag (car (jabber-xml-get-children vcard 'PHOTO))))
+ (when photo-tag
+ (let ((type (jabber-xml-path photo-tag '(TYPE "")))
+ (binval (jabber-xml-path photo-tag '(BINVAL ""))))
+ (when (and type binval)
+ (push (list 'PHOTO type binval) result)))))
+
+ result))
+
+(defun jabber-vcard-reassemble (parsed)
+ "Create a vCard XML structure from PARSED."
+ ;; Save photo in jabber-vcard-photo, to avoid excessive processing.
+ (let ((photo (cdr (assq 'PHOTO parsed))))
+ (cond
+ ;; No photo
+ ((null photo)
+ (setq jabber-vcard-photo nil))
+ ;; Existing photo
+ ((listp photo)
+ (setq jabber-vcard-photo
+ (jabber-avatar-from-base64-string
+ (nth 1 photo) (nth 0 photo))))
+ ;; New photo from file
+ (t
+ (access-file photo "Avatar file not found")
+ ;; Maximum allowed size is 8 kilobytes
+ (when (> (nth 7 (file-attributes photo)) 8192)
+ (error "Avatar bigger than 8 kilobytes"))
+ (setq jabber-vcard-photo (jabber-avatar-from-file photo)))))
+
+ `(vCard ((xmlns . "vcard-temp"))
+ ;; Put in simple fields
+ ,@(mapcar
+ (lambda (field)
+ (when (and (assq (car field) jabber-vcard-fields)
+ (not (zerop (length (cdr field)))))
+ (list (car field) nil (cdr field))))
+ parsed)
+ ;; Put in decomposited name
+ (N nil
+ ,@(mapcar
+ (lambda (name-part)
+ (when (not (zerop (length (cdr name-part))))
+ (list (car name-part) nil (cdr name-part))))
+ (cdr (assq 'N parsed))))
+ ;; Put in addresses
+ ,@(mapcar
+ (lambda (address)
+ (append '(ADR) '(())
+ (mapcar 'list (nth 0 address))
+ (mapcar (lambda (field)
+ (list (car field) nil (cdr field)))
+ (cdr address))))
+ (cdr (assq 'ADR parsed)))
+ ;; Put in phone numbers
+ ,@(mapcar
+ (lambda (phone)
+ (append '(TEL) '(())
+ (mapcar 'list (car phone))
+ (list (list 'NUMBER nil (cdr phone)))))
+ (cdr (assq 'TEL parsed)))
+ ;; Put in e-mail addresses
+ ,@(mapcar
+ (lambda (email)
+ (append '(EMAIL) '(())
+ (mapcar 'list (car email))
+ (list (list 'USERID nil (cdr email)))))
+ (cdr (assq 'EMAIL parsed)))
+ ;; Put in photo
+ ,@(when jabber-vcard-photo
+ `((PHOTO ()
+ (TYPE () ,(avatar-mime-type jabber-vcard-photo))
+ (BINVAL () ,(avatar-base64-data jabber-vcard-photo)))))))
+
+(add-to-list 'jabber-jid-info-menu
+ (cons "Request vcard" 'jabber-vcard-get))
+
+(defun jabber-vcard-get (jc jid)
+ "Request vcard from JID.
+
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "Request vcard from: " nil nil nil 'bare-or-muc)))
+ (jabber-send-iq jc jid
+ "get"
+ '(vCard ((xmlns . "vcard-temp")))
+ #'jabber-process-data #'jabber-vcard-display
+ #'jabber-process-data "Vcard request failed"))
+
+(defun jabber-vcard-edit (jc)
+ "Edit your own vcard.
+
+JC is the Jabber connection."
+ (interactive (list (jabber-read-account)))
+ (jabber-send-iq jc nil
+ "get"
+ '(vCard ((xmlns . "vcard-temp")))
+ #'jabber-vcard-do-edit nil
+ #'jabber-report-success "Vcard request failed"))
+
+(defconst jabber-vcard-fields '((FN . "Full name")
+ (NICKNAME . "Nickname")
+ (BDAY . "Birthday")
+ (URL . "URL")
+ (JABBERID . "JID")
+ (MAILER . "User agent")
+ (TZ . "Time zone")
+ (TITLE . "Title")
+ (ROLE . "Role")
+ (REV . "Last changed")
+ (DESC . "Description")
+ (NOTE . "Note")))
+
+(defconst jabber-vcard-name-fields '((PREFIX . "Prefix")
+ (GIVEN . "Given name")
+ (MIDDLE . "Middle name")
+ (FAMILY . "Family name")
+ (SUFFIX . "Suffix")))
+
+(defconst jabber-vcard-phone-types '((HOME . "Home")
+ (WORK . "Work")
+ (VOICE . "Voice")
+ (FAX . "Fax")
+ (PAGER . "Pager")
+ (MSG . "Message")
+ (CELL . "Cell phone")
+ (VIDEO . "Video")
+ (BBS . "BBS")
+ (MODEM . "Modem")
+ (ISDN . "ISDN")
+ (PCS . "PCS")))
+
+(defconst jabber-vcard-email-types '((HOME . "Home")
+ (WORK . "Work")
+ (INTERNET . "Internet")
+ (X400 . "X400")
+ (PREF . "Preferred")))
+
+(defconst jabber-vcard-address-types '((HOME . "Home")
+ (WORK . "Work")
+ (POSTAL . "Postal")
+ (PARCEL . "Parcel")
+ (DOM . "Domestic")
+ (INTL . "International")
+ (PREF . "Preferred")))
+
+(defconst jabber-vcard-address-fields '((POBOX . "Post box")
+ (EXTADD . "Ext. address")
+ (STREET . "Street")
+ (LOCALITY . "Locality")
+ (REGION . "Region")
+ (PCODE . "Post code")
+ (CTRY . "Country")))
+
+(defun jabber-vcard-display (jc xml-data)
+ "Display received vcard.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+ (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data))))
+ (dolist (simple-field jabber-vcard-fields)
+ (let ((field (assq (car simple-field) parsed)))
+ (when field
+ (insert (cdr simple-field))
+ (indent-to 20)
+ (insert (cdr field) "\n"))))
+
+ (let ((names (cdr (assq 'N parsed))))
+ (when names
+ (insert "\n")
+ (dolist (name-field jabber-vcard-name-fields)
+ (let ((field (assq (car name-field) names)))
+ (when field
+ (insert (cdr name-field))
+ (indent-to 20)
+ (insert (cdr field) "\n"))))))
+
+ (let ((email-addresses (cdr (assq 'EMAIL parsed))))
+ (when email-addresses
+ (insert "\n")
+ (insert (jabber-propertize "E-mail addresses:\n"
+ 'face 'jabber-title-medium))
+ (dolist (email email-addresses)
+ (insert (mapconcat (lambda (type)
+ (cdr (assq type jabber-vcard-email-types)))
+ (car email)
+ " "))
+ (insert ": " (cdr email) "\n"))))
+
+ (let ((phone-numbers (cdr (assq 'TEL parsed))))
+ (when phone-numbers
+ (insert "\n")
+ (insert (jabber-propertize "Phone numbers:\n"
+ 'face 'jabber-title-medium))
+ (dolist (number phone-numbers)
+ (insert (mapconcat (lambda (type)
+ (cdr (assq type jabber-vcard-phone-types)))
+ (car number)
+ " "))
+ (insert ": " (cdr number) "\n"))))
+
+ (let ((addresses (cdr (assq 'ADR parsed))))
+ (when addresses
+ (insert "\n")
+ (insert (jabber-propertize "Addresses:\n"
+ 'face 'jabber-title-medium))
+ (dolist (address addresses)
+ (insert (jabber-propertize
+ (mapconcat (lambda (type)
+ (cdr (assq type jabber-vcard-address-types)))
+ (car address)
+ " ")
+ 'face 'jabber-title-small))
+ (insert "\n")
+ (dolist (address-field jabber-vcard-address-fields)
+ (let ((field (assq (car address-field) address)))
+ (when field
+ (insert (cdr address-field))
+ (indent-to 20)
+ (insert (cdr field) "\n")))))))
+
+ ;; XEP-0153: vCard-based avatars
+ (let ((photo-type (nth 1 (assq 'PHOTO parsed)))
+ (photo-binval (nth 2 (assq 'PHOTO parsed))))
+ (when (and photo-type photo-binval)
+ (condition-case nil
+ ;; ignore the type, let create-image figure it out.
+ (let ((image (jabber-create-image (base64-decode-string photo-binval) nil t)))
+ (insert-image image "[Photo]")
+ (insert "\n"))
+ (error (insert "Couldn't display photo\n")))))))
+
+(defun jabber-vcard-do-edit (jc xml-data closure-data)
+ (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data)))
+ start-position)
+ (with-current-buffer (get-buffer-create "Edit vcard")
+ (jabber-init-widget-buffer nil)
+
+ (setq jabber-buffer-connection jc)
+
+ (setq start-position (point))
+
+ (dolist (simple-field jabber-vcard-fields)
+ (widget-insert (cdr simple-field))
+ (indent-to 15)
+ (let ((default-value (cdr (assq (car simple-field) parsed))))
+ (push (cons (car simple-field)
+ (widget-create 'editable-field (or default-value "")))
+ jabber-widget-alist)))
+
+ (widget-insert "\n")
+ (push (cons 'N
+ (widget-create
+ '(set :tag "Decomposited name"
+ (cons :tag "Prefix" :format "%t: %v" (const :format "" PREFIX) (string :format "%v"))
+ (cons :tag "Given name" :format "%t: %v" (const :format "" GIVEN) (string :format "%v"))
+ (cons :tag "Middle name" :format "%t: %v" (const :format "" MIDDLE) (string :format "%v"))
+ (cons :tag "Family name" :format "%t: %v" (const :format "" FAMILY) (string :format "%v"))
+ (cons :tag "Suffix" :format "%t: %v" (const :format "" SUFFIX) (string :format "%v")))
+ :value (cdr (assq 'N parsed))))
+ jabber-widget-alist)
+
+ (widget-insert "\n")
+ (push (cons 'ADR
+ (widget-create
+ '(repeat :tag "Postal addresses"
+ (cons
+ :tag "Address"
+ (set :tag "Type"
+ (const :tag "Home" HOME)
+ (const :tag "Work" WORK)
+ (const :tag "Postal" POSTAL)
+ (const :tag "Parcel" PARCEL)
+ (const :tag "Domestic" DOM)
+ (const :tag "International" INTL)
+ (const :tag "Preferred" PREF))
+ (set
+ :tag "Address"
+ (cons :tag "Post box" :format "%t: %v"
+ (const :format "" POBOX) (string :format "%v"))
+ (cons :tag "Ext. address" :format "%t: %v"
+ (const :format "" EXTADD) (string :format "%v"))
+ (cons :tag "Street" :format "%t: %v"
+ (const :format "" STREET) (string :format "%v"))
+ (cons :tag "Locality" :format "%t: %v"
+ (const :format "" LOCALITY) (string :format "%v"))
+ (cons :tag "Region" :format "%t: %v"
+ (const :format "" REGION) (string :format "%v"))
+ (cons :tag "Post code" :format "%t: %v"
+ (const :format "" PCODE) (string :format "%v"))
+ (cons :tag "Country" :format "%t: %v"
+ (const :format "" CTRY) (string :format "%v")))))
+ :value (cdr (assq 'ADR parsed))))
+ jabber-widget-alist)
+
+ (widget-insert "\n")
+ (push (cons 'TEL
+ (widget-create
+ '(repeat :tag "Phone numbers"
+ (cons :tag "Number"
+ (set :tag "Type"
+ (const :tag "Home" HOME)
+ (const :tag "Work" WORK)
+ (const :tag "Voice" VOICE)
+ (const :tag "Fax" FAX)
+ (const :tag "Pager" PAGER)
+ (const :tag "Message" MSG)
+ (const :tag "Cell phone" CELL)
+ (const :tag "Video" VIDEO)
+ (const :tag "BBS" BBS)
+ (const :tag "Modem" MODEM)
+ (const :tag "ISDN" ISDN)
+ (const :tag "PCS" PCS))
+ (string :tag "Number")))
+ :value (cdr (assq 'TEL parsed))))
+ jabber-widget-alist)
+
+ (widget-insert "\n")
+ (push (cons 'EMAIL
+ (widget-create
+ '(repeat :tag "E-mail addresses"
+ (cons :tag "Address"
+ (set :tag "Type"
+ (const :tag "Home" HOME)
+ (const :tag "Work" WORK)
+ (const :tag "Internet" INTERNET)
+ (const :tag "X400" X400)
+ (const :tag "Preferred" PREF))
+ (string :tag "Address")))
+ :value (cdr (assq 'EMAIL parsed))))
+ jabber-widget-alist)
+
+ (widget-insert "\n")
+ (widget-insert "Photo/avatar:\n")
+ (let* ((photo (assq 'PHOTO parsed))
+ (avatar (when photo
+ (jabber-avatar-from-base64-string (nth 2 photo)
+ (nth 1 photo)))))
+ (push (cons
+ 'PHOTO
+ (widget-create
+ `(radio-button-choice (const :tag "None" nil)
+ ,@(when photo
+ (list
+ `(const :tag
+ ,(concat
+ "Existing: "
+ (jabber-propertize " "
+ 'display (jabber-avatar-image avatar)))
+ ,(cdr photo))))
+ (file :must-match t :tag "From file"))
+ :value (cdr photo)))
+ jabber-widget-alist))
+
+ (widget-insert "\n")
+ (widget-create 'push-button :notify #'jabber-vcard-submit "Submit")
+
+ (widget-setup)
+ (widget-minor-mode 1)
+ (switch-to-buffer (current-buffer))
+ (goto-char start-position))))
+
+(defun jabber-vcard-submit (&rest ignore)
+ (let ((to-publish (jabber-vcard-reassemble
+ (mapcar (lambda (entry)
+ (cons (car entry) (widget-value (cdr entry))))
+ jabber-widget-alist))))
+ (jabber-send-iq jabber-buffer-connection nil
+ "set"
+ to-publish
+ #'jabber-report-success "Changing vCard"
+ #'jabber-report-success "Changing vCard")
+ (when (bound-and-true-p jabber-vcard-avatars-publish)
+ (jabber-vcard-avatars-update-current
+ jabber-buffer-connection
+ (and jabber-vcard-photo (avatar-sha1-sum jabber-vcard-photo))))))
diff --git a/jabber-version.el b/jabber-version.el
new file mode 100644
index 0000000..22f28f9
--- /dev/null
+++ b/jabber-version.el
@@ -0,0 +1,65 @@
+(require 'jabber-ourversion)
+
+(defcustom jabber-version-show t
+ "Show our client version to others. Acts on loading."
+ :type 'boolean
+ :group 'jabber)
+
+(add-to-list 'jabber-jid-info-menu
+ (cons "Request software version" 'jabber-get-version))
+(defun jabber-get-version (jc to)
+ "Request software version.
+
+JC is the Jabber connection."
+ (interactive (list
+ (jabber-read-account)
+ (jabber-read-jid-completing "Request version of: " nil nil nil 'full t)))
+ (jabber-send-iq jc to
+ "get"
+ '(query ((xmlns . "jabber:iq:version")))
+ #'jabber-process-data #'jabber-process-version
+ #'jabber-process-data "Version request failed"))
+
+;; called by jabber-process-data
+(defun jabber-process-version (jc xml-data)
+ "Handle results from jabber:iq:version requests.
+
+JC is the Jabber connection.
+XML-DATA is the parsed tree data from the stream (stanzas)
+obtained from `xml-parse-region'."
+
+ (let ((query (jabber-iq-query xml-data)))
+ (dolist (x '((name . "Name:\t\t") (version . "Version:\t") (os . "OS:\t\t")))
+ (let ((data (car (jabber-xml-node-children (car (jabber-xml-get-children query (car x)))))))
+ (when data
+ (insert (cdr x) data "\n"))))))
+
+(if jabber-version-show
+ (and
+ (add-to-list 'jabber-iq-get-xmlns-alist (cons "jabber:iq:version" 'jabber-return-version))
+ (jabber-disco-advertise-feature "jabber:iq:version")))
+
+(defun jabber-return-version (jc xml-data)
+ "Return client version as defined in XEP-0092.
+Sender and ID are determined from the incoming packet passed in XML-DATA.
+
+JC is the Jabber connection."
+ ;; Things we might check: does this iq message really have type='get' and
+ ;; exactly one child, namely query with xmlns='jabber:iq:version'?
+ ;; Then again, jabber-process-iq should take care of that.
+ (let ((to (jabber-xml-get-attribute xml-data 'from))
+ (id (jabber-xml-get-attribute xml-data 'id))
+ (os (format "%s %d.%d (%s)"
+ (cond ((featurep 'xemacs) "XEmacs")
+ (t "Emacs"))
+ emacs-major-version emacs-minor-version
+ system-type)))
+ (jabber-send-iq jc to "result"
+ `(query ((xmlns . "jabber:iq:version"))
+ (name () "jabber.el")
+ (version () ,jabber-version)
+ ;; Booting... /vmemacs.el
+ ;; Shamelessly stolen from someone's sig.
+ (os () ,os))
+ nil nil nil nil
+ id)))
diff --git a/jabber-watch.el b/jabber-watch.el
new file mode 100644
index 0000000..9469121
--- /dev/null
+++ b/jabber-watch.el
@@ -0,0 +1,48 @@
+(defcustom jabber-watch-alist nil
+ "Alist of buddies for which an extra notification should be sent
+when they come online, with comment strings as values."
+ ;; XXX: change symbol to jid-symbol or something, and update
+ ;; documentation
+ :type '(alist :key-type symbol :value-type string)
+ :group 'jabber-watch)
+
+(defun jabber-presence-watch (who oldstatus newstatus
+ statustext proposed-alert)
+ "Send a message if one of your extra-important buddies comes online.
+The buddies are stored in `jabber-watch-alist' and are added and removed by
+calling `jabber-watch-add' and `jabber-watch-remove'."
+ ;; check that buddy was previously offline and now online
+ (if (and (null oldstatus)
+ (not (null newstatus)))
+ (let ((entry (assq who jabber-watch-alist)))
+ (when entry
+ ;; Give an intrusive message. With a window system,
+ ;; that's easy.
+ (if window-system
+ (message-box "%s%s" proposed-alert
+ (if (cdr entry) (format ": %s" (cdr entry)) ""))
+ ;; Without a window system, yes-or-no-p should be
+ ;; sufficient.
+ (while (not
+ (yes-or-no-p (format "%s%s Got that? " proposed-alert
+ (if (cdr entry) (format ": %s" (cdr entry)) ""))))))))))
+
+(defun jabber-watch-add (buddy &optional comment)
+ (interactive (list (jabber-read-jid-completing "Add buddy to watch list: ")
+ (read-string "Comment: ")))
+ (unless (memq 'jabber-presence-watch jabber-presence-hooks)
+ (error "The jabber-presence-watch function is not in jabber-presence-hooks"))
+ (add-to-list 'jabber-watch-alist (cons
+ (jabber-jid-symbol buddy)
+ (and (not (zerop (length comment)))
+ comment))))
+
+(defun jabber-watch-remove (buddy)
+ (interactive
+ (list (jabber-read-jid-completing "Remove buddy from watch list: "
+ (or (mapcar 'car jabber-watch-alist)
+ (error "Watch list is empty"))
+ t)))
+ (setq jabber-watch-alist
+ (delq (assq (jabber-jid-symbol buddy) jabber-watch-alist)
+ jabber-watch-alist)))
diff --git a/jabber-widget.el b/jabber-widget.el
new file mode 100644
index 0000000..d10d987
--- /dev/null
+++ b/jabber-widget.el
@@ -0,0 +1,342 @@
+(require 'widget)
+(require 'wid-edit)
+
+(defvar jabber-widget-alist nil
+ "Alist of widgets currently used.")
+
+(defvar jabber-form-type nil
+ "Type of form.
+One of:
+'x-data, jabber:x:data
+'register, as used in jabber:iq:register and jabber:iq:search.")
+
+(defvar jabber-submit-to nil
+ "JID of the entity to which form data is to be sent.")
+
+(jabber-disco-advertise-feature "jabber:x:data")
+
+(define-widget 'jid 'string
+ "JID widget."
+ :value-to-internal (lambda (widget value)
+ (let ((displayname (jabber-jid-rostername value)))
+ (if displayname
+ (format "%s <%s>" displayname value)
+ value)))
+ :value-to-external (lambda (widget value)
+ (if (string-match "<\\([^>]+\\)>[ \t]*$" value)
+ (match-string 1 value)
+ value))
+ :complete-function 'jid-complete)
+
+(defun jid-complete ()
+ "Perform completion on JID preceding point."
+ (interactive)
+ ;; mostly stolen from widget-color-complete
+ (let* ((prefix (buffer-substring-no-properties (widget-field-start widget)
+ (point)))
+ (list (append (mapcar #'symbol-name *jabber-roster*)
+ (delq nil
+ (mapcar #'(lambda (item)
+ (when (jabber-jid-rostername item)
+ (format "%s <%s>" (jabber-jid-rostername item)
+ (symbol-name item))))
+ *jabber-roster*))))
+ (completion (try-completion prefix list)))
+ (cond ((eq completion t)
+ (message "Exact match."))
+ ((null completion)
+ (error "Can't find completion for \"%s\"" prefix))
+ ((not (string-equal prefix completion))
+ (insert-and-inherit (substring completion (length prefix))))
+ (t
+ (message "Making completion list...")
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list (all-completions prefix list nil)
+ prefix))
+ (message "Making completion list...done")))))
+
+(defun jabber-init-widget-buffer (submit-to)
+ "Setup buffer-local variables for widgets."
+ (make-local-variable 'jabber-widget-alist)
+ (make-local-variable 'jabber-submit-to)
+ (setq jabber-widget-alist nil)
+ (setq jabber-submit-to submit-to)
+ (setq buffer-read-only nil)
+ ;; XXX: This is because data from other queries would otherwise be
+ ;; appended to this buffer, which would fail since widget buffers
+ ;; are read-only... or something like that. Maybe there's a
+ ;; better way.
+ (rename-uniquely))
+
+(defun jabber-render-register-form (query &optional default-username)
+ "Display widgets from element in IQ register or search namespace.
+Display widgets from element in jabber:iq:{register,search} namespace.
+DEFAULT-USERNAME is the default value for the username field."
+ (make-local-variable 'jabber-widget-alist)
+ (setq jabber-widget-alist nil)
+ (make-local-variable 'jabber-form-type)
+ (setq jabber-form-type 'register)
+
+ (if (jabber-xml-get-children query 'instructions)
+ (widget-insert "Instructions: " (car (jabber-xml-node-children (car (jabber-xml-get-children query 'instructions)))) "\n"))
+ (if (jabber-xml-get-children query 'registered)
+ (widget-insert "You are already registered. You can change your details here.\n"))
+ (widget-insert "\n")
+
+ (let ((possible-fields
+ ;; taken from XEP-0077
+ '((username . "Username")
+ (nick . "Nickname")
+ (password . "Password")
+ (name . "Full name")
+ (first . "First name")
+ (last . "Last name")
+ (email . "E-mail")
+ (address . "Address")
+ (city . "City")
+ (state . "State")
+ (zip . "Zip")
+ (phone . "Telephone")
+ (url . "Web page")
+ (date . "Birth date"))))
+ (dolist (field (jabber-xml-node-children query))
+ (let ((entry (assq (jabber-xml-node-name field) possible-fields)))
+ (when entry
+ (widget-insert (cdr entry) "\t")
+ ;; Special case: when registering a new account, the default
+ ;; username is the one specified in jabber-username. Things
+ ;; will break if the user changes that name, though...
+ (let ((default-value (or (when (eq (jabber-xml-node-name field) 'username)
+ default-username)
+ "")))
+ (setq jabber-widget-alist
+ (cons
+ (cons (car entry)
+ (widget-create 'editable-field
+ :secret (if (eq (car entry) 'password)
+ ?* nil)
+ (or (car (jabber-xml-node-children
+ field)) default-value)))
+ jabber-widget-alist)))
+ (widget-insert "\n"))))))
+
+(defun jabber-parse-register-form ()
+ "Return children of a tag containing information entered.
+Return children of a tag containing information entered in the
+widgets of the current buffer."
+ (mapcar
+ (lambda (widget-cons)
+ (list (car widget-cons)
+ nil
+ (widget-value (cdr widget-cons))))
+ jabber-widget-alist))
+
+(defun jabber-render-xdata-form (x &optional defaults)
+ "Display widgets from element in jabber:x:data namespace.
+DEFAULTS is an alist associating variable names with default values.
+DEFAULTS takes precedence over values specified in the form."
+ (make-local-variable 'jabber-widget-alist)
+ (setq jabber-widget-alist nil)
+ (make-local-variable 'jabber-form-type)
+ (setq jabber-form-type 'xdata)
+
+ (let ((title (car (jabber-xml-node-children (car (jabber-xml-get-children x 'title))))))
+ (if (stringp title)
+ (widget-insert (jabber-propertize title 'face 'jabber-title-medium) "\n\n")))
+ (let ((instructions (car (jabber-xml-node-children (car (jabber-xml-get-children x 'instructions))))))
+ (if (stringp instructions)
+ (widget-insert "Instructions: " instructions "\n\n")))
+
+ (dolist (field (jabber-xml-get-children x 'field))
+ (let* ((var (jabber-xml-get-attribute field 'var))
+ (label (jabber-xml-get-attribute field 'label))
+ (type (jabber-xml-get-attribute field 'type))
+ (required (jabber-xml-get-children field 'required))
+ (values (jabber-xml-get-children field 'value))
+ (options (jabber-xml-get-children field 'option))
+ (desc (car (jabber-xml-get-children field 'desc)))
+ (default-value (assoc var defaults)))
+ ;; "required" not implemented yet
+
+ (cond
+ ((string= type "fixed")
+ (widget-insert (car (jabber-xml-node-children (car values)))))
+
+ ((string= type "text-multi")
+ (if (or label var)
+ (widget-insert (or label var) ":\n"))
+ (push (cons (cons var type)
+ (widget-create 'text (or (cdr default-value)
+ (mapconcat #'(lambda (val)
+ (car (jabber-xml-node-children val)))
+ values "\n")
+ "")))
+ jabber-widget-alist))
+
+ ((string= type "list-single")
+ (if (or label var)
+ (widget-insert (or label var) ":\n"))
+ (push (cons (cons var type)
+ (apply 'widget-create
+ 'radio-button-choice
+ :value (or (cdr default-value)
+ (car (xml-node-children (car values))))
+ (mapcar (lambda (option)
+ `(item :tag ,(jabber-xml-get-attribute option 'label)
+ :value ,(car (jabber-xml-node-children (car (jabber-xml-get-children option 'value))))))
+ options)))
+ jabber-widget-alist))
+
+ ((string= type "boolean")
+ (push (cons (cons var type)
+ (widget-create 'checkbox
+ :tag (or label var)
+ :value (if default-value
+ (cdr default-value)
+ (not (null
+ (member (car (xml-node-children (car values))) '("1" "true")))))))
+ jabber-widget-alist)
+ (if (or label var)
+ (widget-insert " " (or label var) "\n")))
+
+ (t ; in particular including text-single and text-private
+ (if (or label var)
+ (widget-insert (or label var) ": "))
+ (setq jabber-widget-alist
+ (cons
+ (cons (cons var type)
+ (widget-create 'editable-field
+ :secret (if (string= type "text-private") ?* nil)
+ (or (cdr default-value)
+ (car (jabber-xml-node-children (car values)))
+ "")))
+ jabber-widget-alist))))
+ (when (and desc (car (jabber-xml-node-children desc)))
+ (widget-insert "\n" (car (jabber-xml-node-children desc))))
+ (widget-insert "\n"))))
+
+(defun jabber-parse-xdata-form ()
+ "Return an tag containing information entered in the widgets.
+Return an tag containing information entered in the widgets of the current
+buffer."
+ `(x ((xmlns . "jabber:x:data")
+ (type . "submit"))
+ ,@(mapcar
+ (lambda (widget-cons)
+ (let ((values (jabber-xdata-value-convert (widget-value (cdr widget-cons)) (cdar widget-cons))))
+ ;; empty fields are not included
+ (when values
+ `(field ((var . ,(caar widget-cons)))
+ ,@(mapcar
+ (lambda (value)
+ (list 'value nil value))
+ values)))))
+ jabber-widget-alist)))
+
+(defun jabber-xdata-value-convert (value type)
+ "Convert VALUE from form used by widget library to form required by XEP-0004.
+Return a list of strings, each of which to be included as cdata in a
+ tag."
+ (cond
+ ((string= type "boolean")
+ (if value (list "1") (list "0")))
+ ((string= type "text-multi")
+ (split-string value "[\n\r]"))
+ (t ; in particular including text-single, text-private and list-single
+ (if (zerop (length value))
+ nil
+ (list value)))))
+
+(defun jabber-render-xdata-search-results (xdata)
+ "Render search results in x:data form."
+
+ (let ((title (car (jabber-xml-get-children xdata 'title))))
+ (when title
+ (insert (jabber-propertize (car (jabber-xml-node-children title)) 'face 'jabber-title-medium) "\n")))
+
+ (if (jabber-xml-get-children xdata 'reported)
+ (jabber-render-xdata-search-results-multi xdata)
+ (jabber-render-xdata-search-results-single xdata)))
+
+(defun jabber-render-xdata-search-results-multi (xdata)
+ "Render multi-record search results."
+ (let (fields
+ (jid-fields 0))
+ (let ((reported (car (jabber-xml-get-children xdata 'reported)))
+ (column 0))
+ (dolist (field (jabber-xml-get-children reported 'field))
+ (let (width)
+ ;; Clever algorithm for estimating width based on field type goes here.
+ (setq width 20)
+
+ (setq fields
+ (append
+ fields
+ (list (cons (jabber-xml-get-attribute field 'var)
+ (list 'label (jabber-xml-get-attribute field 'label)
+ 'type (jabber-xml-get-attribute field 'type)
+ 'column column)))))
+ (setq column (+ column width))
+ (if (string= (jabber-xml-get-attribute field 'type) "jid-single")
+ (setq jid-fields (1+ jid-fields))))))
+
+ (dolist (field-cons fields)
+ (indent-to (plist-get (cdr field-cons) 'column) 1)
+ (insert (jabber-propertize (plist-get (cdr field-cons) 'label) 'face 'bold)))
+ (insert "\n\n")
+
+ ;; Now, the items
+ (dolist (item (jabber-xml-get-children xdata 'item))
+
+ (let ((start-of-line (point))
+ jid)
+
+ ;; The following code assumes that the order of the s in each
+ ;;