12234 lines
440 KiB
EmacsLisp
12234 lines
440 KiB
EmacsLisp
;;; jabber.el --- a minimal jabber client
|
|
|
|
;; Copyright (C) 2003-2010, 2013 - Magnus Henoch - mange@freemail.hu
|
|
;; Copyright (C) 2002-2004 - Tom Berger - object@intelectronica.net
|
|
;; Copyright (C) 2005 - Georg Lehner - jorge@magma.com.ni
|
|
;; Copyright (C) 2008-2010, 2012-2013 - Terechkov Evgenii - evg@altlinux.org
|
|
;; Copyright (C) 2006-2010 - Kirill A. Korinskiy - catap@catap.ru
|
|
;; Copyright (C) 2004-2005 - Carl Henrik Lunde - chlunde+jabber+@ping.uio.no
|
|
;; Copyright (C) 2009-2010 - Demyan Rogozhin <demyan.rogozhin@gmail.com>
|
|
;; Copyright (C) 2004 - Mathias Dahl
|
|
;; Copyright (C) 2007 - Serguei Jidkov - jsv@e-mail.ru
|
|
|
|
;; This program is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation; either version 2 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program; if not, write to the Free Software
|
|
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
|
|
|
;;; Commentary:
|
|
;;
|
|
|
|
;;; History:
|
|
;;
|
|
|
|
;;; Code:
|
|
|
|
(require 'goto-addr)
|
|
|
|
(require 'xml)
|
|
(eval-when-compile
|
|
(require 'cl))
|
|
|
|
(defun jabber-escape-xml (str)
|
|
"Escape strings for XML."
|
|
(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"
|
|
;; 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 true, stop after an opening
|
|
<stream:stream> tag.
|
|
|
|
The version of `sgml-skip-tag-forward' in Emacs 21 isn't good
|
|
enough for us."
|
|
(skip-chars-forward "^<")
|
|
(cond
|
|
((looking-at "<!\\[CDATA\\[")
|
|
(if (search-forward "]]>" 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."
|
|
`(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, if given 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, if given 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 the conference name from boomarks or displayname from roster, or 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 jabber-account-list (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 <error/> child.
|
|
The query child is often but not always <query/>."
|
|
(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 <error/> part of an IQ stanza, if any."
|
|
(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."
|
|
(jabber-xml-get-attribute (jabber-iq-query xml-data) 'xmlns))
|
|
|
|
(defun jabber-message-timestamp (xml-data)
|
|
"Given a <message/> element, return its timestamp, or nil if none."
|
|
(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 <delay/> tag in namespace urn:xmpp:delay (XEP-0203), or
|
|
a <x/> tag in namespace jabber:x:delay (XEP-0091).
|
|
Return nil if no such data available."
|
|
(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."
|
|
(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 <error/> 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 <error/> 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 <error/> 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 <stream:error/> 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 <stream:error/> 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\", \"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.
|
|
|
|
See section 9.3 of XMPP Core."
|
|
(signal 'jabber-error
|
|
(list 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
|
|
;; <URL:http://www.jabber.org/registrar/querytypes.html>.
|
|
(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
|
|
"srv not found in `load-path' or jabber-fallback-lib/ directory.")))
|
|
|
|
(defgroup jabber-conn nil "Jabber Connection Settings"
|
|
:group 'jabber)
|
|
|
|
(defun jabber-have-starttls ()
|
|
"Return true 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 "starttls.el 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."
|
|
(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)
|
|
;; 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)
|
|
(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 <success/> 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
|
|
"fsm 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 <stream:stream> 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 <register/> 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 "</stream:stream>")
|
|
(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 "</stream:stream>")
|
|
(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 "</stream:stream>")
|
|
(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 "</stream:stream>")
|
|
(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 "</stream:stream>")
|
|
(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 "</stream:stream>")
|
|
(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 "</stream:stream>")
|
|
(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."
|
|
(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 "</stream:stream>")
|
|
(return (fsm-send fsm :stream-end)))
|
|
|
|
;; Stream header?
|
|
(when (looking-at "<stream:stream[^>]*\\(>\\)")
|
|
;; 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"
|
|
(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 "<?xml version='1.0'?><stream:stream to='"
|
|
(plist-get (fsm-get-state-data jc) :server)
|
|
"' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams'"
|
|
;; Not supporting SASL is not XMPP compliant,
|
|
;; so don't pretend we are.
|
|
(if (and (jabber-have-sasl-p) jabber-use-sasl)
|
|
" version='1.0'"
|
|
"")
|
|
">
|
|
")))
|
|
(jabber-log-xml jc "sending" stream-header)
|
|
(jabber-send-string jc stream-header)))
|
|
|
|
(defun jabber-send-string (jc string)
|
|
"Send STRING to 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\"."
|
|
(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."
|
|
(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."
|
|
(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 "<backtab>") '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"
|
|
(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"
|
|
(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."
|
|
(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."
|
|
(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"
|
|
(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"
|
|
(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 "<iq xmlns='jabber:client'><query xmlns='jabber:iq:roster'>\n")
|
|
(dolist (item items)
|
|
(insert (jabber-sexp2xml item) "\n"))
|
|
(insert "</query></iq>\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 <iq> node with a <query xmlns='jabber:iq:roster'> 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-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"
|
|
(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 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.
|
|
|
|
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."
|
|
(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."
|
|
(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)
|
|
"This function returns 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)
|
|
"This function returns 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. Makes sence only for MUC."
|
|
(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 matches 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 matches 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
|
|
`jabber-history-size-limit' kilobytes. If nil, history files
|
|
will grow indefinitely, otherwise they'll be renamed to
|
|
<history-file>-<number>, where <number> 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
|
|
<history-file>-<number>, where <number> 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 true 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."
|
|
(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 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-map}"
|
|
(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."
|
|
(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 "\\<widget-field-keymap>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 <body/> 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."
|
|
(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."
|
|
;; 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."
|
|
;; 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 <message/> stanza.
|
|
\(car data) is either :local, :foreign, :error or :notice.
|
|
\(cadr data) is the <message/> 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 true, print long timestamp
|
|
\(`jabber-chat-delayed-time-format' as opposed to
|
|
`jabber-chat-time-format').
|
|
If DONT-PRINT-NICK-P is true, 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 true, print long timestamp
|
|
\(`jabber-chat-delayed-time-format' as opposed to
|
|
`jabber-chat-time-format').
|
|
If DONT-PRINT-NICK-P is true, 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 <message/> in a readable way."
|
|
(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 <message/>, if any."
|
|
(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."
|
|
(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."
|
|
(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"
|
|
(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."
|
|
(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 <presence/> stanzas.
|
|
Each function takes one argument, the connection, and returns a
|
|
possibly empty list of extra child element of the <presence/>
|
|
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."
|
|
(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)
|
|
;; 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.
|
|
(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"
|
|
;; 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"
|
|
(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 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 <presence/> stanza."
|
|
`(,(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."
|
|
(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, showing him your request
|
|
text, if specified"
|
|
(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."
|
|
(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"
|
|
(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"
|
|
(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."
|
|
(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 <c/> 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 <value/> 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
|
|
;; <value/> 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 <value/> element.
|
|
(let ((values (sort (mapcar (lambda (value)
|
|
(car (jabber-xml-node-children value)))
|
|
(jabber-xml-get-children field 'value))
|
|
#'string<)))
|
|
;; For each <value/> 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
|
|
<query/> 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
|
|
<query/> 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."
|
|
(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"
|
|
(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"
|
|
(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."
|
|
|
|
(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."
|
|
|
|
(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 <iq/> stanza containing a disco#info result.
|
|
See `jabber-disco-get-info' for a description of the return value."
|
|
(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."
|
|
(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."
|
|
(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."
|
|
(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 if it doesn't answer. See `jabber-keepalive-interval'
|
|
and `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, <x/>, 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 <x/> 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 <query/> 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 <query/> 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 <x/> 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 <x/> 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 <value/> 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 <field/>s in each
|
|
;; <item/> is the same as in the <reported/> 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 <conference/> 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."
|
|
(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'."
|
|
(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
|
|
"hexrgb 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 good enough color from 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."
|
|
(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."
|
|
(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."
|
|
;; 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 true, 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."
|
|
(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."
|
|
(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"
|
|
(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"
|
|
|
|
(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 true, switch to the
|
|
groupchat buffer."
|
|
(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."
|
|
(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"
|
|
(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."
|
|
(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 <message/>, if any."
|
|
(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."
|
|
(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."
|
|
(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."
|
|
(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"
|
|
(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'."
|
|
(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."
|
|
(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 <actor/> and <reason/> 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."
|
|
(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)
|
|
"Updates 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\"."
|
|
(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."
|
|
|
|
(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."
|
|
(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\"."
|
|
(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."
|
|
|
|
;; 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"
|
|
(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."
|
|
(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"
|
|
(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."
|
|
|
|
(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."
|
|
;; 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 <command/> 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 <command/> 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"
|
|
(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. (XEP-0050)"
|
|
(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. (XEP-0050)"
|
|
(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 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."
|
|
|
|
(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 <x/> 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)
|
|
"Checks if one of your extra-important buddies comes online and
|
|
sends a message if that happens. 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 "jabber-presence-watch 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, 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
|
|
"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 when 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
|
|
"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
|
|
"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 -> 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)
|
|
"Returns t only if there is an invisible buffer for JID
|
|
and JID 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', 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'
|
|
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 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 <x/> node should be the only child of the
|
|
;; message, and it should contain an <id/> node.
|
|
;; We check the latter.
|
|
(when (and x (jabber-xml-get-children x 'id))
|
|
;; Currently we don't care about the <id/> 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 <data/> 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 <query/> 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."
|
|
(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."
|
|
(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."
|
|
(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 <presence/> stanza."
|
|
;; 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."
|
|
(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."
|
|
(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."
|
|
(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."
|
|
(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."
|
|
(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."
|
|
(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."
|
|
(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."
|
|
(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."
|
|
(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."
|
|
(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."
|
|
(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."
|
|
(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 <body/> 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 <body/> 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"))
|
|
|
|
(provide 'jabber)
|
|
|
|
;;; jabber.el ends here
|
|
|