diff --git a/jabber.el b/jabber.el
index f596a85..f045c4c 100644
--- a/jabber.el
+++ b/jabber.el
@@ -32,12527 +32,10 @@
;;; Code:
-(require 'goto-addr)
+(require 'literate-elisp)
-(require 'xml)
-(eval-when-compile
- (require 'cl))
-
-(defun jabber-escape-xml (str)
- "Escape strings for XML.
-STR the string to escape."
- (if (stringp str)
- (let ((newstr (concat str)))
- ;; Form feeds might appear in code you copy, etc. Nevertheless,
- ;; it's invalid XML.
- (setq newstr (jabber-replace-in-string newstr "\f" "\n"))
- ;; Other control characters are also illegal, except for
- ;; tab, CR, and LF.
- (setq newstr (jabber-replace-in-string newstr "[\000-\010\013\014\016-\037]" " "))
- (setq newstr (jabber-replace-in-string newstr "&" "&"))
- (setq newstr (jabber-replace-in-string newstr "<" "<"))
- (setq newstr (jabber-replace-in-string newstr ">" ">"))
- (setq newstr (jabber-replace-in-string newstr "'" "'"))
- (setq newstr (jabber-replace-in-string newstr "\"" """))
- newstr)
- str))
-
-(defun jabber-unescape-xml (str)
- "Unescape xml strings.
-STR the string to remove escaped characters."
- ;; Eventually this can be done with `xml-substitute-special', but the
- ;; version in xml.el of GNU Emacs 21.3 is buggy.
- (if (stringp str)
- (let ((newstr str))
- (setq newstr (jabber-replace-in-string newstr """ "\""))
- (setq newstr (jabber-replace-in-string newstr "'" "'"))
- (setq newstr (jabber-replace-in-string newstr ">" ">"))
- (setq newstr (jabber-replace-in-string newstr "<" "<"))
- (setq newstr (jabber-replace-in-string newstr "&" "&"))
- newstr)
- str))
-
-(defun jabber-sexp2xml (sexp)
- "Return SEXP as well-formatted XML.
-SEXP should be in the form (tagname ((attribute-name . attribute-value)...) children...)"
- (cond
- ((stringp sexp)
- (jabber-escape-xml sexp))
- ((listp (car sexp))
- (let ((xml ""))
- (dolist (tag sexp)
- (setq xml (concat xml (jabber-sexp2xml tag))))
- xml))
- ;; work around bug in old versions of xml.el, where ("") can appear
- ;; as children of a node
- ((and (consp sexp)
- (stringp (car sexp))
- (zerop (length (car sexp))))
- "")
- (t
- (let ((xml ""))
- (setq xml (concat "<"
- (symbol-name (car sexp))))
- (dolist (attr (cadr sexp))
- (if (consp attr)
- (setq xml (concat xml
- (format " %s='%s'"
- (symbol-name (car attr))
- (jabber-escape-xml (cdr attr)))))))
- (if (cddr sexp)
- (progn
- (setq xml (concat xml ">"))
- (dolist (child (cddr sexp))
- (setq xml (concat xml
- (jabber-sexp2xml child))))
- (setq xml (concat xml
- ""
- (symbol-name (car sexp))
- ">")))
- (setq xml (concat xml
- "/>")))
- xml))))
-
-(defun jabber-xml-skip-tag-forward (&optional dont-recurse-into-stream)
- "Skip to end of tag or matching closing tag if present.
-Return t iff after a closing tag, otherwise throws an 'unfinished
-tag with value nil.
-If DONT-RECURSE-INTO-STREAM is non-nil, stop after an opening
- tag.
-
-The version of `sgml-skip-tag-forward' in Emacs 21 isn't good
-enough for us."
- (skip-chars-forward "^<")
- (cond
- ((looking-at "" nil t)
- (goto-char (match-end 0))
- (throw 'unfinished nil)))
- ((looking-at "<\\([^[:space:]/>]+\\)\\([[:space:]]+[^=>]+=[[:space:]]*'[^']*'\\|[[:space:]]+[^=>]+=[[:space:]]*\"[^\"]*\"\\)*")
- (let ((node-name (match-string 1)))
- (goto-char (match-end 0))
- (skip-syntax-forward "\s-") ; Skip over trailing white space.
- (cond
- ((looking-at "/>")
- (goto-char (match-end 0))
- t)
- ((looking-at ">")
- (goto-char (match-end 0))
- (unless (and dont-recurse-into-stream (equal node-name "stream:stream"))
- (loop
- do (skip-chars-forward "^<")
- until (looking-at (regexp-quote (concat "" node-name ">")))
- do (jabber-xml-skip-tag-forward))
- (goto-char (match-end 0)))
- t)
- (t
- (throw 'unfinished nil)))))
- (t
- (throw 'unfinished nil))))
-
-(defun jabber-xml-parse-next-stanza ()
- "Parse the first XML stanza in the current buffer.
-Parse and return the first complete XML element in the buffer,
-leaving point at the end of it. If there is no complete XML
-element, return nil."
- (and (catch 'unfinished
- (goto-char (point-min))
- (jabber-xml-skip-tag-forward)
- (> (point) (point-min)))
- (xml-parse-region (point-min) (point))))
-
-(defsubst jabber-xml-node-name (node)
- "Return the tag associated with NODE.
-The tag is a lower-case symbol."
- (if (listp node) (car node)))
-
-(defsubst jabber-xml-node-attributes (node)
- "Return the list of attributes of NODE.
-The list can be nil."
- (if (listp node) (nth 1 node)))
-
-(defsubst jabber-xml-node-children (node)
- "Return the list of children of NODE.
-This is a list of nodes, and it can be nil."
- (let ((children (cddr node)))
- ;; Work around a bug in early versions of xml.el
- (if (equal children '(("")))
- nil
- children)))
-
-(defun jabber-xml-get-children (node child-name)
- "Return the children of NODE whose tag is CHILD-NAME.
-CHILD-NAME should be a lower case symbol."
- (let ((match ()))
- (dolist (child (jabber-xml-node-children node))
- (if child
- (if (equal (jabber-xml-node-name child) child-name)
- (push child match))))
- (nreverse match)))
-
-(defsubst jabber-xml-get-attribute (node attribute)
- "Get from NODE the value of ATTRIBUTE.
-Return nil if the attribute was not found."
- (when (consp node)
- (xml-get-attribute-or-nil node attribute)))
-
-(defsubst jabber-xml-get-xmlns (node)
- "Get \"xmlns\" attribute of NODE, or nil if not present."
- (jabber-xml-get-attribute node 'xmlns))
-
-(defun jabber-xml-path (xml-data path)
- "Find sub-node of XML-DATA according to PATH.
-PATH is a vaguely XPath-inspired list. Each element can be:
-
-a symbol go to first child node with this node name
-cons cell car is string containing namespace URI,
- cdr is string containing node name. Find
- first matching child node.
-any string character data of this node."
- (let ((node xml-data))
- (while (and path node)
- (let ((step (car path)))
- (cond
- ((symbolp step)
- (setq node (car (jabber-xml-get-children node step))))
- ((consp step)
- ;; This will be easier with namespace-aware use
- ;; of xml.el. It will also be more correct.
- ;; Now, it only matches explicit namespace declarations.
- (setq node
- (dolist (x (jabber-xml-get-children node (intern (cdr step))))
- (when (string= (jabber-xml-get-attribute x 'xmlns)
- (car step))
- (return x)))))
- ((stringp step)
- (setq node (car (jabber-xml-node-children node)))
- (unless (stringp node)
- (setq node nil)))
- (t
- (error "Unknown path step: %s" step))))
- (setq path (cdr path)))
- node))
-
-(defmacro jabber-xml-let-attributes (attributes xml-data &rest body)
- "Bind variables to the same-name attribute values in XML-DATA.
-ATTRIBUTES is a list of attribute names."
- `(let ,(mapcar #'(lambda (attr)
- (list attr `(jabber-xml-get-attribute ,xml-data ',attr)))
- attributes)
- ,@body))
-(put 'jabber-xml-let-attributes 'lisp-indent-function 2)
-
-(defun jabber-xml-resolve-namespace-prefixes (xml-data &optional default-ns prefixes)
- (let ((node-name (jabber-xml-node-name xml-data))
- (attrs (jabber-xml-node-attributes xml-data)))
- (setq prefixes (jabber-xml-merge-namespace-declarations attrs prefixes))
-
- ;; If there is an xmlns attribute, it is the new default
- ;; namespace.
- (let ((xmlns (jabber-xml-get-xmlns xml-data)))
- (when xmlns
- (setq default-ns xmlns)))
- ;; Now, if the node name has a prefix, replace it and add an
- ;; "xmlns" attribute. Slightly ugly, but avoids the need to
- ;; change all the rest of jabber.el at once.
- (let ((node-name-string (symbol-name node-name)))
- (when (string-match "\\(.*\\):\\(.*\\)" node-name-string)
- (let* ((prefix (match-string 1 node-name-string))
- (unprefixed (match-string 2 node-name-string))
- (ns (assoc prefix prefixes)))
- (if (null ns)
- ;; This is not supposed to happen...
- (message "jabber-xml-resolve-namespace-prefixes: Unknown prefix in %s" node-name-string)
- (setf (car xml-data) (intern unprefixed))
- (setf (cadr xml-data) (cons (cons 'xmlns (cdr ns)) (delq 'xmlns attrs)))))))
- ;; And iterate through all child elements.
- (mapc (lambda (x)
- (when (listp x)
- (jabber-xml-resolve-namespace-prefixes x default-ns prefixes)))
- (jabber-xml-node-children xml-data))
- xml-data))
-
-(defun jabber-xml-merge-namespace-declarations (attrs prefixes)
- ;; First find any xmlns:foo attributes..
- (dolist (attr attrs)
- (let ((attr-name (symbol-name (car attr))))
- (when (string-match "xmlns:" attr-name)
- (let ((prefix (substring attr-name (match-end 0)))
- (ns-uri (cdr attr)))
- ;; A slightly complicated dance to never change the
- ;; original value of prefixes (since the caller depends on
- ;; it), but also to avoid excessive copying (which remove
- ;; always does). Might need to profile and tweak this for
- ;; performance.
- (setq prefixes
- (cons (cons prefix ns-uri)
- (if (assoc prefix prefixes)
- (remove (assoc prefix prefixes) prefixes)
- prefixes)))))))
- prefixes)
-
-(require 'cl)
-(require 'password-cache)
-(condition-case nil
- (require 'auth-source)
- (error nil))
-
-(defvar jabber-jid-history nil
- "History of entered JIDs.")
-
-(defsubst jabber-replace-in-string (str regexp newtext)
- (replace-regexp-in-string regexp newtext str t t))
-
-(defalias 'jabber-propertize 'propertize)
-
-(unless (fboundp 'bound-and-true-p)
- (defmacro bound-and-true-p (var)
- "Return the value of symbol VAR if it is bound, else nil."
- `(and (boundp (quote ,var)) ,var)))
-
-(defsubst jabber-read-with-input-method (prompt &optional initial-contents history default-value)
- (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)
-
-(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))
- (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 (string)
- "Return the name of the user from STRING as in roster, else nil."
- (let ((user (jabber-jid-symbol string)))
- (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))))
-
-(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 (loop for conference in (first (loop for value being the hash-values of jabber-bookmarks
- collect value))
- do (let ((ls (cadr conference)))
- (if (string= (cdr (assoc 'jid ls)) string)
- (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)))
-
-(defun jabber-jid-symbol (jid)
- "Return the symbol for the given JID.
-JID must be a string."
- ;; If it's already a symbol, just return it.
- (if (symbolp jid)
- jid
- ;; XXX: "downcase" is poor man's nodeprep. See XMPP CORE.
- (intern (downcase (jabber-jid-user jid)) jabber-jid-obarray)))
-
-(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))))
-
-(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
- (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)))
-
-(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
- (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))
- (return (jabber-xml-node-name node)))))
-
-(defun jabber-parse-stream-error (error-xml)
- "Parse the given tag and return a sting fit for human consumption."
- (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'."
- (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 '='.
- (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)))
- (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)))))
-
-(eval-when-compile (require 'cl))
-
-;;;###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.")
-
-;;;###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)))
-
-(eval-when-compile (require 'cl))
-
-;; 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...
- (lexical-let ((targets (jabber-srv-targets server network-server port))
- errors
- (fsm fsm))
- ;; ...and connect to them one after another, asynchronously, until
- ;; connection succeeds.
- (labels
- ((connect
- (target remaining-targets)
- (lexical-let ((target target) (remaining-targets remaining-targets))
- (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
- (lexical-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.
- (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."
- (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))
-
-(require 'cl)
-
-;;; 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 (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 (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."
- (lexical-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 (first sasl-data))
- (step (second sasl-data))
- (passphrase (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)))
-
-;; button.el was introduced in Emacs 22
-(condition-case e
- (require 'button)
- (error nil))
-
-(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)
-
-(require 'ewoc)
-(require 'sgml-mode) ;we base on this mode to hightlight XML
-(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)))))))
-
-(require 'cl)
-
-(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)
-
-(defvar jabber-process-buffer " *-jabber-process-*"
- "The name of the process buffer.")
-
-(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
- (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.
- (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)
- (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)
- (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)
- (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
- (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)
- (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)
- (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)
- (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)))))
-
-(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))
-
-(defvar jabber-pending-presence-timeout 0.5
- "Wait this long before doing presence packet batch processing.")
-
-(define-state jabber-connection :session-established
- (fsm state-data event callback)
- (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)
- (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 "")
- (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)))
-
-(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)))
-
-(require 'format-spec)
-(require 'cl) ;for `find'
-(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 (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 (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))))
- (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
- (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."
- (dolist (fn jabber-roster-sort-functions)
- (let ((comparison (funcall fn a b)))
- (cond
- ((< comparison 0)
- (return t))
- ((> comparison 0)
- (return nil))))))
-
-(defun jabber-roster-sort-by-status (a b)
- "Sort roster items by online status.
-See `jabber-sort-order' for order used."
- (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."
- (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."
- (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 the roster display 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
- (lexical-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 (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
- (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)
-
-(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"))))
-
-(require 'cl)
-
-(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 (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.
- (set-difference groups jid-groups :test #'string=))
- (push (jabber-roster-sexp-to-xml
- (list jid (or name jid-name) nil (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"))))
- (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."
- (assert (eq (jabber-xml-node-name xml-data) 'iq))
- (let ((query (car (jabber-xml-get-children xml-data 'query))))
- (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)))
-
-(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))))
-
-(require 'cl)
-
-(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)))
- (pushnew (quote ,msg) (get 'jabber-alert-message-hooks 'custom-options))
- (defun ,muc (nick group buffer text title)
- ,docstring
- (when title
- (funcall ,function text title)))
- (pushnew (quote ,muc) (get 'jabber-alert-muc-hooks 'custom-options))
- (defun ,pres (who oldstatus newstatus statustext title)
- ,docstring
- (when title
- (funcall ,function statustext title)))
- (pushnew (quote ,pres) (get 'jabber-alert-presence-hooks 'custom-options))
- (defun ,info (infotype buffer text)
- ,docstring
- (when text
- (funcall ,function text)))
- (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)
- (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)
- (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)))
- (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)
- (return (cdr entry))))))
- (if message
- (jabber-chat-send jabber-buffer-connection message)))
- ))
-(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)
- (return (cdr entry))))))
- (if message
- (jabber-chat-send jabber-buffer-connection message)))
- ))
-(pushnew 'jabber-autoanswer-answer-muc (get 'jabber-alert-muc-hooks 'custom-options))
-
-(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."))
-
-(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 (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))))))
-
-;;;###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")))
-
-(require 'ewoc)
-(eval-when-compile (require 'cl))
-
-(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 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. HOW-MANY 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)))
- (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
- (case (car data)
- ((:local :foreign)
- (run-hook-with-args 'jabber-chat-printers (cadr data) (car data) :insert))
- ((:muc-local :muc-foreign)
- (let ((printers (append jabber-muc-printers jabber-chat-printers)))
- (run-hook-with-args 'printers (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")
- (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))))
- (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)))
- (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 (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"))))
-
-(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)
- (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)
- (remove-duplicates
- (mapcar
- (lambda (g) (if (string= g group)
- new-group
- g))
- (get jid 'groups))
- :test 'string=)))))
-
-;;;###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))))
-
- (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.
- (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)
- (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)
- (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 (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"))
-
-(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)))
-
-;;;###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 " "))))
-
-(require 'cl)
-
-(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 (set-difference vars their-vars :test 'string=))
- (theirs-but-not-mine (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 (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)))
-
-(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 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 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
- ;; is the same as in the tag.
- (dolist (field (jabber-xml-get-children item 'field))
- (let ((field-plist (cdr (assoc (jabber-xml-get-attribute field 'var) fields)))
- (value (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value))))))
-
- (indent-to (plist-get field-plist 'column) 1)
-
- ;; Absent values are sometimes "", sometimes nil. insert
- ;; doesn't like nil.
- (when value
- ;; If there is only one JID field, let the whole row
- ;; have the jabber-jid property. If there are many JID
- ;; fields, the string belonging to each field has that
- ;; property.
- (if (string= (plist-get field-plist 'type) "jid-single")
- (if (not (eq jid-fields 1))
- (insert (jabber-propertize value 'jabber-jid value))
- (setq jid value)
- (insert value))
- (insert value)))))
-
- (if jid
- (put-text-property start-of-line (point)
- 'jabber-jid jid))
- (insert "\n")))))
-
-(defun jabber-render-xdata-search-results-single (xdata)
- "Render single-record search results."
- (dolist (field (jabber-xml-get-children xdata 'field))
- (let ((label (jabber-xml-get-attribute field 'label))
- (type (jabber-xml-get-attribute field 'type))
- (values (mapcar #'(lambda (val)
- (car (jabber-xml-node-children val)))
- (jabber-xml-get-children field 'value))))
- ;; XXX: consider type
- (insert (jabber-propertize (concat label ": ") 'face 'bold))
- (indent-to 30)
- (insert (apply #'concat values) "\n"))))
-
-(defun jabber-xdata-formtype (x)
- "Return the form type of the xdata form in X, by XEP-0068.
-Return nil if no form type is specified."
- (catch 'found-formtype
- (dolist (field (jabber-xml-get-children x 'field))
- (when (and (string= (jabber-xml-get-attribute field 'var) "FORM_TYPE")
- (string= (jabber-xml-get-attribute field 'type) "hidden"))
- (throw 'found-formtype (car (jabber-xml-node-children
- (car (jabber-xml-get-children field 'value)))))))))
-
-(require 'cl)
-
-(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
- (lexical-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))
- (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))
- (lexical-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)
- (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)
- (case (car entry)
- (url
- (destructuring-bind (symbol url name) entry
- `(url ((url . ,url)
- (name . ,name)))))
- (conference
- (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
- (remove-if-not
- (lambda (entry)
- (eq (car entry) 'conference))
- value))))
- (dolist (default-nickname jabber-muc-default-nicknames)
- (destructuring-bind (muc-jid . nick) default-nickname
- (let ((entry (assoc muc-jid conferences)))
- (if entry
- (setf (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 (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)))
-
-;;;###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))
-(eval-when-compile (require 'cl)) ;for ignore-errors
-;; 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 ((load-path (cons (expand-file-name
- "jabber-fallback-lib"
- (file-name-directory (locate-library "jabber")))
- 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))))))
-
-;; we need jabber-bookmarks for jabber-muc-autojoin (via
-;; jabber-get-bookmarks and jabber-parse-conference-bookmark):
-
-(require 'cl)
-
-;;;###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*
- (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)
- (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
- (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))))))))
- (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 (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)
- (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 (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))))))))))))
-
-(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 'cl)
-(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."
- (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."
- (let ((times (cdr (assoc group *jabber-muc-participant-last-speaking*))))
- (flet ((fetch-time (nick) (or (assoc nick times) (cons nick 0)))
- (cmp (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
- (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)
-
-(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")))
-
-(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"))))))
-
-(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))))))
-
-(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)))
-
-(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"))
-
-(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."))))))
-
-(eval-when-compile (require 'cl))
-
-(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)
- (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))))
-
-(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)))
-
-(require 'cl)
-
-(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)))
- (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))))))
- (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)
- (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 (delete-if-not jabber-activity-show-p
- jabber-activity-jids))
- (setq jabber-activity-personal-jids
- (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))
-
-(require 'cl)
-
-(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 (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
- (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)
- (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)))))))))
-
-(require 'cl)
-
-(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
- (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.
- (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")
-
-(require 'mailcap)
-(eval-when-compile (require 'cl))
-
-(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)
-
-(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))
-
-(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))))))
-
-(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)))))))
-
-(eval-when-compile (require 'cl))
-(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)))))
-
-(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)))
-
-(require 'cl)
-
-(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))
-
-(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"))
-
-(eval-when-compile (require 'cl))
-;;;###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)))
- (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))
-
-;;; load Unicode tables if this needed
-(when (and (featurep 'xemacs) (not (emacs-version>= 21 5 5)))
- (require 'un-define))
-;;; these customize fields should come first
-(defgroup jabber nil "Jabber instant messaging"
- :group 'applications)
-;;;###autoload
-(defcustom jabber-account-list nil
- "List of Jabber accounts.
-Each element of the list is a cons cell describing a Jabber account,
-where the car is a JID and the CDR is an alist.
-
-JID is a full Jabber ID string (e.g. foo@bar.tld). You can also
-specify the resource (e.g. foo@bar.tld/emacs).
-The following keys can be present in the alist:
-
- :password is a string to authenticate ourself against the server.
- It can be empty. If you don't want to store your password in your
- Emacs configuration, try auth-source (info node `(auth)Top').
-
- :network-server is a string identifying the address to connect to,
- if it's different from the server part of the JID.
-
- :port is the port to use (default depends on connection type).
-
- :connection-type is a symbol. Valid symbols are `starttls',
- `network' and `ssl'.
-
-Only JID is mandatory. The rest can be guessed at run-time.
-
-Examples:
-
-Two accounts without any special configuration:
-\((\"foo@example.com\") (\"bar@example.net\"))
-
-One disabled account with a non-standard port:
-\((\"romeo@montague.net\" (:port . 5242) (:disabled . t)))
-
-If you don't have SRV and STARTTLS capabilities in your Emacs,
-configure a Google Talk account like this:
-\((\"username@gmail.com\"
- (:network-server . \"talk.google.com\")
- (:connection-type . ssl)))"
- :type '(repeat
- (cons :tag "Account information"
- (string :tag "JID")
- (set :format "%v"
- (cons :format "%v"
- (const :format "" :disabled)
- (const :tag "Disabled" t))
- (cons :format "%v"
- (const :format "" :password)
- (string :tag "Password"))
- (cons :format "%v"
- (const :format "" :network-server)
- (string :tag "Network server"))
- (cons :format "%v"
- (const :format "" :port)
- (integer :tag "Port" 5222))
- (cons :format "%v"
- (const :format "" :connection-type)
- (choice :tag "Connection type"
- ;; XXX: detect whether we have STARTTLS? option
- ;; for enforcing encryption?
- (const :tag "STARTTLS" starttls)
- (const :tag "Unencrypted" network)
- (const :tag "Legacy SSL/TLS" ssl))))))
- :group 'jabber)
-
-(defcustom jabber-default-show ""
- "Default show state."
- :type '(choice (const :tag "Online" "")
- (const :tag "Chatty" "chat")
- (const :tag "Away" "away")
- (const :tag "Extended away" "xa")
- (const :tag "Do not disturb" "dnd"))
- :group 'jabber)
-
-(defcustom jabber-default-status ""
- "Default status string."
- :type 'string
- :group 'jabber)
-
-(defcustom jabber-default-priority 10
- "Default priority."
- :type 'integer
- :group 'jabber)
-
-;;;###autoload
-(defvar *jabber-current-status* nil
- "The users current presence status.")
-
-;;;###autoload
-(defvar *jabber-current-show* nil
- "The users current presence show.")
-
-;;;###autoload
-(defvar *jabber-current-priority* nil
- "The user's current priority.")
-
-(defvar *jabber-status-history* nil
- "History of status messages.")
-
-(defgroup jabber-faces nil "Faces for displaying jabber instant messaging."
- :group 'jabber)
-
-(defface jabber-title-small
- '((t (:weight bold :width semi-expanded :height 1.0 :inherit variable-pitch)))
- "Face for small titles."
- :group 'jabber-faces)
-
-(defface jabber-title-medium
- '((t (:weight bold :width expanded :height 2.0 :inherit variable-pitch)))
- "Face for medium titles."
- :group 'jabber-faces)
-
-(defface jabber-title-large
- '((t (:weight bold :width ultra-expanded :height 3.0 :inherit variable-pitch)))
- "Face for large titles."
- :group 'jabber-faces)
-
-(defgroup jabber-debug nil "debugging options"
- :group 'jabber)
-
-(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-debug-keep-process-buffers nil
- "If nil, kill process buffers when the process dies.
-Contents of process buffers might be useful for debugging."
- :type 'boolean
- :group 'jabber-debug)
-
-(defcustom jabber-silent-mode nil
- "If non-nil, do not ask for confirmation for some operations. DANGEROUS!"
- :type 'boolean
- :group 'jabber)
-
-;;;###autoload
-(defconst jabber-presence-faces
- '(("" . jabber-roster-user-online)
- ("away" . jabber-roster-user-away)
- ("xa" . jabber-roster-user-xa)
- ("dnd" . jabber-roster-user-dnd)
- ("chat" . jabber-roster-user-chatty)
- ("error" . jabber-roster-user-error)
- (nil . jabber-roster-user-offline))
- "Mapping from presence types to faces.")
-
-(defconst jabber-presence-strings
- `(("" . ,(jabber-propertize "Online" 'face 'jabber-roster-user-online))
- ("away" . ,(jabber-propertize "Away" 'face 'jabber-roster-user-away))
- ("xa" . ,(jabber-propertize "Extended Away" 'face 'jabber-roster-user-xa))
- ("dnd" . ,(jabber-propertize "Do not Disturb" 'face 'jabber-roster-user-dnd))
- ("chat" . ,(jabber-propertize "Chatty" 'face 'jabber-roster-user-chatty))
- ("error" . ,(jabber-propertize "Error" 'face 'jabber-roster-user-error))
- (nil . ,(jabber-propertize "Offline" 'face 'jabber-roster-user-offline)))
- "Mapping from presence types to readable, colorized strings.")
-
-;;;###autoload
-(defun jabber-customize ()
- "Customize jabber options."
- (interactive)
- (customize-group 'jabber))
-
-;;;###autoload
-(defun jabber-info ()
- "Open jabber.el manual."
- (interactive)
- (info "jabber"))
+(literate-elisp-load (format "%sjabber.org" (file-name-directory load-file-name)))
(provide 'jabber)
;;; jabber.el ends here
-
diff --git a/jabber.org b/jabber.org
index 1120a49..2016e40 100644
--- a/jabber.org
+++ b/jabber.org
@@ -44,7 +44,7 @@ Note that only the connection from you to the server is encrypted; there is no g
*** Installation
jabber.el can be installed using the commands:
-#+BEGIN_SRC
+#+BEGIN_SRC shell
./configure
make
make install
@@ -149,11 +149,13 @@ It is possible to make various web browsers pass links starting with "xmpp:" to
3. [ ] hexrgb.el is not available on MELPA
** About this file
-jabber.el is an Org literate program.
+jabber.el is an Org literate program. We use =literate-elisp= to directly load/compile this Org file. The former is exactly what the file =jabber.el= does - this approach is also compatible with =use-package= and others. The advantages -
+1. links to the source (e.g. =describe-*= buffers, byte-compilation messages) take the user directly to the Org file rather than to the tangled source
+2. no waiting for =org-babel-tangle= (which takes ages)
+3. no need to track tangled files files in VCS, nor ensure they are kept in sync with the Org file
+4. no VCS hooks/CI required to automatically tangle the file
-=org-babel-tangle= takes ages, so we use a little sed one-liner (in the file-local variables) to do the tangling, which is nearly instant. The sed script emits anything between lines matching the exact strings "#+BEGIN_SRC emacs-lisp" and "#+END_SRC".
-
-The sed script has the advantage that one can break a source block to insert Org commentary even within a =defun=, if desired - see =jabber-caps-ver-string= for a situation where such commentary may be desired. However, doing this may cause other tooling working on the s-expression level to break - =literate-elisp= definitely does.
+Note that some tools, like =checkdoc=, still require a tangled file as of the time of this writing.
If a source block does not have syntax highlighting, press =M-o M-o= (=font-lock-fontify-block=) in it.
@@ -210,9 +212,13 @@ If a source block does not have syntax highlighting, press =M-o M-o= (=font-lock
#+END_SRC
** Code
+*** custom variables
+#+BEGIN_SRC emacs-lisp
+(defvar jabber-enable-legacy-features-p nil)
+#+END_SRC
*** XML functions
:PROPERTIES:
-:file: jabber-xml.el
+:old-file: jabber-xml.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -522,7 +528,7 @@ ATTRIBUTES is a list of attribute names."
#+END_SRC
*** various utility functions
:PROPERTIES:
-:file: jabber-util.el
+:old-file: jabber-util.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -1429,7 +1435,7 @@ FN is applied to the node and not to the data itself."
#+END_SRC
*** menu
:PROPERTIES:
-:file: jabber-menu.el
+:old-file: jabber-menu.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -1664,7 +1670,7 @@ This used to be: =(define-key-after global-map [menu-bar jabber-menu] ...)= but
#+END_SRC
*** Network transport functions
:PROPERTIES:
-:file: jabber-conn.el
+:old-file: jabber-conn.el
:END:
A collection of functions, that hide the details of transmitting to and fro a Jabber Server. Mostly inspired by Gnus.
@@ -2114,7 +2120,7 @@ Use `*jabber-virtual-server-function*' as send function."
#+END_SRC
*** SASL authentication
:PROPERTIES:
-:file: jabber-sasl.el
+:old-file: jabber-sasl.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -2271,7 +2277,7 @@ obtained from `xml-parse-region'."
#+END_SRC
*** common keymap for many modes
:PROPERTIES:
-:file: jabber-keymap.el
+:old-file: jabber-keymap.el
:END:
#+BEGIN_SRC emacs-lisp
;; button.el was introduced in Emacs 22
@@ -2323,8 +2329,9 @@ obtained from `xml-parse-region'."
#+END_SRC
*** XML Console mode
:PROPERTIES:
-:file: jabber-console.el
+:old-file: jabber-console.el
:END:
+
#+BEGIN_SRC emacs-lisp
(require 'ewoc)
(require 'sgml-mode) ;we base on this mode to hightlight XML
@@ -2489,7 +2496,7 @@ what kind of chat buffer is being created.")
#+END_SRC
*** core
:PROPERTIES:
-:file: jabber-core.el
+:old-file: jabber-core.el
:END:
Standards (probably) involved -
@@ -3647,7 +3654,7 @@ Return an fsm result list if it is."
#+END_SRC
*** logon
:PROPERTIES:
-:file: jabber-logon.el
+:old-file: jabber-logon.el
:END:
In Emacs 24, sha1 is built in, so this =require= is only needed for earlier versions. It's supposed to be a noop in Emacs 24, but sometimes, for some people, it isn't, and fails with =(file-error "Cannot open load file" "sha1")=.
@@ -3726,7 +3733,7 @@ obtained from `xml-parse-region'."
#+END_SRC
*** Displaying the roster
:PROPERTIES:
-:file: jabber-roster.el
+:old-file: jabber-roster.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -4768,7 +4775,7 @@ obtained from `xml-parse-region'."
#+END_SRC
*** export Jabber roster to file
:PROPERTIES:
-:file: jabber-export.el
+:old-file: jabber-export.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -5039,7 +5046,7 @@ See `jabber-roster-to-sexp' for description of output format."
*** infoquery (IQ) functions
:PROPERTIES:
-:file: jabber-iq.el
+:old-file: jabber-iq.el
:END:
**** *jabber-open-info-queries* :variable:
@@ -5286,7 +5293,7 @@ obtained from `xml-parse-region'."
#+END_SRC
*** Alert hooks
:PROPERTIES:
-:file: jabber-alert.el
+:old-file: jabber-alert.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -5941,7 +5948,7 @@ of `jabber-autoanswer-alist'."
#+END_SRC
*** FIXME Recording message history
:PROPERTIES:
-:file: jabber-history.el
+:old-file: jabber-history.el
:END:
1. [ ] when rotation is enabled, =jabber-history-query= won't look for older history files if the current history file doesn't contain enough backlog entries.
@@ -6318,7 +6325,7 @@ applies, though."
#+END_SRC
*** Functions common to all chat buffers
:PROPERTIES:
-:file: jabber-chatbuffer.el
+:old-file: jabber-chatbuffer.el
:END:
**** jabber-point-insert :variable:
@@ -6472,7 +6479,7 @@ JC is the Jabber connection."
#+END_SRC
*** Compose a Jabber message in a buffer
:PROPERTIES:
-:file: jabber-compose.el
+:old-file: jabber-compose.el
:END:
**** jabber-compose :command:
#+BEGIN_SRC emacs-lisp
@@ -6541,7 +6548,7 @@ JC is the Jabber connection."
*** One-to-one chats
:PROPERTIES:
-:file: jabber-chat.el
+:old-file: jabber-chat.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -7382,7 +7389,7 @@ With a prefix argument, open buffer in other window."
#+END_SRC
*** Roster and presence bookkeeping
:PROPERTIES:
-:file: jabber-presence.el
+:old-file: jabber-presence.el
:END:
**** jabber-presence-element-functions :variable:
@@ -8020,7 +8027,7 @@ JC is the Jabber connection."
#+END_SRC
*** Entity Capabilities ([[https://xmpp.org/extensions/xep-0115.html][XEP-0115]])
:PROPERTIES:
-:file: jabber-disco.el
+:old-file: jabber-disco.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -8376,7 +8383,7 @@ the right node."
#+END_SRC
*** Service Discovery ([[https://xmpp.org/extensions/xep-0030.html][XEP-0030]])
:PROPERTIES:
-:file: jabber-disco.el
+:old-file: jabber-disco.el
:END:
**** Respond to disco requests
***** jabber-advertised-features :variable:
@@ -8786,7 +8793,7 @@ JC is the Jabber connection."
*** XMPP Ping ([[https://xmpp.org/extensions/xep-0199.html][XEP-0199]])
:PROPERTIES:
-:file: jabber-ping.el
+:old-file: jabber-ping.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -8849,7 +8856,7 @@ obtained from `xml-parse-region'."
*** keepalive - try to detect a lost connection
:PROPERTIES:
-:file: jabber-keepalive.el
+:old-file: jabber-keepalive.el
:END:
Send something to the server and see if it answers.
@@ -9049,7 +9056,7 @@ accounts."
*** Feature Negotiation ([[https://xmpp.org/extensions/xep-0020.html][XEP-0020]]) :xep_deprecated:
:PROPERTIES:
-:file: jabber-feature-neg.el
+:old-file: jabber-feature-neg.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -9168,7 +9175,7 @@ protocols."
#+END_SRC
*** widget - display various kinds of forms
:PROPERTIES:
-:file: jabber-widget.el
+:old-file: jabber-widget.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -9561,7 +9568,7 @@ Return nil if no form type is specified."
#+END_SRC
*** Bookmarks ([[https://xmpp.org/extensions/xep-0048.html][XEP-0048]]) :xep_deprecated:
:PROPERTIES:
-:file: jabber-bookmarks.el
+:old-file: jabber-bookmarks.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -9829,7 +9836,7 @@ JC is the Jabber connection."
#+END_SRC
*** Private XML Storage ([[https://xmpp.org/extensions/xep-0049.html][XEP-0049]])
:PROPERTIES:
-:file: jabber-private.el
+:old-file: jabber-private.el
:END:
**** jabber-private-get :function:
@@ -9879,7 +9886,7 @@ JC is the Jabber connection."
#+END_SRC
*** muc-nick-coloring
:PROPERTIES:
-:file: jabber-muc-nick-coloring.el
+:old-file: jabber-muc-nick-coloring.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -9964,7 +9971,7 @@ added in #RGB notation for unknown nicks."
#+END_SRC
*** Multi-User Chat (MUC) ([[https://xmpp.org/extensions/xep-0045.html][XEP-0045]])
:PROPERTIES:
-:file: jabber-muc.el
+:old-file: jabber-muc.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -11418,7 +11425,7 @@ JC is the Jabber connection."
#+END_SRC
*** muc-nick-completion
:PROPERTIES:
-:file: jabber-muc-nick-completion.el
+:old-file: jabber-muc-nick-completion.el
:END:
**** jabber-muc-completion-delimiter :custom:variable:
@@ -11629,7 +11636,7 @@ OLD is last tried nickname."
#+END_SRC
*** In-Band Registration ([[https://xmpp.org/extensions/xep-0077.html][XEP-0077]])
:PROPERTIES:
-:file: jabber-register.el
+:old-file: jabber-register.el
:END:
**** jabber-get-register :command:
@@ -11776,7 +11783,7 @@ obtained from `xml-parse-region'."
#+END_SRC
*** Jabber Search ([[https://xmpp.org/extensions/xep-0055.html][XEP-0055]])
:PROPERTIES:
-:file: jabber-search.el
+:old-file: jabber-search.el
:END:
**** jabber-get-search :command:
@@ -11882,7 +11889,7 @@ obtained from `xml-parse-region'."
#+END_SRC
*** Jabber Browsing ([[https://xmpp.org/extensions/xep-0011.html][XEP-0011]]) :xep_obsolete:
:PROPERTIES:
-:file: jabber-browse.el
+:old-file: jabber-browse.el
:END:
jabber.el can perform browse requests, but will not answer them.
@@ -11970,7 +11977,7 @@ obtained from `xml-parse-region'."
#+END_SRC
*** Software Version ([[https://xmpp.org/extensions/xep-0092.html][XEP-0092]])
:PROPERTIES:
-:file: jabber-version.el
+:old-file: jabber-version.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -12058,7 +12065,7 @@ JC is the Jabber connection."
#+END_SRC
*** Ad Hoc Commands ([[https://xmpp.org/extensions/xep-0050.html][XEP-0050]])
:PROPERTIES:
-:file: jabber-ahc.el
+:old-file: jabber-ahc.el
:END:
**** jabber-ahc-sessionid :variable:
@@ -12310,7 +12317,7 @@ JC is the Jabber connection."
#+END_SRC
*** ahc-presence - provide remote control of presence
:PROPERTIES:
-:file: jabber-ahc-presence.el
+:old-file: jabber-ahc-presence.el
:END:
**** jabber-ahc-presence-node :constant:
@@ -12409,7 +12416,7 @@ obtained from `xml-parse-region'."
#+END_SRC
*** Mode line
:PROPERTIES:
-:file: jabber-modeline.el
+:old-file: jabber-modeline.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -12518,11 +12525,11 @@ and offline contacts, respectively."
#+END_SRC
*** watch - get notified when certain persons go online
:PROPERTIES:
-:file: jabber-watch.el
+:old-file: jabber-watch.el
:END:
**** jabber-watch-alist :custom:variable:
-#+BEGIN_QUOTE
+#+BEGIN_SRC emacs-lisp
(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."
@@ -12584,7 +12591,7 @@ calling `jabber-watch-add' and `jabber-watch-remove'."
#+END_SRC
*** activity - show Jabber activity in the mode line
:PROPERTIES:
-:file: jabber-activity.el
+:old-file: jabber-activity.el
:END:
Allows tracking messages from buddies using the global mode line. See =(info "(jabber)Tracking activity")=
@@ -13103,7 +13110,7 @@ With a numeric arg, enable this display if arg is positive."
#+END_SRC
*** Message Events ([[https://xmpp.org/extensions/xep-0022.html][XEP-0022]]) :xep_obsolete:
:PROPERTIES:
-:file: jabber-events.el
+:old-file: jabber-events.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -13388,7 +13395,7 @@ Add function last in chain, so a chat buffer is already created.
#+END_SRC
*** Chat State Notifications ([[https://xmpp.org/extensions/xep-0085.html][XEP-0085]])
:PROPERTIES:
-:file: jabber-chatstates.el
+:old-file: jabber-chatstates.el
:END:
**** TODO
@@ -13594,7 +13601,7 @@ It can be sent and cancelled several times.")
#+END_SRC
*** Generic functions for avatars
:PROPERTIES:
-:file: jabber-avatar.el
+:old-file: jabber-avatar.el
:END:
There are several methods for transporting avatars in Jabber ([[https://xmpp.org/extensions/xep-0008.html][XEP-0008: IQ-Based Avatars]], [[https://xmpp.org/extensions/xep-0084.html][XEP-0084: User Avatar]], [[https://xmpp.org/extensions/xep-0153.html][XEP-0153: vCard-Based Avatars]]). They all have in common that they identify avatars by their SHA1 checksum, and (at least partially) use Base64-encoded image data. Thus this library of support functions for interpreting and caching avatars.
@@ -13846,7 +13853,7 @@ available."
#+END_SRC
*** vCard ([[https://xmpp.org/extensions/xep-0054.html][XEP-0054]])
:PROPERTIES:
-:file: jabber-vcard.el
+:old-file: jabber-vcard.el
:END:
There are great variations in Jabber vcard implementations. This one adds some spice to the mix, while trying to follow the XEP closely.
@@ -14417,7 +14424,7 @@ obtained from `xml-parse-region'."
#+END_SRC
*** vCard-Based Avatars ([[https://xmpp.org/extensions/xep-0153.html][XEP-0153]])
:PROPERTIES:
-:file: jabber-vcard-avatars.el
+:old-file: jabber-vcard-avatars.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -14565,7 +14572,7 @@ JC is the Jabber connection."
#+END_SRC
*** autoaway
:PROPERTIES:
-:file: jabber-autoaway.el
+:old-file: jabber-autoaway.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -14825,7 +14832,7 @@ The method for finding the terminal only works on GNU/Linux."
#+END_SRC
*** Entity Time ([[https://xmpp.org/extensions/xep-0202.html][XEP-0202]]), Legacy Entity Time ([[https://xmpp.org/extensions/xep-0090.html][XEP-0090]]) :xep_obsolete:
:PROPERTIES:
-:file: jabber-time.el
+:old-file: jabber-time.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -15071,7 +15078,7 @@ obtained from `xml-parse-region'."
#+END_SRC
*** truncate - cleanup top lines in chatbuffers
:PROPERTIES:
-:file: jabber-truncate.el
+:old-file: jabber-truncate.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -15139,7 +15146,7 @@ get it, and then it just gets deleted."
#+END_SRC
*** Message Carbons ([[https://xmpp.org/extensions/xep-0280.html][XEP-0280]])
:PROPERTIES:
-:file: jabber-carbons.el
+:old-file: jabber-carbons.el
:END:
**** jabber-carbon-success :function:
@@ -15171,10 +15178,1163 @@ JC is the Jabber connection."
#'jabber-carbon-success "Carbons feature enablement"
#'jabber-carbon-failure "Carbons feature enablement"))
+#+END_SRC
+*** Stream Initiation (SI) ([[https://xmpp.org/extensions/xep-0095.html][XEP-0095]]) :xep_deprecated:
+**** common
+:PROPERTIES:
+:file: jabber-si-common.el
+:END:
+
+***** jabber-si-stream-methods :variable:
+#+BEGIN_SRC emacs-lisp
+(defvar jabber-si-stream-methods nil
+ "Supported SI stream methods.
+
+Each entry is a list, containing:
+ * The namespace URI of the stream method
+ * Active initiation function
+ * Passive initiation function
+
+The active initiation function should initiate the connection,
+while the passive initiation function should wait for an incoming
+connection. Both functions take the same arguments:
+
+ * JID of peer
+ * SID
+ * \"connection established\" function
+
+The \"connection established\" function should be called when the
+stream has been established and data can be transferred. It is part
+of the profile, and takes the following arguments:
+
+ * JID of peer
+ * SID
+ * Either:
+ - \"send data\" function, with one string argument
+ - an error message, when connection failed
+
+It returns an \"incoming data\" function.
+
+The \"incoming data\" function should be called when data arrives on
+the stream. It takes these arguments:
+
+ * JID of peer
+ * SID
+ * A string containing the received data, or nil on EOF
+
+If it returns nil, the stream should be closed.")
+
+#+END_SRC
+**** client
+:PROPERTIES:
+:file: jabber-si-client.el
+:END:
+
+***** jabber-si-initiate :function:
+#+BEGIN_SRC emacs-lisp
+(defun jabber-si-initiate (jc jid profile-namespace profile-data profile-function &optional mime-type)
+ "Try to initiate a stream to JID.
+PROFILE-NAMESPACE is, well, the namespace of the profile to use.
+PROFILE-DATA is the XML data to send within the SI request.
+PROFILE-FUNCTION is the \"connection established\" function.
+See `jabber-si-stream-methods'.
+MIME-TYPE is the MIME type to specify.
+Returns the SID."
+
+ (let ((sid (apply 'format "emacs-sid-%d.%d.%d" (current-time))))
+ (jabber-send-iq jc jid "set"
+ `(si ((xmlns . "http://jabber.org/protocol/si")
+ (id . ,sid)
+ ,(if mime-type
+ (cons 'mime-type mime-type))
+ (profile . ,profile-namespace))
+ ,profile-data
+ (feature ((xmlns . "http://jabber.org/protocol/feature-neg"))
+ ,(jabber-fn-encode (list
+ (cons "stream-method"
+ (mapcar 'car jabber-si-stream-methods)))
+ 'request)))
+ #'jabber-si-initiate-process (cons profile-function sid)
+ ;; XXX: use other function here?
+ #'jabber-report-success "Stream initiation")
+ sid))
+
+#+END_SRC
+***** jabber-si-initiate-process :function:
+#+BEGIN_SRC emacs-lisp
+(defun jabber-si-initiate-process (jc xml-data closure-data)
+ "Act on response to our SI query."
+
+ (let* ((profile-function (car closure-data))
+ (sid (cdr closure-data))
+ (from (jabber-xml-get-attribute xml-data 'from))
+ (query (jabber-iq-query xml-data))
+ (feature-node (car (jabber-xml-get-children query 'feature)))
+ (feature-alist (jabber-fn-parse feature-node 'response))
+ (chosen-method (cadr (assoc "stream-method" feature-alist)))
+ (method-data (assoc chosen-method jabber-si-stream-methods)))
+ ;; Our work is done. Hand it over to the stream method.
+ (let ((stream-negotiate (nth 1 method-data)))
+ (funcall stream-negotiate jc from sid profile-function))))
+
+#+END_SRC
+**** server
+:PROPERTIES:
+:file: jabber-si-server.el
+:END:
+
+#+BEGIN_SRC emacs-lisp
+(jabber-disco-advertise-feature "http://jabber.org/protocol/si")
+
+#+END_SRC
+***** jabber-si-profiles :variable:
+Now, stream methods push data to profiles. It could be the other way around; not sure which is better.
+
+#+BEGIN_SRC emacs-lisp
+(defvar jabber-si-profiles nil
+ "Supported SI profiles.
+
+Each entry is a list, containing:
+ * The namespace URI of the profile
+ * Accept function, taking entire IQ stanza, and signalling a 'forbidden'
+ error if request is declined; returning an XML node to return in
+ response, or nil of none needed
+ * \"Connection established\" function. See `jabber-si-stream-methods'.")
+
+#+END_SRC
+***** jabber-si-process :function:
+#+BEGIN_SRC emacs-lisp
+(add-to-list 'jabber-iq-set-xmlns-alist
+ (cons "http://jabber.org/protocol/si" 'jabber-si-process))
+(defun jabber-si-process (jc xml-data)
+
+ (let* ((to (jabber-xml-get-attribute xml-data 'from))
+ (id (jabber-xml-get-attribute xml-data 'id))
+ (query (jabber-iq-query xml-data))
+ (profile (jabber-xml-get-attribute query 'profile))
+ (si-id (jabber-xml-get-attribute query 'id))
+ (feature (car (jabber-xml-get-children query 'feature))))
+ (message "Receiving SI with profile '%s'" profile)
+
+ (let (stream-method
+ ;; Find profile
+ (profile-data (assoc profile jabber-si-profiles)))
+ ;; Now, feature negotiation for stream type (errors
+ ;; don't match XEP-0095, so convert)
+ (condition-case err
+ (setq stream-method (jabber-fn-intersection
+ (jabber-fn-parse feature 'request)
+ (list (cons "stream-method" (mapcar 'car jabber-si-stream-methods)))))
+ (jabber-error
+ (jabber-signal-error "cancel" 'bad-request nil
+ '((no-valid-streams ((xmlns . "http://jabber.org/protocol/si")))))))
+ (unless profile-data
+ ;; profile not understood
+ (jabber-signal-error "cancel" 'bad-request nil
+ '((bad-profile ((xmlns . "http://jabber.org/protocol/si"))))))
+ (let* ((profile-accept-function (nth 1 profile-data))
+ ;; accept-function might throw a "forbidden" error
+ ;; on user cancel
+ (profile-response (funcall profile-accept-function jc xml-data))
+ (profile-connected-function (nth 2 profile-data))
+ (stream-method-id (nth 1 (assoc "stream-method" stream-method)))
+ (stream-data (assoc stream-method-id jabber-si-stream-methods))
+ (stream-accept-function (nth 2 stream-data)))
+ ;; prepare stream for the transfer
+ (funcall stream-accept-function jc to si-id profile-connected-function)
+ ;; return result of feature negotiation of stream type
+ (jabber-send-iq jc to "result"
+ `(si ((xmlns . "http://jabber.org/protocol/si"))
+ ,@profile-response
+ (feature ((xmlns . "http://jabber.org/protocol/feature-neg"))
+ ,(jabber-fn-encode stream-method 'response)))
+ nil nil nil nil
+ id)
+ ))))
+
+#+END_SRC
+*** SI File Transfer ([[https://xmpp.org/extensions/xep-0096.html][XEP-0096]]) :xep_deprecated:
+**** common
+:PROPERTIES:
+:file: jabber-ft-common.el
+:END:
+
+***** jabber-ft-md5sum-program :custom:variable:
+#+BEGIN_SRC emacs-lisp
+(defcustom jabber-ft-md5sum-program (or (when (executable-find "md5")
+ (list (executable-find "md5") "-n"))
+ (when (executable-find "md5sum")
+ (list (executable-find "md5sum"))))
+ "The program to use to calculate MD5 sums of files.
+The first item should be the name of the program, and the remaing
+items the arguments. The file name is appended as the last
+argument."
+ :type '(repeat string)
+ :group 'jabber)
+
+#+END_SRC
+***** jabber-ft-get-md5 :function:
+#+BEGIN_SRC emacs-lisp
+(defun jabber-ft-get-md5 (file-name)
+ "Get MD5 sum of FILE-NAME, and return as hex string.
+Return nil if no MD5 summing program is available."
+ (when jabber-ft-md5sum-program
+ (with-temp-buffer
+ (apply 'call-process (car jabber-ft-md5sum-program) nil t nil
+ (append (cdr jabber-ft-md5sum-program) (list file-name)))
+ ;; Output is "hexsum filename"
+ (goto-char (point-min))
+ (forward-word 1)
+ (buffer-substring (point-min) (point)))))
+
+#+END_SRC
+**** client
+:PROPERTIES:
+:file: jabber-ft-client.el
+:END:
+
+#+BEGIN_SRC emacs-lisp
+(eval-when-compile (require 'cl))
+
+#+END_SRC
+***** jabber-ft-send :command:
+#+BEGIN_SRC emacs-lisp
+(defun jabber-ft-send (jc jid filename desc)
+ "Attempt to send FILENAME to JID."
+ (interactive (list (jabber-read-account)
+ (jabber-read-jid-completing "Send file to: " nil nil nil 'full t)
+ (read-file-name "Send which file: " nil nil t)
+ (jabber-read-with-input-method "Description (optional): ")))
+ (if (zerop (length desc)) (setq desc nil))
+ (setq filename (expand-file-name filename))
+ (access-file filename "Couldn't open file")
+
+ (let* ((attributes (file-attributes filename))
+ (size (nth 7 attributes))
+ (date (nth 5 attributes))
+ (hash (jabber-ft-get-md5 filename)))
+ (jabber-si-initiate jc jid "http://jabber.org/protocol/si/profile/file-transfer"
+ `(file ((xmlns . "http://jabber.org/protocol/si/profile/file-transfer")
+ (name . ,(file-name-nondirectory filename))
+ (size . ,size)
+ (date . ,(jabber-encode-time date))
+ ,@(when hash
+ (list (cons 'hash hash))))
+ (desc () ,desc))
+ (lexical-let ((filename filename))
+ (lambda (jc jid sid send-data-function)
+ (jabber-ft-do-send
+ jid sid send-data-function filename))))))
+
+#+END_SRC
+***** jabber-ft-do-send :function:
+#+BEGIN_SRC emacs-lisp
+(defun jabber-ft-do-send (jid sid send-data-function filename)
+ (if (stringp send-data-function)
+ (message "File sending failed: %s" send-data-function)
+ (with-temp-buffer
+ (insert-file-contents-literally filename)
+
+ ;; Ever heard of buffering?
+ (funcall send-data-function (buffer-string))
+ (message "File transfer completed")))
+ ;; File transfer is monodirectional, so ignore received data.
+ #'ignore)
+
+#+END_SRC
+**** server
+:PROPERTIES:
+:file: jabber-ft-server.el
+:END:
+
+***** jabber-ft-sessions :variable:
+#+BEGIN_SRC emacs-lisp
+(defvar jabber-ft-sessions nil
+ "Alist, where keys are (sid jid), and values are buffers of the files.")
+
+#+END_SRC
+***** jabber-ft-size :variable:
+#+BEGIN_SRC emacs-lisp
+(defvar jabber-ft-size nil
+ "Size of the file that is being downloaded")
+
+#+END_SRC
+***** jabber-ft-md5-hash :variable:
+#+BEGIN_SRC emacs-lisp
+(defvar jabber-ft-md5-hash nil
+ "MD5 hash of the file that is being downloaded")
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(jabber-disco-advertise-feature "http://jabber.org/protocol/si/profile/file-transfer")
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(add-to-list 'jabber-si-profiles
+ (list "http://jabber.org/protocol/si/profile/file-transfer"
+ 'jabber-ft-accept
+ 'jabber-ft-server-connected))
+
+#+END_SRC
+***** jabber-ft-accept :function:
+#+BEGIN_SRC emacs-lisp
+(defun jabber-ft-accept (jc xml-data)
+ "Receive IQ stanza containing file transfer request, ask user"
+ (let* ((from (jabber-xml-get-attribute xml-data 'from))
+ (query (jabber-iq-query xml-data))
+ (si-id (jabber-xml-get-attribute query 'id))
+ ;; TODO: check namespace
+ (file (car (jabber-xml-get-children query 'file)))
+ (name (jabber-xml-get-attribute file 'name))
+ (size (jabber-xml-get-attribute file 'size))
+ (date (jabber-xml-get-attribute file 'date))
+ (md5-hash (jabber-xml-get-attribute file 'hash))
+ (desc (car (jabber-xml-node-children
+ (car (jabber-xml-get-children file 'desc)))))
+ (range (car (jabber-xml-get-children file 'range))))
+ (unless (and name size)
+ ;; both name and size must be present
+ (jabber-signal-error "modify" 'bad-request))
+
+ (let ((question (format
+ "%s is sending you the file %s (%s bytes).%s Accept? "
+ (jabber-jid-displayname from)
+ name
+ size
+ (if (not (zerop (length desc)))
+ (concat " Description: '" desc "'")
+ ""))))
+ (unless (yes-or-no-p question)
+ (jabber-signal-error "cancel" 'forbidden)))
+
+ ;; default is to save with given name, in current directory.
+ ;; maybe that's bad; maybe should be customizable.
+ (let* ((file-name (read-file-name "Download to: " nil nil nil name))
+ (buffer (create-file-buffer file-name)))
+ (message "Starting download of %s..." (file-name-nondirectory file-name))
+ (with-current-buffer buffer
+ (kill-all-local-variables)
+ (setq buffer-file-coding-system 'binary)
+ ;; For Emacs, switch buffer to unibyte _before_ anything goes into it,
+ ;; otherwise binary files are corrupted. For XEmacs, it isn't needed,
+ ;; and it also doesn't have set-buffer-multibyte.
+ (if (fboundp 'set-buffer-multibyte)
+ (set-buffer-multibyte nil))
+ (set-visited-file-name file-name t)
+ (set (make-local-variable 'jabber-ft-size)
+ (string-to-number size))
+ (set (make-local-variable 'jabber-ft-md5-hash)
+ md5-hash))
+ (add-to-list 'jabber-ft-sessions
+ (cons (list si-id from) buffer)))
+
+ ;; to support range, return something sensible here
+ nil))
+
+#+END_SRC
+***** jabber-ft-server-connected :function:
+#+BEGIN_SRC emacs-lisp
+(defun jabber-ft-server-connected (jc jid sid send-data-function)
+ ;; We don't really care about the send-data-function. But if it's
+ ;; a string, it means that we have no connection.
+ (if (stringp send-data-function)
+ (message "File receiving failed: %s" send-data-function)
+ ;; On success, we just return our data receiving function.
+ 'jabber-ft-data))
+
+#+END_SRC
+***** jabber-ft-data :function:
+#+BEGIN_SRC emacs-lisp
+(defun jabber-ft-data (jc jid sid data)
+ "Receive chunk of transferred file."
+ (let ((buffer (cdr (assoc (list sid jid) jabber-ft-sessions))))
+ (with-current-buffer buffer
+ ;; If data is nil, there is no more data.
+ ;; But maybe the remote entity doesn't close the stream -
+ ;; then we have to keep track of file size to know when to stop.
+ ;; Return value is whether to keep connection open.
+ (when data
+ (insert data))
+ (if (and data (< (buffer-size) jabber-ft-size))
+ t
+ (basic-save-buffer)
+ (if (and jabber-ft-md5-hash
+ (let ((file-hash (jabber-ft-get-md5 buffer-file-name)))
+ (and file-hash
+ (not (string= file-hash jabber-ft-md5-hash)))))
+ ;; hash mismatch!
+ (progn
+ (message "%s downloaded - CHECKSUM MISMATCH!"
+ (file-name-nondirectory buffer-file-name))
+ (sleep-for 5))
+ ;; all is fine
+ (message "%s downloaded" (file-name-nondirectory buffer-file-name)))
+ (kill-buffer buffer)
+ nil))))
+
+#+END_SRC
+*** SOCKS5 Bytestreams ([[https://xmpp.org/extensions/xep-0065.html][XEP-0065]])
+:PROPERTIES:
+:file: jabber-socks5.el
+:header-args: :tangle jabber-socks5.el :load jabber-enable-legacy-features-p
+:END:
+
+#+BEGIN_SRC emacs-lisp
+(eval-when-compile (require 'cl))
+
+#+END_SRC
+**** jabber-socks5-pending-sessions :variable:
+#+BEGIN_SRC emacs-lisp
+(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")
+
+#+END_SRC
+**** jabber-socks5-active-sessions :variable:
+#+BEGIN_SRC emacs-lisp
+(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")
+
+#+END_SRC
+**** jabber-socks5-proxies :custom:variable:
+#+BEGIN_SRC emacs-lisp
+(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)
+ )
+
+#+END_SRC
+**** jabber-socks5-proxies-data :variable:
+#+BEGIN_SRC emacs-lisp
+(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.")
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(jabber-disco-advertise-feature "http://jabber.org/protocol/bytestreams")
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(add-to-list 'jabber-si-stream-methods
+ (list "http://jabber.org/protocol/bytestreams"
+ 'jabber-socks5-client-1
+ 'jabber-socks5-accept))
+
+#+END_SRC
+**** jabber-socks5-set-proxies :function:
+#+BEGIN_SRC emacs-lisp
+(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)))
+
+#+END_SRC
+**** jabber-socks5-query-all-proxies :command:
+#+BEGIN_SRC emacs-lisp
+(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)))
+
+#+END_SRC
+**** jabber-socks5-query-proxy :function:
+#+BEGIN_SRC emacs-lisp
+(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)))
+
+#+END_SRC
+**** jabber-socks5-process-proxy-response :function:
+#+BEGIN_SRC emacs-lisp
+(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)))))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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))))
+
+#+END_SRC
+**** jabber-socks5-accept :function:
+#+BEGIN_SRC emacs-lisp
+(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))))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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))))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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))))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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))
+
+#+END_SRC
+**** jabber-socks5-process :function:
+#+BEGIN_SRC emacs-lisp
+(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.
+;; )
+ ))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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))))))))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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)))))))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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)))))))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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))))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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)))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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))))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(define-state jabber-socks5-connection done
+ (fsm state-data event callback)
+ ;; ignore all events
+ (list 'done nil nil))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(define-state jabber-socks5-connection fail
+ (fsm state-data event callback)
+ ;; ignore all events
+ (list 'fail nil nil))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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))))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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))))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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)))))
+
+#+END_SRC
+
+#+BEGIN_SRC emacs-lisp
+(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))
+
+#+END_SRC
+**** jabber-socks5-client-1 :function:
+#+BEGIN_SRC emacs-lisp
+(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))))
+
+#+END_SRC
+**** +jabber-socks5-client-2+ :function:
+#+BEGIN_SRC emacs-lisp
+;; (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)))))
+
#+END_SRC
*** In-Band Real Time Text (RTT) ([[https://xmpp.org/extensions/xep-0301.html][XEP-0301]])
:PROPERTIES:
-:file: jabber-rtt.el
+:old-file: jabber-rtt.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -15539,7 +16699,7 @@ XEP-0301, In-Band Real Time Text."
*** Jabber
:PROPERTIES:
-:file: jabber.el
+:old-file: jabber.el
:END:
#+BEGIN_SRC emacs-lisp
@@ -15790,8 +16950,3 @@ Contents of process buffers might be useful for debugging."
;;; jabber.el ends here
#+END_SRC
-
-** local variables
-# Local Variables:
-# eval: (progn (make-local-variable 'after-save-hook) (add-hook 'after-save-hook (lambda () (start-process-shell-command "jabber-sed-tangle" "jabber-sed-tangle" "sed -n -e '/#+BEGIN_SRC emacs-lisp$/,/#+END_SRC$/{//!p;}' jabber.org > jabber.el"))))
-# End: