diff options
| author | Matteo F. Vescovi <mfv@debian.org> | 2016-12-15 17:32:27 -0400 |
|---|---|---|
| committer | Matteo F. Vescovi <mfv@debian.org> | 2016-12-15 17:32:27 -0400 |
| commit | c9cecdbd764570d3a89f0b27265b9a6c1b066f4c (patch) | |
| tree | d4426bc256a15c49c210cbdab9543cdd651b1b96 | |
Import emacs-jabber_0.8.92+git98dc8e.orig.tar.xz
[dgit import orig emacs-jabber_0.8.92+git98dc8e.orig.tar.xz]
100 files changed, 21052 insertions, 0 deletions
@@ -0,0 +1,30 @@ +Developers: +Tom Berger +Magnus Henoch +Kirill A. Korinskiy +Detlev Zundel +Evgenii Terechkov + +Contributors: +Anthony Chaumas-Pellet +Jérémy Compostella +Mathias Dahl +Mario Domenech Goulart +Nolan Eakins +Ami Fischman +François Fleuret +David Hansen +Rodrigo Lazo +Justin Kirby +Carl Henrik Lunde +Olivier Ramonat +Andrey Slusar +Valery V. Vorotyntsev +Milan Zamazal +Xavier Maillard +Vitaly Mayatskikh +Alexander Solovyov +Demyan Rogozhin +Michael Cardell Widerkrantz + +arch-tag: 15700144-3BD9-11D9-871C-000A95C2FCD0 diff --git a/Makefile.am b/Makefile.am new file mode 100644 index 0000000..5eed578 --- /dev/null +++ b/Makefile.am @@ -0,0 +1,71 @@ +ACLOCAL_AMFLAGS = -I m4 +# The following line needs to be here since automake 1.4 doesn't look +# for options in configure.ac. +AUTOMAKE_OPTIONS = 1.11 + +my_lisp_sources=jabber-activity.el jabber-ahc-presence.el \ +jabber-ahc.el jabber-alert.el jabber-autoaway.el jabber-avatar.el \ +jabber-awesome.el jabber-ping.el jabber-libnotify.el jabber-console.el \ +jabber-notifications.el \ +jabber-bookmarks.el jabber-browse.el jabber-chat.el \ +jabber-chatbuffer.el jabber-chatstates.el jabber-compose.el \ +jabber-conn.el jabber-core.el jabber-disco.el jabber-events.el \ +jabber-export.el jabber-feature-neg.el jabber-festival.el \ +jabber-ft-client.el jabber-ft-common.el jabber-ft-server.el \ +jabber-gmail.el jabber-history.el jabber-iq.el jabber-keepalive.el \ +jabber-keymap.el jabber-logon.el jabber-menu.el jabber-modeline.el \ +jabber-muc-nick-completion.el jabber-muc.el jabber-rtt.el \ +jabber-osd.el jabber-presence.el jabber-private.el jabber-ratpoison.el \ +jabber-register.el jabber-roster.el jabber-sasl.el jabber-sawfish.el \ +jabber-screen.el jabber-search.el jabber-si-client.el \ +jabber-si-common.el jabber-si-server.el jabber-socks5.el \ +jabber-time.el jabber-truncate.el jabber-util.el \ +jabber-vcard-avatars.el jabber-vcard.el jabber-version.el \ +jabber-watch.el jabber-widget.el jabber-wmii.el jabber-xmessage.el \ +jabber-muc-nick-coloring.el \ +jabber-xml.el jabber.el srv.el jabber-tmux.el jabber-ourversion.el + +compat_lisp_sources = jabber-fallback-lib/hexrgb.el jabber-fallback-lib/fsm.el + +dist_lisp_LISP=$(my_lisp_sources) $(compat_lisp_sources) jabber-autoloads.el +MAINTAINERCLEANFILES=jabber-autoloads.el + +EXTRA_DIST = jabber-pkg.el.in + +# The autoload file will cause Lisp sources to be rebuilt _twice_: the +# timestamp of the Lisp compilation is set _before_ the autoloads are +# regenerated, which means that jabber-autoload.el is once again +# considered new, which means that everything will be built again. +# Suggestions welcome. +# +# Emacs 21 requires that the file already exist and have non-zero +# size, so we touch it with ancient timestamp. +jabber-autoloads.el: $(my_lisp_sources) + test -s $@ || cp -f $(srcdir)/jabber-autoloads.stub $@; touch -t 197001030000 $@ + $(EMACS) --batch --eval "(setq generated-autoload-file \"$(abs_builddir)/$@\")" -f batch-update-autoloads $(srcdir) + +info_TEXINFOS=jabber.texi + +dist_libexec_SCRIPTS = emacs-jabber-uri-handler + +SUBDIRS = . tests +if USE_GCONFTOOL +if GCONF_SCHEMAS_INSTALL +SUBDIRS += gconf +endif +endif + +# Package everything in a form suitable for ELPA. That is, use +# "jabber" instead of "emacs-jabber" as base name. +CLEANFILES = jabber-pkg.el +elpa: dist + rm -rf emacs-jabber-$(PACKAGE_VERSION) jabber-$(PACKAGE_VERSION) + $(AMTAR) xzf emacs-jabber-$(PACKAGE_VERSION).tar.gz + mv emacs-jabber-$(PACKAGE_VERSION) jabber-$(PACKAGE_VERSION) + rm -rf jabber-$(PACKAGE_VERSION)/tests + cd jabber-$(PACKAGE_VERSION) ; install-info jabber.info dir + sed "s/@""PACKAGE_VERSION@""/$(PACKAGE_VERSION)/" < $(srcdir)/jabber-pkg.el.in > jabber-$(PACKAGE_VERSION)/jabber-pkg.el + $(AMTAR) chf jabber-$(PACKAGE_VERSION).tar jabber-$(PACKAGE_VERSION) + rm -rf jabber-$(PACKAGE_VERSION) + @echo "Created jabber-$(PACKAGE_VERSION).tar" + @@ -0,0 +1,218 @@ +-*- mode: outline -*- + +* New features in jabber.el latest git +** Support for reading passwords from netrc/authinfo files +Use "machine example.com login username password s3cret port xmpp". + +** Support for roster's groups roll state saving + +** Full support for XEP-0012 +Response of idle time. + +** Support for XEP-0202 +Entity Time for request/response time as main method. + +** Support for automatic MUC nicks colorization +See "Customizing the chat buffer" in the manual. + +** XML Console +Log all received/sending XML stanzas into special buffer. Also can be +used to send custom XML stanzas manually. + +** Autoaway +Support for list of autoaway methods. Support for Xa. See section "Autoaway" in manual. + +** MUC +MUC participants list format is now customizable: see +jabber-muc-print-names-format in manual. Also, participants sorted by +role. + +** Treat XML namespace prefixes correctly +A change in the Google Talk server has brought to light the fact that +jabber.el didn't handle XML namespace prefixes correctly. This should +be fixed by the new jabber-xml-resolve-namespace-prefixes function. + +* New features in jabber.el 0.8 +** Support for multiple accounts +Configuration variables have changed. See section "Account settings" +in the manual. + +** Activity mode improved +Customizable face for personal messages added, list of unwanted (banned) JIDs added + +** Simple automatic answering machine +Realized as alert. Can match regexp and answer with predefined string + +** OSD alerts (message, MUC, MUC-personal) + +** Family of personal MUC alerts added +See section "Standard alerts" in manual. + +** MUC nicks completion +See section "Groupchat" in manual. + +** Automatic reconnection +Not enabled by default; See "Reconnecting" section in manual. + +** Support for XEP-0085 +This means "contact is typing" notifications when chatting with Gajim +or Google Talk users, among others. +See "Typing notifications" section in the manual. + +** Option: hide offline contacts in roster +See "The roster buffer" in manual. + +** Clean history from chat buffers +See jabber-truncate-* functions and new options for +jabber-alert-muc-hooks and jabber-alert-message-hooks. See section +"Message history" in manual too. + +** MUC bookmarks +See jabber-edit-bookmarks function and "Bookmarks" section in manual. + +** Name of browse buffers customizable +See "Services" section in manual. + +** Subscription requests are sent to chat buffers +Subscription requests now displayed in chat buffers. See "Presence +subscription" section in manual. + +** Option: hide avatar in chat buffer +`jabber-chat-buffer-show-avatar'. + +** Gmail notifications +(Not documented nor autoloaded) + +** GConf-based installation of URI handler +See "XMPP URIs" in manual. + +* New features in jabber.el 0.7.1 + +** STARTTLS + +** SRV records +Requires No Gnus. + +** Message composition buffer +Try jabber-compose. + +** XMPP URIs are handled +See manual for setup. + +** Autoaway + +** MUC features +*** Don't display alerts for your own messages +See jabber-muc-alert-self. +*** Presence changes are sent to MUC rooms too +*** Check room features before joining + +** Avatars +Viewing and publishing JEP-0153 avatars (vCard-based) is now +supported. + +** File transfer + +** Sound files per contact for alerts + +** Per-user history files changed +For some time after 0.7 these file names erroneously contained double +quotes. If you have used the CVS version you'll need to rename your +history files manually. + +** New function: jabber-send-directed-presence + +** Entity time supported (XEP-0090) + +** Last activity supported (XEP-0012) + +* New features in jabber.el 0.7 + +** SSL connections possible +See variable `jabber-connection-type'. + +** Chat buffers rewritten +New modular design gives increased extensibility. +*** Received URLs are displayed +*** Long lines are filled +See jabber-chat-fill-long-lines. +*** Rare timestamps are printed by default +See jabber-print-rare-time and jabber-rare-time-format. + +** MUC features +*** Different default nicknames for different MUC rooms +See jabber-muc-default-nicknames. +*** Autojoin MUC rooms on connection +See jabber-muc-autojoin. +*** Change nickname +Actually simply an alias from jabber-muc-nick to jabber-muc-join. +*** Invitations +Both sending and receiving invitiations is supported. +*** Basic affiliation change support +(Not finished) +*** Private MUC messages +*** Support for setting and displaying topic + +** Global key bindings +Global keymap under C-x C-j. + +** Vcard viewer and editor + +** Roster export + +** Message events (JEP-0022) + +** Easy way to define external notifiers +See define-jabber-alert. Alerts for Festival (speech synthesis), +Sawfish, and xmessage added. + +** Activity mode improved +Can now display count in frame title. Update hook added. + +** Roster display optimized + +** Optionally use per-contact history files + +** Jabber menu in menubar not enabled by default +Call jabber-menu to have it there. + +** Flyspell in chat buffers +Flyspell will only spell check what you're currently writing. + +** Different time formats for instant and delayed messages +See `jabber-chat-time-format' and `jabber-chat-delayed-time-format'. +You can see the complete timestamp in a tooltip by holding the mouse +over the prompt. + +** Chat buffers in inactive windows are scrolled + +** Roster is sorted by name also + +* New features in jabber.el 0.6.1 + +** Message history +Set jabber-history-enabled to t to activate it. + +** Backlogs +If you have history enabled, the last few messages are inserted when +you open a new chat buffer. + +** Activity tracking on the mode line +Activate it with M-x jabber-activity-mode. + +** Receive an alert when a specific person goes online +Use it with M-x jabber-watch-add. + +** Support for /me in chats (xep-0245, except XHTML-IM) +As in "/me laughs" etc. + +** Message alerts for current buffer can be disabled +Set jabber-message-alert-same-buffer to nil to do that. + +** Basic moderation support in MUC + +** MUC alerts are separated from ordinary message alerts +Customize jabber-alert-muc-hooks to get your desired behaviour. + + +arch-tag: 1CE20E4E-3BD9-11D9-8D64-000A95C2FCD0 @@ -0,0 +1,142 @@ +This is jabber.el 0.8.92, an XMPP client for Emacs. XMPP (also +known as 'Jabber') is an instant messaging system; see +http://xmpp.org for more information. + +Home page: http://emacs-jabber.sourceforge.net +Project page: http://sourceforge.net/projects/emacs-jabber +Wiki page: http://www.emacswiki.org/cgi-bin/wiki/JabberEl +Mailing list: http://lists.sourceforge.net/lists/listinfo/emacs-jabber-general +and: http://dir.gmane.org/gmane.emacs.jabber.general +MUC room: jabber.el@conference.jabber.se and emacs@conference.jabber.ru (Russian, English) + +GNU Emacs +========= + +jabber.el runs on GNU Emacs 23.1 or later. + +The file hexrgb.el (http://www.emacswiki.org/emacs/hexrgb.el) is +needed for MUC nick coloring feature. A copy is located in the compat +directory, and used if the configure script doesn't find another copy +already installed. + +XEmacs +====== + +You need an XEmacs with Mule support, and recent versions of the gnus, +net-utils and mule-ucs packages. jabber.el basically works on XEmacs, +but some features are missing (in particular mouse support). Testing +and patches are very welcome. + +Encrypted connections +===================== +Many Jabber servers require encrypted connections, and even if yours +doesn't it may be good idea. To get an encrypted connection, the most +convenient option is to use GNU Emacs 24 with GnuTLS support compiled +in. You can check whether you have that by typing: + +M-: (gnutls-available-p) + +If that commands shows `t' in the echo area, then you have working +GnuTLS support. If it shows `nil' or signals an error, then you +don't. + +Failing that, jabber.el will use the starttls.el library, which +requires that the GnuTLS command line tool "gnutls-cli" is installed. +In Debian-based distributions, "gnutls-cli" is in the "gnutls-bin" +package. + +The above applies to STARTTLS connections, the most common way to +encrypt a Jabber connection and the only one specified in the +standards. STARTTLS connections start out unencrypted, but switch to +encrypted after negotiation. jabber.el also supports connections that +are encrypted from start. For this it uses the tls.el library, which +requires either "gnutls-cli" or the OpenSSL command line tool +"openssl" to be installed. + +To use the latter form of encryption, customize jabber-account-list. + +Note that only the connection from you to the server is encrypted; +there is no guarantee of connections from your server to your +contacts' server being encrypted. + +Installation +============ +jabber.el can be installed using the commands: +./configure +make +make install + +You can specify which emacs you want to use: +./configure EMACS=emacs-or-xemacs-21.4 + +You can also install jabber.el by hand. Put all .el files somewhere +in your load-path, or have your load-path include the directory +they're in. To install the Info documentation, copy jabber.info to +/usr/local/info and run "install-info /usr/local/info/jabber.info". + +After installation by either method, add (load "jabber-autoloads") to +your .emacs file. (If you got the code from GIT, you still need the +makefile to generate jabber-autoloads.el.) + +If you are upgrading from 0.7-0.7.x, you need to update your +configuration. See the section "Account settings" in the manual. + +Special notes for GIT version +============================= +If you are running jabber.el from GIT, you need to generate the +jabber-autoloads.el file yourself. The simplest way to do this is by +using the "./configure && make" process. + +To generate the configure script, make sure that autoconf and automake +are installed and run "autoreconf -i". + +Usage +===== + +To connect to a Jabber server, type C-x C-j C-c (or equivalently M-x +jabber-connect-all) and enter your JID. With prefix argument, +register a new account. You can set your JID permanently with M-x +jabber-customize. + +Your roster is displayed in a buffer called *-jabber-*. To +disconnect, type C-x C-j C-d or M-x jabber-disconnect. + +You may want to use the menu bar to execute Jabber commands. To +enable the Jabber menu, type M-x jabber-menu. + +For a less terse description, read the enclosed manual. + +For bug reports, help requests and other feedback, use the trackers +and forums at the project page mentioned above. + +Configuration +============= +All available configuration options are described in the manual. This +section only serves to point out the most important ones. + +To change how you are notified about incoming events, type M-x +customize-group RET jabber-alerts. + +To activate logging of all chats, set jabber-history-enabled to t. By +default, history will be saved in ~/.jabber_global_message_log; make +sure that this file has appropriate permissions. Type M-x +customize-group RET jabber-history for more options. + +By default, jabber.el will send a confirmation when messages sent to +you are delivered and displayed, and also send "contact is typing" +notifications. To change this, type M-x customize-group RET +jabber-events, and set the three jabber-events-confirm-* variables to +nil. + +File transfer +============= +This release of jabber.el contains support for file transfer. You may +need to configure some variables to make it work; see the manual for +details. + +XMPP URIs +========= +It is possible to make various web browsers pass links starting with +"xmpp:" to jabber.el. In the ideal case, this works right after +running "make install". Otherwise, see the manual, section "XMPP +URIs". diff --git a/configure.ac b/configure.ac new file mode 100644 index 0000000..bc7d3b7 --- /dev/null +++ b/configure.ac @@ -0,0 +1,23 @@ +AC_INIT([jabber.el], + m4_esyscmd_s([sed -ne 's/^(defconst jabber-version "\(.*\)"$/\1/p' jabber-ourversion.el]), + [emacs-jabber-general@lists.sourceforge.net], + [emacs-jabber]) +AC_CONFIG_AUX_DIR([build-aux]) +dnl Need automake 1.11 for dist-xz option +AM_INIT_AUTOMAKE([1.11 -Wall -Werror foreign dist-bzip2 dist-xz dist-zip]) +AC_CONFIG_MACRO_DIR([m4]) + +AC_SUBST([CONFIG_STATUS_DEPENDENCIES], ['$(top_srcdir)/jabber-ourversion.el']) + +AM_PATH_LISPDIR +AS_IF([test "$EMACS" = no], [AC_MSG_ERROR([cannot find Emacs])]) + +dnl GConf schemas, for registering our URL handler +AC_PATH_PROG(GCONFTOOL, gconftool-2, no) +AM_CONDITIONAL(USE_GCONFTOOL, test "x$GCONFTOOL" != "xno") +AM_CONDITIONAL(GCONF_SCHEMAS_INSTALL, false) +m4_ifndef([AM_GCONF_SOURCE_2], [m4_defun([AM_GCONF_SOURCE_2])]) +AM_GCONF_SOURCE_2 + +AC_CONFIG_FILES([Makefile tests/Makefile gconf/Makefile]) +AC_OUTPUT diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..b9eb776 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,46 @@ +emacs-jabber (0.7.dev) unstable; urgency=low + + * Development snapshot; unofficial as far as Debian is concerned. + + -- Magnus Henoch <mange@freemail.hu> Mon, 17 Jul 2006 08:42:33 +0200 + +emacs-jabber (0.7) unstable; urgency=low + + * SSL connections + * Roster display optimized + * Uncountable minor features and bugfixes + + -- Magnus Henoch <mange@freemail.hu> Tue, 27 Dec 2005 12:55:10 +0100 + +emacs-jabber (0.6.1) unstable; urgency=low + + * Message history + * Activity tracking + * Notification for specific people going online + * Support for /me + * Improved MUC support + + -- Magnus Henoch <mange@freemail.hu> Thu, 23 Dec 2004 19:04:58 +0100 + +emacs-jabber (0.6) unstable; urgency=low + + * Chat buffer no longer uses minibuffer + * Roster and chat buffer prompts are customizable + + -- Magnus Henoch <mange@freemail.hu> Sat, 16 Oct 2004 21:11:58 +0200 + +emacs-jabber (0.5.1) unstable; urgency=low + + * Nicknames are accepted where JIDs are accepted. + * Roster line spacing customizable (default is none) + * Experimental file transfer support (see README) + + -- Magnus Henoch <mange@freemail.hu> Sat, 8 May 2004 21:49:26 +0200 + +emacs-jabber (0.5) unstable; urgency=low + + * Initial debianization. + + -- Magnus Henoch <mange@freemail.hu> Fri, 2 Apr 2004 23:04:36 +0200 + + diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..455f4bd --- /dev/null +++ b/debian/control @@ -0,0 +1,17 @@ +Source: emacs-jabber +Section: net +Priority: optional +Maintainer: Magnus Henoch <mange@freemail.hu> +Build-Depends: debhelper (>= 4.0.0), texinfo +Standards-Version: 3.6.1 + +Package: emacs-jabber +Architecture: all +Depends: gnus (>= 5.10.6-1.NO.20050713-1) | flim | emacs-snapshot | emacs22 +Description: Jabber client for Emacs/XEmacs + jabber.el (emacs-jabber) is an XMPP (Jabber) client for Emacs and XEmacs. + . + XMPP is an open instant messaging system. For more information on + XMPP, see http://xmpp.org/. + . + Homepage: http://emacs-jabber.sourceforge.net/ diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..f84a3fd --- /dev/null +++ b/debian/copyright @@ -0,0 +1,16 @@ +jabber.el was debianized by Magnus Henoch <mange@freemail.hu>. + +jabber.el can be found at http://emacs-jabber.sourceforge.net + +;; 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. + +On Debian GNU/Linux systems you can find a copy of the GPL in +/usr/share/common-licenses/GPL diff --git a/debian/emacsen-install.in b/debian/emacsen-install.in new file mode 100644 index 0000000..b203990 --- /dev/null +++ b/debian/emacsen-install.in @@ -0,0 +1,21 @@ +#! /bin/bash -e +# /usr/lib/emacsen-common/packages/install/emacs-jabber + +# Written by Jim Van Zandt <jrv@vanzandt.mv.com>, borrowing heavily +# from the install scripts for gettext by Santiago Vila +# <sanvila@ctv.es> and octave by Dirk Eddelbuettel <edd@debian.org>. +# +# Patched by Roland Mas <lolando@debian.org> to add support for lists +# of flavor-dependently included/excluded files + +FLAVOR=$1 +STAMPFILE=jabber.elc +PACKAGE=emacs-jabber + +# INCLUDED_emacs20="" +# INCLUDED_emacs21="" +# INCLUDED_xemacs21="" + +# EXCLUDED_emacs20="" +# EXCLUDED_emacs21="" +# EXCLUDED_xemacs21="" diff --git a/debian/emacsen-install.template b/debian/emacsen-install.template new file mode 100644 index 0000000..dca8669 --- /dev/null +++ b/debian/emacsen-install.template @@ -0,0 +1,87 @@ + +UNDERSCORED_FLAVOR=$(echo $FLAVOR | sed 's/-/_/g') +eval included_here=\$$(echo INCLUDED_$UNDERSCORED_FLAVOR) +eval excluded_here=\$$(echo EXCLUDED_$UNDERSCORED_FLAVOR) + +included_all=$(for i in ${!INCLUDED_*} ; do + eval echo \$$i + done | sort -u) + +excluded_all=$(for i in ${!EXCLUDED_*} ; do + eval echo \$$i + done | sort -u) + +if [ ${FLAVOR} = emacs ]; then exit 0; fi + +# Install-info-altdir does not actually exist. +# Maybe somebody will write it. +if test -x /usr/sbin/install-info-altdir; then + echo install/${PACKAGE}: install Info links for ${FLAVOR} + install-info-altdir --quiet --section "" "" --dirname=${FLAVOR} /usr/info/${PACKAGE}.info.gz +fi + +LOG=`tempfile -pelc_ -s.log -m644` +ELDIR=/usr/share/emacs/site-lisp/${PACKAGE} +ELCDIR=/usr/share/${FLAVOR}/site-lisp/${PACKAGE} +if test -e "${ELCDIR}/${STAMPFILE}"; then + echo "${PACKAGE} files already compiled in ${ELCDIR}." + exit +fi +echo install/${PACKAGE}: Handling ${FLAVOR}, logged in ${LOG} + +if [ -z "$FLAGS" ] ; then + FLAGS="-q -no-site-file --no-site-file -batch -l path.el -f batch-byte-compile" +fi + +install -m 755 -d ${ELCDIR} +cd ${ELDIR} + +# Now to compute the list of files to install... + +FILES=$(ls -1 *.el) +# Here we have all of them + +PATTERN="" +for i in $included_all $excluded_all ; do + [ ! -z "$PATTERN" ] && PATTERN="${PATTERN}\|" + PATTERN="${PATTERN}^$i\$" +done +FILES2=$FILES +if [ ! -z "$PATTERN" ] ; then + FILES=$(for i in $FILES2 ; do echo $i | grep -v $PATTERN || true ; done) +fi +# Here we only have those not explicitly included or excluded by any flavour + +FILES="$FILES $included_here" +# Here we also have those included for the current flavour + +for i in $excluded_all ; do + include_i="yes" + for j in $excluded_here ; do + [ $i = $j ] && include_i="no" + done + [ $include_i = "yes" ] && FILES="$FILES $i" +done +# And now we have those excluded by other flavours but not the current one + +FILES=$(for i in $FILES ; do echo $i ; done | sort -u) +# And now for my last trick... The list is now uniquified! + +cp ${FILES} ${ELCDIR} +cd ${ELCDIR} + +cat << EOF > path.el +(setq load-path (cons "." load-path) byte-compile-warnings nil) +EOF +if test "${APPEND_LOAD_PATH}" != "" +then + cat << EOF >> path.el +(setq load-path (append ${APPEND_LOAD_PATH} load-path)) +EOF +fi + +echo ${FLAVOR} ${FLAGS} ${FILES} >> ${LOG} +${FLAVOR} ${FLAGS} ${FILES} >> ${LOG} &> ${LOG} +rm -f *.el path.el + +exit 0 diff --git a/debian/emacsen-remove.in b/debian/emacsen-remove.in new file mode 100644 index 0000000..5486985 --- /dev/null +++ b/debian/emacsen-remove.in @@ -0,0 +1,5 @@ +#!/bin/sh -e +# /usr/lib/emacsen-common/packages/remove/emacs-jabber + +FLAVOR=$1 +PACKAGE=emacs-jabber diff --git a/debian/emacsen-remove.template b/debian/emacsen-remove.template new file mode 100644 index 0000000..c6a062e --- /dev/null +++ b/debian/emacsen-remove.template @@ -0,0 +1,10 @@ + +if [ ${FLAVOR} != emacs ]; then + if test -x /usr/sbin/install-info-altdir; then + echo remove/${PACKAGE}: removing Info links for ${FLAVOR} + install-info-altdir --quiet --remove --dirname=${FLAVOR} /usr/info/${PACKAGE}.info.gz + fi + + echo remove/${PACKAGE}: purging byte-compiled files for ${FLAVOR} + rm -rf /usr/share/${FLAVOR}/site-lisp/${PACKAGE} +fi diff --git a/debian/emacsen-startup b/debian/emacsen-startup new file mode 100644 index 0000000..0be558b --- /dev/null +++ b/debian/emacsen-startup @@ -0,0 +1,17 @@ +;; -*-emacs-lisp-*- +;; +;; Emacs startup file for jabber.el as packaged for Debian + +(if (not (file-exists-p "/usr/share/emacs/site-lisp/emacs-jabber")) + (message + "Package emacs-jabber removed but not purged. Skipping setup.") + (debian-pkg-add-load-path-item + (concat "/usr/share/" (symbol-name flavor) "/site-lisp/emacs-jabber")) + + ;; Make sure that the uncompiled files are also in the load-path, near the + ;; end. This is for moving point to the code when view help. + (setq load-path + (nconc load-path (list "/usr/share/emacs/site-lisp/emacs-jabber"))) + + (require 'jabber)) + diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..d31e5dc --- /dev/null +++ b/debian/rules @@ -0,0 +1,44 @@ +#!/usr/bin/make -f + +export DH_COMPAT=4 + +build: build-stamp +build-stamp: + dh_testdir + makeinfo jabber.texi + makeinfo --html -o html jabber.texi + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp + rm -rf html + dh_clean + +binary: binary-arch binary-indep + +binary-arch: + +binary-indep: build + dh_testdir + dh_testroot + dh_clean -k + dh_installdirs usr/share/emacs/site-lisp/emacs-jabber + + install -m 644 *.el debian/emacs-jabber/usr/share/emacs/site-lisp/emacs-jabber + cat debian/emacsen-install.in debian/emacsen-install.template > debian/emacsen-install + cat debian/emacsen-remove.in debian/emacsen-remove.template > debian/emacsen-remove + dh_installemacsen + dh_installdocs html README AUTHORS NEWS + dh_installinfo jabber.info + dh_installchangelogs + + dh_compress + dh_fixperms + dh_installdeb + dh_gencontrol + dh_md5sums + dh_builddeb + +.PHONY: binary-indep binary-arch binary clean build diff --git a/emacs-jabber-uri-handler b/emacs-jabber-uri-handler new file mode 100755 index 0000000..e60673d --- /dev/null +++ b/emacs-jabber-uri-handler @@ -0,0 +1,7 @@ +#!/bin/sh + +# Pass XMPP URIs to jabber.el. See `(jabber)XMPP URIs'. + +emacsclient -e "(jabber-handle-uri \"$1\")" + +# arch-tag: 3b655d90-0247-11db-86ba-000a95c2fcd0 diff --git a/gconf/Makefile.am b/gconf/Makefile.am new file mode 100644 index 0000000..abe0441 --- /dev/null +++ b/gconf/Makefile.am @@ -0,0 +1,14 @@ +schemadir = $(GCONF_SCHEMA_FILE_DIR) + +schema_DATA = emacs-jabber.schemas +CLEANFILES = $(schema_DATA) +EXTRA_DIST = emacs-jabber.schemas.in + +emacs-jabber.schemas: emacs-jabber.schemas.in Makefile + sed -e "s|@""libexecdir@""|$(libexecdir)|" < $(srcdir)/emacs-jabber.schemas.in > emacs-jabber.schemas + +install-data-local: + GCONF_CONFIG_SOURCE=$(GCONF_SCHEMA_CONFIG_SOURCE) $(GCONFTOOL) --makefile-install-rule $(schema_DATA) + +uninstall-local: + GCONF_CONFIG_SOURCE=$(GCONF_SCHEMA_CONFIG_SOURCE) $(GCONFTOOL) --makefile-uninstall-rule $(schema_DATA) diff --git a/gconf/emacs-jabber.schemas.in b/gconf/emacs-jabber.schemas.in new file mode 100644 index 0000000..2d1e2e6 --- /dev/null +++ b/gconf/emacs-jabber.schemas.in @@ -0,0 +1,38 @@ +<?xml version="1.0"?> +<gconfschemafile> + <schemalist> + <schema> + <key>/schemas/desktop/gnome/url-handlers/xmpp/enabled</key> + <applyto>/desktop/gnome/url-handlers/xmpp/enabled</applyto> + <owner>emacs-jabber</owner> + <type>bool</type> + <default>true</default> + <locale name="C"> + <short>Whether the specified command should handle "xmpp" URLs</short> + <long>True if the command specified in the "command" key should handle "xmpp" URLs.</long> + </locale> + </schema> + <schema> + <key>/schemas/desktop/gnome/url-handlers/xmpp/command</key> + <applyto>/desktop/gnome/url-handlers/xmpp/command</applyto> + <owner>emacs-jabber</owner> + <type>string</type> + <default>@libexecdir@/emacs-jabber-uri-handler "%s"</default> + <locale name="C"> + <short>The handler for "xmpp" URLs</short> + <long>The command used to handle "xmpp" URLs, if enabled.</long> + </locale> + </schema> + <schema> + <key>/schemas/desktop/gnome/url-handlers/xmpp/needs_terminal</key> + <applyto>/desktop/gnome/url-handlers/xmpp/needs_terminal</applyto> + <owner>emacs-jabber</owner> + <type>bool</type> + <default>false</default> + <locale name="C"> + <short>Run the command in a terminal</short> + <long>True if the command used to handle this type of URL should be run in a terminal.</long> + </locale> + </schema> + </schemalist> +</gconfschemafile> diff --git a/jabber-activity.el b/jabber-activity.el new file mode 100644 index 0000000..430283e --- /dev/null +++ b/jabber-activity.el @@ -0,0 +1,439 @@ +;;; jabber-activity.el --- show jabber activity in the mode line + +;; Copyright (C) 2004 Carl Henrik Lunde - <chlunde+jabber+@ping.uio.no> + +;; This file is a part of jabber.el + +;; 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, or (at your option) +;; any later version. + +;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Allows tracking messages from buddies using the global mode line +;; See (info "(jabber)Tracking activity") + +;;; TODO: + +;; - Make it possible to enable this mode using M-x customize +;; - When Emacs is on another desktop, (get-buffer-window buf 'visible) +;; returns nil. We need to know when the user selects the frame again +;; so we can remove the string from the mode line. (Or just run +;; jabber-activity-clean often). +;; - jabber-activity-switch-to needs a keybinding. In which map? +;; - Is there any need for having defcustom jabber-activity-make-string? +;; - When there's activity in a buffer it would be nice with a hook which +;; does the opposite of bury-buffer, so switch-to-buffer will show that +;; buffer first. + +;;; Code: + +(require 'jabber-core) +(require 'jabber-alert) +(require 'jabber-util) +(require 'jabber-muc-nick-completion) ;we need jabber-muc-looks-like-personal-p +(require 'cl) + +(defgroup jabber-activity nil + "activity tracking options" + :group 'jabber) + +;; All the (featurep 'jabber-activity) is so we don't call a function +;; with an autoloaded cookie while the file is loading, since that +;; would lead to endless load recursion. + +(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)) + +;;; Hooks + +(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)) + +;;; Interactive functions + +(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)) + +(provide 'jabber-activity) + +;; arch-tag: 127D7E42-356B-11D9-BE1E-000A95C2FCD0 diff --git a/jabber-ahc-presence.el b/jabber-ahc-presence.el new file mode 100644 index 0000000..063d3b6 --- /dev/null +++ b/jabber-ahc-presence.el @@ -0,0 +1,107 @@ +;; jabber-ahc-presence.el - provide remote control of presence + +;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-ahc) + +(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.")))))) + +(provide 'jabber-ahc-presence) + +;;; arch-tag: 4b8cbbe7-00a9-4d42-a4ac-b824ab914fba diff --git a/jabber-ahc.el b/jabber-ahc.el new file mode 100644 index 0000000..605c0f8 --- /dev/null +++ b/jabber-ahc.el @@ -0,0 +1,231 @@ +;; jabber-ahc.el - Ad-Hoc Commands by JEP-0050 + +;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-disco) +(require 'jabber-widget) + +(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.") + + +;;; SERVER +(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))))) + +;;; CLIENT +(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. (JEP-0050)" + (interactive (list (jabber-read-account) + (jabber-read-jid-completing "Request command list from: " nil nil nil 'full t))) + (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. (JEP-0050)" + (interactive (list (jabber-read-account) + (jabber-read-jid-completing "Execute command of: " nil nil nil 'full t) + (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")) + +(provide 'jabber-ahc) + +;;; arch-tag: c0d5ed8c-50cb-44e1-8e0f-4058b79ee353 diff --git a/jabber-alert.el b/jabber-alert.el new file mode 100644 index 0000000..105c5f4 --- /dev/null +++ b/jabber-alert.el @@ -0,0 +1,514 @@ +;; jabber-alert.el - alert hooks + +;; Copyright (C) 2003, 2004, 2005, 2007, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-util) + +(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))) + +;;; Info alert hooks + +(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)) + +(provide 'jabber-alert) + +;;; arch-tag: 725bd73e-c613-4fdc-a11d-3392a7598d4f diff --git a/jabber-autoaway.el b/jabber-autoaway.el new file mode 100644 index 0000000..625dc2e --- /dev/null +++ b/jabber-autoaway.el @@ -0,0 +1,211 @@ +;;; jabber-autoaway.el --- change status to away after idleness + +;; Copyright (C) 2010 - Kirill A. Korinskiy - catap@catap.ru +;; Copyright (C) 2010 - Terechkov Evgenii - evg@altlinux.org +;; Copyright (C) 2006, 2008 Magnus Henoch + +;; Author: Magnus Henoch <mange@freemail.hu> + +;; This file 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, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +(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))))) + +(provide 'jabber-autoaway) +;; arch-tag: 5bcea14c-842d-11da-a120-000a95c2fcd0 diff --git a/jabber-autoloads.stub b/jabber-autoloads.stub new file mode 100644 index 0000000..1701018 --- /dev/null +++ b/jabber-autoloads.stub @@ -0,0 +1,12 @@ +;;; jabber-autoloads.el --- automatically extracted autoloads +;; +;;; Code: + + +(provide 'jabber-autoloads) +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; jabber-autoloads.el ends here diff --git a/jabber-avatar.el b/jabber-avatar.el new file mode 100644 index 0000000..ac02523 --- /dev/null +++ b/jabber-avatar.el @@ -0,0 +1,234 @@ +;;; jabber-avatar.el --- generic functions for avatars + +;; Copyright (C) 2006, 2007, 2008 Magnus Henoch + +;; Author: Magnus Henoch <mange@freemail.hu> + +;; This file 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, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; There are several methods for transporting avatars in Jabber +;; (JEP-0008, JEP-0084, JEP-0153). They all have in common that they +;; identify avatars by their SHA1 checksum, and (at least partially) +;; use Base64-encoded image data. Thus this library of support +;; functions for interpreting and caching avatars. + +;; A contact with an avatar has the image in the avatar property of +;; the JID symbol. Use `jabber-avatar-set' to set it. + +;;; Code: + +(require 'mailcap) +(eval-when-compile (require 'cl)) + +;;;; Variables + +(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) + +;;;; Avatar data handling + +(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 JEP-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)) + +;;;; Avatar cache + +(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)) + +(provide 'jabber-avatar) +;; arch-tag: 2405c3f8-8eaa-11da-826c-000a95c2fcd0 diff --git a/jabber-awesome.el b/jabber-awesome.el new file mode 100644 index 0000000..692e673 --- /dev/null +++ b/jabber-awesome.el @@ -0,0 +1,42 @@ +;; jabber-awesome.el - emacs-jabber interface to awesome and naughty + +;; Copyright (C) 2009 - Evgenii Terechkov - evg@altlinux.org + +;; This file is a part of jabber.el. + +;; 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 + +(eval-when-compile (require 'jabber-alert)) + +(defcustom jabber-awesome-args ", timeout=5" + "Additional args to naughty." + :type 'string + :group 'jabber-alerts) + +(defun jabber-awesome-message (text &optional title) + "Show MSG in Awesome" + ;; Possible errors include not finding the awesome binary. + (condition-case e + (let ((process-connection-type)) + (shell-command-to-string (format "echo 'naughty.notify({text = \"%s\" %s})' | awesome-client -" + (or title text) jabber-awesome-args)) + ) + (error nil))) + +(define-jabber-alert awesome "Show a message through the Awesome window manager" + 'jabber-awesome-message) +(define-personal-jabber-alert jabber-muc-awesome) + +(provide 'jabber-awesome) diff --git a/jabber-bookmarks.el b/jabber-bookmarks.el new file mode 100644 index 0000000..5a9f39f --- /dev/null +++ b/jabber-bookmarks.el @@ -0,0 +1,248 @@ +;; jabber-bookmarks.el - bookmarks according to XEP-0048 + +;; Copyright (C) 2007, 2008 - Magnus Henoch - mange@freemail.hu + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-private) +(require 'jabber-widget) + +(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))) + +(provide 'jabber-bookmarks) +;; arch-tag: a7d6f862-bac0-11db-831f-000a95c2fcd0 diff --git a/jabber-browse.el b/jabber-browse.el new file mode 100644 index 0000000..78dc124 --- /dev/null +++ b/jabber-browse.el @@ -0,0 +1,100 @@ +;; jabber-browse.el - jabber browsing by JEP-0011 + +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net +;; Copyright (C) 2003, 2004 - Magnus Henoch - mange@freemail.hu + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-iq) +(require 'jabber-xml) +(require 'jabber-util) + +;; jabber.el can perform browse requests, but will not answer them. + +(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 + ;; JEP-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)))))) + +(provide 'jabber-browse) + +;;; arch-tag: be01ab34-96eb-4fcb-aa35-a0d3e6c446c3 diff --git a/jabber-chat.el b/jabber-chat.el new file mode 100644 index 0000000..6feaad5 --- /dev/null +++ b/jabber-chat.el @@ -0,0 +1,683 @@ +;; jabber-chat.el - one-to-one chats + +;; Copyright (C) 2005, 2007, 2008 - Magnus Henoch - mange@freemail.hu + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-core) +(require 'jabber-chatbuffer) +(require 'jabber-history) +(require 'jabber-menu) ;we need jabber-jid-chat-menu +(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 + jabber-chatting-with 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-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. + (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)) + (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 + ;; `goto-address' is autoloaded, but `goto-address-fontify' is not. + (require 'goto-addr) + (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))))) + +;; jabber-compose is autoloaded in jabber.el +(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")))) + +(provide 'jabber-chat) + +;; arch-tag: f423eb92-aa87-475b-b590-48c93ccba9be diff --git a/jabber-chatbuffer.el b/jabber-chatbuffer.el new file mode 100644 index 0000000..2ea9119 --- /dev/null +++ b/jabber-chatbuffer.el @@ -0,0 +1,137 @@ +;; jabber-chatbuffer.el - functions common to all chat buffers + +;; Copyright (C) 2005, 2007, 2008 - Magnus Henoch - mange@freemail.hu + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-keymap) + +(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)))))) + +(provide 'jabber-chatbuffer) +;; arch-tag: 917e5b60-5894-4c49-b3bc-12e1f97ffdc6 diff --git a/jabber-chatstates.el b/jabber-chatstates.el new file mode 100644 index 0000000..83090f8 --- /dev/null +++ b/jabber-chatstates.el @@ -0,0 +1,177 @@ +;;; jabber-chatstate.el --- Chat state notification (XEP-0085) implementation + +;; Author: Ami Fischman <ami@fischman.org> +;; (based entirely on jabber-events.el by Magnus Henoch <mange@freemail.hu>) + +;; This file 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, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;; TODO +;; - Currently only active/composing notifications are /sent/ though all 5 +;; notifications are handled on receipt. + +(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) + +;;; INCOMING +;;; Code for requesting chat state notifications from others and handling +;;; them. + +(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)))))) + +;;; OUTGOING +;;; Code for handling requests for chat state notifications and providing +;;; them, modulo user preferences. + +(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))))) + +;;; COMMON + +(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") + +(provide 'jabber-chatstates) +;; arch-tag: d879de90-51e1-11dc-909d-000a95c2fcd0 diff --git a/jabber-compose.el b/jabber-compose.el new file mode 100644 index 0000000..8b721ab --- /dev/null +++ b/jabber-compose.el @@ -0,0 +1,82 @@ +;;; jabber-compose.el --- compose a Jabber message in a buffer + +;; Copyright (C) 2006, 2007 Magnus Henoch + +;; Author: Magnus Henoch <mange@freemail.hu> +;; Keywords: + +;; This file 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, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Code: + +;;;###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"))) + +(provide 'jabber-compose) +;; arch-tag: 59032c00-994d-11da-8d97-000a95c2fcd0 diff --git a/jabber-conn.el b/jabber-conn.el new file mode 100644 index 0000000..6a4c2d5 --- /dev/null +++ b/jabber-conn.el @@ -0,0 +1,396 @@ +;; jabber-conn.el - Network transport functions + +;; Copyright (C) 2005 - Georg Lehner - jorge@magma.com.ni +;; mostly inspired by Gnus. + +;; Copyright (C) 2005 - Carl Henrik Lunde - chlunde+jabber+@ping.uio.no +;; (starttls) + +;; This file is a part of jabber.el. + +;; 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 + +;; A collection of functions, that hide the details of transmitting to +;; and fro a Jabber Server + +(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)) + +(require 'srv) + +(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)) + +(provide 'jabber-conn) +;; arch-tag: f95ec240-8cd3-11d9-9dbf-000a95c2fcd0 diff --git a/jabber-console.el b/jabber-console.el new file mode 100644 index 0000000..7b2b4e3 --- /dev/null +++ b/jabber-console.el @@ -0,0 +1,143 @@ +;; jabber-console.el - XML Console mode + +;; Copyright (C) 2009, 2010 - Demyan Rogozhin <demyan.rogozhin@gmail.com> + +;; 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: + +;; Use *-jabber-console-* for sending custom XMPP code. Be careful! + +;;; Code: + +(require 'jabber-keymap) +(require 'jabber-util) +(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))))))) + +(provide 'jabber-console) +;;; jabber-console.el ends here diff --git a/jabber-core.el b/jabber-core.el new file mode 100644 index 0000000..9258647 --- /dev/null +++ b/jabber-core.el @@ -0,0 +1,1006 @@ +;; jabber-core.el - core functions + +;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; SSL-Connection Parts: +;; Copyright (C) 2005 - Georg Lehner - jorge@magma.com.ni + +;; This file is a part of jabber.el. + +;; 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 + +(require 'cl) + +(require 'jabber-util) +(require 'jabber-logon) +(require 'jabber-conn) +(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."))) + +(require 'jabber-sasl) +(require 'jabber-console) + +(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") + +;; jabber-connect and jabber-connect-all should load jabber.el, not +;; just jabber-core.el, when autoloaded. + +;;;###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))) + + (require 'jabber) + + (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 (interactive-p) + (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 (interactive-p) + (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))) + +(provide 'jabber-core) + +;;; arch-tag: 9d273ce6-c45a-447b-abf3-21d3ce73a51a diff --git a/jabber-disco.el b/jabber-disco.el new file mode 100644 index 0000000..4669e17 --- /dev/null +++ b/jabber-disco.el @@ -0,0 +1,652 @@ +;; jabber-disco.el - service discovery functions + +;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-iq) +(require 'jabber-xml) +(require 'jabber-menu) + +;;; Respond to disco requests + +(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 JEP-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))) + +;;; Interactive disco requests + +(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")))) + +;;; Caching API for disco requests + +;; 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)) + +;;; Publish + +(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")) + +;;; Entity Capabilities (XEP-0115) + +;;;###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)))))) + +;;; Entity Capabilities utility functions + +(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))))))))) + +;;; Sending Entity Capabilities + +(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)) + +(provide 'jabber-disco) + +;;; arch-tag: 71f5c76f-2956-4ed2-b871-9f5fe198092d diff --git a/jabber-events.el b/jabber-events.el new file mode 100644 index 0000000..f78030a --- /dev/null +++ b/jabber-events.el @@ -0,0 +1,245 @@ +;;; jabber-events.el --- Message events (JEP-0022) implementation + +;; Copyright (C) 2005, 2008 Magnus Henoch + +;; Author: Magnus Henoch <mange@freemail.hu> + +;; This file 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, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +(require 'cl) + +(defgroup jabber-events nil + "Message events and notifications." + :group 'jabber) + +;;; INCOMING +;;; Code for requesting event notifications from others and handling +;;; them. + +(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)))) + +;;; OUTGOING +;;; Code for handling requests for event notifications and providing +;;; them, modulo user preferences. + +(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)))) + +;;; COMMON + +;; Add function last in chain, so a chat buffer is already created. +(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))))))))) + +(provide 'jabber-events) +;; arch-tag: 7b6e61fe-a9b3-11d9-afca-000a95c2fcd0 diff --git a/jabber-export.el b/jabber-export.el new file mode 100644 index 0000000..63b7df5 --- /dev/null +++ b/jabber-export.el @@ -0,0 +1,251 @@ +;;; jabber-export.el --- export Jabber roster to file + +;; Copyright (C) 2005, 2007 Magnus Henoch + +;; Author: Magnus Henoch <mange@freemail.hu> + +;; This file 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, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +(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))) + +(provide 'jabber-export) + +;;; arch-tag: 9c6b94a9-290a-4c0f-9286-72bd9c1fb8a3 diff --git a/jabber-fallback-lib/.nosearch b/jabber-fallback-lib/.nosearch new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/jabber-fallback-lib/.nosearch diff --git a/jabber-fallback-lib/fsm.el b/jabber-fallback-lib/fsm.el new file mode 100644 index 0000000..e97dc09 --- /dev/null +++ b/jabber-fallback-lib/fsm.el @@ -0,0 +1,421 @@ +;;; fsm.el --- state machine library + +;; Copyright (C) 2006, 2007, 2008 Magnus Henoch + +;; Author: Magnus Henoch <mange@freemail.hu> +;; Version: 0.1ttn4 + +;; This file 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, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; fsm.el is an exercise in metaprogramming inspired by gen_fsm of +;; Erlang/OTP. It aims to make asynchronous programming in Emacs Lisp +;; easy and fun. By "asynchronous" I mean that long-lasting tasks +;; don't interfer with normal editing. + +;; Some people say that it would be nice if Emacs Lisp had threads +;; and/or continuations. They are probably right, but there are few +;; things that can't be made to run in the background using facilities +;; already available: timers, filters and sentinels. As the code can +;; become a bit messy when using such means, with callbacks everywhere +;; and such things, it can be useful to structure the program as a +;; state machine. + +;; In this model, a state machine passes between different "states", +;; which are actually only different event handler functions. The +;; state machine receives "events" (from timers, filters, user +;; requests, etc) and reacts to them, possibly entering another state, +;; possibly returning a value. + +;; The essential macros/functions are: +;; +;; define-state-machine - create start-FOO function +;; define-state - event handler for each state (required) +;; define-enter-state - called when entering a state (optional) +;; define-fsm - encapsulates the above three (more sugar!) +;; fsm-send - send an event to a state machine +;; fsm-call - send an event and wait for reply + +;; fsm.el is similar to but different from Distel: +;; <URL:http://fresh.homeunix.net/~luke/distel/> +;; Emacs' tq library is a similar idea. + +;; Here is a simple (not using all the features of fsm.el) example: +;; +;; (require 'cl) +;; (labels ((hey (n ev) +;; (message "%d (%s)\tp%sn%s!" n ev +;; (if (zerop (% n 4)) "o" "i") +;; (make-string (max 1 (abs n)) ?g)))) +;; (macrolet ((zow (next timeout) +;; `(progn (hey (incf count) event) +;; (list ,next count ,timeout)))) +;; (define-fsm pingpong +;; :start ((init) "Start a pingpong fsm." +;; (interactive "nInit (number, negative to auto-terminate): ") +;; (list :ping (ash (ash init -2) 2) ; 4 is death +;; (when (interactive-p) 0))) +;; :state-data-name count +;; :states +;; ((:ping +;; (:event (zow :pingg 0.1))) +;; (:pingg +;; (:event (zow :pinggg 0.1))) +;; (:pinggg +;; (:event (zow :pong 1))) +;; (:pong +;; (:event (zow :ping (if (= 0 count) +;; (fsm-goodbye-cruel-world 'pingpong) +;; 3)))))))) +;; +;; (fsm-send (start-pingpong -16) t) +;; +;; Copy into a buffer, uncomment, and type M-x eval-buffer RET. +;; Alternatively, you can replace the `fsm-goodbye-cruel-world' +;; form with `nil', eval just the `labels' form and then type +;; M-x start-pingpong RET -16 RET. + +;; NOTE: This is version 0.1ttn4 of fsm.el, with the following +;; mods (an exercise in meta-meta-programming ;-) by ttn: +;; -- Refill for easy (traditional 80-column) perusal. +;; -- New var `fsm-debug-timestamp-format'. +;; -- Make variables satisfy `user-variable-p'. +;; -- Use `format' instead of `concat'. +;; -- New func `fsm-goodbye-cruel-world'. +;; -- Make start-function respect `interactive' spec. +;; -- Make enter-/event-functions anonymous. +;; -- New macro `define-fsm'. +;; -- Example usage in Commentary. + +;;; Code: + +;; We require cl at runtime, since we insert `destructuring-bind' into +;; modules that use fsm.el. +(require 'cl) + +(defvar fsm-debug "*fsm-debug*" + "*Name of buffer for fsm debug messages. +If nil, don't output debug messages.") + +(defvar fsm-debug-timestamp-format nil + "*Timestamp format (a string) for `fsm-debug-output'. +Default format is whatever `current-time-string' returns +followed by a colon and a space.") + +(defun fsm-debug-output (format &rest args) + "Append debug output to buffer named by the variable `fsm-debug'. +FORMAT and ARGS are passed to `format'." + (when fsm-debug + (with-current-buffer (get-buffer-create fsm-debug) + (save-excursion + (goto-char (point-max)) + (insert (if fsm-debug-timestamp-format + (format-time-string fsm-debug-timestamp-format) + (concat (current-time-string) ": ")) + (apply 'format format args) "\n"))))) + +(defmacro* define-state-machine (name &key start sleep) + "Define a state machine class called NAME. +A function called start-NAME is created, which uses the argument +list and body specified in the :start argument. BODY should +return a list of the form (STATE STATE-DATA [TIMEOUT]), where +STATE is the initial state (defined by `define-state'), +STATE-DATA is any object, and TIMEOUT is the number of seconds +before a :timeout event will be sent to the state machine. BODY +may refer to the instance being created through the dynamically +bound variable `fsm'. + +SLEEP-FUNCTION, if provided, takes one argument, the number of +seconds to sleep while allowing events concerning this state +machine to happen. There is probably no reason to change the +default, which is accept-process-output with rearranged +arguments. + +\(fn NAME :start ((ARG ...) DOCSTRING BODY) [:sleep SLEEP-FUNCTION])" + (declare (debug (&define name :name start + &rest + &or [":start" + (lambda-list + [&optional ("interactive" interactive)] + stringp def-body)] + [":sleep" function-form]))) + (let ((start-name (intern (format "start-%s" name))) + interactive-spec) + (destructuring-bind (arglist docstring &body body) start + (when (and (consp (car body)) (eq 'interactive (caar body))) + (setq interactive-spec (list (pop body)))) + (unless (stringp docstring) + (error "Docstring is not a string")) + `(progn + (put ',name :fsm-enter (make-hash-table :size 11 :test 'eq)) + (put ',name :fsm-event (make-hash-table :size 11 :test 'eq)) + (defun ,start-name ,arglist + ,docstring + ,@interactive-spec + (fsm-debug-output "Starting %s" ',name) + (let ((fsm (gensym (concat "fsm-" ,(symbol-name name) "-")))) + (destructuring-bind (state state-data &optional timeout) + (progn ,@body) + (put fsm :name ',name) + (put fsm :state nil) + (put fsm :state-data nil) + (put fsm :sleep ,(or sleep (lambda (secs) + (accept-process-output + nil secs)))) + (put fsm :deferred nil) + (fsm-update fsm state state-data timeout) + fsm))))))) + +(defmacro* define-state (fsm-name state-name arglist &body body) + "Define a state called STATE-NAME in the state machine FSM-NAME. +ARGLIST and BODY make a function that gets called when the state +machine receives an event in this state. The arguments are: + +FSM the state machine instance (treat it as opaque) +STATE-DATA An object +EVENT The occurred event, an object. +CALLBACK A function of one argument that expects the response + to this event, if any (often `ignore' is used) + +If the event should return a response, the state machine should +arrange to call CALLBACK at some point in the future (not necessarily +in this handler). + +The function should return a list of the form (NEW-STATE +NEW-STATE-DATA TIMEOUT): + +NEW-STATE The next state, a symbol +NEW-STATE-DATA An object +TIMEOUT A number: send timeout event after this many seconds + nil: cancel existing timer + :keep: let existing timer continue + +Alternatively, the function may return the keyword :defer, in +which case the event will be resent when the state machine enters +another state." + (declare (debug (&define name name :name handler lambda-list def-body))) + `(setf (gethash ',state-name (get ',fsm-name :fsm-event)) + (lambda ,arglist ,@body))) + +(defmacro* define-enter-state (fsm-name state-name arglist &body body) + "Define a function to call when FSM-NAME enters the state STATE-NAME. +ARGLIST and BODY make a function that gets called when the state +machine enters this state. The arguments are: + +FSM the state machine instance (treat it as opaque) +STATE-DATA An object + +The function should return a list of the form (NEW-STATE-DATA +TIMEOUT): + +NEW-STATE-DATA An object +TIMEOUT A number: send timeout event after this many seconds + nil: cancel existing timer + :keep: let existing timer continue" + (declare (debug (&define name name :name enter lambda-list def-body))) + `(setf (gethash ',state-name (get ',fsm-name :fsm-enter)) + (lambda ,arglist ,@body))) + +(defmacro* define-fsm (name &key + start sleep states + (fsm-name 'fsm) + (state-data-name 'state-data) + (callback-name 'callback) + (event-name 'event)) + "Define a state machine class called NAME, along with its STATES. +This macro is (further) syntatic sugar for `define-state-machine', +`define-state' and `define-enter-state' macros, q.v. + +NAME is a symbol. Everything else is specified with a keyword arg. + +START and SLEEP are the same as for `define-state-machine'. + +STATES is a list, each element having the form (STATE-NAME . STATE-SPEC). +STATE-NAME is a symbol. STATE-SPEC is an alist with keys `:event' or +`:enter', and values a series of expressions representing the BODY of +a `define-state' or `define-enter-state' call, respectively. + +FSM-NAME, STATE-DATA-NAME, CALLBACK-NAME, and EVENT-NAME are symbols, +used to construct the state functions' arglists." + `(progn + (define-state-machine ,name :start ,start :sleep ,sleep) + ,@(loop for (state-name . spec) in states + if (assq :enter spec) collect + `(define-enter-state ,name ,state-name + (,fsm-name ,state-data-name) + ,@(cdr it)) + end + if (assq :event spec) collect + `(define-state ,name ,state-name + (,fsm-name ,state-data-name + ,event-name + ,callback-name) + ,@(cdr it)) + end))) + +(defun fsm-goodbye-cruel-world (name) + "Unbind functions related to fsm NAME (a symbol). +Includes start-NAME, and each fsm-NAME-STATE and fsm-NAME-enter-STATE. +Functions are `fmakunbound', which will probably give (fatal) pause to +any state machines using them. Return nil." + (interactive "SUnbind function definitions for fsm named: ") + (fmakunbound (intern (format "start-%s" name))) + (let (ht) + (when (hash-table-p (setq ht (get name :fsm-event))) + (clrhash ht) + (remprop name :fsm-event)) + (when (hash-table-p (setq ht (get name :fsm-enter))) + (clrhash ht) + (remprop name :fsm-enter))) + nil) + +(defun fsm-start-timer (fsm secs) + "Send a timeout event to FSM after SECS seconds. +The timer is canceled if another event occurs before, unless the +event handler explicitly asks to keep the timer." + (fsm-stop-timer fsm) + (put fsm + :timeout (run-with-timer + secs nil + #'fsm-send-sync fsm :timeout))) + +(defun fsm-stop-timer (fsm) + "Stop the timeout timer of FSM." + (let ((timer (get fsm :timeout))) + (when (timerp timer) + (cancel-timer timer) + (put fsm :timeout nil)))) + +(defun fsm-maybe-change-timer (fsm timeout) + "Change the timer of FSM according to TIMEOUT." + (cond + ((numberp timeout) + (fsm-start-timer fsm timeout)) + ((null timeout) + (fsm-stop-timer fsm)) + ;; :keep needs no timer change + )) + +(defun fsm-send (fsm event &optional callback) + "Send EVENT to FSM asynchronously. +If the state machine generates a response, eventually call +CALLBACK with the response as only argument." + (run-with-timer 0 nil #'fsm-send-sync fsm event callback)) + +(defun fsm-update (fsm new-state new-state-data timeout) + (let ((fsm-name (get fsm :name)) + (old-state (get fsm :state))) + (put fsm :state new-state) + (put fsm :state-data new-state-data) + (fsm-maybe-change-timer fsm timeout) + + ;; On state change, call enter function and send deferred events + ;; again. + (unless (eq old-state new-state) + (fsm-debug-output "%s enters %s" fsm-name new-state) + (let ((enter-fn (gethash new-state (get fsm-name :fsm-enter)))) + (when (functionp enter-fn) + (fsm-debug-output "Found enter function for %S" new-state) + (condition-case e + (destructuring-bind (newer-state-data newer-timeout) + (funcall enter-fn fsm new-state-data) + (fsm-debug-output "Using data from enter function") + (put fsm :state-data newer-state-data) + (fsm-maybe-change-timer fsm newer-timeout)) + ((debug error) + (fsm-debug-output "Didn't work: %S" e))))) + + (let ((deferred (nreverse (get fsm :deferred)))) + (put fsm :deferred nil) + (dolist (event deferred) + (apply 'fsm-send-sync fsm event)))))) + +(defun fsm-send-sync (fsm event &optional callback) + "Send EVENT to FSM synchronously. +If the state machine generates a response, eventually call +CALLBACK with the response as only argument." + (save-match-data + (let* ((fsm-name (get fsm :name)) + (state (get fsm :state)) + (state-data (get fsm :state-data)) + (state-fn (gethash state (get fsm-name :fsm-event)))) + ;; If the event is a list, output only the car, to avoid an + ;; overflowing debug buffer. + (fsm-debug-output "Sent %S to %s in state %s" + (or (car-safe event) event) fsm-name state) + (let ((result (condition-case e + (funcall state-fn fsm state-data event + (or callback 'ignore)) + ((debug error) (cons :error-signaled e))))) + ;; Special case for deferring an event until next state change. + (cond + ((eq result :defer) + (let ((deferred (get fsm :deferred))) + (put fsm :deferred (cons (list event callback) deferred)))) + ((null result) + (fsm-debug-output "Warning: event %S ignored in state %s/%s" event fsm-name state)) + ((eq (car-safe result) :error-signaled) + (fsm-debug-output "Error in %s/%s: %s" + fsm-name state + (error-message-string (cdr result)))) + ((and (listp result) + (<= 2 (length result)) + (<= (length result) 3)) + (destructuring-bind (new-state new-state-data &optional timeout) result + (fsm-update fsm new-state new-state-data timeout))) + (t + (fsm-debug-output "Incorrect return value in %s/%s: %S" + fsm-name state + result))))))) + +(defun fsm-call (fsm event) + "Send EVENT to FSM synchronously, and wait for a reply. +Return the reply. +`with-timeout' might be useful." + (lexical-let (reply) + (fsm-send-sync fsm event (lambda (r) (setq reply (list r)))) + (while (null reply) + (fsm-sleep fsm 1)) + (car reply))) + +(defun fsm-make-filter (fsm) + "Return a filter function that sends events to FSM. +Events sent are of the form (:filter PROCESS STRING)." + (lexical-let ((fsm fsm)) + (lambda (process string) + (fsm-send-sync fsm (list :filter process string))))) + +(defun fsm-make-sentinel (fsm) + "Return a sentinel function that sends events to FSM. +Events sent are of the form (:sentinel PROCESS STRING)." + (lexical-let ((fsm fsm)) + (lambda (process string) + (fsm-send-sync fsm (list :sentinel process string))))) + +(defun fsm-sleep (fsm secs) + "Sleep up to SECS seconds in a way that lets FSM receive events." + (funcall (get fsm :sleep) secs)) + +(defun fsm-get-state-data (fsm) + "Return the state data of FSM. +Note the absence of a set function. The fsm should manage its +state data itself; other code should just send messages to it." + (get fsm :state-data)) + +(provide 'fsm) + +;;; fsm.el ends here diff --git a/jabber-fallback-lib/hexrgb.el b/jabber-fallback-lib/hexrgb.el new file mode 100644 index 0000000..57f2c2c --- /dev/null +++ b/jabber-fallback-lib/hexrgb.el @@ -0,0 +1,731 @@ +;;; hexrgb.el --- Functions to manipulate colors, including RGB hex strings. +;; +;; Filename: hexrgb.el +;; Description: Functions to manipulate colors, including RGB hex strings. +;; Author: Drew Adams +;; Maintainer: Drew Adams +;; Copyright (C) 2004-2009, Drew Adams, all rights reserved. +;; Created: Mon Sep 20 22:58:45 2004 +;; Version: 21.0 +;; Last-Updated: Sat Nov 14 15:55:15 2009 (-0800) +;; By: dradams +;; Update #: 732 +;; URL: http://www.emacswiki.org/cgi-bin/wiki/hexrgb.el +;; Keywords: number, hex, rgb, color, background, frames, display +;; Compatibility: GNU Emacs: 20.x, 21.x, 22.x, 23.x +;; +;; Features that might be required by this library: +;; +;; None +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; Functions to manipulate colors, including RGB hex strings. +;; +;; This library provides functions for converting between RGB (red, +;; green, blue) color components and HSV (hue, saturation, value) +;; color components. It helps you convert among Emacs color values +;; (whole numbers from 0 through 65535), RGB and HSV floating-point +;; components (0.0 through 1.0), Emacs color-name strings (such as +;; "blue"), and hex RGB color strings (such as "#FC43A7912"). +;; +;; An RGB hex string, such as used as a frame `background-color' +;; property, is a string of 1 + (3 * n) characters, the first of +;; which is "#". The other characters are hexadecimal digits, in +;; three groups representing (from the left): red, green, and blue +;; hex codes. +;; +;; Constants defined here: +;; +;; `hexrgb-defined-colors', `hexrgb-defined-colors-alist', +;; `hexrgb-defined-colors-no-dups', +;; `hexrgb-defined-colors-no-dups-alist'. +;; +;; Options defined here: +;; +;; `hexrgb-canonicalize-defined-colors-flag'. +;; +;; Commands defined here: +;; +;; `hexrgb-blue', `hexrgb-complement', `hexrgb-green', +;; `hexrgb-hue', `hexrgb-read-color', `hexrgb-red', +;; `hexrgb-saturation', `hexrgb-value'. +;; +;; Non-interactive functions defined here: +;; +;; `hexrgb-approx-equal', `hexrgb-canonicalize-defined-colors', +;; `hexrgb-color-name-to-hex', `hexrgb-color-values-to-hex', +;; `hexrgb-color-value-to-float', `hexrgb-defined-colors', +;; `hexrgb-defined-colors-alist', +;; `hexrgb-delete-whitespace-from-string', +;; `hexrgb-float-to-color-value', `hexrgb-hex-char-to-integer', +;; `hexrgb-hex-to-color-values', `hexrgb-hex-to-hsv', +;; `hexrgb-hex-to-rgb', `hexrgb-hsv-to-hex', `hexrgb-hex-to-int', +;; `hexrgb-hsv-to-rgb', `hexrgb-increment-blue', +;; `hexrgb-increment-equal-rgb', `hexrgb-increment-green', +;; `hexrgb-increment-hex', `hexrgb-increment-red', +;; `hexrgb-int-to-hex', `hexrgb-rgb-hex-string-p', +;; `hexrgb-rgb-to-hex', `hexrgb-rgb-to-hsv'. +;; +;; +;; Add this to your initialization file (~/.emacs or ~/_emacs): +;; +;; (require 'hexrgb) +;; +;; Do not try to use this library without a window manager. +;; That is, do not use this with `emacs -nw'. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Change log: +;; +;; 2009/11/14 dadams +;; hexrgb-rgb-to-hsv: Corrected hue when > 1.0. Use strict inequality for hue limit tests. +;; hexrgb-approx-equal: Convert RFUZZ and AFUZZ to their absolute values. +;; 2009/11/03 dadams +;; Added: hexrgb-delete-whitespace-from-string, hexrgb-canonicalize-defined-colors, +;; hexrgb-defined-colors(-no-dups)(-alist), hexrgb-canonicalize-defined-colors-flag. +;; hexrgb-read-color: Use function hexrgb-defined-colors-alist, not the constant. +;; 2008/12/25 dadams +;; hexrgb-rgb-to-hsv: +;; Replace (not (equal 0.0e+NaN saturation)) by standard test (= saturation saturation). +;; Thx to Michael Heerdegen for the bug report. +;; 2008-10-17 dadams +;; hexrgb-defined-colors(-alist): Prevent load-time error if user tries to use emacs -nw. +;; 2007/12/30 dadams +;; Added: hexrgb-hex-to-color-values. +;; 2007/10/20 dadams +;; hexrgb-read-color: Treat pseudo colors too (e.g. *point foreground*). +;; 2007/01/21 dadams +;; hexrgb-read-color: Error if empty string (and not allow-empty-name-p). +;; 2006/06/06 dadams +;; Added: hexrgb-defined-colors(-alist). Use instead of (x-defined-colors). +;; hexrgb-(red|green|blue): Added interactive specs. +;; 2006/06/04 dadams +;; hexrgb-read-color: Added optional arg allow-empty-name-p. +;; 2006/06/02 dadams +;; Added: hexrgb-rgb-hex-string-p. Used it. +;; 2006/05/30 dadams +;; Added: hexrgb-hex-to-(hsv|rgb), hexrgb-hsv-to-hex, hexrgb-color-name-to-hex, +;; hexrgb-complement, hexrgb-read-color, hexrgb-hue, hexrgb-saturation, +;; hexrgb-value, hexrgb-red, hexrgb-blue, hexrgb-green. +;; approx-equal: Add optional fuzz factor arguments. Changed the algorithm. +;; Renamed: approx-equal to hexrgb-approx-equal. +;; hexrgb-rgb-to-hsv: Changed test from < to <=: (when (<= hue 0.0)...). +;; hexrgb-hsv-to-rgb: Treat hue = 0.0 (int 0) the same as hue = 1.0 (int 6). +;; hexrgb-rgb-to-hex, hexrgb-increment-hex: Corrected doc strings. +;; 2006/05/22 dadams +;; Added: hexrgb-hsv-to-hex, hexrgb-rgb-to-hex. Require cl.el when byte-compile. +;; 2005/08/09 dadams +;; hexrgb-rgb-to-hsv: Side-stepped Emacs-20 bug in comparing NaN. +;; hexrgb-increment-*: Added optional arg wrap-p. +;; hexrgb-increment-hex: Prevent wrap if not wrap-p. +;; 2005/08/02 dadams +;; hexrgb-rgb-to-hes: Bug fix: If delta is zero, then so are hue and saturation. +;; 2005/06/24 dadams +;; hexrgb-rgb-to-hsv: Bug fix: test for NaN (e.g. on divide by zero). +;; 2005/02/08 dadams +;; hexrgb-hsv-to-rgb: Bug fix (typo: p, q -> pp, qq; added ww). +;; 2005/01/09 dadams +;; hexrgb-int-to-hex: Fixed bug in hexrgb-int-to-hex: nb-digits not respected. +;; Added: hexrgb-hsv-to-rgb, hexrgb-rgb-to-hsv, approx-equal. +;; Renamed old hexrgb-increment-value to hexrgb-increment-equal-rgb. +;; 2005/01/05 dadams +;; hexrgb-int-to-hex: Used a suggestion from Juri Linkov. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; 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, 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; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth +;; Floor, Boston, MA 02110-1301, USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Code: + +(eval-when-compile (require 'cl)) ;; case; plus, for Emacs < 20: when, unless + +;; Unless you first load `hexrgb.el', then either `palette.el' or `eyedropper.el', you will get +;; warnings about variables and functions with prefix `eyedrop-' when you byte-compile +;; `hexrgb.el'. You can ignore these warnings. + +(defvar eyedrop-picked-foreground) +(defvar eyedrop-picked-background) + +;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;###autoload +(eval-and-compile + (defun hexrgb-canonicalize-defined-colors (list) + "Copy of LIST with color names canonicalized. +LIST is a list of color names (strings). +Canonical names are lowercase, with no whitespace. +There are no duplicate names." + (let ((tail list) + this new) + (while tail + (setq this (car tail) + this (hexrgb-delete-whitespace-from-string (downcase this) 0 (length this))) + (unless (member this new) (push this new)) + (pop tail)) + (nreverse new))) + + (defun hexrgb-delete-whitespace-from-string (string &optional from to) + "Remove whitespace from substring of STRING from FROM to TO. +If FROM is nil, then start at the beginning of STRING (FROM = 0). +If TO is nil, then end at the end of STRING (TO = length of STRING). +FROM and TO are zero-based indexes into STRING. +Character FROM is affected (possibly deleted). Character TO is not." + (setq from (or from 0) + to (or to (length string))) + (with-temp-buffer + (insert string) + (goto-char (+ from (point-min))) + (let ((count from) + char) + (while (and (not (eobp)) (< count to)) + (setq char (char-after)) + (if (memq char '(?\ ?\t ?\n)) (delete-char 1) (forward-char 1)) + (setq count (1+ count))) + (buffer-string))))) + +;;;###autoload +(defconst hexrgb-defined-colors (eval-when-compile (and window-system (x-defined-colors))) + "List of all supported colors.") + +;;;###autoload +(defconst hexrgb-defined-colors-no-dups + (eval-when-compile + (and window-system (hexrgb-canonicalize-defined-colors (x-defined-colors)))) + "List of all supported color names, with no duplicates. +Names are all lowercase, without any spaces.") + +;;;###autoload +(defconst hexrgb-defined-colors-alist + (eval-when-compile (and window-system (mapcar #'list (x-defined-colors)))) + "Alist of all supported color names, for use in completion. +See also `hexrgb-defined-colors-no-dups-alist', which is the same +thing, but without any duplicates, such as \"light blue\" and +\"LightBlue\".") + +;;;###autoload +(defconst hexrgb-defined-colors-no-dups-alist + (eval-when-compile + (and window-system + (mapcar #'list (hexrgb-canonicalize-defined-colors (x-defined-colors))))) + "Alist of all supported color names, with no duplicates, for completion. +Names are all lowercase, without any spaces.") + +;;;###autoload +(defcustom hexrgb-canonicalize-defined-colors-flag t + "*Non-nil means remove duplicate color names. +Names are considered duplicates if they are the same when abstracting +from whitespace and letter case." + :type 'boolean + :group 'Icicles :group 'doremi-frame-commands :group 'faces :group 'convenience) + +;; You should use these two functions, not the constants, so users can change +;; the behavior by customizing `hexrgb-canonicalize-defined-colors-flag'. + +(defun hexrgb-defined-colors () + "List of supported color names. +If `hexrgb-canonicalize-defined-colors-flag' is non-nil, then names +are lowercased, whitespace is removed, and there are no duplicates." + (if hexrgb-canonicalize-defined-colors-flag + hexrgb-defined-colors-no-dups + hexrgb-defined-colors)) + +(defun hexrgb-defined-colors-alist () + "Alist of supported color names. Usable for completion. +If `hexrgb-canonicalize-defined-colors-flag' is non-nil, then names +are lowercased, whitespace is removed, and there are no duplicates." + (if hexrgb-canonicalize-defined-colors-flag + hexrgb-defined-colors-no-dups-alist + hexrgb-defined-colors-alist)) + +;; RMS added this function to Emacs (23) as `read-color', with some feature loss. +;;;###autoload +(defun hexrgb-read-color (&optional convert-to-RGB-p allow-empty-name-p prompt) + "Read a color name or RGB hex value: #RRRRGGGGBBBB. +Completion is available for color names, but not for RGB hex strings. +If you input an RGB hex string, it must have the form #XXXXXXXXXXXX or +XXXXXXXXXXXX, where each X is a hex digit. The number of Xs must be a +multiple of 3, with the same number of Xs for each of red, green, and +blue. The order is red, green, blue. + +Color names that are normally considered equivalent are canonicalized: +They are lowercased, whitespace is removed, and duplicates are +eliminated. E.g. \"LightBlue\" and \"light blue\" are both replaced +by \"lightblue\". If you do not want this behavior, but want to +choose names that might contain whitespace or uppercase letters, then +customize option `hexrgb-canonicalize-defined-colors-flag' to nil. + +In addition to standard color names and RGB hex values, the following +are available as color candidates. In each case, the corresponding +color is used. + +* `*copied foreground*' - last copied foreground, if available +* `*copied background*' - last copied background, if available +* `*mouse-2 foreground*' - foreground where you click `mouse-2' +* `*mouse-2 background*' - background where you click `mouse-2' +* `*point foreground*' - foreground under the cursor +* `*point background*' - background under the cursor + +\(You can copy a color using eyedropper commands such as +`eyedrop-pick-foreground-at-mouse'.) + +Checks input to be sure it represents a valid color. If not, raises +an error (but see exception for empty input with non-nil +ALLOW-EMPTY-NAME-P). + +Interactively, or with optional arg CONVERT-TO-RGB-P non-nil, converts +an input color name to an RGB hex string. Returns the RGB hex string. + +Optional arg ALLOW-EMPTY-NAME-P controls what happens if you enter an +empty color name (that is, you just hit `RET'). If non-nil, then +`hexrgb-read-color' returns an empty color name, \"\". If nil, then +it raises an error. Programs must test for \"\" if ALLOW-EMPTY-NAME-P +is non-nil. They can then perform an appropriate action in case of +empty input. + +Optional arg PROMPT is the prompt. Nil means use a default prompt." + (interactive "p") ; Always convert to RGB interactively. + (let* ((completion-ignore-case t) + ;; Free variables here: `eyedrop-picked-foreground', `eyedrop-picked-background'. + ;; They are defined in library `palette.el' or library `eyedropper.el'. + (colors (if (fboundp 'eyedrop-foreground-at-point) + (append (and eyedrop-picked-foreground + '(("*copied foreground*"))) + (and eyedrop-picked-background + '(("*copied background*"))) + '(("*mouse-2 foreground*") + ("*mouse-2 background*") + ("*point foreground*") ("*point background*")) + (hexrgb-defined-colors-alist)) + (hexrgb-defined-colors-alist))) + (color (completing-read (or prompt "Color (name or #R+G+B+): ") + colors)) + hex-string) + (when (fboundp 'eyedrop-foreground-at-point) + (cond ((string= "*copied foreground*" color) (setq color eyedrop-picked-foreground)) + ((string= "*copied background*" color) (setq color eyedrop-picked-background)) + ((string= "*point foreground*" color) (setq color (eyedrop-foreground-at-point))) + ((string= "*point background*" color) (setq color (eyedrop-background-at-point))) + ((string= "*mouse-2 foreground*" color) + (setq color (prog1 (eyedrop-foreground-at-mouse + (read-event "Click `mouse-2' to choose foreground color - ")) + (read-event)))) ; Discard mouse up event. + ((string= "*mouse-2 background*" color) + (setq color (prog1 (eyedrop-background-at-mouse + (read-event "Click `mouse-2' to choose background color - ")) + (read-event)))))) ; Discard mouse up event. + (setq hex-string (or (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color) + (and (string-match "^\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color) + t))) + (if (and allow-empty-name-p (string= "" color)) + "" + (when (and hex-string (not (eq 0 hex-string))) + (setq color (concat "#" color))) ; No #; add it. + (unless hex-string + (when (or (string= "" color) + (not (if (fboundp 'test-completion) ; Not defined in Emacs 20. + (test-completion color colors) + (try-completion color colors)))) + (error "No such color: %S" color)) + (when convert-to-RGB-p (setq color (hexrgb-color-name-to-hex color)))) + (when (interactive-p) (message "Color: `%s'" color)) + color))) + +;;;###autoload +(defun hexrgb-rgb-hex-string-p (color &optional laxp) + "Non-nil if COLOR is an RGB string #XXXXXXXXXXXX. +Each X is a hex digit. The number of Xs must be a multiple of 3, with +the same number of Xs for each of red, green, and blue. + +Non-nil optional arg LAXP means that the initial `#' is optional. In +that case, for a valid string of hex digits: when # is present 0 is +returned; otherwise, t is returned." + (or (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color) + (and laxp (string-match "^\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color) t))) + +;;;###autoload +(defun hexrgb-complement (color) + "Return the color that is the complement of COLOR." + (interactive (list (hexrgb-read-color))) + (setq color (hexrgb-color-name-to-hex color)) + (let ((red (hexrgb-red color)) + (green (hexrgb-green color)) + (blue (hexrgb-blue color))) + (setq color (hexrgb-rgb-to-hex (- 1.0 red) (- 1.0 green) (- 1.0 blue)))) + (when (interactive-p) (message "Complement: `%s'" color)) + color) + +;;;###autoload +(defun hexrgb-hue (color) + "Return the hue component of COLOR, in range 0 to 1 inclusive. +COLOR is a color name or hex RGB string that starts with \"#\"." + (interactive (list (hexrgb-read-color))) + (setq color (hexrgb-color-name-to-hex color)) + (car (hexrgb-rgb-to-hsv (hexrgb-red color) (hexrgb-green color) (hexrgb-blue color)))) + +;;;###autoload +(defun hexrgb-saturation (color) + "Return the saturation component of COLOR, in range 0 to 1 inclusive. +COLOR is a color name or hex RGB string that starts with \"#\"." + (interactive (list (hexrgb-read-color))) + (setq color (hexrgb-color-name-to-hex color)) + (cadr (hexrgb-rgb-to-hsv (hexrgb-red color) (hexrgb-green color) (hexrgb-blue color)))) + +;;;###autoload +(defun hexrgb-value (color) + "Return the value component of COLOR, in range 0 to 1 inclusive. +COLOR is a color name or hex RGB string that starts with \"#\"." + (interactive (list (hexrgb-read-color))) + (setq color (hexrgb-color-name-to-hex color)) + (caddr (hexrgb-rgb-to-hsv (hexrgb-red color) (hexrgb-green color) (hexrgb-blue color)))) + +;;;###autoload +(defun hexrgb-red (color) + "Return the red component of COLOR, in range 0 to 1 inclusive. +COLOR is a color name or hex RGB string that starts with \"#\"." + (interactive (list (hexrgb-read-color))) + (setq color (hexrgb-color-name-to-hex color)) + (/ (hexrgb-hex-to-int (substring color 1 (1+ (/ (1- (length color)) 3)))) + (expt 16.0 (/ (1- (length color)) 3.0)))) + +;;;###autoload +(defun hexrgb-green (color) + "Return the green component of COLOR, in range 0 to 1 inclusive. +COLOR is a color name or hex RGB string that starts with \"#\"." + (interactive (list (hexrgb-read-color))) + (setq color (hexrgb-color-name-to-hex color)) + (let* ((len (/ (1- (length color)) 3)) + (start (1+ len))) + (/ (hexrgb-hex-to-int (substring color start (+ start len))) + (expt 16.0 (/ (1- (length color)) 3.0))))) + +;;;###autoload +(defun hexrgb-blue (color) + "Return the blue component of COLOR, in range 0 to 1 inclusive. +COLOR is a color name or hex RGB string that starts with \"#\"." + (interactive (list (hexrgb-read-color))) + (setq color (hexrgb-color-name-to-hex color)) + (let* ((len (/ (1- (length color)) 3)) + (start (+ 1 len len))) + (/ (hexrgb-hex-to-int (substring color start (+ start len))) + (expt 16.0 (/ (1- (length color)) 3.0))))) + +;;;###autoload +(defun hexrgb-rgb-to-hsv (red green blue) + "Convert RED, GREEN, BLUE components to HSV (hue, saturation, value). +Each input component is 0.0 to 1.0, inclusive. +Returns a list of HSV components of value 0.0 to 1.0, inclusive." + (let* ((min (min red green blue)) + (max (max red green blue)) + (value max) + (delta (- max min)) + hue saturation) + (if (hexrgb-approx-equal 0.0 delta) + (setq hue 0.0 + saturation 0.0) ; Gray scale - no color; only value. + (if (and (condition-case nil + (setq saturation (/ delta max)) + (arith-error nil)) + ;; Must be a number, not a NaN. The standard test for a NaN is (not (= N N)), + ;; but an Emacs 20 bug makes (= N N) return t for a NaN also. + (or (< emacs-major-version 21) (= saturation saturation))) + (if (hexrgb-approx-equal 0.0 saturation) + (setq hue 0.0 + saturation 0.0) ; Again, no color; only value. + ;; Color + (setq hue (if (hexrgb-approx-equal red max) + (/ (- green blue) delta) ; Between yellow & magenta. + (if (hexrgb-approx-equal green max) + (+ 2.0 (/ (- blue red) delta)) ; Between cyan & yellow. + (+ 4.0 (/ (- red green) delta)))) ; Between magenta & cyan. + hue (/ hue 6.0)) + ;; (when (<= hue 0.0) (setq hue (+ hue 1.0))) ; $$$$$$ + ;; (when (>= hue 1.0) (setq hue (- hue 1.0)))) ; $$$$$$ + (when (< hue 0.0) (setq hue (+ hue 1.0))) + (when (> hue 1.0) (setq hue (- hue 1.0)))) + (setq hue 0.0 ; Div by zero (max=0): H:=0, S:=0. (Hue undefined.) + saturation 0.0))) + (list hue saturation value))) + +;;;###autoload +(defun hexrgb-hsv-to-rgb (hue saturation value) + "Convert HUE, SATURATION, VALUE components to RGB (red, green, blue). +Each input component is 0.0 to 1.0, inclusive. +Returns a list of RGB components of value 0.0 to 1.0, inclusive." + (let (red green blue int-hue fract pp qq tt ww) + (if (hexrgb-approx-equal 0.0 saturation) + (setq red value + green value + blue value) ; Gray + (setq hue (* hue 6.0) ; Sectors: 0 to 5 + int-hue (floor hue) + fract (- hue int-hue) + pp (* value (- 1 saturation)) + qq (* value (- 1 (* saturation fract))) + ww (* value (- 1 (* saturation (- 1 (- hue int-hue)))))) + (case int-hue + ((0 6) (setq red value + green ww + blue pp)) + (1 (setq red qq + green value + blue pp)) + (2 (setq red pp + green value + blue ww)) + (3 (setq red pp + green qq + blue value)) + (4 (setq red ww + green pp + blue value)) + (otherwise (setq red value + green pp + blue qq)))) + (list red green blue))) + +;;;###autoload +(defun hexrgb-hsv-to-hex (hue saturation value) + "Return the hex RBG color string for inputs HUE, SATURATION, VALUE. +The inputs are each in the range 0 to 1. +The output string is of the form \"#RRRRGGGGBBBB\"." + (hexrgb-color-values-to-hex + (mapcar (lambda (x) (floor (* x 65535.0))) (hexrgb-hsv-to-rgb hue saturation value)))) + +;;;###autoload +(defun hexrgb-rgb-to-hex (red green blue) + "Return the hex RBG color string for inputs RED, GREEN, BLUE. +The inputs are each in the range 0 to 1. +The output string is of the form \"#RRRRGGGGBBBB\"." + (hexrgb-color-values-to-hex + (mapcar (lambda (x) (floor (* x 65535.0))) (list red green blue)))) + +;;;###autoload +(defun hexrgb-hex-to-hsv (color) + "Return a list of HSV (hue, saturation, value) color components. +Each component is a value from 0.0 to 1.0, inclusive. +COLOR is a color name or a hex RGB string that starts with \"#\" and +is followed by an equal number of hex digits for red, green, and blue +components." + (let ((rgb-components (hexrgb-hex-to-rgb color))) + (apply #'hexrgb-rgb-to-hsv rgb-components))) + +;;;###autoload +(defun hexrgb-hex-to-rgb (color) + "Return a list of RGB (red, green, blue) color components. +Each component is a value from 0.0 to 1.0, inclusive. +COLOR is a color name or a hex RGB string that starts with \"#\" and +is followed by an equal number of hex digits for red, green, and blue +components." + (unless (hexrgb-rgb-hex-string-p color) (setq color (hexrgb-color-name-to-hex color))) + (let ((len (/ (1- (length color)) 3))) + (list (/ (hexrgb-hex-to-int (substring color 1 (1+ len))) 65535.0) + (/ (hexrgb-hex-to-int (substring color (1+ len) (+ 1 len len))) 65535.0) + (/ (hexrgb-hex-to-int (substring color (+ 1 len len))) 65535.0)))) + +;;;###autoload +(defun hexrgb-color-name-to-hex (color) + "Return the RGB hex string for the COLOR name, starting with \"#\". +If COLOR is already a string starting with \"#\", then just return it." + (let ((components (x-color-values color))) + (unless components (error "No such color: %S" color)) + (unless (hexrgb-rgb-hex-string-p color) + (setq color (hexrgb-color-values-to-hex components)))) + color) + +;; Just hard-code 4 as the number of hex digits, since `x-color-values' +;; seems to produce appropriate integer values for this value. +;; +;; Color "components" would be better in the name than color "value" +;; but this name follows the Emacs tradition (e.g. `x-color-values', +;; 'ps-color-values', `ps-e-x-color-values'). +;;;###autoload +(defun hexrgb-color-values-to-hex (values) + "Convert list of rgb color VALUES to a hex string, #XXXXXXXXXXXX. +Each X in the string is a hexadecimal digit. +Input VALUES is as for the output of `x-color-values'." + (concat "#" (hexrgb-int-to-hex (nth 0 values) 4) ; red + (hexrgb-int-to-hex (nth 1 values) 4) ; green + (hexrgb-int-to-hex (nth 2 values) 4))) ; blue + +;;;###autoload +(defun hexrgb-hex-to-color-values (color) + "Convert hex COLOR to a list of rgb color values. +COLOR is a hex rgb color string, #XXXXXXXXXXXX +Each X in the string is a hexadecimal digit. There are 3N X's, N > 0. +The output list is as for `x-color-values'." + (let* ((hex-strgp (string-match + "^\\(#\\)?\\(\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+\\)$" + color)) + (ndigits (/ (if (eq (match-beginning 1) (match-end 1)) + (length color) + (1- (length color))) + 3)) + red green blue) + (unless hex-strgp (error "Invalid RGB color string: %s" color)) + (setq color (substring color (match-beginning 2) (match-end 2)) + red (hexrgb-hex-to-int (substring color 0 ndigits)) + green (hexrgb-hex-to-int (substring color ndigits (* 2 ndigits))) + blue (hexrgb-hex-to-int (substring color ndigits (* 3 ndigits)))) + (list red green blue))) + +;;;###autoload +(defun hexrgb-increment-red (hex nb-digits increment &optional wrap-p) + "Increment red value of rgb string HEX by INCREMENT. +String HEX starts with \"#\". Each color is NB-DIGITS hex digits long. +If optional arg WRAP-P is non-nil, then the result wraps around zero. +For example, incrementing \"#FFFFFFFFF\" by 1 will cause it to wrap +around to \"#000000000\"." + (concat "#" + (hexrgb-increment-hex (substring hex 1 (1+ nb-digits)) increment nb-digits wrap-p) + (substring hex (1+ nb-digits) (1+ (* nb-digits 2))) + (substring hex (1+ (* nb-digits 2))))) + +;;;###autoload +(defun hexrgb-increment-green (hex nb-digits increment &optional wrap-p) + "Increment green value of rgb string HEX by INCREMENT. +String HEX starts with \"#\". Each color is NB-DIGITS hex digits long. +For example, incrementing \"#FFFFFFFFF\" by 1 will cause it to wrap +around to \"#000000000\"." + (concat + "#" (substring hex 1 (1+ nb-digits)) + (hexrgb-increment-hex (substring hex (1+ nb-digits) (1+ (* nb-digits 2))) + increment + nb-digits + wrap-p) + (substring hex (1+ (* nb-digits 2))))) + +;;;###autoload +(defun hexrgb-increment-blue (hex nb-digits increment &optional wrap-p) + "Increment blue value of rgb string HEX by INCREMENT. +String HEX starts with \"#\". Each color is NB-DIGITS hex digits long. +For example, incrementing \"#FFFFFFFFF\" by 1 will cause it to wrap +around to \"#000000000\"." + (concat "#" (substring hex 1 (1+ (* nb-digits 2))) + (hexrgb-increment-hex (substring hex (1+ (* nb-digits 2))) + increment + nb-digits + wrap-p))) + +;;;###autoload +(defun hexrgb-increment-equal-rgb (hex nb-digits increment &optional wrap-p) + "Increment each color value (r,g,b) of rgb string HEX by INCREMENT. +String HEX starts with \"#\". Each color is NB-DIGITS hex digits long. +For example, incrementing \"#FFFFFFFFF\" by 1 will cause it to wrap +around to \"#000000000\"." + (concat + "#" (hexrgb-increment-hex (substring hex 1 (1+ nb-digits)) increment nb-digits wrap-p) + (hexrgb-increment-hex (substring hex (1+ nb-digits) (1+ (* nb-digits 2))) + increment + nb-digits + wrap-p) + (hexrgb-increment-hex (substring hex (1+ (* nb-digits 2))) increment nb-digits wrap-p))) + +;;;###autoload +(defun hexrgb-increment-hex (hex increment nb-digits &optional wrap-p) + "Increment HEX number (a string NB-DIGITS long) by INCREMENT. +For example, incrementing \"FFFFFFFFF\" by 1 will cause it to wrap +around to \"000000000\"." + (let* ((int (hexrgb-hex-to-int hex)) + (new-int (+ increment int))) + (if (or wrap-p + (and (>= int 0) ; Not too large for the machine. + (>= new-int 0) ; For the case where increment < 0. + (<= (length (format (concat "%X") new-int)) nb-digits))) ; Not too long. + (hexrgb-int-to-hex new-int nb-digits) ; Use incremented number. + hex))) ; Don't increment. + +;;;###autoload +(defun hexrgb-hex-to-int (hex) + "Convert HEX string argument to an integer. +The characters of HEX must be hex characters." + (let* ((factor 1) + (len (length hex)) + (indx (1- len)) + (int 0)) + (while (>= indx 0) + (setq int (+ int (* factor (hexrgb-hex-char-to-integer (aref hex indx)))) + indx (1- indx) + factor (* 16 factor))) + int)) + +;; From `hexl.el'. This is the same as `hexl-hex-char-to-integer' defined there. +;;;###autoload +(defun hexrgb-hex-char-to-integer (character) + "Take a CHARACTER and return its value as if it were a hex digit." + (if (and (>= character ?0) (<= character ?9)) + (- character ?0) + (let ((ch (logior character 32))) + (if (and (>= ch ?a) (<= ch ?f)) + (- ch (- ?a 10)) + (error "Invalid hex digit `%c'" ch))))) + +;; Originally, I used the code from `int-to-hex-string' in `float.el'. +;; This version is thanks to Juri Linkov <juri@jurta.org>. +;; +;;;###autoload +(defun hexrgb-int-to-hex (int &optional nb-digits) + "Convert integer argument INT to a #XXXXXXXXXXXX format hex string. +Each X in the output string is a hexadecimal digit. +NB-DIGITS is the number of hex digits. If INT is too large to be +represented with NB-DIGITS, then the result is truncated from the +left. So, for example, INT=256 and NB-DIGITS=2 returns \"00\", since +the hex equivalent of 256 decimal is 100, which is more than 2 digits." + (setq nb-digits (or nb-digits 4)) + (substring (format (concat "%0" (int-to-string nb-digits) "X") int) (- nb-digits))) + +;; Inspired by Elisp Info manual, node "Comparison of Numbers". +;;;###autoload +(defun hexrgb-approx-equal (x y &optional rfuzz afuzz) + "Return non-nil if numbers X and Y are approximately equal. +RFUZZ is a relative fuzz factor. AFUZZ is an absolute fuzz factor. +RFUZZ defaults to 1.0e-8. AFUZZ defaults to (/ RFUZZ 10). +RFUZZ and AFUZZ are converted to their absolute values. +The algorithm is: + (< (abs (- X Y)) (+ AFUZZ (* RFUZZ (+ (abs X) (abs Y)))))." + (setq rfuzz (or rfuzz 1.0e-8) + rfuzz (abs rfuzz) + afuzz (or afuzz (/ rfuzz 10)) + afuzz (abs afuzz)) + (< (abs (- x y)) (+ afuzz (* rfuzz (+ (abs x) (abs y)))))) + +;;;###autoload +(defun hexrgb-color-value-to-float (n) + "Return the floating-point equivalent of color value N. +N must be an integer between 0 and 65535, or else an error is raised." + (unless (and (wholenump n) (<= n 65535)) + (error "Not a whole number less than 65536")) + (/ (float n) 65535.0)) + +;;;###autoload +(defun hexrgb-float-to-color-value (x) + "Return the color value equivalent of floating-point number X. +X must be between 0.0 and 1.0, or else an error is raised." + (unless (and (numberp x) (<= 0.0 x) (<= x 1.0)) + (error "Not a floating-point number between 0.0 and 1.0")) + (floor (* x 65535.0))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'hexrgb) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; hexrgb.el ends here diff --git a/jabber-feature-neg.el b/jabber-feature-neg.el new file mode 100644 index 0000000..748a4cd --- /dev/null +++ b/jabber-feature-neg.el @@ -0,0 +1,125 @@ +;; jabber-feature-neg.el - Feature Negotiation by JEP-0020 + +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net +;; Copyright (C) 2003, 2004 - Magnus Henoch - mange@freemail.hu + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-disco) +(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 JEP-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))) + +(provide 'jabber-feature-neg) + +;;; arch-tag: 65b2cdcc-7a5f-476b-a613-84ec8e590186 diff --git a/jabber-festival.el b/jabber-festival.el new file mode 100644 index 0000000..07f25d5 --- /dev/null +++ b/jabber-festival.el @@ -0,0 +1,35 @@ +;;; jabber-festival.el --- Festival alert hooks + +;; Copyright (C) 2005 Magnus Henoch + +;; This file is a part of jabber.el. + +;; 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, 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +(eval-when-compile (require 'jabber-alert)) + +(condition-case e + (progn + ;; Most people don't have Festival, so this will often fail + (require 'festival) + (define-jabber-alert festival "Voice messages through Festival" + (lambda (text &optional title) (festival-say-string (or title text))))) + (error nil)) + +(provide 'jabber-festival) +;; arch-tag: 8922D096-5D07-11D9-B4C2-000A95C2FCD0 + + diff --git a/jabber-ft-client.el b/jabber-ft-client.el new file mode 100644 index 0000000..fa9da9a --- /dev/null +++ b/jabber-ft-client.el @@ -0,0 +1,68 @@ +;; jabber-ft-client.el - send file transfer requests, by JEP-0096 + +;; Copyright (C) 2004 - Magnus Henoch - mange@freemail.hu + +;; This file is a part of jabber.el. + +;; 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 + +(eval-when-compile (require 'cl)) + +(require 'jabber-si-client) +(require 'jabber-util) + +(require 'jabber-ft-common) + +(defun jabber-ft-send (jc jid filename desc) + "Attempt to send FILENAME to JID." + (interactive (list (jabber-read-account) + (jabber-read-jid-completing "Send file to: " nil nil nil 'full t) + (read-file-name "Send which file: " nil nil t) + (jabber-read-with-input-method "Description (optional): "))) + (if (zerop (length desc)) (setq desc nil)) + (setq filename (expand-file-name filename)) + (access-file filename "Couldn't open file") + + (let* ((attributes (file-attributes filename)) + (size (nth 7 attributes)) + (date (nth 5 attributes)) + (hash (jabber-ft-get-md5 filename))) + (jabber-si-initiate jc jid "http://jabber.org/protocol/si/profile/file-transfer" + `(file ((xmlns . "http://jabber.org/protocol/si/profile/file-transfer") + (name . ,(file-name-nondirectory filename)) + (size . ,size) + (date . ,(jabber-encode-time date)) + ,@(when hash + (list (cons 'hash hash)))) + (desc () ,desc)) + (lexical-let ((filename filename)) + (lambda (jc jid sid send-data-function) + (jabber-ft-do-send + jid sid send-data-function filename)))))) + +(defun jabber-ft-do-send (jid sid send-data-function filename) + (if (stringp send-data-function) + (message "File sending failed: %s" send-data-function) + (with-temp-buffer + (insert-file-contents-literally filename) + + ;; Ever heard of buffering? + (funcall send-data-function (buffer-string)) + (message "File transfer completed"))) + ;; File transfer is monodirectional, so ignore received data. + #'ignore) + +(provide 'jabber-ft-client) +;;; arch-tag: fba686d5-37b5-4165-86c5-49b76fa0ea6e diff --git a/jabber-ft-common.el b/jabber-ft-common.el new file mode 100644 index 0000000..ac7b048 --- /dev/null +++ b/jabber-ft-common.el @@ -0,0 +1,46 @@ +;;; jabber-ft-common.el --- Common functions for sending and receiving files (JEP-0096) + +;; Copyright (C) 2006, 2008 Magnus Henoch + +;; Author: Magnus Henoch <mange@freemail.hu> + +;; This file 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, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +(defcustom jabber-ft-md5sum-program (or (when (executable-find "md5") + (list (executable-find "md5") "-n")) + (when (executable-find "md5sum") + (list (executable-find "md5sum")))) + "The program to use to calculate MD5 sums of files. +The first item should be the name of the program, and the remaing +items the arguments. The file name is appended as the last +argument." + :type '(repeat string) + :group 'jabber) + +(defun jabber-ft-get-md5 (file-name) + "Get MD5 sum of FILE-NAME, and return as hex string. +Return nil if no MD5 summing program is available." + (when jabber-ft-md5sum-program + (with-temp-buffer + (apply 'call-process (car jabber-ft-md5sum-program) nil t nil + (append (cdr jabber-ft-md5sum-program) (list file-name))) + ;; Output is "hexsum filename" + (goto-char (point-min)) + (forward-word 1) + (buffer-substring (point-min) (point))))) + +(provide 'jabber-ft-common) +;; arch-tag: 1ce4cce0-8360-11da-a5ba-000a95c2fcd0 diff --git a/jabber-ft-server.el b/jabber-ft-server.el new file mode 100644 index 0000000..b2afceb --- /dev/null +++ b/jabber-ft-server.el @@ -0,0 +1,131 @@ +;; jabber-ft-server.el - handle incoming file transfers, by JEP-0096 + +;; Copyright (C) 2003, 2004, 2007 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-si-server) +(require 'jabber-util) + +(defvar jabber-ft-sessions nil + "Alist, where keys are (sid jid), and values are buffers of the files.") + +(defvar jabber-ft-size nil + "Size of the file that is being downloaded") + +(defvar jabber-ft-md5-hash nil + "MD5 hash of the file that is being downloaded") + +(jabber-disco-advertise-feature "http://jabber.org/protocol/si/profile/file-transfer") + +(add-to-list 'jabber-si-profiles + (list "http://jabber.org/protocol/si/profile/file-transfer" + 'jabber-ft-accept + 'jabber-ft-server-connected)) + +(defun jabber-ft-accept (jc xml-data) + "Receive IQ stanza containing file transfer request, ask user" + (let* ((from (jabber-xml-get-attribute xml-data 'from)) + (query (jabber-iq-query xml-data)) + (si-id (jabber-xml-get-attribute query 'id)) + ;; TODO: check namespace + (file (car (jabber-xml-get-children query 'file))) + (name (jabber-xml-get-attribute file 'name)) + (size (jabber-xml-get-attribute file 'size)) + (date (jabber-xml-get-attribute file 'date)) + (md5-hash (jabber-xml-get-attribute file 'hash)) + (desc (car (jabber-xml-node-children + (car (jabber-xml-get-children file 'desc))))) + (range (car (jabber-xml-get-children file 'range)))) + (unless (and name size) + ;; both name and size must be present + (jabber-signal-error "modify" 'bad-request)) + + (let ((question (format + "%s is sending you the file %s (%s bytes).%s Accept? " + (jabber-jid-displayname from) + name + size + (if (not (zerop (length desc))) + (concat " Description: '" desc "'") + "")))) + (unless (yes-or-no-p question) + (jabber-signal-error "cancel" 'forbidden))) + + ;; default is to save with given name, in current directory. + ;; maybe that's bad; maybe should be customizable. + (let* ((file-name (read-file-name "Download to: " nil nil nil name)) + (buffer (create-file-buffer file-name))) + (message "Starting download of %s..." (file-name-nondirectory file-name)) + (with-current-buffer buffer + (kill-all-local-variables) + (setq buffer-file-coding-system 'binary) + ;; For Emacs, switch buffer to unibyte _before_ anything goes into it, + ;; otherwise binary files are corrupted. For XEmacs, it isn't needed, + ;; and it also doesn't have set-buffer-multibyte. + (if (fboundp 'set-buffer-multibyte) + (set-buffer-multibyte nil)) + (set-visited-file-name file-name t) + (set (make-local-variable 'jabber-ft-size) + (string-to-number size)) + (set (make-local-variable 'jabber-ft-md5-hash) + md5-hash)) + (add-to-list 'jabber-ft-sessions + (cons (list si-id from) buffer))) + + ;; to support range, return something sensible here + nil)) + +(defun jabber-ft-server-connected (jc jid sid send-data-function) + ;; We don't really care about the send-data-function. But if it's + ;; a string, it means that we have no connection. + (if (stringp send-data-function) + (message "File receiving failed: %s" send-data-function) + ;; On success, we just return our data receiving function. + 'jabber-ft-data)) + +(defun jabber-ft-data (jc jid sid data) + "Receive chunk of transferred file." + (let ((buffer (cdr (assoc (list sid jid) jabber-ft-sessions)))) + (with-current-buffer buffer + ;; If data is nil, there is no more data. + ;; But maybe the remote entity doesn't close the stream - + ;; then we have to keep track of file size to know when to stop. + ;; Return value is whether to keep connection open. + (when data + (insert data)) + (if (and data (< (buffer-size) jabber-ft-size)) + t + (basic-save-buffer) + (if (and jabber-ft-md5-hash + (let ((file-hash (jabber-ft-get-md5 buffer-file-name))) + (and file-hash + (not (string= file-hash jabber-ft-md5-hash))))) + ;; hash mismatch! + (progn + (message "%s downloaded - CHECKSUM MISMATCH!" + (file-name-nondirectory buffer-file-name)) + (sleep-for 5)) + ;; all is fine + (message "%s downloaded" (file-name-nondirectory buffer-file-name))) + (kill-buffer buffer) + nil)))) + +(provide 'jabber-ft-server) + +;;; arch-tag: 334adcff-6210-496e-8382-8f49ae0248a1 diff --git a/jabber-gmail.el b/jabber-gmail.el new file mode 100644 index 0000000..3a8d299 --- /dev/null +++ b/jabber-gmail.el @@ -0,0 +1,98 @@ +;;; jabber-gmail.el --- Gmail notifications via emacs-jabber + +;; Copyright (C) 2008 Magnus Henoch <mange@freemail.hu> +;; Copyright (C) 2007 Valery V. Vorotyntsev <valery.vv@gmail.com> + +;; 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Usage: + +;; Add the following line to your ~/.emacs: +;; +;; (require 'jabber-gmail) +;; +;; If you prefer on demand loading +;; [http://a-nickels-worth.blogspot.com/2007/11/effective-emacs.html]: +;; +;; (autoload 'jabber-gmail-query "jabber-gmail") +;; (autoload 'jabber-gmail-subscribe "jabber-gmail") +;; (add-hook 'jabber-post-connect-hook 'jabber-gmail-subscribe) +;; +;; You may wish to bind a shortcut for `jabber-gmail-query' +;; +;; (global-set-key (kbd "<f9> g") 'jabber-gmail-query) +;; +;; or to customize `jabber-gmail-dothreads' +;; +;; (defun jabber-gmail-dothreads (ts) +;; (let ((msg (format "%d new messages in gmail inbox" (length ts)))) +;; (message msg) +;; (jabber-screen-message msg))) + +;;;###autoload +(defun jabber-gmail-subscribe (jc) + "Subscribe to gmail notifications. +See http://code.google.com/apis/talk/jep_extensions/usersettings.html#4" + (interactive (list (jabber-read-account))) + (jabber-send-iq jc (jabber-connection-bare-jid jc) "set" + '(usersetting ((xmlns . "google:setting")) + (mailnotifications ((value . "true")))) + #'jabber-report-success "Gmail subscription" + #'jabber-process-data "Gmail subscription") + + ;; Looks like "one shot" request is still needed to activate + ;; notifications machinery. + (jabber-gmail-query jc)) + +(add-to-list 'jabber-iq-set-xmlns-alist + (cons "google:mail:notify" #'jabber-gmail-process-new-mail)) +(defun jabber-gmail-process-new-mail (jc xml-sexp) + "Process new gmail notification. +See http://code.google.com/apis/talk/jep_extensions/gmail.html#notifications" + (let ((from (jabber-xml-get-attribute xml-sexp 'from)) + (id (jabber-xml-get-attribute xml-sexp 'id))) + ;; respond to server + (jabber-send-iq jc from "result" nil + nil nil nil nil + id)) + + (jabber-gmail-query jc)) + +;;;###autoload +(defun jabber-gmail-query (jc) + "Request mail information from the Google Talk server (a.k.a. one shot query). +See http://code.google.com/apis/talk/jep_extensions/gmail.html#requestmail" + (interactive (list (jabber-read-account))) + (jabber-send-iq jc (jabber-connection-bare-jid jc) "get" + '(query ((xmlns . "google:mail:notify"))) + #'jabber-gmail-process-mailbox nil + #'jabber-process-data "Gmail query" "gmail-query")) + +(defun jabber-gmail-process-mailbox (jc xml-sexp &rest ignore) + "Process gmail query response. +See http://code.google.com/apis/talk/jep_extensions/gmail.html#response" + (let ((ts (jabber-xml-node-children + (car (jabber-xml-get-children xml-sexp 'mailbox))))) + (when ts (jabber-gmail-dothreads ts)))) + +(defun jabber-gmail-dothreads (threads) + "Process <mail-thread-info/> elements. +THREADS is a list of XML sexps, corresponding to <mail-thread-info/> elements. +See http://code.google.com/apis/talk/jep_extensions/gmail.html#response" + (message "%d new messages in gmail inbox" (length threads))) + +(provide 'jabber-gmail) +;; arch-tag: 102bc8e4-e08f-11dc-ab66-000a95c2fcd0 diff --git a/jabber-history.el b/jabber-history.el new file mode 100644 index 0000000..a1e8250 --- /dev/null +++ b/jabber-history.el @@ -0,0 +1,337 @@ +;; jabber-history.el - recording message history + +;; Copyright (C) 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2004 - Mathias Dahl + +;; This file is a part of jabber.el. + +;; 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 + +;;; Log format: +;; Each message is on one separate line, represented as a vector with +;; five elements. The first element is time encoded according to +;; JEP-0082. The second element is direction, "in" or "out". +;; The third element is the sender, "me" or a JID. The fourth +;; element is the recipient. The fifth element is the text +;; of the message. + +;; FIXME: when rotation is enabled, jabber-history-query won't look +;; for older history files if the current history file doesn't contain +;; enough backlog entries. + +(require 'jabber-core) +(require 'jabber-util) + +(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.")) + +(provide 'jabber-history) + +;; arch-tag: 0AA0C235-3FC0-11D9-9FE7-000A95C2FCD0 diff --git a/jabber-iq.el b/jabber-iq.el new file mode 100644 index 0000000..a4a4121 --- /dev/null +++ b/jabber-iq.el @@ -0,0 +1,213 @@ +;; jabber-iq.el - infoquery functions + +;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-core) +(require 'jabber-util) +(require 'jabber-keymap) + +(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)))) + +(provide 'jabber-iq) + +;;; arch-tag: 5585dfa3-b59a-42ee-9292-803652c85e26 diff --git a/jabber-keepalive.el b/jabber-keepalive.el new file mode 100644 index 0000000..e89592c --- /dev/null +++ b/jabber-keepalive.el @@ -0,0 +1,176 @@ +;; jabber-keepalive.el - try to detect lost connection + +;; Copyright (C) 2004, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2007 - Detlev Zundel - dzu@gnu.org + +;; This file is a part of jabber.el. + +;; 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 + + +;;;; Keepalive - send something to the server and see if it answers +;;; +;;; These keepalive functions send a urn:xmpp:ping request to the +;;; server every X minutes, and considers the connection broken if +;;; they get no answer within Y seconds. + +(require 'jabber-ping) + +;;;###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))) + +;;;; Whitespace pings - less traffic, no error checking on our side +;;; +;;; Openfire needs something like this, but I couldn't bring myself to +;;; enable keepalive by default... Whitespace pings are light and +;;; unobtrusive. + +(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 " ")))) + +(provide 'jabber-keepalive) + +;;; arch-tag: d19ca743-75a1-475f-9217-83bd18012146 diff --git a/jabber-keymap.el b/jabber-keymap.el new file mode 100644 index 0000000..6be8833 --- /dev/null +++ b/jabber-keymap.el @@ -0,0 +1,62 @@ +;; jabber-keymap.el - common keymap for many modes + +;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + + +;; 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) + +(provide 'jabber-keymap) + +;;; arch-tag: 22a9993d-a4a7-40ef-a025-7cff6c3f5587 diff --git a/jabber-libnotify.el b/jabber-libnotify.el new file mode 100644 index 0000000..bf4d44c --- /dev/null +++ b/jabber-libnotify.el @@ -0,0 +1,103 @@ +;; jabber-libnotify.el - emacs-jabber interface to libnotify + +;; Copyright (C) 2010 - Kirill A. Korinskiy - catap@catap.ru +;; Copyright (C) 2007 - Rodrigo Lazo - rlazo.paz@gmail.com + +;; 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 + +(require 'dbus nil t) +(eval-when-compile (require 'jabber-alert)) + +(defcustom jabber-libnotify-icon "" + "Icon to be used on the notification pop-up. Default is empty" + :type '(file :must-match t) + :group 'jabber-alerts) + + +(defcustom jabber-libnotify-timeout 2500 + "Specifies the timeout of the pop up window in millisecond" + :type 'integer + :group 'jabber-alerts) + +(defcustom jabber-libnotify-message-header "Jabber message" + "Defines the header of the pop up." + :type 'string + :group 'jabber-alerts) + +(defcustom jabber-libnotify-app "Emacs Jabber" + "Defines the app of the pop up." + :type 'string + :group 'jabber-alerts) + +(defcustom jabber-libnotify-urgency "low" + "Urgency of libnotify message" + :type '(choice (const :tag "Low" "low") + (const :tag "Normal" "normal") + (const :tag "Critical" "critical")) + :group 'jabber-alerts) + +(defcustom jabber-libnotify-method (if (featurep 'dbus) 'dbus 'shell) + "Specifies the method for libnotify call. Dbus is more faster but require emacs23+" + :type '(choice (const :tag "Shell" shell) + (const :tag "D-Bus" dbus)) + :group 'jabber-alerts) + +(defvar jabber-libnotify-id 0) + +(defun jabber-libnotify-next-id () + "Return the next notification id." + (setq jabber-libnotify-id (+ jabber-libnotify-id 1))) + +(defun jabber-libnotify-message (text &optional title) + "Show MSG using libnotify" + (let + ((body (or (jabber-escape-xml text) " ")) + (head (jabber-escape-xml + (or title + (or jabber-libnotify-message-header " ") + text)))) + ;; Possible errors include not finding the notify-send binary. + (condition-case e + (cond + ((eq jabber-libnotify-method 'shell) + (let ((process-connection-type nil)) + (start-process "notification" nil "notify-send" + "-t" (format "%s" jabber-libnotify-timeout) + "-i" (or jabber-libnotify-icon "\"\"") + "-u" jabber-libnotify-urgency + head body))) + ((eq jabber-libnotify-method 'dbus) + (dbus-call-method + :session ; use the session (not system) bus + "org.freedesktop.Notifications" ; service name + "/org/freedesktop/Notifications" ; path name + "org.freedesktop.Notifications" "Notify" ; Method + jabber-libnotify-app + (jabber-libnotify-next-id) + jabber-libnotify-icon + ':string (encode-coding-string head 'utf-8) + ':string (encode-coding-string body 'utf-8) + '(:array) + '(:array :signature "{sv}") + ':int32 jabber-libnotify-timeout))) + (error nil)))) + +(define-jabber-alert libnotify "Show a message through the libnotify interface" + 'jabber-libnotify-message) +(define-personal-jabber-alert jabber-muc-libnotify) + +(provide 'jabber-libnotify) + +;; arch-tag: e9c4c210-8245-11dd-bddf-000a95c2fcd0 diff --git a/jabber-logon.el b/jabber-logon.el new file mode 100644 index 0000000..9f96faf --- /dev/null +++ b/jabber-logon.el @@ -0,0 +1,83 @@ +;; jabber-logon.el - logon functions + +;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-xml) +(require 'jabber-util) +;; In Emacs 24, sha1 is built in, so this require is only needed for +;; earlier versions. It's supposed to be a noop in Emacs 24, but +;; sometimes, for some people, it isn't, and fails with +;; (file-error "Cannot open load file" "sha1"). +(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))) + +(provide 'jabber-logon) + +;;; arch-tag: f24ebe5e-3420-44bb-af81-d4de21f378b0 diff --git a/jabber-menu.el b/jabber-menu.el new file mode 100644 index 0000000..40082ee --- /dev/null +++ b/jabber-menu.el @@ -0,0 +1,217 @@ +;; jabber-menu.el - menu definitions + +;; Copyright (C) 2003, 2004, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-util) +(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.") + +;; This used to be: +;; (define-key-after global-map [menu-bar jabber-menu] ...) +;; but that doesn't work in Emacs 21. +;;;###autoload +(define-key-after (lookup-key global-map [menu-bar]) + [jabber-menu] + (list 'menu-item "Jabber" jabber-menu + :visible + ;; If the package was installed by the user personally, it's + ;; probably ok to "clutter" the menu bar with a Jabber menu. + (let ((user-installed-package + (and (bound-and-true-p package-user-dir) + (string= + (file-name-as-directory + (expand-file-name ".." (file-name-directory load-file-name))) + (file-name-as-directory + (expand-file-name package-user-dir)))))) + `(or (eq jabber-display-menu t) + (and (eq jabber-display-menu 'maybe) + (or ,user-installed-package + (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))) + +(provide 'jabber-menu) + +;;; arch-tag: 5147f52f-de47-4348-86ff-b799d7a75e3f diff --git a/jabber-modeline.el b/jabber-modeline.el new file mode 100644 index 0000000..e322819 --- /dev/null +++ b/jabber-modeline.el @@ -0,0 +1,98 @@ +;; jabber-modeline.el - display jabber status in modeline + +;; Copyright (C) 2004 - Magnus Henoch - mange@freemail.hu + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-presence) +(require 'jabber-alert) +(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)))) + +(provide 'jabber-modeline) + +;;; arch-tag: c03a7d3b-8811-49d4-b0e0-7ffd661d7925 diff --git a/jabber-muc-nick-coloring.el b/jabber-muc-nick-coloring.el new file mode 100644 index 0000000..5a7a171 --- /dev/null +++ b/jabber-muc-nick-coloring.el @@ -0,0 +1,85 @@ +;;; jabber-muc-nick-coloring.el --- Add nick coloring abilyty to emacs-jabber + +;; Copyright 2009, 2010, 2012, 2013 Terechkov Evgenii - evg@altlinux.org + +;; 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, 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: + +;;; Code: + +(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."))) + +;;;;########################################################################## +;;;; User Options, Variables +;;;;########################################################################## + +(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)))))) + +(provide 'jabber-muc-nick-coloring) + +;;; jabber-muc-nick-coloring.el ends here diff --git a/jabber-muc-nick-completion.el b/jabber-muc-nick-completion.el new file mode 100644 index 0000000..78ff46d --- /dev/null +++ b/jabber-muc-nick-completion.el @@ -0,0 +1,188 @@ +;;; jabber-muc-nick-completion.el --- Add nick completion abilyty to emacs-jabber + +;; Copyright (C) 2008 - Terechkov Evgenii - evg@altlinux.org +;; Copyright (C) 2007, 2008, 2010 - Kirill A. Korinskiy - catap@catap.ru +;; Copyright (C) 2007 - Serguei Jidkov - jsv@e-mail.ru + +;; This file is a part of jabber.el. + +;; 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 + +;;; User customizations here: +(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 'jabber-muc) +(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) + +(provide 'jabber-muc-nick-completion) + +;; arch-tag: 2a81ac72-d261-11dc-be91-000a95c2fcd0 +;;; jabber-muc-completion.el ends here diff --git a/jabber-muc.el b/jabber-muc.el new file mode 100644 index 0000000..95066e3 --- /dev/null +++ b/jabber-muc.el @@ -0,0 +1,1171 @@ +;; jabber-muc.el - advanced MUC functions + +;; Copyright (C) 2010 - Kirill A. Korinskiy - catap@catap.ru +;; Copyright (C) 2003, 2004, 2007, 2008, 2009, 2010 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-chat) +(require 'jabber-widget) +(require 'jabber-disco) +(require 'jabber-muc-nick-coloring) + +;; we need jabber-bookmarks for jabber-muc-autojoin (via +;; jabber-get-bookmarks and jabber-parse-conference-bookmark): +(require 'jabber-bookmarks) + +(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)))))))))))) + +(provide 'jabber-muc) + +;;; arch-tag: 1ff7ab35-1717-46ae-b803-6f5b3fb2cd7d diff --git a/jabber-notifications.el b/jabber-notifications.el new file mode 100644 index 0000000..cb7963b --- /dev/null +++ b/jabber-notifications.el @@ -0,0 +1,91 @@ +;; jabber-notifications.el - emacs-jabber interface to notifications.el + +;; Copyright (C) 2014 - Adam Sjøgren - asjo@koldfront.dk +;; Copyright (C) 2010 - Kirill A. Korinskiy - catap@catap.ru +;; Copyright (C) 2007 - Rodrigo Lazo - rlazo.paz@gmail.com + +;; 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 + +;; Built on jabber-libnotify.el. + +(eval-when-compile (require 'jabber-alert)) +(unless (string< emacs-version "24.1") ;notifications.el preset since Emacs 24.1 + (require 'notifications) + + (defcustom jabber-notifications-icon "" + "Icon to be used on the notification pop-up. Default is empty" + :type '(file :must-match t) + :group 'jabber-alerts) + + (defcustom jabber-notifications-timeout nil + "Specifies the timeout of the pop up window in millisecond" + :type 'integer + :group 'jabber-alerts) + + (defcustom jabber-notifications-message-header "Jabber message" + "Defines the header of the pop up." + :type 'string + :group 'jabber-alerts) + + (defcustom jabber-notifications-app "Emacs Jabber" + "Defines the app of the pop up." + :type 'string + :group 'jabber-alerts) + + (defcustom jabber-notifications-urgency "low" + "Urgency of message" + :type '(choice (const :tag "Low" "low") + (const :tag "Normal" "normal") + (const :tag "Critical" "critical")) + :group 'jabber-alerts) + + (defun jabber-message-notifications (from buffer text title) + "Show a message through the notifications.el interface" + (let + ((body (or (jabber-escape-xml text) " ")) + (head (jabber-escape-xml + (or title + (or jabber-notifications-message-header " ") + text))) + (avatar-hash (get (jabber-jid-symbol from) 'avatar-hash))) + (notifications-notify + :title title + :body body + :app-icon (or (and avatar-hash (jabber-avatar-find-cached avatar-hash)) + jabber-notifications-icon) + :app-name jabber-notifications-app + :category "jabber.message" + :timeout jabber-notifications-timeout))) + + (defun jabber-muc-notifications (nick group buffer text title) + "Show MUC message through the notifications.el interface" + (jabber-message-notifications group buffer (if nick (format "%s: %s" nick text) text) title) + ) + + (defun jabber-muc-notifications-personal (nick group buffer text title) + "Show personal MUC message through the notifications.el interface" + (if (jabber-muc-looks-like-personal-p text group) + (jabber-muc-notifications nick group buffer text title)) + ) + + ;; jabber-*-notifications* requires "from" argument, so we cant use + ;; define-jabber-alert/define-personal-jabber-alert here and do the + ;; work by hand: + (pushnew 'jabber-message-notifications (get 'jabber-alert-message-hooks 'custom-options)) + (pushnew 'jabber-muc-notifications (get 'jabber-alert-muc-hooks 'custom-options)) + (pushnew 'jabber-muc-notifications-personal (get 'jabber-alert-muc-hooks 'custom-options)) + ) + +(provide 'jabber-notifications) diff --git a/jabber-osd.el b/jabber-osd.el new file mode 100644 index 0000000..ffcee86 --- /dev/null +++ b/jabber-osd.el @@ -0,0 +1,35 @@ +;;; jabber-osd.el --- OSD support for jabber.el + +;; Copyright (C) 2008 - Terechkov Evgenii - evg@altlinux.org + +;; This file is a part of jabber.el. + +;; 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, 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +(eval-when-compile (require 'jabber-alert)) + +(condition-case e + (progn + ;; Most people don't have osd.el, so this will often fail + (require 'osd) + (define-jabber-alert osd "Display a message in osd" + (lambda (text &optional title) (osd-show-string (or title text)))) + (define-personal-jabber-alert jabber-muc-osd)) + (error nil)) + +(provide 'jabber-osd) + +;; arch-tag: 3eb8d55a-dd86-11dc-b2c6-000a95c2fcd0 diff --git a/jabber-ourversion.el b/jabber-ourversion.el new file mode 100644 index 0000000..b722cc4 --- /dev/null +++ b/jabber-ourversion.el @@ -0,0 +1,8 @@ +;; jabber-ourversion.el. Holds the version number in a format that +;; configure.ac can read. + +;; On the following line, only change the part between double quotes: +(defconst jabber-version "0.8.92" + "version returned to those who query us") + +(provide 'jabber-ourversion) diff --git a/jabber-ping.el b/jabber-ping.el new file mode 100644 index 0000000..e9056ab --- /dev/null +++ b/jabber-ping.el @@ -0,0 +1,61 @@ +;; jabber-ping.el - XMPP "Ping" by XEP-0199 + +;; Copyright (C) 2009 - Evgenii Terechkov - evg@altlinux.org + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-iq) +(require 'jabber-util) +(require 'jabber-menu) +(require 'jabber-disco) + +(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))) + +(provide 'jabber-ping) diff --git a/jabber-pkg.el.in b/jabber-pkg.el.in new file mode 100644 index 0000000..bcd7f48 --- /dev/null +++ b/jabber-pkg.el.in @@ -0,0 +1,5 @@ +;; For ELPA: http://tromey.com/elpa/ +(define-package "jabber" "@PACKAGE_VERSION@" "A Jabber client for Emacs." + '((fsm "0.2"))) + +;; arch-tag: fa652136-12f7-11dd-b4c4-000a95c2fcd0 diff --git a/jabber-presence.el b/jabber-presence.el new file mode 100644 index 0000000..5f4573d --- /dev/null +++ b/jabber-presence.el @@ -0,0 +1,565 @@ +;; jabber-presence.el - roster and presence bookkeeping + +;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-core) +(require 'jabber-iq) +(require 'jabber-alert) +(require 'jabber-util) +(require 'jabber-menu) +(require 'jabber-muc) + +(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=))))) + + +(provide 'jabber-presence) + +;;; arch-tag: b8616d4c-dde8-423e-86c7-da7b4928afc3 diff --git a/jabber-private.el b/jabber-private.el new file mode 100644 index 0000000..d748f0f --- /dev/null +++ b/jabber-private.el @@ -0,0 +1,61 @@ +;;; jabber-private.el --- jabber:iq:private API by JEP-0049 + +;; Copyright (C) 2005 Magnus Henoch + +;; Author: Magnus Henoch <mange@freemail.hu> + +;; This file 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, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;;###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)) + +(provide 'jabber-private) + +;; arch-tag: 065bd03e-40fa-11da-ab48-000a95c2fcd0 diff --git a/jabber-ratpoison.el b/jabber-ratpoison.el new file mode 100644 index 0000000..8ac05a1 --- /dev/null +++ b/jabber-ratpoison.el @@ -0,0 +1,35 @@ +;; jabber-ratpoison.el - emacs-jabber interface to ratpoison + +;; Copyright (C) 2005, 2008 - Magnus Henoch - mange@freemail.hu + +;; This file is a part of jabber.el. + +;; 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 + +(eval-when-compile (require 'jabber-alert)) + +(defun jabber-ratpoison-message (text &optional title) + "Show MSG in Ratpoison" + ;; Possible errors include not finding the ratpoison binary. + (condition-case e + (let ((process-connection-type)) + (call-process "ratpoison" nil 0 nil "-c" (concat "echo " (or title text)))) + (error nil))) + +(define-jabber-alert ratpoison "Show a message through the Ratpoison window manager" + 'jabber-ratpoison-message) + +(provide 'jabber-ratpoison) +;; arch-tag: 19650075-5D05-11D9-B80F-000A95C2FCD0 diff --git a/jabber-register.el b/jabber-register.el new file mode 100644 index 0000000..8527601 --- /dev/null +++ b/jabber-register.el @@ -0,0 +1,144 @@ +;; jabber-register.el - registration according to JEP-0077 + +;; Copyright (C) 2003, 2004, 2007 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-iq) +(require 'jabber-widget) + +(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 JEP-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"))) + +(provide 'jabber-register) + +;;; arch-tag: e6b349d6-b1ad-4d19-a412-74459dfae239 diff --git a/jabber-roster.el b/jabber-roster.el new file mode 100644 index 0000000..b62b182 --- /dev/null +++ b/jabber-roster.el @@ -0,0 +1,893 @@ +;; jabber-roster.el - displaying the roster -*- coding: utf-8; -*- + +;; Copyright (C) 2009 - Kirill A. Korinskiy - catap@catap.ru +;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-presence) +(require 'jabber-util) +(require 'jabber-alert) +(require 'jabber-keymap) +(require 'format-spec) +(require 'cl) ;for `find' +(require 'jabber-private) + +(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 (interactive-p) + (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")))) + +(provide 'jabber-roster) + +;;; arch-tag: 096af063-0526-4dd2-90fd-bc6b5ba07d32 diff --git a/jabber-rtt.el b/jabber-rtt.el new file mode 100644 index 0000000..8d34850 --- /dev/null +++ b/jabber-rtt.el @@ -0,0 +1,321 @@ +;;; jabber-rtt.el --- XEP-0301: In-Band Real Time Text + +;; Copyright (C) 2013 Magnus Henoch + +;; Author: Magnus Henoch <magnus.henoch@gmail.com> + +;; 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 3 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, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(eval-when-compile (require 'cl)) + +;;;; Handling incoming events + +;;;###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) + +;; Add function last in chain, so a chat buffer is already created. +;;;###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))))) + +;;;; Sending events + +(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)) + +(provide 'jabber-rtt) +;;; jabber-rtt.el ends here diff --git a/jabber-sasl.el b/jabber-sasl.el new file mode 100644 index 0000000..61d3c56 --- /dev/null +++ b/jabber-sasl.el @@ -0,0 +1,157 @@ +;; jabber-sasl.el - SASL authentication + +;; Copyright (C) 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu + +;; This file is a part of jabber.el. + +;; 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 + +(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. + +(require 'jabber-xml) + +(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))) + +(provide 'jabber-sasl) +;;; arch-tag: 2a4a234d-34d3-49dd-950d-518c899c0fd0 diff --git a/jabber-sawfish.el b/jabber-sawfish.el new file mode 100644 index 0000000..3cc7a5a --- /dev/null +++ b/jabber-sawfish.el @@ -0,0 +1,44 @@ +;; jabber-sawfish.el - emacs-jabber interface to sawfish + +;; Copyright (C) 2005 - Mario Domenech Goulart + +;; This file is a part of jabber.el. + +;; 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 + +(eval-when-compile (require 'jabber-alert)) + +(defcustom jabber-sawfish-display-time 3 + "Time in seconds for displaying a jabber message through the +Sawfish window manager." + :type 'integer + :group 'jabber-alerts) + +(defun jabber-sawfish-display-message (text &optional title) + "Displays MESSAGE through the Sawfish window manager." + (let ((process-connection-type nil)) + (start-process-shell-command + "jabber-sawfish" nil "echo" + (concat "'(progn (require (quote timers)) (display-message \"" + (or title text) + "\")(make-timer (lambda () (display-message nil)) " + (number-to-string jabber-sawfish-display-time) + "))' | sawfish-client - &> /dev/null")))) + +(define-jabber-alert sawfish "Display a message through the Sawfish window manager" + 'jabber-sawfish-display-message) + +(provide 'jabber-sawfish) +;; arch-tag: 4F0154ED-5D05-11D9-9E6B-000A95C2FCD0 diff --git a/jabber-screen.el b/jabber-screen.el new file mode 100644 index 0000000..b6f5ae5 --- /dev/null +++ b/jabber-screen.el @@ -0,0 +1,31 @@ +;; jabber-screen.el - emacs-jabber interface to screen + +;; Copyright (C) 2005 - Magnus Henoch - mange@freemail.hu + +;; This file is a part of jabber.el. + +;; 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 + +(eval-when-compile (require 'jabber-alert)) + +(defun jabber-screen-message (text &optional title) + "Show MSG in screen" + (call-process "screen" nil nil nil "-X" "echo" (or title text))) + +(define-jabber-alert screen "Show a message through the Screen terminal manager" + 'jabber-screen-message) + +(provide 'jabber-screen) +;; arch-tag: B576ADDA-5D04-11D9-AA52-000A95C2FCD0 diff --git a/jabber-search.el b/jabber-search.el new file mode 100644 index 0000000..c5a2f9e --- /dev/null +++ b/jabber-search.el @@ -0,0 +1,116 @@ +;; jabber-search.el - searching by JEP-0055, with x:data support + +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net +;; Copyright (C) 2003, 2004 - Magnus Henoch - mange@freemail.hu + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-register) + +(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")) + +;; jabber-process-register-or-search logically comes here, rendering +;; the search form, but since register and search are so similar, +;; having two functions would be serious code duplication. See +;; jabber-register.el. + +;; jabber-submit-search is called when the "submit" button of the +;; search form is activated. +(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")))))) + +(provide 'jabber-search) + +;;; arch-tag: c39e9241-ab6f-4ac5-b1ba-7908bbae009c diff --git a/jabber-si-client.el b/jabber-si-client.el new file mode 100644 index 0000000..8e1c5a2 --- /dev/null +++ b/jabber-si-client.el @@ -0,0 +1,70 @@ +;; jabber-si-client.el - send stream requests, by JEP-0095 + +;; Copyright (C) 2004 - Magnus Henoch - mange@freemail.hu + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-iq) +(require 'jabber-feature-neg) + +(require 'jabber-si-common) + +(defun jabber-si-initiate (jc jid profile-namespace profile-data profile-function &optional mime-type) + "Try to initiate a stream to JID. +PROFILE-NAMESPACE is, well, the namespace of the profile to use. +PROFILE-DATA is the XML data to send within the SI request. +PROFILE-FUNCTION is the \"connection established\" function. +See `jabber-si-stream-methods'. +MIME-TYPE is the MIME type to specify. +Returns the SID." + + (let ((sid (apply 'format "emacs-sid-%d.%d.%d" (current-time)))) + (jabber-send-iq jc jid "set" + `(si ((xmlns . "http://jabber.org/protocol/si") + (id . ,sid) + ,(if mime-type + (cons 'mime-type mime-type)) + (profile . ,profile-namespace)) + ,profile-data + (feature ((xmlns . "http://jabber.org/protocol/feature-neg")) + ,(jabber-fn-encode (list + (cons "stream-method" + (mapcar 'car jabber-si-stream-methods))) + 'request))) + #'jabber-si-initiate-process (cons profile-function sid) + ;; XXX: use other function here? + #'jabber-report-success "Stream initiation") + sid)) + +(defun jabber-si-initiate-process (jc xml-data closure-data) + "Act on response to our SI query." + + (let* ((profile-function (car closure-data)) + (sid (cdr closure-data)) + (from (jabber-xml-get-attribute xml-data 'from)) + (query (jabber-iq-query xml-data)) + (feature-node (car (jabber-xml-get-children query 'feature))) + (feature-alist (jabber-fn-parse feature-node 'response)) + (chosen-method (cadr (assoc "stream-method" feature-alist))) + (method-data (assoc chosen-method jabber-si-stream-methods))) + ;; Our work is done. Hand it over to the stream method. + (let ((stream-negotiate (nth 1 method-data))) + (funcall stream-negotiate jc from sid profile-function)))) + +(provide 'jabber-si-client) + +;;; arch-tag: e14ec451-3f18-4f36-b92a-e8a8aa1f5acd diff --git a/jabber-si-common.el b/jabber-si-common.el new file mode 100644 index 0000000..c5c8ff7 --- /dev/null +++ b/jabber-si-common.el @@ -0,0 +1,61 @@ +;;; jabber-si-common.el --- stream initiation (JEP-0095) + +;; Copyright (C) 2006 Magnus Henoch + +;; Author: Magnus Henoch <mange@freemail.hu> + +;; This file 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, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +(defvar jabber-si-stream-methods nil + "Supported SI stream methods. + +Each entry is a list, containing: + * The namespace URI of the stream method + * Active initiation function + * Passive initiation function + +The active initiation function should initiate the connection, +while the passive initiation function should wait for an incoming +connection. Both functions take the same arguments: + + * JID of peer + * SID + * \"connection established\" function + +The \"connection established\" function should be called when the +stream has been established and data can be transferred. It is part +of the profile, and takes the following arguments: + + * JID of peer + * SID + * Either: + - \"send data\" function, with one string argument + - an error message, when connection failed + +It returns an \"incoming data\" function. + +The \"incoming data\" function should be called when data arrives on +the stream. It takes these arguments: + + * JID of peer + * SID + * A string containing the received data, or nil on EOF + +If it returns nil, the stream should be closed.") + +(provide 'jabber-si-common) +;; arch-tag: 9e7a5c8a-bdde-11da-8030-000a95c2fcd0 +;;; jabber-si-common.el ends here diff --git a/jabber-si-server.el b/jabber-si-server.el new file mode 100644 index 0000000..70b99ad --- /dev/null +++ b/jabber-si-server.el @@ -0,0 +1,92 @@ +;; jabber-si-server.el - handle incoming stream requests, by JEP-0095 + +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net +;; Copyright (C) 2003, 2004 - Magnus Henoch - mange@freemail.hu + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-iq) +(require 'jabber-disco) +(require 'jabber-feature-neg) + +(require 'jabber-si-common) + +(jabber-disco-advertise-feature "http://jabber.org/protocol/si") + +;; Now, stream methods push data to profiles. It could be the other +;; way around; not sure which is better. +(defvar jabber-si-profiles nil + "Supported SI profiles. + +Each entry is a list, containing: + * The namespace URI of the profile + * Accept function, taking entire IQ stanza, and signalling a 'forbidden' + error if request is declined; returning an XML node to return in + response, or nil of none needed + * \"Connection established\" function. See `jabber-si-stream-methods'.") + +(add-to-list 'jabber-iq-set-xmlns-alist + (cons "http://jabber.org/protocol/si" 'jabber-si-process)) +(defun jabber-si-process (jc xml-data) + + (let* ((to (jabber-xml-get-attribute xml-data 'from)) + (id (jabber-xml-get-attribute xml-data 'id)) + (query (jabber-iq-query xml-data)) + (profile (jabber-xml-get-attribute query 'profile)) + (si-id (jabber-xml-get-attribute query 'id)) + (feature (car (jabber-xml-get-children query 'feature)))) + (message "Receiving SI with profile '%s'" profile) + + (let (stream-method + ;; Find profile + (profile-data (assoc profile jabber-si-profiles))) + ;; Now, feature negotiation for stream type (errors + ;; don't match JEP-0095, so convert) + (condition-case err + (setq stream-method (jabber-fn-intersection + (jabber-fn-parse feature 'request) + (list (cons "stream-method" (mapcar 'car jabber-si-stream-methods))))) + (jabber-error + (jabber-signal-error "cancel" 'bad-request nil + '((no-valid-streams ((xmlns . "http://jabber.org/protocol/si"))))))) + (unless profile-data + ;; profile not understood + (jabber-signal-error "cancel" 'bad-request nil + '((bad-profile ((xmlns . "http://jabber.org/protocol/si")))))) + (let* ((profile-accept-function (nth 1 profile-data)) + ;; accept-function might throw a "forbidden" error + ;; on user cancel + (profile-response (funcall profile-accept-function jc xml-data)) + (profile-connected-function (nth 2 profile-data)) + (stream-method-id (nth 1 (assoc "stream-method" stream-method))) + (stream-data (assoc stream-method-id jabber-si-stream-methods)) + (stream-accept-function (nth 2 stream-data))) + ;; prepare stream for the transfer + (funcall stream-accept-function jc to si-id profile-connected-function) + ;; return result of feature negotiation of stream type + (jabber-send-iq jc to "result" + `(si ((xmlns . "http://jabber.org/protocol/si")) + ,@profile-response + (feature ((xmlns . "http://jabber.org/protocol/feature-neg")) + ,(jabber-fn-encode stream-method 'response))) + nil nil nil nil + id) + )))) + +(provide 'jabber-si-server) + +;;; arch-tag: d3c75c66-4052-4cf5-8f04-8765adfc8b96 diff --git a/jabber-socks5.el b/jabber-socks5.el new file mode 100644 index 0000000..97f6d8a --- /dev/null +++ b/jabber-socks5.el @@ -0,0 +1,678 @@ +;; jabber-socks5.el - SOCKS5 bytestreams by JEP-0065 + +;; Copyright (C) 2003, 2004, 2007 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-iq) +(require 'jabber-disco) +(require 'jabber-si-server) +(require 'jabber-si-client) + +;; jabber-core will require fsm for us +(require 'jabber-core) +(eval-when-compile (require 'cl)) + +(defvar jabber-socks5-pending-sessions nil + "List of pending sessions. + +Each entry is a list, containing: + * Stream ID + * Full JID of initiator + * State machine managing the session") + +(defvar jabber-socks5-active-sessions nil + "List of active sessions. + +Each entry is a list, containing: + * Network connection + * Stream ID + * Full JID of initiator + * Profile data function") + +(defcustom jabber-socks5-proxies nil + "JIDs of JEP-0065 proxies to use for file transfer. +Put preferred ones first." + :type '(repeat string) + :group 'jabber +; :set 'jabber-socks5-set-proxies) + ) + +(defvar jabber-socks5-proxies-data nil + "Alist containing information about proxies. +Keys of the alist are strings, the JIDs of the proxies. +Values are \"streamhost\" XML nodes.") + +(jabber-disco-advertise-feature "http://jabber.org/protocol/bytestreams") + +(add-to-list 'jabber-si-stream-methods + (list "http://jabber.org/protocol/bytestreams" + 'jabber-socks5-client-1 + 'jabber-socks5-accept)) + +(defun jabber-socks5-set-proxies (symbol value) + "Set `jabber-socks5-proxies' and query proxies. +This is the set function of `jabber-socks5-proxies-data'." + (set-default symbol value) + (when jabber-connections + (jabber-socks5-query-all-proxies))) + +(defun jabber-socks5-query-all-proxies (jc &optional callback) + "Ask all proxies in `jabber-socks5-proxies' for connection information. +If CALLBACK is non-nil, call it with no arguments when all +proxies have answered." + (interactive (list (jabber-read-account))) + (setq jabber-socks5-proxies-data nil) + (dolist (proxy jabber-socks5-proxies) + (jabber-socks5-query-proxy jc proxy callback))) + +(defun jabber-socks5-query-proxy (jc jid &optional callback) + "Query the SOCKS5 proxy specified by JID for IP and port number." + (jabber-send-iq jc jid "get" + '(query ((xmlns . "http://jabber.org/protocol/bytestreams"))) + #'jabber-socks5-process-proxy-response (list callback t) + #'jabber-socks5-process-proxy-response (list callback nil))) + +(defun jabber-socks5-process-proxy-response (jc xml-data closure-data) + "Process response from proxy query." + (let* ((query (jabber-iq-query xml-data)) + (from (jabber-xml-get-attribute xml-data 'from)) + (streamhosts (jabber-xml-get-children query 'streamhost))) + + (let ((existing-entry (assoc from jabber-socks5-proxies-data))) + (when existing-entry + (setq jabber-socks5-proxies-data + (delq existing-entry jabber-socks5-proxies-data)))) + + (destructuring-bind (callback successp) closure-data + (when successp + (setq jabber-socks5-proxies-data + (cons (cons from streamhosts) + jabber-socks5-proxies-data))) + (message "%s from %s. %d of %d proxies have answered." + (if successp "Response" "Error") from + (length jabber-socks5-proxies-data) (length jabber-socks5-proxies)) + (when (and callback (= (length jabber-socks5-proxies-data) (length jabber-socks5-proxies))) + (funcall callback))))) + +(define-state-machine jabber-socks5 + :start ((jc jid sid profile-function role) + "Start JEP-0065 bytestream with JID. +SID is the session ID used. +PROFILE-FUNCTION is the function to call upon success. See `jabber-si-stream-methods'. +ROLE is either :initiator or :target. The initiator sends an IQ +set; the target waits for one." + (let ((new-state-data (list :jc jc + :jid jid + :sid sid + :profile-function profile-function + :role role)) + (new-state + ;; We want information about proxies; it might be needed in + ;; various situations. + (cond + ((null jabber-socks5-proxies) + ;; We know no proxy addresses. Try to find them by disco. + 'seek-proxies) + ((null jabber-socks5-proxies-data) + ;; We need to query the proxies for addresses. + 'query-proxies) + ;; So, we have our proxies. + (t + 'initiate)))) + (list new-state new-state-data nil)))) + +(defun jabber-socks5-accept (jc jid sid profile-function) + "Remember that we are waiting for connection from JID, with stream id SID" + ;; asking the user for permission is done in the profile + (add-to-list 'jabber-socks5-pending-sessions + (list sid jid (start-jabber-socks5 jc jid sid profile-function :target)))) + +(define-enter-state jabber-socks5 seek-proxies (fsm state-data) + ;; Look for items at the server. + (let* ((jc (plist-get state-data :jc)) + (server (jabber-jid-server (jabber-connection-jid jc)))) + (jabber-disco-get-items jc + server + nil + (lambda (jc fsm result) + (fsm-send-sync fsm (cons :items result))) + fsm)) + ;; Spend no more than five seconds looking for a proxy. + (list state-data 5)) + +(define-state jabber-socks5 seek-proxies (fsm state-data event callback) + "Collect disco results, looking for a bytestreams proxy." + ;; We put the number of outstanding requests as :remaining-info in + ;; the state-data plist. + (cond + ;; We're not ready to handle the IQ stanza yet + ((eq (car-safe event) :iq) + :defer) + + ;; Got list of items at the server. + ((eq (car-safe event) :items) + (dolist (entry (cdr event)) + ;; Each entry is ["name" "jid" "node"]. We send a disco info + ;; request to everything without a node. + (when (null (aref entry 2)) + (lexical-let ((jid (aref entry 1))) + (jabber-disco-get-info + (plist-get state-data :jc) + jid nil + (lambda (jc fsm result) + (fsm-send-sync fsm (list :info jid result))) + fsm)))) + ;; Remember number of requests sent. But if none, we just go on. + (if (cdr event) + (list 'seek-proxies (plist-put state-data :remaining-info (length (cdr event))) :keep) + (list 'initiate state-data nil))) + + ;; Got disco info from an item at the server. + ((eq (car-safe event) :info) + (fsm-debug-output "got disco event") + ;; Count the response. + (plist-put state-data :remaining-info (1- (plist-get state-data :remaining-info))) + (unless (eq (first (third event)) 'error) + (let ((identities (first (third event)))) + ;; Is it a bytestream proxy? + (when (dolist (identity identities) + (when (and (string= (aref identity 1) "proxy") + (string= (aref identity 2) "bytestreams")) + (return t))) + ;; Yes, it is. Add it to the list. + (push (second event) jabber-socks5-proxies)))) + + ;; Wait for more responses, if any are to be expected. + (if (zerop (plist-get state-data :remaining-info)) + ;; No more... go on to querying the proxies. + (list 'query-proxies state-data nil) + ;; We expect more responses... + (list 'seek-proxies state-data :keep))) + + ((eq event :timeout) + ;; We can't wait anymore... + (list 'query-proxies state-data nil)))) + +(define-enter-state jabber-socks5 query-proxies (fsm state-data) + (jabber-socks5-query-all-proxies + (plist-get state-data :jc) + (lexical-let ((fsm fsm)) + (lambda () (fsm-send-sync fsm :proxies)))) + (list state-data 5)) + +(define-state jabber-socks5 query-proxies (fsm state-data event callback) + "Query proxies in `jabber-socks5-proxies'." + (cond + ;; Can't handle the iq stanza yet... + ((eq (car-safe event) :iq) + :defer) + + ((eq (car-safe event) :info) + ;; stray event... do nothing + (list 'query-proxies state-data :keep)) + + ;; Got response/error from all proxies, or timeout + ((memq event '(:proxies :timeout)) + (list 'initiate state-data nil)))) + +(define-enter-state jabber-socks5 initiate (fsm state-data) + ;; Sort the alist jabber-socks5-proxies-data such that the + ;; keys are in the same order as in jabber-socks5-proxies. + (setq jabber-socks5-proxies-data + (sort jabber-socks5-proxies-data + #'(lambda (a b) + (> (length (member (car a) jabber-socks5-proxies)) + (length (member (car b) jabber-socks5-proxies)))))) + + ;; If we're the initiator, send initiation stanza. + (when (eq (plist-get state-data :role) :initiator) + ;; This is where initiation of server sockets would go + + (jabber-send-iq + (plist-get state-data :jc) + (plist-get state-data :jid) "set" + `(query ((xmlns . "http://jabber.org/protocol/bytestreams") + (sid . ,(plist-get state-data :sid))) + ,@(mapcar + #'(lambda (proxy) + (mapcar + #'(lambda (streamhost) + (list 'streamhost + (list (cons 'jid (jabber-xml-get-attribute streamhost 'jid)) + (cons 'host (jabber-xml-get-attribute streamhost 'host)) + (cons 'port (jabber-xml-get-attribute streamhost 'port))) + ;; (proxy ((xmlns . "http://affinix.com/jabber/stream"))) + )) + (cdr proxy))) + jabber-socks5-proxies-data) + ;; (fast ((xmlns . "http://affinix.com/jabber/stream"))) + ) + (lexical-let ((fsm fsm)) + (lambda (jc xml-data closure-data) + (fsm-send-sync fsm (list :iq xml-data)))) + nil + ;; TODO: error handling + #'jabber-report-success "SOCKS5 negotiation")) + + ;; If we're the target, we just wait for an incoming stanza. + (list state-data nil)) + +(add-to-list 'jabber-iq-set-xmlns-alist + (cons "http://jabber.org/protocol/bytestreams" 'jabber-socks5-process)) +(defun jabber-socks5-process (jc xml-data) + "Accept IQ get for SOCKS5 bytestream" + (let* ((jid (jabber-xml-get-attribute xml-data 'from)) + (id (jabber-xml-get-attribute xml-data 'id)) + (query (jabber-iq-query xml-data)) + (sid (jabber-xml-get-attribute query 'sid)) + (session (dolist (pending-session jabber-socks5-pending-sessions) + (when (and (equal sid (nth 0 pending-session)) + (equal jid (nth 1 pending-session))) + (return pending-session))))) + ;; check that we really are expecting this session + (unless session + (jabber-signal-error "auth" 'not-acceptable)) + + (setq jabber-socks5-pending-sessions (delq session jabber-socks5-pending-sessions)) + (fsm-send-sync (nth 2 session) (list :iq xml-data)) + + ;; find streamhost to connect to +;; (let* ((streamhosts (jabber-xml-get-children query 'streamhost)) +;; (streamhost (dolist (streamhost streamhosts) +;; (let ((connection (jabber-socks5-connect streamhost sid jid (concat jabber-username "@" jabber-server "/" jabber-resource)))) +;; (when connection +;; ;; We select the first streamhost that we are able to connect to. +;; (push (list connection sid jid profile-data-function) +;; jabber-socks5-active-sessions) +;; ;; Now set the filter, for the rest of the output +;; (set-process-filter connection #'jabber-socks5-filter) +;; (set-process-sentinel connection #'jabber-socks5-sentinel) +;; (return streamhost)))))) +;; (unless streamhost +;; (jabber-signal-error "cancel" 'item-not-found)) + +;; ;; tell initiator which streamhost we use +;; (jabber-send-iq jid "result" +;; `(query ((xmlns . "http://jabber.org/protocol/bytestreams")) +;; (streamhost-used ((jid . ,(jabber-xml-get-attribute streamhost 'jid))))) +;; nil nil nil nil id) +;; ;; now, as data is sent, it will be passed to the profile. +;; ) + )) + +(define-state jabber-socks5 initiate (fsm state-data event callback) + (let* ((jc (plist-get state-data :jc)) + (jc-data (fsm-get-state-data jc)) + (our-jid (concat (plist-get jc-data :username) "@" + (plist-get jc-data :server) "/" + (plist-get jc-data :resource))) + (their-jid (plist-get state-data :jid)) + (initiator-jid (if (eq (plist-get state-data :role) :initiator) our-jid their-jid)) + (target-jid (if (eq (plist-get state-data :role) :initiator) their-jid our-jid))) + (cond + ;; Stray event... + ((memq (car-safe event) '(:proxy :info)) + (list 'initiate state-data :keep)) + + ;; Incoming IQ + ((eq (car-safe event) :iq) + (let ((xml-data (second event))) + ;; This is either type "set" (with a list of streamhosts to + ;; use), or a "result" (indicating the streamhost finally used + ;; by the other party). + (cond + ((string= (jabber-xml-get-attribute xml-data 'type) "set") + ;; A "set" makes sense if we're the initiator and offered + ;; Psi's "fast mode". We don't yet, though, so this is only + ;; for target. + (dolist (streamhost (jabber-xml-get-children (jabber-iq-query xml-data) 'streamhost)) + (jabber-xml-let-attributes + (jid host port) streamhost + ;; This is where we would attempt to support zeroconf + (when (and jid host port) + (start-jabber-socks5-connection + jc initiator-jid target-jid jid + (plist-get state-data :sid) host port fsm)))) + + (list 'wait-for-connection (plist-put state-data :iq-id (jabber-xml-get-attribute xml-data 'id)) 30)) + + ((string= (jabber-xml-get-attribute xml-data 'type) "result") + ;; The other party has decided what streamhost to use. + (let* ((proxy-used (jabber-xml-get-attribute (jabber-xml-path xml-data '(query streamhost-used)) 'jid)) + ;; If JID is our own JID, we have probably already detected + ;; what connection to use. But that is a later problem... + (streamhosts (cdr (assoc proxy-used jabber-socks5-proxies-data)))) + ;; Try to connect to all addresses of this proxy... + (dolist (streamhost streamhosts) + (jabber-xml-let-attributes + (jid host port) streamhost + (when (and jid host port) + (start-jabber-socks5-connection + jc initiator-jid target-jid jid + (plist-get state-data :sid) host port fsm))))) + + (list 'wait-for-connection state-data 30)))))))) + +(define-state-machine jabber-socks5-connection + :start + ((jc initiator-jid target-jid streamhost-jid sid host port socks5-fsm) + "Connect to a single JEP-0065 streamhost." + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + ;; make-network-process, which we really want, for asynchronous + ;; connection and such, was introduced in Emacs 22. + (if (fboundp 'make-network-process) + (let ((connection + (make-network-process + :name "socks5" + :buffer nil + :host host + :service (string-to-number port) + :nowait t + :filter (fsm-make-filter fsm) + :sentinel (fsm-make-sentinel fsm)))) + (list 'wait-for-connection + (list :jc jc + :connection connection + :initiator-jid initiator-jid + :target-jid target-jid + :streamhost-jid streamhost-jid + :sid sid + :socks5-fsm socks5-fsm) + 30)) + ;; So we open a stream, and wait for the connection to succeed. + (condition-case nil + (let ((connection + (open-network-stream "socks5" nil + host (string-to-number port)))) + (set-process-filter connection (fsm-make-filter fsm)) + (set-process-sentinel connection (fsm-make-sentinel fsm)) + (list 'authenticate + (list :jc jc + :connection connection + :initiator-jid initiator-jid + :target-jid target-jid + :streamhost-jid streamhost-jid + :sid sid + :socks5-fsm socks5-fsm) + nil)) + (error (list 'fail '() nil))))))) + +(define-state jabber-socks5-connection wait-for-connection + (fsm state-data event callback) + (cond + ((eq (car-safe event) :sentinel) + (let ((string (third event))) + (cond + ;; Connection succeeded + ((string= (substring string 0 4) "open") + (list 'authenticate state-data nil)) + ;; Connection failed + (t + (list 'fail state-data nil))))))) + +(define-enter-state jabber-socks5-connection authenticate + (fsm state-data) + "Send authenticate command." + ;; version: 5. number of auth methods supported: 1. + ;; which one: no authentication. + (process-send-string (plist-get state-data :connection) (string 5 1 0)) + (list state-data 30)) + +(define-state jabber-socks5-connection authenticate + (fsm state-data event callback) + "Receive response to authenticate command." + (cond + ((eq (car-safe event) :filter) + (let ((string (third event))) + ;; should return: + ;; version: 5. auth method to use: none + (if (string= string (string 5 0)) + ;; Authenticated. Send connect command. + (list 'connect state-data nil) + ;; Authentication failed... + (delete-process (second event)) + (list 'fail state-data nil)))) + + ((eq (car-safe event) :sentinel) + (list 'fail state-data nil)))) + +(define-enter-state jabber-socks5-connection connect (fsm state-data) + "Send connect command." + (let* ((sid (plist-get state-data :sid)) + (initiator (plist-get state-data :initiator-jid)) + (target (plist-get state-data :target-jid)) + (hash (sha1-string (concat sid initiator target)))) + (process-send-string + (plist-get state-data :connection) + (concat (string 5 1 0 3 (length hash)) + hash + (string 0 0))) + (list state-data 30))) + +(define-state jabber-socks5-connection connect + (fsm state-data event callback) + "Receive response to connect command." + (cond + ((eq (car-safe event) :filter) + (let ((string (third event))) + (if (string= (substring string 0 2) (string 5 0)) + ;; connection established + (progn + (fsm-send (plist-get state-data :socks5-fsm) + (list :connected + (plist-get state-data :connection) + (plist-get state-data :streamhost-jid))) + ;; Our work is done + (list 'done nil)) + (list 'fail state-data nil)))) + ((eq (car-safe event) :sentinel) + (list 'fail state-data nil)))) + +(define-state jabber-socks5-connection done + (fsm state-data event callback) + ;; ignore all events + (list 'done nil nil)) + +(define-enter-state jabber-socks5-connection fail (fsm state-data) + ;; Notify parent fsm about failure + (fsm-send (plist-get state-data :socks5-fsm) + :not-connected) + (list nil nil)) + +(define-state jabber-socks5-connection fail + (fsm state-data event callback) + ;; ignore all events + (list 'fail nil nil)) + +(define-state jabber-socks5 wait-for-connection + (fsm state-data event callback) + (cond + ((eq (car-safe event) :connected) + (destructuring-bind (ignored connection streamhost-jid) event + (setq state-data (plist-put state-data :connection connection)) + ;; If we are expected to tell which streamhost we chose, do so. + (let ((iq-id (plist-get state-data :iq-id))) + (when iq-id + (jabber-send-iq + (plist-get state-data :jc) + (plist-get state-data :jid) "result" + `(query ((xmlns . "http://jabber.org/protocol/bytestreams")) + (streamhost-used ((jid . ,streamhost-jid)))) + nil nil nil nil + iq-id))) + + ;; If we are the initiator, we should activate the bytestream. + (if (eq (plist-get state-data :role) :initiator) + (progn + (jabber-send-iq + (plist-get state-data :jc) + streamhost-jid "set" + `(query ((xmlns . "http://jabber.org/protocol/bytestreams") + (sid . ,(plist-get state-data :sid))) + (activate nil ,(plist-get state-data :jid))) + (lambda (jc xml-data fsm) (fsm-send-sync fsm :activated)) fsm + (lambda (jc xml-data fsm) (fsm-send-sync fsm :activation-failed)) fsm) + (list 'wait-for-activation state-data 10)) + ;; Otherwise, we just let the data flow. + (list 'stream-activated state-data nil)))) + + ((eq event :not-connected) + ;; If we were counting the streamhosts, we would know when there + ;; are no more chances left. + (list 'wait-for-connection state-data :keep)) + + ((eq event :timeout) + (list 'fail (plist-put state-data :error "Timeout when connecting to streamhosts") nil)))) + +(define-state jabber-socks5 wait-for-activation + (fsm state-data event callback) + (cond + ((eq event :activated) + (list 'stream-activated state-data nil)) + ((eq event :activation-failed) + (list 'fail (plist-put state-data :error "Proxy activation failed") nil)) + + ;; Stray events from earlier state + ((eq (car-safe event) :connected) + ;; We just close the connection + (delete-process (second event)) + (list 'wait-for-activation state-data :keep)) + ((eq event :not-connected) + (list 'wait-for-activation state-data :keep)))) + +(define-enter-state jabber-socks5 stream-activated + (fsm state-data) + (let ((connection (plist-get state-data :connection)) + (jc (plist-get state-data :jc)) + (jid (plist-get state-data :jid)) + (sid (plist-get state-data :sid)) + (profile-function (plist-get state-data :profile-function))) + (set-process-filter connection (fsm-make-filter fsm)) + (set-process-sentinel connection (fsm-make-sentinel fsm)) + ;; Call the profile function, passing the data send function, and + ;; receiving the data receiving function. Put the data receiving + ;; function in the plist. + (list (plist-put state-data + :profile-data-function + (funcall profile-function + jc jid sid + (lexical-let ((fsm fsm)) + (lambda (data) + (fsm-send fsm (list :send data)))))) + nil))) + + +(define-state jabber-socks5 stream-activated + (fsm state-data event callback) + (let ((jc (plist-get state-data :jc)) + (connection (plist-get state-data :connection)) + (profile-data-function (plist-get state-data :profile-data-function)) + (sid (plist-get state-data :sid)) + (jid (plist-get state-data :jid))) + (cond + ((eq (car-safe event) :send) + (process-send-string connection (second event)) + (list 'stream-activated state-data nil)) + + ((eq (car-safe event) :filter) + ;; Pass data from connection to profile data function + ;; If the data function requests it, tear down the connection. + (unless (funcall profile-data-function jc jid sid (third event)) + (fsm-send fsm (list :sentinel (second event) "shutdown"))) + + (list 'stream-activated state-data nil)) + + ((eq (car-safe event) :sentinel) + ;; Connection terminated. Shuffle together the remaining data, + ;; and kill the buffer. + (delete-process (second event)) + (funcall profile-data-function jc jid sid nil) + (list 'closed nil nil)) + + ;; Stray events from earlier state + ((eq (car-safe event) :connected) + ;; We just close the connection + (delete-process (second event)) + (list 'stream-activated state-data nil)) + ((eq event :not-connected) + (list 'stream-activated state-data nil))))) + +(define-enter-state jabber-socks5 fail (fsm state-data) + "Tell our caller that we failed." + (let ((jc (plist-get state-data :jc)) + (jid (plist-get state-data :jid)) + (sid (plist-get state-data :sid)) + (profile-function (plist-get state-data :profile-function)) + (iq-id (plist-get state-data :iq-id))) + (funcall profile-function jc jid sid (plist-get state-data :error)) + + (when iq-id + (jabber-send-iq-error jc jid iq-id nil "cancel" + 'remote-server-not-found))) + (list nil nil)) + +(defun jabber-socks5-client-1 (jc jid sid profile-function) + "Negotiate a SOCKS5 connection with JID. +This function simply starts a state machine." + (add-to-list 'jabber-socks5-pending-sessions + (list sid jid (start-jabber-socks5 jc jid sid profile-function :initiator)))) + +;; (defun jabber-socks5-client-2 (xml-data jid sid profile-function) +;; "Contact has selected a streamhost to use. Connect to the proxy." +;; (let* ((query (jabber-iq-query xml-data)) +;; (streamhost-used (car (jabber-xml-get-children query 'streamhost-used))) +;; (proxy-used (jabber-xml-get-attribute streamhost-used 'jid)) +;; connection) +;; (let ((streamhosts-left (cdr (assoc proxy-used jabber-socks5-proxies-data)))) +;; (while (and streamhosts-left (not connection)) +;; (setq connection +;; (jabber-socks5-connect (car streamhosts-left) +;; sid +;; (concat jabber-username "@" jabber-server "/" jabber-resource) +;; jid)) +;; (setq streamhosts-left (cdr streamhosts-left)))) +;; (unless connection +;; (error "Couldn't connect to proxy %s" proxy-used)) + +;; ;; Activation is only needed for proxies. +;; (jabber-send-iq proxy-used "set" +;; `(query ((xmlns . "http://jabber.org/protocol/bytestreams") +;; (sid . ,sid)) +;; (activate () ,jid)) +;; (lexical-let ((jid jid) (sid sid) (profile-function profile-function) +;; (connection connection)) +;; (lambda (xml-data closure-data) +;; (jabber-socks5-client-3 xml-data jid sid profile-function connection))) nil +;; ;; TODO: report error to contact? +;; #'jabber-report-success "Proxy activation"))) + +;; (defun jabber-socks5-client-3 (xml-data jid sid profile-function proxy-connection) +;; "Proxy is activated. Start the transfer." +;; ;; The response from the proxy does not contain any interesting +;; ;; information, beyond success confirmation. + +;; (funcall profile-function jid sid +;; (lexical-let ((proxy-connection proxy-connection)) +;; (lambda (data) +;; (process-send-string proxy-connection data))))) + +(provide 'jabber-socks5) + +;;; arch-tag: 9e70dfea-2522-40c6-a79f-302c8fb82ac5 diff --git a/jabber-time.el b/jabber-time.el new file mode 100644 index 0000000..299ccef --- /dev/null +++ b/jabber-time.el @@ -0,0 +1,200 @@ +;; jabber-time.el - time reporting by XEP-0012, XEP-0090, XEP-0202 + +;; Copyright (C) 2006, 2010 - Kirill A. Kroinskiy - catap@catap.ru +;; Copyright (C) 2006 - Magnus Henoch - mange@freemail.hu + +;; This file is a part of jabber.el. + +;; 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +(require 'jabber-iq) +(require 'jabber-util) +(require 'jabber-autoaway) + +(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)))))))) + +;; the only difference between these two functions is the +;; jabber-read-jid-completing call. +(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))) + + +(provide 'jabber-time) + +;; arch-tag: 5396bfda-323a-11db-ac8d-000a95c2fcd0 diff --git a/jabber-tmux.el b/jabber-tmux.el new file mode 100644 index 0000000..379f839 --- /dev/null +++ b/jabber-tmux.el @@ -0,0 +1,32 @@ +;; jabber-tmux.el - emacs-jabber interface to tmux + +;; Copyright (C) 2012 - Michael Cardell Widerkrantz <mc@hack.org> + +;; This file is a part of jabber.el. + +;; 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 + +(eval-when-compile (require 'jabber-alert)) + +(defun jabber-tmux-message (msg) + "Show MSG in tmux" + (call-process "tmux" nil nil nil "display-message" msg)) + +; Automatically defines jabber-{message,muc,presence,info}-tmux +; functions. +(define-jabber-alert tmux "Show a message through the tmux terminal multiplexer" + 'jabber-tmux-message) + +(provide 'jabber-tmux) diff --git a/jabber-truncate.el b/jabber-truncate.el new file mode 100644 index 0000000..bbb7b51 --- /dev/null +++ b/jabber-truncate.el @@ -0,0 +1,75 @@ +;; jabber-truncate.el - cleanup top lines in chatbuffers + +;; Copyright (C) 2007 - Kirill A. Korinskiy - catap@catap.ru + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-chat) +(require 'jabber-alert) + +(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)) + +(provide 'jabber-truncate) + +;; arch-tag: 3d1e3428-f598-11db-a314-000a95c2fcd0 diff --git a/jabber-util.el b/jabber-util.el new file mode 100644 index 0000000..40d2b20 --- /dev/null +++ b/jabber-util.el @@ -0,0 +1,772 @@ +;; jabber-util.el - various utility functions -*- coding: utf-8; -*- + +;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net +;; Copyright (C) 2008, 2010 - Terechkov Evgenii - evg@altlinux.org +;; Copyright (C) 2010 - Kirill A. Korinskiy - catap@catap.ru + +;; This file is a part of jabber.el. + +;; 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 + +(require 'cl) +(condition-case nil + (require 'password) + (error nil)) +(condition-case nil + (require 'auth-source) + (error nil)) + +(defvar jabber-jid-history nil + "History of entered JIDs") + +;; Define `jabber-replace-in-string' somehow. +(cond + ;; Emacs 21 has replace-regexp-in-string. + ((fboundp 'replace-regexp-in-string) + (defsubst jabber-replace-in-string (str regexp newtext) + (replace-regexp-in-string regexp newtext str t t))) + ;; XEmacs has replace-in-string. However, color-theme defines it as + ;; well on Emacs 2x, so this check must be last. + ((fboundp 'replace-in-string) + ;; And the version in color-theme takes only three arguments. Check + ;; just to be sure. + (condition-case nil + (replace-in-string "foobar" "foo" "bar" t) + (wrong-number-of-arguments + (error "`replace-in-string' doesn't accept fourth argument"))) + (defsubst jabber-replace-in-string (str regexp newtext) + (replace-in-string str regexp newtext t))) + (t + (error "No implementation of `jabber-replace-in-string' available"))) + +;;; XEmacs compatibility. Stolen from ibuffer.el +(if (fboundp 'propertize) + (defalias 'jabber-propertize 'propertize) + (defun jabber-propertize (string &rest properties) + "Return a copy of STRING with text properties added. + + [Note: this docstring has been copied from the Emacs 21 version] + +First argument is the string to copy. +Remaining arguments form a sequence of PROPERTY VALUE pairs for text +properties to add to the result." + (let ((str (copy-sequence string))) + (add-text-properties 0 (length str) + properties + str) + str))) + +(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))) + +;;; more XEmacs compatibility +;;; Preserve input method when entering a minibuffer +(if (featurep 'xemacs) + ;; I don't know how to do this + (defsubst jabber-read-with-input-method (prompt &optional initial-contents history default-value) + (read-string prompt initial-contents history default-value)) + (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)))) + +(if (fboundp 'float-time) + (defalias 'jabber-float-time 'float-time) + (defun jabber-float-time (&optional specified-time) + (unless specified-time + (setq specified-time (current-time))) + ;; second precision is good enough for us + (+ (* 65536.0 (car specified-time)) + (cadr specified-time)))) + +(cond + ((fboundp 'cancel-timer) + (defalias 'jabber-cancel-timer 'cancel-timer)) + ((fboundp 'delete-itimer) + (defalias 'jabber-cancel-timer 'delete-itimer)) + (t + (error "No `cancel-timer' function found"))) + +(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 the given connection." + (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 the given connection." + (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 the given connection. +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) + "Given a dead connection, find an active connection to the same account. +Return nil if none found." + (let ((jid (jabber-connection-bare-jid dead-jc))) + (jabber-find-connection jid))) + +(defun jabber-jid-username (string) + "return the username portion of a JID, or nil if no username" + (when (string-match "\\(.*\\)@.*\\(/.*\\)?" string) + (match-string 1 string))) + +(defun jabber-jid-user (string) + "return the user (username@server) portion of a JID" + ;;transports don't have @, so don't require it + ;;(string-match ".*@[^/]*" string) + (string-match "[^/]*" string) + (match-string 0 string)) + +(defun jabber-jid-server (string) + "Return the server portion of a JID." + (string-match "^\\(.*@\\)?\\([^@/]+\\)\\(/.*\\)?$" string) + (match-string 2 string)) + +(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" + (require 'jabber-bookmarks) + (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 (string) + "return the resource portion of a JID, or nil if there is none." + (when (string-match "^\\(\\([^/]*@\\)?[^/]*\\)/\\(.*\\)" string) + (match-string 3 string))) + +(defun jabber-jid-symbol (string) + "return the symbol for the given JID" + ;; If it's already a symbol, just return it. + (if (symbolp string) + string + ;; XXX: "downcase" is poor man's nodeprep. See XMPP CORE. + (intern (downcase (jabber-jid-user string)) 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-ignore-case input jid-completion-table)) + (symbol-name (cdr (assoc-ignore-case input jid-completion-table))) + (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))) + (if (require 'password-cache nil t) + ;; Need to copy the password, as sasl.el wants to erase it. + (copy-sequence + (password-read prompt (jabber-password-key bare-jid))) + (read-passwd prompt)))))) + +(defun jabber-cache-password (bare-jid password) + "Cache PASSWORD for BARE-JID." + (when (fboundp 'password-cache-add) + (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)))) + (when (fboundp 'password-cache-remove) + (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 JEP-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 JEP-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))) + ;; fractions are optional + (fraction (if (eq (aref time 19) ?.) + (string-to-number (substring time 20 23)))) + (timezone (substring time (if fraction 23 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 (JEP-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 JEP-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))))) + +(provide 'jabber-util) + +;;; arch-tag: cfbb73ac-e2d7-4652-a08d-dc789bcded8a diff --git a/jabber-vcard-avatars.el b/jabber-vcard-avatars.el new file mode 100644 index 0000000..eb77493 --- /dev/null +++ b/jabber-vcard-avatars.el @@ -0,0 +1,137 @@ +;;; jabber-vcard-avatars.el --- Avatars by JEP-0153 + +;; Copyright (C) 2006, 2007, 2008 Magnus Henoch + +;; Author: Magnus Henoch <mange@freemail.hu> + +;; This file 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, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; + +;;; Code: + +(require 'jabber-avatar) + +(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))))))) + +(provide 'jabber-vcard-avatars) +;; arch-tag: 3e50d460-8eae-11da-826c-000a95c2fcd0 diff --git a/jabber-vcard.el b/jabber-vcard.el new file mode 100644 index 0000000..aab91cd --- /dev/null +++ b/jabber-vcard.el @@ -0,0 +1,550 @@ +;;; jabber-vcard.el --- vcards according to JEP-0054 + +;; Copyright (C) 2005, 2007 Magnus Henoch + +;; Author: Magnus Henoch <mange@freemail.hu> + +;; This file is a part of jabber.el. + +;; 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, 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; There are great variations in Jabber vcard implementations. This +;; one adds some spice to the mix, while trying to follow the JEP +;; closely. + +;; Fields not implemented: GEO, LOGO, AGENT, ORG, CATEGORIES, SOUND, +;; CLASS, KEY. + +;; The internal data structure used for vCards is an alist. All +;; keys are uppercase symbols. +;; +;; FN, NICKNAME, BDAY, JABBERID, MAILER, TZ, TITLE, ROLE, NOTE, +;; PRODID, REV, SORT-STRING, UID, URL, DESC: +;; Value is a string. +;; +;; N: +;; Value is an alist, with keys FAMILY, GIVEN, MIDDLE, PREFIX and SUFFIX. +;; +;; ADR: +;; Value is a list, each element representing a separate address. +;; The car of each address is a list of types; possible values are +;; HOME, WORK, POSTAL, PARCEL, DOM, INTL, PREF. +;; The cdr of each address is an alist, with keys POBOX, EXTADD, +;; STREET, LOCALITY, REGION, PCODE, CTRY, and values being strings. +;; +;; TEL: +;; Value is a list, each element representing a separate phone number. +;; The car of each number is a list of types; possible values are +;; HOME, WORK, VOICE, FAX, PAGER, MSG, CELL, VIDEO, BBS, MODEM, ISDN, +;; PCS, PREF +;; The cdr is the phone number as a string. +;; +;; EMAIL: +;; Value is a list, each element representing a separate e-mail address. +;; The car of each address is a list of types; possible values are +;; HOME, WORK, INTERNET, PREF, X400. At least one of INTERNET and +;; X400 is always present. +;; The cdr is the address as a string. + +;;; Code: + +(require 'jabber-core) +(require 'jabber-widget) +(require 'jabber-iq) +(require 'jabber-avatar) + +(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))) + + ;; JEP-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"))))))) + + ;; JEP-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)))))) + +(provide 'jabber-vcard) +;; arch-tag: 65B95E9C-63BD-11D9-94A9-000A95C2FCD0 diff --git a/jabber-version.el b/jabber-version.el new file mode 100644 index 0000000..5f3dc19 --- /dev/null +++ b/jabber-version.el @@ -0,0 +1,84 @@ +;; jabber-version.el - version reporting by JEP-0092 + +;; Copyright (C) 2003, 2004, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-iq) +(require 'jabber-util) +(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 JEP-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))) + +(provide 'jabber-version) + +;;; arch-tag: 2051dbe7-01b5-401e-bd8a-fe24afb88e1e diff --git a/jabber-watch.el b/jabber-watch.el new file mode 100644 index 0000000..dfaf991 --- /dev/null +++ b/jabber-watch.el @@ -0,0 +1,76 @@ +;; jabber-watch.el - get notified when certain persons go online + +;; Copyright (C) 2004 - Mathias Dahl +;; Copyright (C) 2004 - Magnus Henoch - mange@freemail.hu + +;; This file is a part of jabber.el. + +;; 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 + +(require 'jabber-util) + +(defcustom jabber-watch-alist nil + "Alist of buddies for which an extra notification should be sent +when they come online, with comment strings as values." + ;; XXX: change symbol to jid-symbol or something, and update + ;; documentation + :type '(alist :key-type symbol :value-type string) + :group 'jabber-watch) + +(defun jabber-presence-watch (who oldstatus newstatus + statustext proposed-alert) + "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))) + +(provide 'jabber-watch) + +;; arch-tag: c27299d8-019e-44b5-9529-d67b8682be23 diff --git a/jabber-widget.el b/jabber-widget.el new file mode 100644 index 0000000..8e8fd0b --- /dev/null +++ b/jabber-widget.el @@ -0,0 +1,363 @@ +;; jabber-widget.el - display various kinds of forms + +;; Copyright (C) 2003, 2004, 2007 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + +(require 'widget) +(require 'wid-edit) +(require 'jabber-util) +(require 'jabber-disco) + +(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 JEP-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 JEP-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 JEP-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))))))))) + +(provide 'jabber-widget) + +;;; arch-tag: da3312f3-1970-41d5-a974-14b8d76156b8 diff --git a/jabber-wmii.el b/jabber-wmii.el new file mode 100644 index 0000000..f0b1a9b --- /dev/null +++ b/jabber-wmii.el @@ -0,0 +1,58 @@ +;; jabber-wmii.el - emacs-jabber interface to wmii + +;; Copyright (C) 2007 - Detlev Zundel - dzu@gnu.org + +;; This file is a part of jabber.el. + +;; 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 + +(eval-when-compile (require 'jabber-alert)) + +(defvar jabber-wmii-color "#ffffff #335577 #447799" + "Color specification as needed by the wmii window manager for the jabber alert messages.") + +(defvar jabber-wmii-reset-time "20 sec" + "If non-nil time to reset wmii message. If nil the message has to be cleared by other means, i.e. from wmiirc.") + +(defvar jabber-wmii-timer nil + "Timer to clear wmii message.") + +(defun jabber-wmii-clear () + "Clear any previous message output through wmii window manager." + (condition-case e + (call-process "wmiir" nil nil nil "remove" "/rbar/jabber") + (error nil))) + +(defun jabber-wmii-message (text &optional title) + "Show MSG in wmii." + (when jabber-wmii-timer + (cancel-timer jabber-wmii-timer)) + (let ((tmp (make-temp-file temporary-file-directory))) + (with-temp-file tmp + (insert jabber-wmii-color " " (or title text))) + ;; Possible errors include not finding the wmiir binary, and + ;; too many pipes open because of message flood. + (condition-case e + (call-process "wmiir" tmp nil nil "create" "/rbar/jabber") + (error nil)) + (delete-file tmp)) + (when jabber-wmii-reset-time + (setq jabber-wmii-timer + (run-at-time jabber-wmii-reset-time nil 'jabber-wmii-clear)))) + +(define-jabber-alert wmii "Show a message through the wmii window manager." + 'jabber-wmii-message) + +(provide 'jabber-wmii) diff --git a/jabber-xmessage.el b/jabber-xmessage.el new file mode 100644 index 0000000..cf942d5 --- /dev/null +++ b/jabber-xmessage.el @@ -0,0 +1,43 @@ +;; jabber-xmessage.el - emacs-jabber interface to xmessage + +;; Copyright (C) 2008 - Magnus Henoch +;; Copyright (C) 2005 - Mario Domenech Goulart + +;; This file is a part of jabber.el. + +;; 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 + +(eval-when-compile (require 'jabber-alert)) + +(defcustom jabber-xmessage-timeout 15 + "Timeout in seconds for xmessage alerts. +Set this to nil to have no timeout." + :type '(choice (integer :tag "Seconds") + (const :tag "No timeout" nil)) + :group 'jabber-alerts) + +(defun jabber-xmessage-display-message (text &optional title) + "Displays MESSAGE using the xmessage program." + (let* ((process-connection-type nil) + (timeout-args (when jabber-xmessage-timeout + (list "-timeout" (number-to-string jabber-xmessage-timeout)))) + (args (append timeout-args (list (or title text))))) + (apply 'start-process "xmessage" nil "xmessage" args))) + +(define-jabber-alert xmessage "Display a message using the xmessage program." + 'jabber-xmessage-display-message) + +(provide 'jabber-xmessage) +;; arch-tag: 10A74D00-5D2C-11D9-A294-000A95C2FCD0 diff --git a/jabber-xml.el b/jabber-xml.el new file mode 100644 index 0000000..520f033 --- /dev/null +++ b/jabber-xml.el @@ -0,0 +1,289 @@ +;; jabber-xml.el - XML functions + +;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; This file is a part of jabber.el. + +;; 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 + +(require 'xml) +(require 'jabber-util) +(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) + "converts an SEXP in the format (tagname ((attribute-name . attribute-value)...) children...) and converts it to well-formatted xml." + (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))) + +;; `xml-get-attribute' returns "" if the attribute is not found, which +;; is not very useful. Therefore, we use `xml-get-attribute-or-nil' +;; if present, or emulate its behavior. +(eval-and-compile + (if (fboundp 'xml-get-attribute-or-nil) + (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-attribute (node attribute) + "Get from NODE the value of ATTRIBUTE. +Return nil if the attribute was not found." + (when (consp node) + (let ((result (xml-get-attribute node attribute))) + (and (> (length result) 0) result)))))) + +(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) + +(provide 'jabber-xml) + +;;; arch-tag: ca206e65-7026-4ee8-9af2-ff6a9c5af98a diff --git a/jabber.el b/jabber.el new file mode 100644 index 0000000..607b726 --- /dev/null +++ b/jabber.el @@ -0,0 +1,253 @@ +;; jabber.el - a minimal jabber client + +;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; SSL - Support, mostly inspired by Gnus +;; Copyright (C) 2005 - Georg Lehner - jorge@magma.com.ni + +;; This file is a part of jabber.el. + +;; 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 + +;;; 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) + +;;; guess internal dependencies! +(require 'jabber-util) +(require 'jabber-menu) +(require 'jabber-xml) +(require 'jabber-conn) +(require 'jabber-core) +(require 'jabber-logon) +(require 'jabber-roster) +(require 'jabber-presence) +(require 'jabber-alert) +(require 'jabber-chat) +(require 'jabber-disco) +(require 'jabber-iq) +(require 'jabber-widget) +(require 'jabber-register) +(require 'jabber-search) +(require 'jabber-browse) +(require 'jabber-muc) +(require 'jabber-muc-nick-completion) +(require 'jabber-version) +(require 'jabber-ahc-presence) +(require 'jabber-modeline) +(require 'jabber-watch) +(require 'jabber-activity) +(require 'jabber-vcard) +(require 'jabber-events) +(require 'jabber-chatstates) +(require 'jabber-vcard-avatars) +(require 'jabber-autoaway) +(require 'jabber-time) +(require 'jabber-truncate) + +(require 'jabber-ft-client) +(require 'jabber-ft-server) +(require 'jabber-socks5) + +;; External notifiers +(require 'jabber-screen) +(require 'jabber-tmux) +(require 'jabber-ratpoison) +(require 'jabber-sawfish) +(require 'jabber-festival) +(require 'jabber-xmessage) +(require 'jabber-wmii) +(require 'jabber-osd) +(require 'jabber-awesome) +(require 'jabber-libnotify) +(require 'jabber-notifications) + +;;;###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 + "Silent mode switch. Not ask confirmanions 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) + +;;; arch-tag: 5145153e-4d19-4dc2-800c-b1282feb155d diff --git a/jabber.texi b/jabber.texi new file mode 100644 index 0000000..128b551 --- /dev/null +++ b/jabber.texi @@ -0,0 +1,3020 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename jabber.info +@settitle jabber.el manual 0.8.0 +@c %**end of header + +@dircategory Emacs +@direntry +* jabber.el: (jabber). Emacs XMPP (Jabber) client +@end direntry + +@copying +This manual is for jabber.el, version 0.8.0. + +Copyright @copyright{} 2004, 2005, 2006, 2007, 2008, 2009 Magnus Henoch, Tom Berger. + +@quotation +Permission is granted to make and distribute verbatim copies or +modified versions of this manual, provided the copyright notice and +this permission notice are preserved on all copies. +@end quotation +@end copying + +@titlepage +@title jabber.el +@subtitle instant messaging for XMPP (Jabber) +@author by Magnus Henoch and Tom Berger + +@page +@vskip 0pt plus 1filll +@insertcopying +@end titlepage + +@contents + +@ifnottex +@node Top, Introduction, (dir), (dir) +@top jabber.el manual + +@insertcopying + +@end ifnottex + +@menu +* Introduction:: +* Basic operation:: +* Groupchat:: +* Composing messages:: +* File transfer:: +* Services:: +* Personal information:: +* Avatars:: +* Time queries:: +* Useful features:: +* Message history:: +* Typing notifications:: +* Roster import and export:: +* XMPP URIs:: +* Customization:: +* Hacking and extending:: +* Protocol support:: +* Concept index:: +* Function index:: +* Variable index:: +@end menu + + +@node Introduction, Basic operation, Top, Top +@chapter Introduction + +jabber.el is an XMPP (Jabber) client running under Emacs. For more +information on the open instant messaging protocol, +please visit @uref{http://xmpp.org}. + +As a XMPP client, jabber.el is mostly just a face in the crowd, +except that it uses buffers where GUI clients have windows. There is +a roster buffer, and to chat with someone you open a chat buffer, and +there are buffers for +interaction with servers and services. Then again, jabber.el delivers +excellent console performance and customizable hooks (if you have +speech synthesizer software, hook it up to your presence alerts). + +jabber.el does not yet support PGP encryption, sending and receiving +roster items, and various other things. + +@menu +* Contacts:: +@end menu + +@node Contacts, , , Introduction +@section Contacts + +@itemize @bullet +@item +There is a web page at +@uref{http://emacs-jabber.sf.net/}. + +@item +There is a Sourceforge +project page at @uref{http://sourceforge.net/projects/emacs-jabber}, +with bug and patch trackers. + +@item +There is a mailing list: +@email{emacs-jabber-general@@lists.sourceforge.net}, +@uref{https://lists.sourceforge.net/lists/listinfo/emacs-jabber-general}, +@uref{http://dir.gmane.org/gmane.emacs.jabber.general} + +@item +There is a chat room, @code{jabber.el@@conference.jabber.se}. If you +have successfully connected, you can join it by typing @kbd{M-x +jabber-muc-join} and entering the address. + +@end itemize + +@node Basic operation, Groupchat, Introduction, Top +@chapter Basic operation + +This chapter is intended as an introduction to basic usage of +jabber.el. If you have used XMPP before and are familiar with the +terminology, you might find it a bit too basic---in that case, just +skim it, making sure to pick up the commands mentioned. + +I'll assume that you have already successfully installed jabber.el; if +not, consult the @file{README} file. Also, make sure you have +@code{(require 'jabber)} or @code{(load "jabber-autoloads")} in your +@file{.emacs}. + +There are a handful of global keybindings for common commands. They +start with @kbd{C-x C-j}, and you can get a list of them by typing +@kbd{C-x C-j C-h}. + +@menu +* Do you have a Jabber account?:: +* Registering an account:: +* Connecting:: +* Chatting:: +* Presence:: +* Presence subscription:: +* Roster buffer:: +@end menu + +@node Do you have a Jabber account?, Registering an account, , Basic operation +@section Do you have a Jabber account? + +Jabber has become rather popular as an instant messaging technology. +Several sites use it, but often not under the names ``Jabber'' or +``XMPP''. Examples: + +@itemize @bullet +@item +Google Talk uses Jabber. If you have a Gmail address, you can use it as +a Jabber ID. @xref{Account settings}, for Google-specific configuration. + +@item +LJ Talk (of Livejournal) uses Jabber. Your Jabber ID is +@samp{@var{ljusername}@@livejournal.com}. +@end itemize + +@node Registering an account, Connecting, Do you have a Jabber account?, Basic operation +@section Registering an account + +@cindex Registering an account + +If you do not yet have a Jabber account, you can register one. The +registration processes for various servers differ, but many servers +support so-called ``in-band registration'', which is described in this +section. + +To register an account, type @kbd{C-u M-x jabber-connect} and enter your +desired JID in the form @samp{@var{username}@@@var{server}}. You will +be presented with a registration form to fill out and send. There the +username you chose will be prefilled. After registration, you can +connect to the server as usual. + +@node Connecting, Chatting, Registering an account, Basic operation +@section Connecting + +@findex jabber-connect-all +@findex jabber-connect +@findex jabber-disconnect-one +@findex jabber-disconnect + +@cindex Connecting + +Now, type @kbd{C-x C-j C-c} and enter your JID and password. If you +successfully connect, jabber.el will download your roster and display it +in a buffer called @code{*-jabber-roster-*}. + +By default, you will appear as ``online'' to your contacts. To change +this to e.g. ``away'', type @kbd{M-x jabber-send-presence} or @kbd{C-x +C-j C-p}. @xref{Presence}, for more information. + +To disconnect, type @kbd{M-x jabber-disconnect} or @kbd{C-x C-j C-d}. +Use @kbd{M-x jabber-disconnect-one} to disconnect just one account (or just type @kbd{C-u C-x C-j C-d}). + +If you don't want to type your JID every time you connect, you can save +it in the variable @code{jabber-account-list}. @xref{Account +settings}. If you configure more than one account, all of them will be +connected when you type @kbd{C-x C-j C-c}, as that key is bound to +@code{jabber-connect-all}. To connect only one account, possibly one +that's not in your list, type @kbd{M-x jabber-connect} or @kbd{C-u C-x +C-j C-c}. + +@node Chatting, Presence, Connecting, Basic operation +@section Chatting + +@cindex Chatting +@findex jabber-chat-with + +There are several ways to open a chat buffer. The shortest way is to +put point over the person you want to chat with in the roster display +and hit RET. + +You can also use the function @code{jabber-chat-with}. This function is +bound to @kbd{C-x C-j C-j} in the global keymap. You will be asked to +enter a JID in the minibuffer. You can also enter the roster name of +one of your contacts. All JIDs and names in your roster can be +tab-completed. + +You can also use menus to access commands. In the roster display, you +can access several menus through keystrokes or mouse clicks. You can +bring one big menu up by pressing the second mouse button, or you can +bring up the ``chat menu'' by typing @kbd{C-c C-c}. If you do the +latter while point is on a roster entry, that entry will be the +default value when you are asked for whom to chat with. + +Now, try opening a chat with someone. A buffer named +@code{*-jabber-chat-:-@var{person}-*} will be created and selected. +Type your message at the end of the buffer, and hit @kbd{RET} to send +it. To include a newline in your message, use @kbd{C-j}. + +When you receive a message from someone, you will see a red indicator in +the mode line. You can click this indicator with the mouse, or type +@kbd{C-x C-j C-l} to switch to the relevant buffer. @xref{Tracking +activity}. + +@node Presence, Presence subscription, Chatting, Basic operation +@section Presence + +@cindex Presence +@cindex Sending presence +@findex jabber-send-presence +@findex jabber-send-default-presence +@vindex jabber-default-show +@vindex jabber-default-status +@vindex jabber-default-priority + +@dfn{Presence} is the Jabber term for letting other people know that you +are online, and additionally how ``available'' you are. There are +three elements to presence: availability state (called ``show''), +status message, and priority. + +Your show state may either be empty (meaning simply ``online''), or +one of @code{away}, @code{xa}, @code{dnd} and @code{chat}, meaning +``away'', ``extended away'' (i.e. away for an extended period), ``do +not disturb'', and ``free for chat'', respectively. This information +is available to everyone subscribing to your presence, but technically +it does not restrict anyone's actions. You can chat with people even +if you claim to be away. + +The status message is a short text complementing your show status, +such as ``at home'', ``working'', ``phone'', ``playing games'' or +whatever you want. It is sent to everyone subscribing to your +presence, but not all clients prominently display it to the user. + +The priority is only interesting if you are running more than one Jabber +client at a time accessing the same account. @xref{Resources and +priority}. + +To set your presence, use the function @code{jabber-send-presence} +(bound to @kbd{C-x C-j C-p}). +It can be called both interactively and in Lisp code. For the latter +case, use something like @code{(jabber-send-presence "away" "idle for +10 minutes" 10)}. There are a few shortcuts: +@table @kbd +@item C-x C-j C-a +Send ``away'' presence (with prefix argument, specify status text) +@item C-x C-j C-x +Send ``extended away'' presence (with prefix argument, specify status +text) +@item C-x C-j C-o +Send default presence (see below) +@end table + +By default, jabber.el sets your presence when you connect. If you +want it not to do that, remove @code{jabber-send-current-presence} +from @code{jabber-post-connect-hooks}. If you want to change the +presence that is sent, change the variables +@code{jabber-default-show}, @code{jabber-default-status} and +@code{jabber-default-priority}. + +With jabber.el, you can set your presence remotely. @xref{Ad-Hoc Commands}. + +@menu +* Resources and priority:: +* Directed presence:: +@end menu + +@node Resources and priority, Directed presence, , Presence +@subsection Resources and priority + +@cindex Resource +@cindex Priority + +Every connection to an account has a specific name, a @dfn{resource}. +The account itself has a JID of the form +@samp{@var{username}@@@var{server}} (a @dfn{bare JID}), but the +connections have JIDs of the form +@samp{@var{username}@@@var{server}/@var{resource}} (a @dfn{full JID}). +You can choose the resource name yourself by entering a JID of the +latter form at the connection prompt (@pxref{Connecting}), or by +configuring it in @code{jabber-account-list} (@pxref{Account settings}) + +Each session has a @dfn{priority}. The priority determines what happens +when a message is sent to the bare JID (i.e. without specifying what +connection should receive message). Such messages are delivered to the +connection with the highest non-negative priority value. If there are +no connections, or if all connections have negative priority, the +message is either stored on the server for later delivery or bounced to +the sender, depending on the server configuration. + +If there are several connections with the same priority, the behaviour +depends on the server. Some server implementations deliver the message +to all such connections, while others choose one connection depending on +certain rules. + +Note that these rules do not apply when a message is sent to a full +JID. Such messages are sent to the specified resource, if it is still +connected, and otherwise treated as messages to the bare JID. In the +chat buffers of jabber.el, messages are sent to whatever JID the last +message came from (usually a full JID), or to the bare JID if no message +has been received yet. Other clients may have different behaviour. + +@node Directed presence, , Resources and priority, Presence +@subsection Directed presence + +@cindex directed presence +@cindex send directed presence +@findex jabber-send-directed-presence +You can send ``directed presence'' with @kbd{M-x +jabber-send-directed-presence}. This is mostly useful to manage +transports---sending directed presence is a way to turn them on and +off. You can also send directed presence to an annoying contact to +appear as away or offline to that contact. Note, however, that in both +of these cases, all subscribed entities will get your next global +presence update. + +@node Presence subscription, Roster buffer, Presence, Basic operation +@section Presence subscription + +@cindex Presence subscription +@cindex Subscribing to someone's presence +@findex jabber-send-subscription-request + +Having permission to view the presence status of a person is called +@dfn{subscribing to his presence}. Presence subscription between two +persons can be asymmetric. Subscription state is shown in the roster +display by arrows (@pxref{Customizing the roster buffer}). A +left-pointing arrow means that the contact can see your presence +(``from''). A right-pointing arrow means that you can see the contact's +presence (``to''). The most common case is mutual subscription, a +double-ended arrow (``both''). + +When jabber.el receives a presence subscription request, it will present +it to you in a chat buffer, and offer you to choose subscription mode +and send a subscription request back to that person. The ``Mutual'' +button accepts the request and sends a reciprocal request.@footnote{If this +request is superfluous, the server will drop it without bothering the +contact.} The ``One-way'' button accepts the request, but doesn't ask +for a subscription in return. The ``Decline'' button declines the +request. + +To request subscription to someone, type @kbd{M-x +jabber-send-subscription-request}. You will be prompted for the JID +to send it to. This command can also be accessed through the Roster +menu, by typing @kbd{C-c C-r} in the roster buffer. After that, you +will probably want to give the contact a more readable name. The +command for that is @code{jabber-roster-change}, which is also +available in the Roster menu or by typing @kbd{e} on a person in the +roster buffer. + +@node Roster buffer, , Presence subscription, Basic operation +@section The roster buffer + +@cindex Roster buffer, basics +@cindex Menus +@cindex Key bindings + +The roster buffer is called @code{*-jabber-roster-*}. It simply +contains a list of the contacts on your roster. If you have several +accounts connected, contacts will be grouped by account. + +In the roster buffer, any command which requires a JID will default to +the JID under point when called. These commands can be called through +either keyboard menus or mouse menus. To open a menu with the mouse, +simply press the second mouse button over the JID in +question.@footnote{For some reason, mouse menus don't work in XEmacs. +Patches are welcome.} This will bring up a menu with all available +actions. The keyboard menus are split into categories: Chat, Roster, +Information, MUC (Multi-User Chat, or groupchat) and Services, opened +by @kbd{C-c C-c}, @kbd{C-c C-r}, @kbd{C-c C-i}, @kbd{C-c C-m} and +@kbd{C-c C-s}, respectively. + +@vindex jabber-roster-show-bindings +A list of keybindings is displayed at the top of the roster buffer. +You can turn it off by setting @code{jabber-roster-show-bindings} to +nil. + +@findex jabber-display-roster +You can call @code{jabber-display-roster} (bound to @kbd{g}) to +redisplay your roster according to changed preferences +(@pxref{Customizing the roster buffer}). This will not refetch your +roster from the server. Refetching the roster is usually not needed, +since updates are pushed to clients automatically. + +You can choose not to have the roster updated automatically on +presence changes (@pxref{Presence alerts}). In that case, you need to +call @code{jabber-display-roster} manually. + +@vindex jabber-show-offline-contacts +@cindex Hiding offline contacts +@cindex Offline contacts, hiding +Please note, that by default offline contacts showed in roster as any +others. To hide them, you can use @kbd{o} in roster buffer. To +permanently hide them, customize @code{jabber-show-offline-contacts} +variable. + +@node Groupchat, Composing messages, Basic operation, Top +@chapter Groupchat + +@cindex Groupchat +@cindex MUC +@cindex Chatrooms + +The groupchat menu can be accessed by typing @kbd{C-c C-m} in the +roster buffer. You can also type the commands directly, as will be +shown here. + +@findex jabber-muc-join +@cindex Joining a groupchat +@cindex Changing nickname +@cindex Nickname, changing +To join a groupchat, type @kbd{M-x jabber-muc-join}. You will +be prompted for the groupchat to join, and your nickname in the +groupchat. This nickname doesn't need to have any correlation to your +JID; in fact, groupchats are usually (but not always) configured such +that only moderators can see your JID. You can change your nickname +with @kbd{M-x jabber-muc-nick}. @xref{Configuration}, for setting default +nicknames. + +@cindex Query groupchat +@vindex jabber-muc-disable-disco-check +When trying to join a room, jabber.el first sends a service discovery +info request to the room, to find out whether it exists and what +features are enabled (in particular whether the room is +password-protected). However, this can cause problems with some buggy +MUC services (or services that respond in a way that jabber.el doesn't +expect). A workaround for that is to set +@code{jabber-muc-disable-disco-check} to @code{t}; however, the bug should be +unearthed and fixed. + +Groupchat messages will be displayed in a buffer called +@code{*-jabber-groupchat-:-@var{groupchat}-*}. By default, the buffer +name is based on the JID of the chat room. If you want a shorter name, +you can add the chat room to your roster and give it a name, using the +command @kbd{M-x jabber-roster-change}. The groupchat buffer works much +like the chat buffer. It has its own class of alerts +(@pxref{Customizing alerts}), and uses activity tracking +(@pxref{Tracking activity}). + +@vindex jabber-muc-completion-delimiter +@vindex jabber-muc-looks-personaling-symbols +@cindex Groupchat completion +@cindex Nick completion in groupchat +Also, to save from repeating unnesesary typing you can press @kbd{Tab} +key to complete nick of a groupchat member that you are talking with. +You can customize your form of personal talking in MUC +(@code{jabber-muc-completion-delimiter}) and form of personal talking to +you (@code{jabber-muc-looks-personaling-symbols})---see ``jabber-chat'' +customization group. Defaults are sane, so it is unlikely that you would +want to change this, but... it is Emacs! + +@cindex Topic, MUC +@findex jabber-muc-set-topic +To change the topic of a groupchat, type @kbd{M-x jabber-muc-set-topic}. +The current topic is shown in the header line. + +@findex jabber-muc-leave +To leave a groupchat, type @kbd{M-x jabber-muc-leave}. + +@findex jabber-muc-get-config +If you are the owner of a groupchat, you can change its configuration +by typing @kbd{M-x jabber-muc-get-config}. A configuration form +will be rendered in new buffer. + +@findex jabber-muc-names +@vindex jabber-muc-print-names-format +To see which people are in a groupchat, type @kbd{M-x +jabber-muc-names}. This gives a list of nicknames, +``affiliations'', and possibly JIDs according @code{jabber-muc-print-names-format}, sorted by ``roles''. +@xref{MUC Administration}, for the meaning of roles and affiliations. + + +@menu +* Configuration:: +* Invitations:: +* Private messages:: +* MUC Administration:: +@end menu + +@node Configuration, Invitations, , Groupchat +@section Configuration + +@vindex jabber-muc-default-nicknames +@vindex jabber-muc-autojoin +@findex jabber-muc-autojoin +@cindex Default MUC nickname +@cindex Autojoin chat rooms +@cindex Bookmarks, MUC +@findex jabber-edit-bookmarks + +You can configure jabber.el to use a certain nickname for a certain +room, or to automatically join a certain room when you connect. You can +do this either by storing bookmarks on the server or by setting Emacs +variables. + +Type @kbd{M-x jabber-edit-bookmarks} to add bookmarks. You can specify +the JID of the conference, the name of the conference (not used by +jabber.el), whether to automatically join the room, your desired +nickname (or leave empty), and the room password (or leave empty). + +The default nickname for groupchats is the username part of your JID. +If you don't use bookmarks, you can set different nicknames for +different groups by customizing @code{jabber-muc-default-nicknames}. +There you specify the JID of the group, and your preferred nickname. + +Automatically joining certain rooms when connecting can be accomplished +by setting @code{jabber-muc-autojoin} to a list containing the JIDs of +the rooms you want to enter. To disable this feature, remove +@code{jabber-muc-autojoin} from @code{jabber-post-connect-hooks}. + +Please note, that @code{jabber-muc-default-nicknames} and +@code{jabber-muc-autojoin} are machine-local, but apply to @emph{all} +accounts---if you connect several accounts, both will try to connect to +the same chat rooms, or use the same nickname. This will lead to +confusion. + +@node Invitations, Private messages, Configuration, Groupchat +@section Invitations + +@cindex Invitations +@findex jabber-muc-invite + +You can invite someone to a groupchat with @kbd{M-x jabber-muc-invite} +(also available in the MUC menu). Pay attention to the order of the +arguments---as both users and rooms are just JIDs, it is technically +possible to invite a room to a user, but that's probably not what you +want. + +When you receive an invitation, it appears in the chat buffer along +with two buttons, ``Accept'' and ``Decline''. Pressing ``Accept'' +enters the room, as you would expect. Pressing ``Decline'' gives you +an opportunity to state the reason why you're not joining. + +@node Private messages, MUC Administration, Invitations, Groupchat +@section Private messages + +@cindex Private MUC messages +@findex jabber-muc-private + +You can open a private chat with a participant in a chat room with +@kbd{M-x jabber-muc-private} (or by using the MUC menu). This creates +a buffer with the name +@code{*-jabber-muc-priv-@var{group}-@var{nickname}-*} (customizable by +@code{jabber-muc-private-buffer-format}), which behaves mostly like an +ordinary chat buffer. This buffer will also be created if someone +sends a private message to you. + +Private MUC messages use the same alerts as normal chat messages. +@xref{Message alerts}. + +@node MUC Administration, , Private messages, Groupchat +@section Administration + +Administration of a MUC room mostly consists of managing roles and +affiliations. Roles are temporary, and apply until the user leaves the +room. Affiliations are permanent, and based on JIDs. + +@subsection Roles + +@findex jabber-muc-set-role +@cindex Kicking, MUC +@cindex Voice, MUC +@cindex Moderator, MUC +@cindex Roles, MUC +If you have moderator privileges, you can change the role of a +participant with @kbd{M-x jabber-muc-set-role}. Kicking means setting +the role to ``none''. Granting and revoking voice are ``participant'' +and ``visitor'', respectively. ``moderator'' gives moderator +privileges, obviously. + +The possible roles are: + +@table @samp +@item moderator +Has voice, can change other people's roles. + +@item participant +Has voice. + +@item visitor +Doesn't have voice (can't send messages to everyone, but can send +private messages) + +@item none +Not in room. +@end table + +@subsection Affiliations + +@findex jabber-muc-set-affiliation +@cindex Affiliations, MUC +@cindex Banning, MUC +If you have admin or owner privileges, you can change the affiliation of +a user with @kbd{M-x jabber-muc-set-affiliation}. Affiliation is +persistent, and based on JIDs. Depending of your affiliation and the +MUC implementation, you might not be allowed to perform all kinds of +changes, and maybe not in one step. + +Affiliations are: + +@table @samp +@item owner +Can destroy room, appoint admins, make people members, ban people. + +@item admin +Can make people members or ban people. + +@item member +Can enter the room, and has voice by default. + +@item none +Rights depend on room configuration. The room might be members-only, or +grant voice only to members. + +@item outcast +Banned from the room. +@end table + + +@node Composing messages, File transfer, Groupchat, Top +@chapter Composing messages + +@findex jabber-compose +@cindex composing messages +@cindex message composition + +The chat buffer interface can be inconvenient for some purposes. As you +can't use @kbd{RET} to insert a newline (use @kbd{C-j} for that), +writing a longer message can be painful. Also, it is not possible to +include a subject in the message, or send the message to multiple +recipients. + +These features are implemented by the message composing tool. Type +@kbd{M-x jabber-compose} to start it. In the buffer that comes up, you +can specify recipients, enter a subject, and type your message. + +@node File transfer, Services, Composing messages, Top +@chapter File transfer + +@cindex File transfer +@cindex Sending files + +jabber.el has limited support for file transfer. The most important +limit is that files sent and received are kept in buffers, so Emacs must +be able to allocate enough memory for the entire file, and the file size +must be smaller than the maximum buffer size.@footnote{The maximum +buffer size depends on in the variable @code{most-positive-fixnum}. On +32-bit systems, this is 128 or 256 megabytes, depending on your +Emacs version.} + +jabber.el is able to exchange files with most Jabber clients (and also +some MSN transports), but notably not with the official Google Talk +client. The Google Talk client uses a different file transfer protocol +which, at the time of this release, has not been published. + +@menu +* Receiving files:: +* Sending files:: +@end menu + +@node Receiving files, Sending files, , File transfer +@section Receiving files + +Receiving files requires no configuration. When someone wants to send a +file to you, you are asked (through @code{yes-or-no-p}) whether you want +to accept the file. If you answer yes, you get to choose where to save +the file. + +If the sender's client is correctly configured (this is often not the +case; see below), the file transfer will start. Currently, the only way +to watch the progress is to inspect the buffer of the file being +transfered; @kbd{C-x C-b} is one way of doing that. @xref{List Buffers, +, Listing Existing Buffers, emacs, GNU Emacs Manual}. When the transfer +is done, the message ``@var{file} downloaded'' appears in the echo area, +and the buffer is killed. + +@c This truly sucks... +If this doesn't happen, it is most likely the sender's fault. The +sender needs to have a public IP address, either directly, through port +forwarding (in which case the client needs to be configured with the +real public IP address), or through an XEP-0065 proxy. If you have +activated XML logging (@pxref{Debug options}), you can see the IP +address that the other client is asking you to connect to there. Often +you will find that this is an internal IP address (often starts with +@code{192.168}). See the documentation of the sender's client for +setting this up. + +@node Sending files, , Receiving files, File transfer +@section Sending files + +@cindex proxy, file transfer +@cindex file transfer proxy +@cindex XEP-0065 proxy + +To send a file to someone, you need an XEP-0065 proxy.@footnote{This +requirement is not inherent in the protocol, only in the current file +transfer implementation of jabber.el, and in Emacs versions earlier than +22.} If your Jabber server hosts such a proxy, it will be found +automatically, otherwise it needs to be manually configured. + +You can check whether your Jabber server has a proxy with @kbd{M-x +jabber-get-disco-items}; see @ref{Service discovery}. + +@vindex jabber-socks5-proxies +@findex jabber-socks5-query-all-proxies +To configure a proxy manually, customize the variable +@code{jabber-socks5-proxies}. Putting @code{proxy.jabber.se} there +should work. Type @kbd{M-x jabber-socks5-query-all-proxies} to see if +the proxies answer. + +@findex jabber-ft-send +Now, you can type @kbd{M-x jabber-ft-send} to send a file to someone. +You need to enter the correct full JID, including resource, to get this +right. If the contact is logged in with only one client, and you can +see it online, just typing the JID or roster name is enough. If you run +the command from a chat buffer, the JID of the contact is given as +the default value. + +If the contact has several clients online, you probably want to send the +file to a particular one. If you run this command from within a chat +buffer, the default target will be the one that last sent a message to +you. If you just type a bare JID or a roster name, the client with the +highest priority will get the file. + +If the contact accepts the file, and the contact's client succeeds in +connecting to the proxy, jabber.el will send the file through the +proxy. During this time, your Emacs will be blocked, so you might want +to avoid sending large files over slow connections. + +@node Services, Personal information, File transfer, Top +@chapter Services + +@cindex Browse buffers + +Not every Jabber entity is a physical person. There are many +automatic entities, called servers, services, components, agents, +transports and other names. The use of these is described here. + +The functions described in this chapter use @dfn{browse buffers}. +Browse buffers are named @code{*-jabber-browse-:-@var{service}-*}, +sometimes with a numerical suffix. The different menus have the same +keybindings as in the roster buffer, and if you call a function +operating on a JID while point is over a JID, that JID will be the +default value, so you don't have to type it or copy it yourself. + +You can change the buffer name template by customizing +the variable @code{jabber-browse-buffer-format}. + +@menu +* Commands:: +* Your home server:: +* Transports:: +* User directories:: +* MUC services:: +@end menu + +@node Commands, Your home server, , Services +@section Commands + +A small number of commands is used for almost all interaction with +Jabber services. Essentially, they are all the same: you request a form +from the server, fill it in, and send it back. + +Most of these commands are available under the Service menu, which is +opened by typing @kbd{C-c C-s}. Service discovery is under the Info +menu instead, which is available under @kbd{C-c C-i}. + +@menu +* Registration:: +* Search:: +* Ad-Hoc Commands:: +* Service discovery:: +* Browsing:: +@end menu + +@node Registration, Search, , Commands +@subsection Registration + +@cindex Registration +@findex jabber-get-register + +You can get a registration form for a service by typing @kbd{M-x +jabber-get-register} and entering the JID of the service. On success, +you get a single-stage form to fill in. + +There are two buttons at the bottom of the form, ``Submit'' and ``Cancel +registration''. ``Submit'' does what you would expect it to, but +``Cancel registration'' cancels any existing registration with the +service. Whichever of them you choose, you get a message in the echo +area informing whether the operation succeeded. + +@node Search, Ad-Hoc Commands, Registration, Commands +@subsection Search + +@cindex Search +@findex jabber-get-search + +You can get a search form for a service by typing @kbd{M-x +jabber-get-search}. This gives you a single-stage form to fill in. +After you press the ``Submit'' button at the bottom, the search results +will be displayed in the same buffer. + +@node Ad-Hoc Commands, Service discovery, Search, Commands +@subsection Ad-Hoc Commands + +@cindex Ad-Hoc Commands +@findex jabber-ahc-get-list +@findex jabber-ahc-execute-command + +jabber.el supports a subset of XEP-0050, the standard for Ad-Hoc +Commands. As the name implies, this can be used for just about +anything. In particular, it is used not only by services, but also by +clients (e.g. Psi, and jabber.el itself). + +To find which commands are available, run ``Request command list'' +(@code{jabber-ahc-get-list}).@footnote{This is the same thing as a +disco items request to the node +@code{http://jabber.org/protocol/commands}.} + +To run a command from the list, put point over it and run ``Execute +command'' (@code{jabber-ahc-execute-command}), accepting the defaults +for JID and node. (If you already know those, you could of course +enter them yourself.) + +What happens next depends on the command and the service. In some +cases, the service just responds that the command has been run. You may +also get a form to fill out. This form may have multiple stages, in +which case there are ``Next'' and ``Previous'' buttons for navigating +between stages. You may also see ``Complete'', which runs the command +skipping any remaining stages of the form, and ``Cancel'', which cancels +the command. + +Currently, jabber.el uses ad-hoc commands for setting presence remotely. +If you realize that you forgot to set your client to ``away'' with a low +priority, you can do it remotely from any JID from +@code{jabber-account-list}. So, you can add disabled JIDs in +@code{jabber-account-list} to allow them control your +presence.@footnote{Most Jabber servers also support kicking a client off +the net by logging in with another client with exactly the same +resource.} + +@node Service discovery, Browsing, Ad-Hoc Commands, Commands +@subsection Service discovery + +@cindex Service discovery +@findex jabber-get-disco-items +@findex jabber-get-disco-info + +Service discovery is used to find information about servers, services +and clients. There are two kinds of requests: find @dfn{info} about a +Jabber entity---i.e. its identity and supported features---and find +@dfn{items} related to an entity, where the definition of ``related'' is +left to the entity itself. + +The commands to execute such requests are @code{jabber-get-disco-info} +and @code{jabber-get-disco-items}, respectively. These commands can be +accessed from the Info menu, which is opened by typing @kbd{C-c C-i}. +The commands accept a JID and optionally a ``node''. + +The result of such a command is displayed in a browse buffer. For an +info request, the result just lists the identities and features of the +entity. For an item request, the related items are listed. The items +may be JIDs, or JIDs with a node. If you put point on one of the items, +its JID and node will be the default value for any Jabber command. + +If you think that the interface to service discovery is awkward and +should be replaced with something better, you are completely right. + +@node Browsing, , Service discovery, Commands +@subsection Browsing + +@cindex Browsing +@findex jabber-get-browse + +Before service discovery, browsing was the way to find information about +Jabber entities. Nowadays it is all but superseded, but jabber.el still +supports it. You can use it by typing @kbd{M-x jabber-get-browse}. It +works much like service discovery. + +@node Your home server, Transports, Commands, Services +@section Your home server + +@cindex Password change +@cindex Changing password +@cindex Account removal +@cindex Removing an account + +You can interact with your Jabber server to change your password or +remove your account. Both of these can be accomplished by typing +@kbd{M-x jabber-get-register} and typing the JID of your server; +@pxref{Registration}. + + +@node Transports, User directories, Your home server, Services +@section Transports to other IM networks + +@cindex Gateways +@cindex Transports +@cindex MSN transport +@cindex ICQ transport +@cindex AIM transport + +Some Jabber services make it possible to communicate with users on other +instant messaging networks (e.g. MSN, ICQ, AIM), in effect turning your +Jabber client into a multi-protocol client. These are called +@dfn{gateways} or @dfn{transports}. They work by impersonating you on +the legacy network; therefore you need to provide your username and +password through registration. + +@subsection Finding a transport + +To use such a transport, you first need to find one, obviously. +Sometimes your home server provides the transports you need, but you are +not limited to those; in principle you can use any transport on the +Jabber network. Some transports only accept local users, though. + +Transports are generally mentioned on the web page of the Jabber server +in question. You can also find transports from within the client; +@pxref{Service discovery}. + +@subsection Registering with a transport + +To register with a transport, type @kbd{M-x jabber-get-register} and +enter the JID of the transport. This will open a registration form +where you get to fill in your login information; @pxref{Registration}. +You can later use this same form to change the information or cancel +your registration. + +After you have registered, the transport will request presence +subscription. It needs that to know when you are online, and +synchronize your presence on the legacy network. + +@subsection Contact list + +Once you are registered, the transport will transfer the contact list +from the legacy service. From the Jabber side, it appears as if lots of +people suddenly request presence subscription to you. This is somewhat +inconvenient, but it is currently the only way that the transport can +influence your Jabber contact list, as it is an entity external to your +server.@footnote{Of course, jabber.el could do more to alleviate this +inconvenience.} + +When you have accepted these presence subscriptions, the contacts from +legacy networks appear as if they were Jabber contacts. + +@subsection Finding users + +Some legacy networks have a global database of users, and some +transports support searching that database. In that case, you can +search for other users with @kbd{M-x jabber-get-search}; +@pxref{Search}. + +@node User directories, MUC services, Transports, Services +@section User directories + +There are some Jabber user directories, usually abbreviated JUDs. The +most well-known one is @samp{users.jabber.org}. You can register with +such a directory to let other people find you (@pxref{Registration}), +and you can search the directory (@pxref{Search}). + +@node MUC services, , User directories, Services +@section MUC services + +MUC services (Multi-User Chat, chat rooms) are usually not operated by +these commands, but by commands specific to the MUC protocol; +@pxref{Groupchat}. However, some MUC services offer nickname +registration through the registration protocol (@pxref{Registration}), +and other commands; @pxref{Ad-Hoc Commands}. + +@node Personal information, Avatars, Services, Top +@chapter Personal information + +@cindex vCard +@cindex Personal information +@findex jabber-vcard-get +@findex jabber-vcard-edit + +The Jabber way of handling personal information (name, addresses, phone +numbers, etc) is ``vCards'' encoded in XML.@footnote{@xref{XEP-0054}.} +You can get information about a user by running @kbd{M-x +jabber-vcard-get}, @kbd{M-x jabber-muc-vcard-get} if you in MUC (also +available in the MUC menu), and you can edit your own information by +running @kbd{M-x jabber-vcard-edit}. + +The form for editing your information can be slightly confusing---you +are allowed to enter any number of addresses, phone numbers and e-mail +addresses, each of which has a set of orthogonal properties. You can +add and remove items with the @samp{[INS]} and @samp{[DEL]} buttons, +respectively. + +This is also where you set your avatar (@pxref{Avatars}). The size of +your avatar file is limited to 8 kilobytes. + +@node Avatars, Time queries, Personal information, Top +@chapter Avatars + +@cindex avatars +@vindex jabber-vcard-avatars-retrieve +@vindex jabber-vcard-avatars-publish +@vindex jabber-avatar-cache-directory +@vindex jabber-chat-buffer-show-avatar + +jabber.el supports viewing and publishing avatars according to XEP-0153, +vCard-Based Avatars. By default, if you have an avatar in your vCard +(@pxref{Personal information}), it will be published for others to see, +and if other people publish their avatars, they will be displayed in the +roster buffer and in the header line of chat buffers, if your Emacs can +display images. Otherwise, jabber.el will not fetch avatars at all. + +To disable retrieval of other people's avatars, set +@code{jabber-vcard-avatars-retrieve} to nil. To disable publishing of +your own avatar, set @code{jabber-vcard-avatars-publish} to nil. To +disable avatars in chat buffer header lines, set +@code{jabber-chat-buffer-show-avatar} to nil. + +There are a number of restrictions on avatar images in the +specification. Most of them are not enforced by jabber.el. +@itemize @bullet +@item +The image should be smaller than 8 kilobytes; this is enforced by +jabber.el. +@item +The image height and width should be between 32 and 96 pixels; the +recommended size is 64 by 64 pixels. +@item +The image should be square. +@item +The image should be in either PNG, GIF, or JPEG format. (jabber.el will +behave incorrectly if the image is not in a format supported by Emacs.) +@end itemize + +Avatars are cached in the directory specified by +@code{jabber-avatar-cache-directory}, by default +@file{~/.emacs.d/jabber-avatar-cache/}.@footnote{The default directory +used to be @file{~/.jabber-avatars}. If this directory already +exists, it will be used.} The cache is never cleaned, so you might +want to do that yourself from time to time. + +@node Time queries, Useful features, Avatars, Top +@chapter Time queries + +@cindex time query +@findex jabber-get-time +With @kbd{M-x jabber-get-time}, you can ask what time an entity (client, +server or component) thinks it is, and what time zone it thinks it is +in. + +@cindex last online +@findex jabber-get-last-online +You can query a server about when a certain user was last seen online. +Use @kbd{M-x jabber-get-last-online} for that. + +@cindex uptime, query +@cindex idle time, query +@findex jabber-get-idle-time +You can also ask a client about how long a user has been idle with +@kbd{M-x jabber-get-idle-time}. Not all clients answer such queries, +e.g. jabber.el doesn't. This command can also tell the uptime of a +server or component. + +The first of these commands uses the old Entity Time protocol +(@pxref{XEP-0090}). It has been superseded by XEP-0202, but jabber.el +doesn't implement the newer protocol yet. The latter two commands use +the Last Activity protocol (@pxref{XEP-0012}). + +@node Useful features, Message history, Time queries, Top +@chapter Useful features + +jabber.el includes a number of features meant to improve the user +interface and do other useful things. + +@menu +* Autoaway:: +* Modeline status:: +* Keepalive:: +* Reconnecting:: +* Tracking activity:: +* Watch buddies:: +* Spell checking:: +* Gmail notifications:: +* Saving groups roll state:: +@end menu + +@node Autoaway, Modeline status, , Useful features +@section Autoaway + +@cindex autoaway +@cindex idle +@cindex xprintidle +@vindex jabber-autoaway-method +@vindex jabber-autoaway-methods +@findex jabber-current-idle-time +@findex jabber-xprintidle-program +@findex jabber-termatime-get-idle-time +@vindex jabber-autoaway-timeout +@vindex jabber-autoaway-xa-timeout +@vindex jabber-autoaway-status +@vindex jabber-autoaway-xa-status +@vindex jabber-autoaway-priority +@vindex jabber-autoaway-xa-priority + +It is possible to automatically set your status to ``away'' or ``xa'' +when you haven't used your computer for a while. This lets your +contacts know that you might not answer immediately. You can customize +timeouts (@code{jabber-autoaway-timeout}, +@code{jabber-autoaway-xa-timeout}), statuses +(@code{jabber-autoaway-status}, @code{jabber-autoaway-xa-status}) and +priorityes (@code{jabber-autoaway-priority}, +@code{jabber-autoaway-xa-priority}) to set. + +To activate this feature, add @code{jabber-autoaway-start} to +@code{jabber-post-connect-hooks}, e.g: +@example +(add-hook 'jabber-post-connect-hooks 'jabber-autoaway-start) +@end example + +There are different methods to find how long you have been ``idle''. +The method(s) to use is specified by @code{jabber-autoaway-methods} +(obsoleted @code{jabber-autoaway--method} will also work). The value +of this variable should be a list functions that returns the number of +seconds you have been idle (or nil on error). Minimum of values, +returned by these functions, is used as ``idle'' time, so default +should works well. Three functions are provided (all used by default). + +@itemize @bullet +@item +@code{jabber-current-idle-time} is used if your Emacs has the +@code{current-idle-time} function (which was introduced in Emacs 22). +Note that this method only measures the time since you last interacted +with Emacs, and thus disregards activity in other programs. + +@item +@code{jabber-xprintidle-get-idle-time} uses xprintidle +@footnote{@uref{http://www.dtek.chalmers.se/~henoch/text/xprintidle.html}} +program, if found. You can also manually set +@code{jabber-xprintidle-program} to the correct file path. This method +uses the same method as +@uref{http://www.jwz.org/xscreensaver,XScreensaver} to find your idle +time. + +@item +@code{jabber-termatime-get-idle-time} used on GNU/Linux terminals. It +uses the access time of the terminal device as a measure of idle time. + +@end itemize + +@node Modeline status, Keepalive, Autoaway, Useful features +@section Modeline status + +@cindex Modeline +@findex jabber-mode-line-mode +@vindex jabber-mode-line-mode +@vindex jabber-mode-line-compact + +By typing @kbd{M-x jabber-mode-line-mode} you toggle display of some +status in mode lines. The information is your own presence status, +and some numbers showing the status of your roster contacts. By +default, there are three numbers, for ``online'' (chatty and online), +``away'' (away, extended away and do not disturb) and offline +contacts. + +If you set @code{jabber-mode-line-compact} to nil, you get a complete +breakdown of presence status. That gives you six numbers indicating +the number of chatty, online, away, extended away, dnd, and offline +contacts, respectively. + +@node Keepalive, Reconnecting, Modeline status, Useful features +@section Keepalive + +@cindex Keepalive +@cindex Detecting lost connections + +Sometimes network connections are lost without you noticing. This is +especially true with Jabber, as it is quite reasonable to keep the +connection open for a long time without either sending or receiving +any data. + +On the other hand, the server may want to do the same kind of +detection, and may expect the client to send something at regular +intervals. + +If you want to detect a lost connection earlier, or make sure that the +server doesn't drop your connection, you can use the +keepalive functions. These come in two flavours: whitespace pings and +XMPP pings. + +@subsection Whitespace pings +@cindex Whitespace pings + +A @dfn{whitespace ping} is a single space character sent to the server. +This is often enough to make NAT devices consider the connection +``alive'', and likewise for certain Jabber servers, e.g. Openfire. It +may also make the OS detect a lost connection faster---a TCP connection +on which no data is sent or received is indistinguishable from a lost +connection. + +@findex jabber-whitespace-ping-start +@findex jabber-whitespace-ping-stop +Type @kbd{M-x jabber-whitespace-ping-start} to start it, and @kbd{M-x +jabber-whitespace-ping-stop} to stop it. The former is in +@code{jabber-post-connect-hooks} by default; @pxref{Hooks}. + +@vindex jabber-whitespace-ping-interval +The frequency of whitespace pings is controlled by the variable +@code{jabber-whitespace-ping-interval}. The default value is once every +30 seconds. + +@subsection XMPP pings + +These functions work by sending a ping request to your server once in a +while (by default every ten minutes), and considering the connection +lost if the server doesn't answer within reasonable time (by default +20 seconds). + +@findex jabber-keepalive-start +@findex jabber-keepalive-stop +Type @kbd{M-x jabber-keepalive-start} to start +it, and @kbd{M-x jabber-keepalive-stop} to stop it. You may want to add +@code{jabber-keepalive-start} to @code{jabber-post-connect-hooks}; +@pxref{Hooks}. + +@vindex jabber-keepalive-interval +@vindex jabber-keepalive-timeout +You can customize the interval and the timeout with the variables +@code{jabber-keepalive-interval} and @code{jabber-keepalive-timeout}, +respectively. + +@findex jabber-ping +You can also manually ping some client/server by using @kbd{M-x +jabber-ping}. Note that pong will be displayed according +@code{jabber-alerts-info-messages-hooks} (default is echo in +minibuffer). + +@node Reconnecting, Tracking activity, Keepalive, Useful features +@section Reconnecting + +@cindex Reconnect +@cindex Automatic reconnection +@vindex jabber-auto-reconnect + +jabber.el supports automatic reconnection to Jabber server(s) upon lost +connection. By default it is off. To turn on, customize +the @code{jabber-auto-reconnect} variable. + +This is of limited use if you have to type your password every time +jabber.el reconnects. There are two ways to save your password: you can +set it in @code{jabber-account-alist} (@pxref{Account settings}), and +you can use @file{password-cache.el}, which is available in +recent versions of Gnus and in Emacs 23. Note that you probably want to +customize @code{password-cache-expiry} if you use the latter. + +@node Tracking activity, Watch buddies, Reconnecting, Useful features +@section Tracking activity + +@cindex Activity +@findex jabber-activity-mode +@vindex jabber-activity-make-strings +@vindex jabber-activity-query-unread +@vindex jabber-activity-count-in-title +@vindex jabber-activity-count-in-title-format + +When you're working on something important you might want to delay +responding to incoming messages. However, when you're done working, +will you remember them? If you're anything like me, you'll have a lot +of buffers in your Emacs session, and a Jabber chat buffer can easily +get lost. + +When @code{jabber-activity-mode} is enabled (by default, it is), Emacs keeps +track of the buddies which have messaged you since last you visited +their buffer, and will display them in mode line. As soon as you +visit their buffer they disappear from the mode line, indicating that +you've read their message. + +If your mode line fills over because of these notifications, you can +customize @code{jabber-activity-make-strings} to shorten them to the +shortest possibly unambiguous form. + +If you try to exit Emacs while you still have unread messages, you +will be notified and asked about this. If you don't like that, set +@code{jabber-activity-query-unread} to nil. + +If you want to display the number of unread buffers in the frame title, +set @code{jabber-activity-count-in-title} to t. The format of the +number can be changed through +@code{jabber-activity-count-in-title-format}. + +To hide activity notifications for some contacts, use +@code{jabber-activity-banned} variable - just add boring JIDs (as +regexps) here. + +For complete customizability, write a hook function for +@code{jabber-activity-update-hook}. From that function, you can take +action based on @code{jabber-activity-jids}, +@code{jabber-activity-mode-string}, and +@code{jabber-activity-count-string}. + +@node Watch buddies, Spell checking, Tracking activity, Useful features +@section Watch buddies + +@cindex Watch +@cindex Online notifications +@findex jabber-watch-add +@findex jabber-watch-remove + +Sometimes you might be waiting for a certain person to come online, +and you don't want that occasion to get lost in the noise. To get an +obtrusive message when that happens, type @kbd{M-x jabber-watch-add} +and select the person in question. You can enter a comment, to +remember why you added the watch. + +You will get a message whenever that person goes from offline to +online. jabber.el will remember this for the rest of your Emacs +session (it's not saved to disk, though), but if you want to get rid +of it, type @kbd{M-x jabber-watch-remove}. + +@node Spell checking, Gmail notifications, Watch buddies, Useful features +@section Spell checking + +@cindex flyspell +@cindex Spell checking + +You can activate spell checking in a chat buffer with @kbd{M-x +flyspell-mode}. It will check only what you are currently writing, not +what you receive or what you have already sent. You may want to add +@code{flyspell-mode} to @code{jabber-chat-mode-hook}. + +For more information about Emacs spell checking, @pxref{Spelling, , +Checking and Correcting Spelling, emacs, GNU Emacs Manual}. + +@node Gmail notifications, Saving groups roll state, Spell checking, Useful features +@section Gmail notifications + +@cindex Gmail notifications + +If you are connected to a Google Talk account, you can receive +notifications when a new Gmail message arrives. Gmail notifications +are enabled by adding the following line to your @file{.emacs}: + +@example +(add-hook 'jabber-post-connect-hooks 'jabber-gmail-subscribe) +@end example + +Default behavior is to display a message that mentions the number of +received gmails. You can customize this behavior by providing your +own @code{jabber-gmail-dothreads} function. + +Example: + +@example +(eval-after-load "jabber-gmail" + '(defun jabber-gmail-dothreads (threads) + "Process <mail-thread-info/> elements. +THREADS is a list of XML sexps corresponding to <mail-thread-info/> +elements. +See http://code.google.com/apis/talk/jep_extensions/gmail.html#response" + (osd "gmail: %d" (length threads)))) + +;;; It's usually a good idea to have a shortcut for querying GTalk server. +(global-set-key (kbd "<f9> g") 'jabber-gmail-query) + +;;; The definition of `osd' function used by `jabber-gmail-dothreads'. +;;; `osd_cat' is shipped with the X OSD library +;;; [http://www.ignavus.net/software.html]. +(if (and (display-graphic-p) (file-executable-p "/usr/bin/osd_cat")) + (defun osd (fmt &rest args) + "Display message on X screen." + (let ((opts "-p bottom -A center -l 1 \ +-f '-adobe-helvetica-bold-r-*-*-24-*-*-*-*-*-iso10646-1'") + (msg (apply 'format (concat fmt "\n") args))) + (start-process "osd" nil shell-file-name shell-command-switch + (format "echo %s | osd_cat %s" + (shell-quote-argument msg) opts)))) + (defalias 'osd 'message)) +@end example + +@node Saving groups roll state, , Gmail notifications, Useful features +@section Saving groups roll state + +@cindex Saving groups roll state + +You can save roster's groups rollup/rolldown state between sessions. +To do this you need to add @code{jabber-roster-save-groups} to +@code{jabber-pre-disconnect-hook} and +@code{jabber-roster-restore-groups} to +@code{jabber-post-connect-hooks}, respectively. + +State saved in private storage on server-side (for each account). Note +that state restoring working by rolling up groups, rolled up at state +saving (by default, all groups rolled down). Also note that at now, +@code{jabber-pre-disconnect-hook} run only with +@code{jabber-disconnect} (not with @code{jabber-disconnect-one}). + + +@node Message history, Typing notifications, Useful features, Top +@chapter Message history + +@cindex History +@cindex Backlog +@findex jabber-truncate-top +@findex jabber-truncate-muc +@findex jabber-truncate-chat +@vindex jabber-history-enabled +@vindex jabber-history-muc-enabled +@vindex jabber-global-history-filename +@vindex jabber-use-global-history +@vindex jabber-history-dir +@vindex jabber-history-enable-rotation +@vindex jabber-history-size-limit +@vindex jabber-backlog-number +@vindex jabber-backlog-days +@vindex jabber-log-lines-to-keep + +If you want a record of messages sent and received, set +@code{jabber-history-enabled} to t. If you also want record MUC +groupchat messages, set @code{jabber-history-muc-enabled} to t. +Messages will be saved in one file per contact in the directory +specified by the variable @code{jabber-history-dir} (the default is +@file{~/.emacs.d/jabber-history}). If you prefer to store messages +for all contacts in a single file, set +@code{jabber-use-global-history} to @code{t} and set +@code{jabber-global-history-filename} as required.@footnote{Using a +global history file used to be the default. If the file specified by +@code{jabber-global-history-filename} exists, +@code{jabber-use-global-history} will default to @code{t} to support +existing installations.} + +When you open a new chat buffer and have entries in your history file, +the last few messages you recently exchanged with the contact in +question will be inserted. You can control how many messages with +@code{jabber-backlog-number} (by default 10), and how old messages +with @code{jabber-backlog-days} (by default 3 days). + +@findex jabber-chat-display-more-backlog +If you want to see more messages, use the function +@code{jabber-chat-display-more-backlog}, available in the Chat menu. +This is currently the only way to view the message history, apart from +opening the history files manually. + +@cindex Rotation of history files +@cindex History file rotation +If you worry about your history file(s) size, you can enable history +rotation feature by setting the variable +@code{jabber-history-enable-rotation} to @code{t} (default is +@code{nil}). This feature ``rotates'' your history files according to +the following rule: When @code{jabber-history-size-limit} (in +kilobytes) is reached, the @var{history-file} is renamed to +@file{@var{history-file}-@var{number}}, where @var{number} is 1 or the smallest number +after the last rotation. + +For example, suppose you set the +@code{jabber-history-size-limit} variable to 512 and you chat with +your buddy @samp{foo@@jabber.server} using the per-contact strategy to store +history files. So, when the history file (@file{foo@@jabber-server}) +reaches 512K bytes, it will be renamed to @file{foo@@jabber-server-1} +and @file{foo@@jabber-server} will be set empty. Next time +@file{foo@@jabber-server} grows to 512K bytes, it will be saved as +@file{foo@@jabber-server-2} and so on. Although the example was +presented with the per-contact history file strategy, history rotation +works for both per-contact and global history logging strategies. + +@cindex Truncate +@cindex Truncation +If you also want to keep chat and groupchat buffers from growing too +much, you can customize @code{jabber-alert-message-hooks} and +@code{jabber-alert-muc-hooks} by adding truncation upon receiving +message (@code{jabber-truncate-chat} and @code{jabber-truncate-muc}, respectively). +The truncation limit may be set by customizing the variable +@code{jabber-log-lines-to-keep}. + +@node Typing notifications, Roster import and export, Message history, Top +@chapter Typing notifications + +There are two protocols for ``contact is typing'' notifications in +Jabber. jabber.el supports both of them, displaying various information +in the header line of chat buffers. + +@section Message events + +@cindex Composing +@cindex Delivered +@cindex Displayed +@vindex jabber-events-request-these +@vindex jabber-events-confirm-delivered +@vindex jabber-events-confirm-displayed +@vindex jabber-events-confirm-composing + +The older protocol is called Message Events (@pxref{XEP-0022}). Besides +typing notification, it lets you know what happens to the messages you send. +These states are possible: + +@itemize @bullet +@item +@samp{In offline storage} (the user will receive it on next logon) + +@item +@samp{Delivered} to user's client (but not necessarily displayed) + +@item +@samp{Displayed} to user + +@item +User is @samp{typing a message} + +@end itemize + +The first state is only reported by servers; the other three are +reported by clients. jabber.el can report all three of them, and can +display all four; not all clients support all states, though. + +If you don't want jabber.el to send out this information about you, set +the variables @code{jabber-events-confirm-delivered}, +@code{jabber-events-confirm-displayed}, and/or +@code{jabber-events-confirm-composing} to nil. You can make jabber.el +not to request such information by customizing +@code{jabber-events-request-these}. + +@section Chat states + +@vindex jabber-chatstates-confirm + +The newer protocol is called Chat States (@pxref{XEP-0085}). Rather +than dealing with individual messages, it describes the state of the +chat session between two people. The following states are possible: + +@itemize @bullet +@item +Active (the default state, not displayed) + +@item +Inactive + +@item +Composing + +@item +Paused (i.e., taking a short pause in composing) + +@item +Gone + +@end itemize + +jabber.el can display all five states, but only ever sends ``active'' +and ``composing'' itself. + +To customize sending of chat states, customize the variable +@code{jabber-chatstates-confirm}. + + +@node Roster import and export, XMPP URIs, Typing notifications, Top +@chapter Roster import and export + +@findex jabber-export-roster +@findex jabber-import-roster +@cindex Export roster +@cindex Import roster + +Your roster is saved on the Jabber server, and usually not in the +client. However, you might want to save the roster to a file anyway. +The most common reason for this is probably to copy it to another +account. + +To export your roster to a file, type @kbd{M-x jabber-export-roster}. +A buffer will appear in which you can edit the data to be exported. +Changes done in that buffer will not affect your real roster. + +To import your roster from a file, type @kbd{M-x jabber-import-roster}. +You will be able to edit the data before importing it. Items not in the +roster will be added; items in the roster will be modified to match +imported data. Subscriptions will be updated. + +The format of the roster files is the XML used by roster pushes in the +XMPP protocol, in UTF-8 encoding. + +@node XMPP URIs, Customization, Roster import and export, Top +@chapter XMPP URIs + +@cindex URIs +@cindex URLs +@cindex links +@cindex xmpp: links +@cindex Mozilla integration +@cindex web browser integration +@cindex browser integration +@findex jabber-handle-uri + +Many web page authors use links starting with @samp{xmpp:} for JIDs. +Your web browser could be made to pass such links to jabber.el, so that +such links are actually useful and not just decoration. How to do that +depends on your operating system and web browser. + +For any of these methods, you need to make sure that you are running +the Emacs server. @xref{Emacs Server, , Using Emacs as a Server, +emacs, GNU Emacs Manual}, though the simplest way to start it is to +customize the variable @code{server-mode}. + +@section GNOME + +The jabber.el distribution contains a GConf schema which tries to set +up handling of @samp{xmpp:} URIs. It is installed by @samp{make +install}. This may or may not work, depending on your GConf +configuration and other installed applications. To check, try +running: + +@example +gconftool --get /desktop/gnome/url-handlers/xmpp/command +@end example + +This should print something like: + +@example +/usr/local/libexec/emacs-jabber-uri-handler "%s" +@end example + +This setting is picked up by most GNOME or GTK based web browsers, +including Firefox. + +@section Mozilla and Unix + +If you use a Mozilla-based web browser on a Unix-like operating +system, and the GConf method above doesn't work, you can set it up +manually by following these steps: + +@enumerate + +@item +Note the path of the @file{emacs-jabber-uri-handler} file in the jabber.el +distribution, and make sure it is executable. + +@item +Set the Mozilla preference @samp{network.protocol-handler.app.xmpp} to +the path of @file{emacs-jabber-uri-handler}. There are two ways to do this: + +@itemize +@item +Go to the URL @samp{about:config}, right-click in the list, choose ``New +string'', and enter @samp{network.protocol-handler.app.xmpp} and the +path in the following dialogs. + +@item +Open or create the file @file{user.js} in your Mozilla profile directory +(in the same directory as @file{prefs.js}), and add the following line: + +@example +user_pref("network.protocol-handler.app.xmpp", + "@var{/path/to}/emacs-jabber-uri-handler"); +@end example + +Restart Mozilla for this change to take effect. +@end itemize +@end enumerate + +@section Other systems + +If you know how to pass an XMPP URI from your browser to the function +@code{jabber-handle-uri}, your contribution for this section would be +appreciated. + +@node Customization, Hacking and extending, XMPP URIs, Top +@chapter Customization + +@findex jabber-customize +@cindex Customization + +jabber.el is intended to be customizable for many tastes. After all, +this is Emacs. To open a customization buffer for jabber.el, type +@kbd{M-x jabber-customize}. + +@menu +* Account settings:: +* Menu:: +* Customizing the roster buffer:: +* Customizing the chat buffer:: +* Customizing alerts:: +* Hooks:: +* Debug options:: +@end menu + +@node Account settings, Menu, , Customization +@section Account settings + +@cindex Username +@cindex Resource +@cindex Password +@cindex JID +@cindex Network server + +@vindex jabber-account-list +All account settings reside in the variable @code{jabber-account-list}. +Usually you only need to set the JID, in the form +@samp{username@@server} (or @samp{username@@server/resource} to use a +specific resource name). These are the other account options: + +@table @asis +@item Disabled +If the account is disabled, @code{jabber-connect-all} will not attempt +to connect it. You can still connect it manually with +@code{jabber-connect}. + +@item Password +You can set the password of the account, so you don't have to enter it +when you connect. Note that it will be stored unencrypted in your +customization file. + +@item Network server +If the JID of the Jabber server is not also its DNS name, you may have +to enter the real DNS name or IP address of the server here. + +@item Connection type +This option specifies whether to use an encrypted connection to the +server. Usually you want ``STARTTLS'' (@code{starttls}), which means +that encryption is activated if the server supports it. The other +possibilities are ``unencrypted'' (@code{network}), which means just +that, and ``legacy SSL/TLS'' (@code{ssl}), which means that encryption +is activated on connection. + +@item Port +If the Jabber server uses a nonstandard port, specify it here. The +default is 5222 for STARTTLS and unencrypted connections, and 5223 for +legacy SSL connections. +@end table + +@subsection For Google Talk + +@cindex Google Talk + +If you have a very new version of @file{dns.el},@footnote{Specifically, +you need Emacs 23, or No Gnus 0.3.} you can connect to +Google Talk just by specifying your Gmail address as JID. Otherwise, +you also need to set +``network server'' to @kbd{talk.google.com} and ``connection type'' to +``legacy SSL''. + +See also @ref{Gmail notifications}. + +@subsection Upgrade note + +Previous versions of jabber.el had the variables @code{jabber-username}, +@code{jabber-server}, @code{jabber-resource} and +@code{jabber-password}. These are now obsolete and not used. + +@node Menu, Customizing the roster buffer, Account settings, Customization +@section Menu + +@vindex jabber-display-menu +@cindex Menus +There is a Jabber menu on the menu bar with some common commands. By +default, it is displayed only if you are connected, or if you have +configured any accounts. You can set the variable +@code{jabber-display-menu} to @code{t} or @code{nil}, to have the menu +displayed always or never, respectively. The default behaviour +corresponds to the setting @code{maybe}. + +@findex jabber-menu +Earlier, the way to have the menu appear was to call the function +@code{jabber-menu}. It still works, but is considered obsolete. + +@node Customizing the roster buffer, Customizing the chat buffer, Menu, Customization +@section Customizing the roster buffer + +@cindex Roster buffer, customizing + +@cindex Sorting the roster +@vindex jabber-roster-sort-functions +@code{jabber-roster-sort-functions} controls how roster items are +sorted. By default, contacts are sorted first by presence, and then +alphabetically by displayed name. + +@vindex jabber-sort-order +@code{jabber-sort-order} controls how roster items are sorted by +presence. It is a list containing strings corresponding to show +status (@pxref{Presence}) or @code{nil}, which represents offline. + +@vindex jabber-show-resources +@code{jabber-show-resources} controls when your contacts' resources +are shown in the roster buffer. The default is to show resources when +a contact has more than one connected resource. + +@vindex jabber-roster-line-format +@code{jabber-roster-line-format} specifies how the entry for each +contact looks. It is a string where some characters are special if +preceded by a percent sign: + +@table @code +@item %a +Avatar of contact, if any +@item %c +@samp{*} if the contact is connected, or @samp{ } if not +@item %u +Subscription state---see below +@item %n +Nickname of contact, or JID if no nickname +@item %j +Bare JID of contact (without resource) +@item %r +Highest-priority resource of contact +@item %s +Availability of contact as a string ("Online", "Away" etc) +@item %S +Status string specified by contact +@end table + +@code{jabber-roster-show-title} controls whether to show a "Jabber +roster" string at the top of the roster buffer. You need to run +@kbd{M-x jabber-display-roster} after changing this variable to update +the display. + +@code{%u} is replaced by one of the strings given by +`jabber-roster-subscription-display'. + +@vindex jabber-resource-line-format +@code{jabber-resource-line-format} is nearly identical, except that +the values correspond to the values of the resource in question, and +that the @code{%p} escape is available, which inserts the priority of +the resource. + +@vindex jabber-roster-buffer +@code{jabber-roster-buffer} specifies the name of the roster buffer. +If you change this, the new name will be used the next time the roster +is redisplayed. + +@vindex jabber-roster-show-bindings +@code{jabber-roster-show-bindings} controls whether to show a list of +keybindings at the top of the roster buffer. You need to run @kbd{M-x +jabber-display-roster} after changing this variable to update the display. + +@node Customizing the chat buffer, Customizing alerts, Customizing the roster buffer, Customization +@section Customizing the chat buffer + +@cindex Chat buffer +@cindex Timestamps +@cindex Faces, chat buffer + +You can customize the look of the prompts in the chat buffer. There +are separate settings for local text (i.e. what you write) and foreign text +(i.e. what other people write). + +@vindex jabber-chat-text-local +@vindex jabber-chat-text-foreign +@code{jabber-chat-text-local} and @code{jabber-chat-text-foreign} +determine the faces used for chat messages. + +@vindex jabber-chat-prompt-local +@vindex jabber-chat-prompt-foreign +@vindex jabber-muc-colorize-local +@vindex jabber-muc-colorize-foreign +@vindex jabber-muc-nick-saturation +@vindex jabber-muc-nick-value +@vindex jabber-muc-participant-colors +@cindex Nick coloring +@code{jabber-chat-prompt-local} and @code{jabber-chat-prompt-foreign} +determine the faces used for the prompts. You can also turn on +automatic colorization of local (@code{jabber-muc-colorize-local}) +and/or foreign (@code{jabber-muc-colorize-foreign}) prompts. By +default it is off. You can correct and save for future use auto-generated colors by +customizing @code{jabber-muc-participant-colors}, @code{jabber-muc-nick-saturation} and +@code{jabber-muc-nick-value}, if you wish. + +@vindex jabber-chat-local-prompt-format +@vindex jabber-chat-foreign-prompt-format +@code{jabber-chat-local-prompt-format} and +@code{jabber-chat-foreign-prompt-format} determine what text is +displayed in the prompts. They are format strings, with the following +special sequences defined: + +@table @code +@item %t +The time when the message was sent or received +@item %n +The nickname of the user. For the foreign prompt, this is the name of +the contact in the roster, or the JID if no name set. For the local +prompt, this is the username part of your JID. +@item %u +The username of the user (i.e. the first part of the JID). +@item %r +The resource. +@item %j +The bare JID of the user +@end table + +@cindex Timestamp format +@vindex jabber-chat-time-format +@code{jabber-chat-time-format} defines how @code{%t} shows time. Its +format is identical to that passed to @code{format-time-string}. +@xref{Time Conversion, , Time Conversion, elisp, GNU Emacs Lisp +Reference Manual}. + +@vindex jabber-chat-delayed-time-format +@code{jabber-chat-delayed-time-format} is used instead of +@code{jabber-chat-time-format} for delayed messages (messages sent while +you were offline, or fetched from history). This way you can have short +timestamps everywhere except where you need long ones. You can always +see the complete timestamp in a tooltip by hovering over the prompt with +the mouse. + +@cindex Rare timestamps +@vindex jabber-print-rare-time +@vindex jabber-rare-time-format +@vindex jabber-chat-text-local +By default, timestamps are printed in the chat buffer every hour (at +``rare'' times). This can be toggled with +@code{jabber-print-rare-time}. You can customize the displayed time by +setting @code{jabber-rare-time-format}. Rare timestamps will be printed +whenever time formatted by that format string would change. + +@cindex Header line of chat buffers +@vindex jabber-chat-header-line-format +@vindex jabber-muc-header-line-format +You can also customize the header line of chat buffers, by modifying +the variable @code{jabber-chat-header-line-format}. The format of +that variable is the same as that of @code{mode-line-format} and +@code{header-line-format}. @xref{Mode Line Format, , Mode-Line +Format, elisp, GNU Emacs Lisp Reference Manual}. For MUC buffers, +@code{jabber-muc-header-line-format} is used instead. + +@vindex jabber-chat-fill-long-lines +@cindex Filling long lines in chat buffer +The variable @code{jabber-chat-fill-long-lines} controls whether long +lines in the chat buffer are wrapped. + +@node Customizing alerts, Hooks, Customizing the chat buffer, Customization +@section Customizing alerts + +@cindex Alert hooks +@findex define-jabber-alert + +When an event happens (currently including presence changes, incoming +messages, and completed queries) you will usually want to be +notified. Since tastes in this area vary wildly, these alerts are +implemented as hooks, so you can choose which ones you want, or write +your own if none fit. + +Actually, if you don't want to write your own, stop reading this +section and just read @ref{Standard alerts}. + +Many kinds of alerts consist in displaying a text message through a +certain mechanism. This text message is provided by a function which +you can rewrite or replace. If this function returns @code{nil}, no +message is displayed, and non-textual alerts refrain from action. + +If you want to write alert hooks that do nothing except displaying the +supplied message in some way, use the macro +@code{define-jabber-alert}. For example, if @var{foo} is a function +that takes a string as an argument, write +@example +(define-jabber-alert foo + "Display a message in a fooish way" + 'foo) +@end example +@noindent +and all details will be taken care of for you. + +The hooks take different arguments depending on category. However, +they all have in common that the last argument is the result of the +message function. The message function for each category takes the +same arguments as the corresponding hooks, except for that last +argument. + +Alert hook contributions are very welcome. You can send them to the +mailing list, or to the Sourceforge patch tracker. @xref{Contacts}. + +Alert hooks are meant for optional UI things, that are subject to +varying user tastes, and that can be toggled by simply adding or +removing the function to and from the hook. For other purposes, there +are corresponding general hooks, that are defvars instead of +defcustoms, and that are meant to be managed by Lisp code. They have the +same name as the alert hooks minus the @code{-alert} part, +e.g. @code{jabber-message-hooks} vs @code{jabber-alert-message-hooks}, +etc. + +@menu +* Standard alerts:: +* Presence alerts:: +* Message alerts:: +* MUC alerts:: +* Info alerts:: +@end menu + +@node Standard alerts, Presence alerts, , Customizing alerts +@subsection Standard alerts + +@cindex Alerts +@cindex Scroll + +Thirteen alerts are already written for all four alert categories. These +all obey the result from the corresponding message function. + +The @code{beep} alerts simply sound the terminal bell by calling +@code{ding}. They are disabled by default. + +The @code{echo} alerts display a message in the echo area by calling +@code{message}. They are enabled by default. + +The @code{switch} alerts switch to the buffer where the event occurred +(chat buffer for incoming messages, roster buffer for presence +changes, browse buffer for completed queries). They are disabled by +default. Take care when using them, as they may interrupt your +editing. + +The @code{display} alerts display but do not select the buffer in +question, using the function @code{display-buffer}. @xref{Choosing +Window, , Choosing a Window for Display, elisp, GNU Emacs Lisp +Reference Manual}, for information about customizing its behaviour. +This is enabled by default for info requests. + +@cindex Sound effects +The @code{wave} alerts play a sound file by calling +@code{play-sound-file}. No sound files are provided. To use this, +enter the names of the sound files in +@code{jabber-alert-message-wave}, @code{jabber-alert-presence-wave} +and @code{jabber-alert-info-wave}, respectively. You can specify +specific sound files for contacts matching a regexp in the variables +@code{jabber-alert-message-wave-alist} and +@code{jabber-alert-presence-wave-alist}. + +@cindex Screen terminal manager +The @code{screen} alerts send a message through the Screen terminal +manager@footnote{See @uref{http://www.gnu.org/software/screen/}.}. They do no +harm if called when you don't use Screen. + +@cindex Tmux terminal manager +The @code{tmux} alerts send a message through the tmux terminal +manager@footnote{See @uref{http://tmux.sourceforge.net/}.}. + +@cindex Ratpoison window manager +@cindex Window manager, Ratpoison +The @code{ratpoison} alerts send a message through the Ratpoison +window manager@footnote{See @uref{http://ratpoison.sourceforge.net/}.}. They +do no harm if used when you're not running X, but if you are running X +with another window manager, the ratpoison processes will never exit. +Emacs doesn't hold on to them, though. + +@cindex Sawfish window manager +@cindex Window manager, Sawfish +The @code{sawfish} alerts send a message through the Sawfish window +manager. + +@cindex wmii window manager +@cindex Window manager, wmii +The @code{wmii} alerts display a message through the wmii window +manager. + +@cindex awesome window manager +@cindex Window manager, awesome +The @code{awesome} alerts display a message through the awesome window +manager. However, to work it needs naughty (i.e. +@code{require("naughty")} in rc.lua). + +@cindex xmessage +@vindex jabber-xmessage-timeout +The @code{xmessage} alerts send a message through the standard +@code{xmessage} tool. The variable @code{jabber-xmessage-timeout} +controls how long the alert appears. + +@cindex OSD +The @code{osd} alerts send a message onto your screen using +XOSD.@footnote{XOSD can be found at +@uref{http://www.ignavus.net/software.html}. You also need +@file{osd.el} from @uref{http://www.brockman.se/software/osd.el}.} + +@cindex notifications.el +The @code{notifications} alerts send a message using Emacs built-in +package @file{notifications.el}. Note that @file{notifications.el} first appear in +Emacs 24.1, so they are disabled by default. + +@cindex libnotify +@cindex notification-daemon +The @code{libnotify} alerts send a message onto your screen using +@code{notification-daemon}. + +@cindex Festival speech synthesis +@cindex Speech synthesis, Festival +The @code{festival} alerts speak the message using the Emacs interface +of the Festival speech synthesis system@footnote{See +@uref{http://www.cstr.ed.ac.uk/projects/festival/}.}. + +@cindex Autoanswerer +The @code{autoanswer} alert is kind of special: it will not show you +message/muc alert, but instead will automaticaly answer to sender. See +variable `jabber-autoanswer-alist' description for details. + +@cindex Scroll chat buffers +Additionally, for one-to-one and MUC messages, there are @code{scroll} +alerts (enabled by default), that aim to do the right thing with chat +buffers that are visible but not active. Sometimes you want point to +scroll down, and sometimes not. These functions should do what you +mean; if they don't, it's a bug. + +Also, in MUC you can use a family of so-called ``personal'' alerts. +They are like other MUC alerts, but fire only on incoming messages +addresed directly to you (also known as ``private messages''). One +example of such an alert is @code{jabber-muc-echo-personal}, which shows +a note for an MUC message only if it was addressed to you. + +Some of these functions are in the @file{jabber-alert.el} file, and the +others are in their own files. You can use them as templates or +inspiration for your own alerts. + +@node Presence alerts, Message alerts, Standard alerts, Customizing alerts +@subsection Presence alerts + +@vindex jabber-alert-presence-message-function +@findex jabber-presence-default-message + +Set @code{jabber-alert-presence-message-function} to your desired +function. This function should look like: + +@example +(defun @var{function} (@var{who} @var{oldstatus} @var{newstatus} @var{statustext}) + ... + ) +@end example + +@var{who} is the JID symbol (@pxref{JID symbols}), +@var{oldstatus} and @var{newstatus} are the previous and current +stati, respectively, and @var{statustext} is the status message if +provided, otherwise nil. + +@var{oldstatus} and @var{newstatus} can be one of @code{""} +(i.e. online), @code{"away"}, @code{"xa"}, @code{"dnd"}, @code{"chat"}, +@code{"error"} and @code{nil} (i.e. offline). + +@var{newstatus} can also be one of @code{"subscribe"}, +@code{"subscribed"}, @code{"unsubscribe"} and @code{"unsubscribed"}. + +The default function, @code{jabber-presence-default-message}, returns +@code{nil} if @var{oldstatus} and @var{newstatus} are the same, and in +other cases constructs a message from the given data. + +Another function, @code{jabber-presence-only-chat-open-message}, +behave just like @code{jabber-presence-default-message}, but only if +conversation buffer for according JID is already open. Use it to show +presence notifications only for ``interesting'' contacts. + +All presence alert hooks take the same arguments plus the additional +@var{proposed-alert}, which is the result of the specified message +function. This last argument is usually the only one they use. + +@node Message alerts, MUC alerts, Presence alerts, Customizing alerts +@subsection Message alerts + +@vindex jabber-alert-message-function +@findex jabber-message-default-message + +Set @code{jabber-alert-message-function} to your desired +function.@footnote{Logically it should be +@code{jabber-alert-message-message-function}, but that would be +really ugly.} This function should look like: + +@example +(defun @var{function} (@var{from} @var{buffer} @var{text}) + ... + ) +@end example + +@var{from} is the JID symbol (@pxref{JID symbols}), @var{buffer} +is the buffer where the message is displayed, and @var{text} is the +text of the message. + +The default function, @code{jabber-message-default-message}, returns +``Message from @var{person}'', where @var{person} is the name of the +person if specified in the roster, otherwise the JID. + +All message alert hooks take the same arguments plus the additional +@var{proposed-alert}, which is the result of the specified message +function. + +@vindex jabber-message-alert-same-buffer +If you don't want message alerts when the chat buffer in question is +already the current buffer, set @code{jabber-message-alert-same-buffer} +to nil. This affects the behaviour of the default message function, so +you'll have to reimplement this functionality if you write your own +message function. + +@node MUC alerts, Info alerts, Message alerts, Customizing alerts +@subsection MUC alerts + +@vindex jabber-alert-muc-function +@vindex jabber-muc-alert-self +@findex jabber-muc-default-message + +Set @code{jabber-alert-muc-function} to your desired +function. This function should look like: + +@example +(defun @var{function} (@var{nick} @var{group} @var{buffer} @var{text}) + ... + ) +@end example + +@var{nick} is the nickname, @var{group} is the JID of the group, +@var{buffer} is the buffer where the message is displayed, and +@var{text} is the text of the message. + +The default function, @code{jabber-muc-default-message}, returns +``Message from @var{nick} in @var{group}'' or ``Message in +@var{group}'', the latter for messages from the room itself. + +All MUC alert hooks take the same arguments plus the additional +@var{proposed-alert}, which is the result of the specified message +function. + +By default, no alert is made for messages from yourself. To change +that, customize the variable @code{jabber-muc-alert-self}. + +@node Info alerts, , MUC alerts, Customizing alerts +@subsection Info alerts + +@vindex jabber-alert-info-message-function +@findex jabber-info-default-message + +Info alerts are sadly underdeveloped. The message function, +@code{jabber-alert-info-message-function}, takes two arguments, +@var{infotype} and @var{buffer}. @var{buffer} is the buffer where +something happened, and @var{infotype} is either @code{'roster} for +roster updates, or @code{'browse} for anything that uses the browse +buffer (basically anything except chatting). + +The info alert hooks take an extra argument, as could be expected. + +@node Hooks, Debug options, Customizing alerts, Customization +@section Hooks + +jabber.el provides various hooks that you can use for whatever +purpose. + +@table @code +@vindex jabber-post-connect-hooks +@item jabber-post-connect-hooks +This hook is called after successful connection and authentication. +By default it contains @code{jabber-send-current-presence} +(@pxref{Presence}). The hook functions get the connection object as +argument. + +@vindex jabber-lost-connection-hooks +@item jabber-lost-connection-hooks +This hook is called when you have been disconnected for unknown +reasons. Usually this isn't noticed for quite a long time. + +The hook is called with one argument: the connection object. + +@vindex jabber-pre-disconnect-hook +@item jabber-pre-disconnect-hook +This hook is called just before voluntary disconnection, i.e. in +@code{jabber-disconnect}, the command to disconnect all accounts. There +is currently no hook for disconnection of a single account. + +@vindex jabber-post-disconnect-hook +@item jabber-post-disconnect-hook +This hook is called after disconnection of any kind, possibly just +after @code{jabber-lost-connection-hook}. + +@vindex jabber-chat-mode-hook +@item jabber-chat-mode-hook +This hook is called when a new chat buffer is created. + +@vindex jabber-browse-mode-hook +@item jabber-browse-mode-hook +This hook is called when a new browse buffer is created. + +@vindex jabber-roster-mode-hook +@item jabber-roster-mode-hook +This hook is called when the roster buffer is created. + +@end table + +@node Debug options, , Hooks, Customization +@section Debug options + +These settings provide a lot of information which is usually not very +interesting, but can be useful for debugging various things. + +@vindex jabber-debug-log-xml +@cindex XML console +@code{jabber-debug-log-xml} activates XML console. All XML stanzas +sent and received are logged in the buffer @code{*-jabber-console-@var{jid}-*} +(and to specified file if value is string). +Also this buffer can be used to send XML stanzas manually. + +@vindex jabber-console-name-format +Format for console buffer name. %s mean connection jid. Default value is +@code{*-jabber-console-%s-*}. + +@vindex jabber-console-truncate-lines +Maximum number of lines in console buffer. Use this option to prevent +over bloating size of buffer. +Set value to 0 if you want to keep all stanzas in buffer, but +it's not recommended and may be unsafe. + +@vindex jabber-debug-keep-process-buffers +Usually, the process buffers for Jabber connections are killed when the +connection is closed, as they would otherwise just fill up memory. +However, they might contain information about why the connection was +lost. To keep process buffers, set +@code{jabber-debug-keep-process-buffers} to @code{t}. + +@node Hacking and extending, Protocol support, Customization, Top +@chapter Hacking and extending + +This part of the manual is an attempt to explain parts of the source +code. It is not meant to discourage you from reading the code +yourself and trying to figure it out, but as a guide on where to +look. Knowledge of Jabber protocols is assumed. + +@menu +* Connection object:: +* XML representation:: +* JID symbols:: +* Listening for new requests:: +* Sending new requests:: +* Extending service discovery:: +* Chat printers:: +* Stanza chains:: +@end menu + +@node Connection object, XML representation, , Hacking and extending +@section Connection object +@cindex connection object +@cindex account object +@cindex FSM + +Each Jabber connection is represented by a ``connection object''. This +object has the form of a finite state machine, and is realized by the +library @code{fsm}.@footnote{So far, this library is only distributed +with jabber.el. The author hopes that it could be useful for other +projects, too.} + +The various states of this object are defined in @file{jabber-core.el}. +They describe the way of the connection through the establishing of a +network connection and authentication, and finally comes to the +@code{:session-established} state where ordinary traffic takes place. + +These details are normally opaque to an extension author. As will be +noted, many functions expect to receive a connection object, and +functions at extension points generally receive such an object in order +to pass it on. The following functions simply query the internal state +of the connection: + +@defun jabber-connection-jid connection +The @code{jabber-connection-jid} function returns the full JID of +@var{connection}, i.e. a string of the form +@code{"username@@server/resource"}. +@end defun + +@defun jabber-connection-bare-jid connection +The @code{jabber-connection-bare-jid} function returns the bare JID of +@var{connection}, i.e. a string of the form @code{"username@@server"}. +@end defun + +@node XML representation, JID symbols, Connection object, Hacking and extending +@section XML representation + +@cindex XML representation + +The XML representation is the one generated by @file{xml.el} in Emacs, +namely the following. Each tag is a list. The first element of the +list is a symbol, the name of which is the name of the tag. The +second element is an alist of attributes, where the keys are the +attribute names in symbol form, and the values are strings. The +remaining elements are the tags and data contained within the tag. + +For example, +@example +<foo bar='baz'> +<frobozz/>Fnord +</foo> +@end example +is represented as +@example +(foo ((bar . "baz")) (frobozz nil "") "Fnord +") +@end example + +Note the empty string as the third element of the @code{frobozz} +list. It is not present in newer (post-21.3) versions of +@file{xml.el}, but it's probably best to assume it might be there. + +@defun jabber-sexp2xml xml-sexp +This function takes a tag in list representation, and returns its XML +representation as a string. You will normally not need to use this +function directly, but it can be useful to see how your sexps will look +when sent to the outer, non-Lisp, world. +@end defun + +@defun jabber-send-sexp connection sexp +This function sends @var{sexp}, an XMPP stanza in list representation, +and sends it over @var{connection}. + +You will normally use the functions @code{jabber-send-presence}, +@code{jabber-send-message} and @code{jabber-send-iq} instead of this +function. +@end defun + +@node JID symbols, Listening for new requests, XML representation, Hacking and extending +@section JID symbols + +@vindex jabber-jid-obarray +JIDs are sometimes represented as symbols. Its name is the JID, and it is interned +in @code{jabber-jid-obarray}. A roster entry can have the following +properties: + +@table @code +@item xml +The XML tag received from the server on roster update + +@item name +The name of the roster item (just like the XML attribute) + +@item subscription +The subscription state; a string, one of @code{"none"}, @code{"from"}, +@code{"to"} and @code{"both"} + +@item ask +The ask state; either @code{nil} or @code{"subscribe"} + +@item groups +A list of strings (possibly empty) containing all the groups the +contact is in + +@item connected +Boolean, true if any resource is connected + +@item show +Presence show value for highest-priority connected resource; a string, +one of @code{""} (i.e. online), @code{"away"}, @code{"xa"}, +@code{"dnd"}, @code{"chat"}, @code{"error"} and @code{nil} +(i.e. offline) + +@item status +Presence status message for highest-priority connected resource + +@item resources +Alist. Keys are strings (resource names), values are plists with +properties @code{connected}, @code{show}, @code{status} and +@code{priority}. + +@end table + +Incoming presence information is inserted in @code{resources}, and the +information from the resource with the highest priority is inserted in +@code{show} and @code{status} by the function +@code{jabber-prioritize-resources}. + +@node Listening for new requests, Sending new requests, JID symbols, Hacking and extending +@section Listening for new requests + +@findex jabber-send-iq +@findex jabber-process-iq +@findex jabber-signal-error +@vindex jabber-iq-get-xmlns-alist +@vindex jabber-iq-set-xmlns-alist + +To listen for new IQ requests, add the appropriate entry in +@code{jabber-iq-get-xmlns-alist} or @code{jabber-iq-set-xmlns-alist}. +The key is the namespace of the request, and the value is a function +that takes two arguments, the connection object, and +the entire IQ stanza in list format. +@code{jabber-process-iq} reads these alists to determine which +function to call on incoming packets. + +For example, the Ad-Hoc Commands module contains the following: + +@example +(add-to-list 'jabber-iq-set-xmlns-alist + (cons "http://jabber.org/protocol/commands" + 'jabber-ahc-process)) +@end example + +To send a response to an IQ request, use @samp{(jabber-send-iq +@var{connection} @var{sender} "result" @var{query} nil nil nil nil +@var{id})}, where @var{query} is the query in list format. +@code{jabber-send-iq} will encapsulate the query in an IQ packet with +the specified id. + +To return an error to the Jabber entity that sent the query, use +@code{jabber-signal-error}. The signal is caught by +@code{jabber-process-iq}, which takes care of sending the error. +You can also use @code{jabber-send-iq-error}. + +@node Sending new requests, Extending service discovery, Listening for new requests, Hacking and extending +@section Sending new requests + +@findex jabber-send-iq +@findex jabber-process-iq + +To send an IQ request, use @code{jabber-send-iq}. It will generate an +id, and create a mapping for it for use when the response comes. The +syntax is: + +@example +(jabber-send-iq @var{connection} @var{to} @var{type} @var{query} + @var{success-callback} @var{success-closure} + @var{failure-callback} @var{failure-closure}) +@end example + +@var{success-callback} will be called if the response is of type +@samp{result}, and @var{failure-callback} will be called if the response +is of type @samp{error}. Both callbacks take three arguments, the +connection object, the IQ stanza of the response, and the corresponding +closure item earlier passed to @code{jabber-send-iq}. + +@findex jabber-report-success +@findex jabber-process-data +Two standard callbacks are provided. @code{jabber-report-success} takes +a string as closure item, and reports success or failure in the echo +area by appending either @samp{succeeded} or @samp{failed} to the +string. @code{jabber-process-data} prepares a browse buffer. If its +closure argument is a function, it calls that function with point in +this browse buffer. If it's a string, it prints that string along with +the error message in the IQ response. If it's anything else +(e.g. @code{nil}), it just dumps the XML in the browse buffer. + +Examples follow. This is the hypothetical Jabber protocol ``frob'', +for which only success report is needed: +@example +(jabber-send-iq connection + "someone@@somewhere.org" "set" + '(query ((xmlns . "frob"))) + 'jabber-report-success "Frobbing" + 'jabber-report-success "Frobbing") +@end example +This will print ``Frobbing succeeded'' or ``Frobbing failed: @var{reason}'', +respectively, in the echo area. + +The protocol ``investigate'' needs to parse results and show them in a +browse buffer: +@example +(jabber-send-iq connection + "someone@@somewhere.org" "get" + '(query ((xmlns . "investigate"))) + 'jabber-process-data 'jabber-process-investigate + 'jabber-process-data "Investigation failed") +@end example +Of course, the previous example could have used +@code{jabber-report-success} for the error message. It's a matter of +UI taste. + +@node Extending service discovery, Chat printers, Sending new requests, Hacking and extending +@section Service discovery + +Service discovery (XEP-0030) is a Jabber protocol for communicating +features supported by a certain entity, and items affiliated with an +entity. jabber.el has APIs for both providing and requesting such +information. + + +@menu +* Providing info:: +* Requesting info:: +@end menu + +@node Providing info, Requesting info, , Extending service discovery +@subsection Providing info + +Your new IQ request handlers will likely want to advertise their +existence through service discovery. + +@vindex jabber-advertised-features +To have an additional feature reported in response to disco info +requests, add a string to @code{jabber-advertised-features}. + +@vindex jabber-disco-items-nodes +@vindex jabber-disco-info-nodes +By default, the service discovery functions reject all requests +containing a node identifier with an ``Item not found'' error. To +make them respond, add the appropriate entries to +@code{jabber-disco-items-nodes} and @code{jabber-disco-info-nodes}. +Both variables work in the same way. They are alists, where the keys +are the node names, and the values are lists of two items. + +The first item is the data to return --- either a list, or a function +taking the connection object and the entire IQ stanza and returning a +list; in either case this list contains the XML nodes to include in the +@code{<query/>} node in the response. + +@findex jabber-my-jid-p +The second item is the access control function. An access control +function receives the connection object and a JID as arguments, and +returns non-nil if access is to be granted. If nil is specified +instead of a function, access is always granted. One such function is +provided, @code{jabber-my-jid-p}, which grants access for JIDs where +the username and server (not necessarily resource) are equal to those +of the user, or one of the user's configured accounts. + +@node Requesting info, , Providing info, Extending service discovery +@subsection Requesting info + +jabber.el has a facility for requesting disco items and info. All +positive responses are cached. + +To request disco items or info from an entity, user one of these +functions: + +@defun jabber-disco-get-info jc jid node callback closure-data &optional force +Get disco information for @var{jid} and @var{node}. A request is sent +asynchronously on the connection @var{jc}. When the response arrives, +@var{callback} is called with three arguments: @var{jc}, +@var{closure-data}, and the result. The result may be retrieved from +the cache, unless @var{force} is non-nil. + +If the request was successful, or retrieved from cache, it looks like +@code{(@var{identities} @var{features})}, where @var{identities} and +@var{features} are lists. Each identity is @code{["@var{name}" +"@var{category}" "@var{type}"]}, and each feature is a string denoting +the namespace of the feature. + +If the request failed, the result is an @code{<error/>} node. +@end defun + +@defun jabber-disco-get-items jc jid node callback closure-data &optional force +Get disco information for @var{jid} and @var{node}. A request is sent +asynchronously on the connection @var{jc}. When the response arrives, +@var{callback} is called with three arguments: @var{jc}, +@var{closure-data}, and the result. The result may be retrieved from +the cache, unless @var{force} is non-nil. + +If the request was successful, or retrieved from cache, the result is +a list of items, where each item is @code{["@var{name}" "@var{jid}" +"@var{node}"]}. The values are either strings or nil. + +If the request failed, the result is an @code{<error/>} node. +@end defun + +If you only want to see what is in the cache, use one of the following +functions. They don't use a callback, but return the result directly. + +@defun jabber-disco-get-info-immediately jid node +Return cached disco information for @var{jid} and @var{node}, or nil +if the cache doesn't contain this information. The result is the same +as for @code{jabber-disco-get-info}. +@end defun + +@defun jabber-disco-get-items-immediately jid node +Return cached disco items for @var{jid} and @var{node}, or nil +if the cache doesn't contain this information. The result is the same +as for @code{jabber-disco-get-items}. +@end defun + +In the future, this facility will be expanded to provide information +acquired through XEP-0115, Entity capabilities, which is a protocol +for sending disco information in @code{<presence/>} stanzas. + +@node Chat printers, Stanza chains, Extending service discovery, Hacking and extending +@section Chat printers + +@vindex jabber-chat-printers +@vindex jabber-muc-printers +@vindex jabber-body-printers +@cindex Chat printers +@cindex Body printers + +Chat printers are functions that print a certain aspect of an incoming +message in a chat buffer. Included are functions for printing subjects +(@code{jabber-chat-print-subject}), bodies +(@code{jabber-chat-print-body}, and @code{jabber:x:oob}-style URLs +(@code{jabber-chat-print-url}). The functions in +@code{jabber-chat-printers} are called in order, with the entire +@code{<message/>} stanza as argument. As described in the docstring +of @code{jabber-chat-printers}, these functions are run in one of two +modes: @code{printp}, in which they are supposed to return true if +they would print anything, and @code{insert}, in which they are +supposed to actually print something, if appropriate, using the +function @code{insert}. + +For MUC, the functions in @code{jabber-muc-printers} are prepended to +those in @code{jabber-chat-printers}. + +Body printers are a subgroup of chat printers. They are exclusive; only +one of them applies to any given message. The idea is that +``higher-quality'' parts of the message override pieces included for +backwards compatibility. Included are @code{jabber-muc-print-invite} +and @code{jabber-chat-normal-body}; functions for XHTML-IM and PGP +encrypted messages may be written in the future. The functions in +@code{jabber-body-printers} are called in order until one of them +returns non-nil. + +@node Stanza chains, , Chat printers, Hacking and extending +@section Stanza chains + +@vindex jabber-message-chain +@vindex jabber-iq-chain +@vindex jabber-presence-chain + +If you really need to get under the skin of jabber.el, you can add +functions to the lists @code{jabber-message-chain}, +@code{jabber-iq-chain} and @code{jabber-presence-chain}. The +functions in these lists will be called in order when an XML stanza of +the corresponding type arrives, with the connection object and the +entire XML stanza passed as arguments. Earlier functions can modify +the stanza to change the behaviour of downstream functions, but +remember: with great power comes great responsibility. + +@node Protocol support, Concept index, Hacking and extending, Top +@appendix Protocol support + +@cindex Supported protocols + +These are the protocols currently supported (in full or partially) by +jabber.el. + +@menu +* RFC 3920:: XMPP-CORE +* RFC 3921:: XMPP-IM +* XEP-0004:: Data Forms +* XEP-0012:: Last Activity +* XEP-0020:: Feature Negotiation +* XEP-0022:: Message Events +* XEP-0030:: Service Discovery +* XEP-0045:: Multi-User Chat +* XEP-0049:: Private XML Storage +* XEP-0050:: Ad-Hoc Commands +* XEP-0054:: vcard-temp +* XEP-0055:: Jabber Search +* XEP-0065:: SOCKS5 Bytestreams +* XEP-0066:: Out of Band Data +* XEP-0068:: Field Standardization for Data Forms +* XEP-0077:: In-Band Registration +* XEP-0078:: Non-SASL Authentication +* XEP-0082:: Jabber Date and Time Profiles +* XEP-0085:: Chat State Notifications +* XEP-0086:: Error Condition Mappings +* XEP-0090:: Entity Time +* XEP-0091:: Delayed Delivery +* XEP-0092:: Software Version +* XEP-0095:: Stream Initiation +* XEP-0096:: File Transfer +* XEP-0146:: Remote Controlling Clients +* XEP-0153:: vCard-Based Avatars +* XEP-0199:: XMPP Ping +* XEP-0245:: The /me Command +@end menu + +@node RFC 3920, RFC 3921, , Protocol support +@section RFC 3920 (XMPP-CORE) + +Most of RFC 3920 is supported, with the following exceptions. + +SASL is supported only when an external SASL library from FLIM or Gnus +is present. As SASL is an essential part to XMPP, jabber.el will send +pre-XMPP stream headers if it is not available. + +None of the stringprep profiles are implemented. jabber.el changes +JIDs to lowercase internally; that's all. + +jabber.el doesn't interpret namespace prefixes. + +The @code{xml:lang} attribute is neither interpreted nor generated. + +SRV records are used if a modern version of @code{dns.el} is installed. + +@node RFC 3921, XEP-0004, RFC 3920, Protocol support +@section RFC 3921 (XMPP-IM) + +Most of RFC 3921 is supported, with the following exceptions. + +Messages of type ``headline'' are not treated in any special way. + +The @code{<thread/>} element is not used or generated. + +Sending ``directed presence'' is supported; however, presence stanzas +received from contacts not in roster are ignored. + +Privacy lists are not supported at all. + +jabber.el doesn't support XMPP-E2E or ``im:'' CPIM URIs. + +@node XEP-0004, XEP-0012, RFC 3921, Protocol support +@section XEP-0004 (Data Forms) + +XEP-0004 support is good enough for many purposes. Limitations are +the following. + +Forms in incoming messages are not interpreted. See each specific +protocol for whether forms are accepted in that context. + +``Cancel'' messages are probably not consistently generated when they +should be. This is partly a paradigm clash, as jabber.el doesn't use +modal dialog boxes but buffers which can easily be buried. + +@code{<required/>} elements are not enforced. + +The field types ``jid-single'', ``jid-multi'' and ``list-multi'' are +not implemented, due to programmer laziness. Let us know if you need +them. + +@node XEP-0012, XEP-0020, XEP-0004, Protocol support +@section XEP-0012 (Last Activity) + +jabber.el can generate all three query types described in the protocol. +However, it does not answer to such requests. + +@node XEP-0020, XEP-0022, XEP-0012, Protocol support +@section XEP-0020 (Feature Negotiation) + +There are no known limitations or bugs in XEP-0020 support. + +@node XEP-0022, XEP-0030, XEP-0020, Protocol support +@section XEP-0022 (Message Events) + +jabber.el understands all four specified kinds of message events +(offline, delivered, displayed, and composing) and by default requests +all of them. It also reports those three events that make sense for +clients. + +@node XEP-0030, XEP-0045, XEP-0022, Protocol support +@section XEP-0030 (Service Discovery) + +Service discovery is supported, both as client and server. When used in +the code, service discovery results are cached indefinitely. + +@node XEP-0045, XEP-0049, XEP-0030, Protocol support +@section XEP-0045 (Multi-User Chat) + +jabber.el supports parts of XEP-0045. Entering, leaving and chatting +work. So do invitations and private messages. Room configuration is +supported. Changing roles of participants (basic moderation) is +implemented, as is changing affiliations, but requesting affiliation +lists is not yet supported. + +@node XEP-0049, XEP-0050, XEP-0045, Protocol support +@section XEP-0049 (Private XML Storage) + +jabber.el contains an implementation of XEP-0049; It is used +for bookmarks and roster's groups roll state saving. + +@node XEP-0050, XEP-0054, XEP-0049, Protocol support +@section XEP-0050 (Ad-Hoc Commands) + +jabber.el is probably the first implementation of XEP-0050 (see +@uref{http://article.gmane.org/gmane.network.jabber.devel/21413, post +on jdev from 2004-03-10}). Both the client and server parts are +supported. + +@node XEP-0054, XEP-0055, XEP-0050, Protocol support +@section XEP-0054 (vcard-temp) + +Both displaying other users' vCards and editing your own vCard are +supported. The implementation tries to follow the schema in the XEP +accurately. + +@node XEP-0055, XEP-0065, XEP-0054, Protocol support +@section XEP-0055 (Jabber Search) + +XEP-0055 is supported, both with traditional fields and with Data Forms +(@pxref{XEP-0004}). As the traditional fields specified by the XEP is a +subset of those allowed in XEP-0077, handling of those two form types +are merged. @xref{XEP-0077}. + +@node XEP-0065, XEP-0066, XEP-0055, Protocol support +@section XEP-0065 (SOCKS5 Bytestreams) + +XEP-0065 is supported. Currently jabber.el cannot act as a server, not +even on on Emacsen that support server sockets (GNU Emacs 22 and up). +Therefore it relies on proxies. Proxies have to be entered and queried +manually. + +Psi's ``fast mode'' +(@uref{http://delta.affinix.com/specs/stream.html}), which gives +greater flexibility with regards to NAT, is not implemented. + +@node XEP-0066, XEP-0068, XEP-0065, Protocol support +@section XEP-0066 (Out of Band Data) + +jabber.el will display URLs sent in message stanzas qualified by +the @code{jabber:x:oob} namespace, as described in this XEP. Sending +such URLs or doing anything with iq stanzas (using the +@code{jabber:iq:oob} namespace) is not supported. + +@node XEP-0068, XEP-0077, XEP-0066, Protocol support +@section XEP-0068 (Field Standardization for Data Forms) + +XEP-0068 is only used in the context of creating a new Jabber account, +to prefill the username field of the registration form. + +@node XEP-0077, XEP-0078, XEP-0068, Protocol support +@section XEP-0077 (In-Band Registration) + +In-band registration is supported for all purposes. That means +registering a new Jabber account, changing Jabber password, removing a +Jabber account, registering with a service, and cancelling +registration to a service. Data forms are supported as well. URL +redirections are not. + +jabber.el will not prevent or alert a user trying to change a password +over an unencrypted connection. + +@node XEP-0078, XEP-0082, XEP-0077, Protocol support +@section XEP-0078 (Non-SASL Authentication) + +Non-SASL authentication is supported, both plaintext and digest. +Digest is preferred, and a warning is displayed to the user if only +plaintext is available. + +@node XEP-0082, XEP-0085, XEP-0078, Protocol support +@section XEP-0082 (Jabber Date and Time Profiles) + +The DateTime profile of XEP-0082 is supported. Currently this is only +used for file transfer. + +@node XEP-0085, XEP-0086, XEP-0082, Protocol support +@section XEP-0085 (Chat State Notifications) + +XEP-0085 is partially supported. Currently only active/composing +notifications are @emph{sent} though all five notifications are handled on +receipt. + +@node XEP-0086, XEP-0090, XEP-0085, Protocol support +@section XEP-0086 (Error Condition Mappings) + +Legacy errors are interpreted, but never generated. XMPP style error +messages take precedence when errors are reported to the user. + +@node XEP-0090, XEP-0091, XEP-0086, Protocol support +@section XEP-0090 (Entity Time) + +jabber.el can query other entities for their time, and return the +current time to those who ask. + +@node XEP-0091, XEP-0092, XEP-0090, Protocol support +@section XEP-0091 (Delayed Delivery) + +The time specified on delayed incoming messages is interpreted, and +displayed in chat buffers instead of the current time. + +@node XEP-0092, XEP-0095, XEP-0091, Protocol support +@section XEP-0092 (Software Version) + +The user can request the version of any entity. jabber.el answers +version requests to anyone, giving ``jabber.el'' as name, and the +Emacs version as OS. + +@node XEP-0095, XEP-0096, XEP-0092, Protocol support +@section XEP-0095 (Stream Initiation) + +XEP-0095 is supported, both incoming and outgoing, except that jabber.el +doesn't check service discovery results before sending a stream +initiation request. + +@node XEP-0096, XEP-0146, XEP-0095, Protocol support +@section XEP-0096 (File Transfer) + +Both sending and receiving files is supported. If a suitable program is +found, MD5 hashes of outgoing files are calculated and sent. However, +hashes of received files are not checked. Ranged transfers are not +supported. In-band bytestreams are not yet supported, even though +XEP-0096 requires them. + +@node XEP-0146, XEP-0153, XEP-0096, Protocol support +@section XEP-0146 (Remote Controlling Clients) + +The ``set-status'' command in XEP-0146 is supported. + +@node XEP-0153, XEP-0199, XEP-0146, Protocol support +@section XEP-0153 (vCard-Based Avatars) + +vCard-based avatars are supported, both publishing and displaying. The +pixel size limits on avatars are not enforced. + +@node XEP-0199, XEP-0245, XEP-0153, Protocol support +@section XEP-0199 (XMPP Ping) + +XEP-0199 is fully supported. + +@node XEP-0245, ,XEP-0199, Protocol support +@section XEP-0245 (/me Command) + +XEP-0245 is partially supported (except XHTML-IM). + +@node Concept index, Function index, Protocol support, Top +@unnumbered Concept index + +@printindex cp + +@node Function index, Variable index, Concept index, Top +@unnumbered Function index + +@printindex fn + +@node Variable index, , Function index, Top +@unnumbered Variable index + +@printindex vr + +@bye + +@ignore + arch-tag: 995bf3da-0e87-4b15-895a-1e85fac139a2 +@end ignore diff --git a/m4/emacs-lib.m4 b/m4/emacs-lib.m4 new file mode 100644 index 0000000..6562cfd --- /dev/null +++ b/m4/emacs-lib.m4 @@ -0,0 +1,24 @@ +# AX_EMACS_RUN_IFELSE(PROGRAM, ACTION-IF-TRUE, ACTION-IF-FALSE) +# ------------------------------------------------------------- +# Run PROGRAM in emacs. If it finishes successfully, execute +# ACTION-IF-TRUE, else ACTION-IF-FALSE. +AC_DEFUN([AX_EMACS_RUN_IFELSE], +[cat >conftest.el <<EOF +$1 +EOF +AC_RUN_LOG([$EMACS -batch -l conftest.el]) +AS_IF([test $ac_status -eq 0], [$2], [$3])]) + +# AX_CHECK_EMACS_LIB(LIBRARY, ACTION-IF-PRESENT, ACTION-IF-NOT) +# ------------------------------------------------------------- +# Check whether emacs can load LIBRARY with require. Execute +# ACTION-IF-PRESENT if it can, else ACTION-IF-NOT. +AC_DEFUN([AX_CHECK_EMACS_LIB], +[ +AC_CACHE_CHECK([whether $EMACS has library $1], + [AS_TR_SH([ax_cv_emacs_lib_$1])], + [AX_EMACS_RUN_IFELSE([(require '$1)], + [AS_TR_SH([ax_cv_emacs_lib_$1])=yes], + [AS_TR_SH([ax_cv_emacs_lib_$1])=no])]) +AS_IF([test $AS_TR_SH([ax_cv_emacs_lib_$1]) = yes], [$2], [$3]) +]) @@ -0,0 +1,131 @@ +;;; srv.el --- perform SRV DNS requests + +;; Copyright (C) 2005, 2007 Magnus Henoch + +;; Author: Magnus Henoch <mange@freemail.hu> +;; Keywords: comm +;; Version: 0.1 + +;; This file 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, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This code implements RFC 2782 (SRV records). It requires a version +;; of dns.el that supports SRV records; look in Gnus CVS if you don't +;; have one. + +;;; Code: + +(condition-case nil + (require 'dns) + (error nil)) +(eval-when-compile (require 'cl)) + +(defun srv-lookup (target) + "Perform SRV lookup of TARGET and return list of connection candidiates. +TARGET is a string of the form \"_Service._Proto.Name\". + +Returns a list with elements of the form (HOST . PORT), where HOST is +a hostname and PORT is a numeric port. The caller is supposed to +make connection attempts in the order given, starting from the beginning +of the list. The list is empty if no SRV records were found." + (unless (boundp 'dns-query-types) + (error "No dns.el available")) + (unless (assq 'SRV dns-query-types) + (error "dns.el doesn't support SRV lookups")) + (let* ((result (srv--dns-query target)) + (answers (mapcar #'(lambda (a) + (cadr (assq 'data a))) + (cadr (assq 'answers result)))) + answers-by-priority weighted-result) + (if (or (null answers) + ;; Special case for "service decidedly not available" + (and (eq (length answers) 1) + (string= (cadr (assq 'target (car answers))) "."))) + nil + ;; Sort answers into groups of same priority. + (dolist (a answers) + (let* ((priority (cadr (assq 'priority a))) + (entry (assq priority answers-by-priority))) + (if entry + (push a (cdr entry)) + (push (cons priority (list a)) answers-by-priority)))) + ;; Sort by priority. + (setq answers-by-priority + (sort answers-by-priority + #'(lambda (a b) (< (car a) (car b))))) + ;; Randomize by weight within priority groups. See + ;; algorithm in RFC 2782. + (dolist (p answers-by-priority) + (let ((weight-acc 0) + weight-order) + ;; Assign running sum of weight to each entry. + (dolist (a (cdr p)) + (incf weight-acc (cadr (assq 'weight a))) + (push (cons weight-acc a) weight-order)) + (setq weight-order (nreverse weight-order)) + + ;; While elements remain, pick a random number between 0 and + ;; weight-acc inclusive, and select the first entry whose + ;; running sum is greater than or equal to this number. + (while weight-order + (let* ((r (random (1+ weight-acc))) + (next-entry (dolist (a weight-order) + (if (>= (car a) r) + (return a))))) + (push (cdr next-entry) weighted-result) + (setq weight-order + (delq next-entry weight-order)))))) + ;; Extract hostnames and ports + (mapcar #'(lambda (a) (cons (cadr (assq 'target a)) + (cadr (assq 'port a)))) + (nreverse weighted-result))))) + +(defun srv--dns-query (target) + ;; dns-query uses UDP, but that is not supported on Windows... + (if (featurep 'make-network-process '(:type datagram)) + (dns-query target 'SRV t) + ;; ...so let's call nslookup instead. + (srv--nslookup target))) + +(defun srv--nslookup (target) + (with-temp-buffer + (call-process "nslookup" nil t nil "-type=srv" target) + (goto-char (point-min)) + (let (results) + ;; This matches what nslookup prints on Windows. It's unlikely + ;; to work for other systems, but on those systems we use DNS + ;; directly. + (while (search-forward-regexp + (concat "[\s\t]*priority += \\(.*\\)\r?\n" + "[\s\t]*weight += \\(.*\\)\r?\n" + "[\s\t]*port += \\(.*\\)\r?\n" + "[\s\t]*svr hostname += \\(.*\\)\r?\n") + nil t) + (push + (list + (list 'data + (list + (list 'priority (string-to-number (match-string 1))) + (list 'weight (string-to-number (match-string 2))) + (list 'port (string-to-number (match-string 3))) + (list 'target (match-string 4))))) + results)) + (list (list 'answers results))))) + +(provide 'srv) +;; arch-tag: b43358f2-d241-11da-836e-000a95c2fcd0 +;;; srv.el ends here diff --git a/tests/Makefile.am b/tests/Makefile.am new file mode 100644 index 0000000..e171536 --- /dev/null +++ b/tests/Makefile.am @@ -0,0 +1,6 @@ +# LOG_COMPILER was introduced in Automake 1.12; don't expect "make +# check" or "make distcheck" to work with earlier versions. +LOG_COMPILER = env top_builddir=$(top_builddir) $(EMACS) -batch -L $(top_builddir) -L $(top_srcdir) -L $(srcdir) -l +TESTS = load-all.el skip-tag-forward.el history.el jabberd.el nick-change-fail.el +TESTS += caps-hash.el parse-next-stanza.el +dist_noinst_DATA = $(TESTS) diff --git a/tests/caps-hash.el b/tests/caps-hash.el new file mode 100644 index 0000000..55d18b9 --- /dev/null +++ b/tests/caps-hash.el @@ -0,0 +1,51 @@ +;; Test disco hash against examples in XEP-0115 + +(message "Let's go") +(condition-case e + (require 'jabber-disco) + (error + (message "disco bad! %S" e))) +(message "more") +(condition-case e + (require 'jabber-widget) + (error + (message "bad! %S" e))) +(message "done!") + +(let ((query + (with-temp-buffer + (insert "<query xmlns='http://jabber.org/protocol/disco#info' + node='http://psi-im.org#q07IKJEyjvHSyhy//CH0CxmKi8w='> + <identity xml:lang='en' category='client' name='Psi 0.11' type='pc'/> + <identity xml:lang='el' category='client' name='Ψ 0.11' type='pc'/> + <feature var='http://jabber.org/protocol/caps'/> + <feature var='http://jabber.org/protocol/disco#info'/> + <feature var='http://jabber.org/protocol/disco#items'/> + <feature var='http://jabber.org/protocol/muc'/> + <x xmlns='jabber:x:data' type='result'> + <field var='FORM_TYPE' type='hidden'> + <value>urn:xmpp:dataforms:softwareinfo</value> + </field> + <field var='ip_version'> + <value>ipv4</value> + <value>ipv6</value> + </field> + <field var='os'> + <value>Mac</value> + </field> + <field var='os_version'> + <value>10.5.1</value> + </field> + <field var='software'> + <value>Psi</value> + </field> + <field var='software_version'> + <value>0.11</value> + </field> + </x> + </query>") + (car (xml-parse-region (point-min) (point-max)))))) + (message "parsed xml") + (unless (equal "q07IKJEyjvHSyhy//CH0CxmKi8w=" + (jabber-caps-ver-string query "sha-1")) + (error "Incorrect caps hash"))) diff --git a/tests/history.el b/tests/history.el new file mode 100644 index 0000000..149aa9a --- /dev/null +++ b/tests/history.el @@ -0,0 +1,39 @@ +;; Tests for history + +(require 'jabber-history) + +;; 1. Smoke test +(let ((jabber-use-global-history t) + (jabber-global-history-filename (make-temp-file "history-test")) + ;; Jabber's birthday :) + (our-time (encode-time 0 0 0 4 1 1999 0))) + (unwind-protect + (progn + (jabber-history-log-message "in" "romeo@montague.net/Balcony" nil "hi" our-time) + (with-temp-buffer + (insert-file-contents-literally jabber-global-history-filename) + (let ((expected "\\[\"\\([^\"]+\\)\" \"in\" \"romeo@montague.net/Balcony\" \"me\" \"hi\"]\n") + (actual (buffer-string))) + (unless (string-match expected actual) + (error "Testcase 1 failed; %S doesn't match %S" actual expected)) + ;; The timestamps don't match for some reason... + ;; (let ((timestamp (match-string 1 actual))) +;; (unless (equal (jabber-parse-time timestamp) our-time) +;; (error "Testcase 1 failed; timestamp %S didn't match %S (%S vs %S)" timestamp (jabber-encode-time our-time) (jabber-parse-time timestamp) our-time))) + ))) + (delete-file jabber-global-history-filename))) + +;; 2. Test with unwritable history file - should not signal an error +;; This should reflect out-of-disk condition too. +(let ((jabber-use-global-history t) + (jabber-global-history-filename (make-temp-file "history-test"))) + (set-file-modes jabber-global-history-filename #o444) + (unwind-protect + (progn + (jabber-history-log-message "in" "romeo@montague.net/Balcony" nil "hi" nil) + (message "Please ignore the preceding \"Unable to write history\" error message.") + ;; No error signalled - we're done. + ) + (delete-file jabber-global-history-filename))) + +;; arch-tag: 43dd7ffe-22d7-11dd-9a7c-000a95c2fcd0 diff --git a/tests/jabberd.el b/tests/jabberd.el new file mode 100644 index 0000000..0985687 --- /dev/null +++ b/tests/jabberd.el @@ -0,0 +1,139 @@ +;;; Test the client by capturing its input and output into a virtual +;;; jabber server. This is not a test in itself, but a framework for +;;; actual tests. + +(require 'jabber) +(require 'cl) + +(defvar jabberd-stanza-handlers '(jabberd-sasl jabberd-iq) + "List of stanza handler hooks. +These functions are called in order with two arguments, the +client FSM and the stanza, until one function returns non-nil, +indicating that it has handled the stanza.") + +(defvar jabberd-iq-get-handlers + '(("jabber:iq:roster" . jabberd-iq-empty-success) + ("jabber:iq:auth" . jabberd-iq-auth-get)) + "Alist of handlers for IQ get stanzas. +The key is the namespace of the request (a string), and the value +is a function to handle the request. The function takes two +arguments, the client FSM and the stanza.") + +(defvar jabberd-iq-set-handlers + '(("urn:ietf:params:xml:ns:xmpp-bind" . jabberd-iq-bind) + ("urn:ietf:params:xml:ns:xmpp-session" . jabberd-iq-empty-success) + ("jabber:iq:auth" . jabberd-iq-empty-success)) + "Alist of handlers for IQ set stanzas. +The key is the namespace of the request (a string), and the value +is a function to handle the request. The function takes two +arguments, the client FSM and the stanza.") + +(defun jabberd-connect () + (setq *jabber-virtual-server-function* #'jabberd-handle) + (jabber-connect "romeo" "montague.net" nil nil "foo" nil nil 'virtual)) + +(defun jabberd-handle (fsm text) + ;; First, parse stanzas from text into sexps. + (let (stanzas) + (with-temp-buffer + (insert text) + (goto-char (point-min)) + ;; Skip processing directive + (when (looking-at "<\\?xml[^?]*\\?>") + (delete-region (match-beginning 0) (match-end 0))) + (catch 'unfinished + (while t + (push + (if (prog1 + (looking-at "<stream:stream") + (jabber-xml-skip-tag-forward t)) + ;; Stream start - just leave as a string + (delete-and-extract-region (point-min) (point)) + ;; Normal stanza + (prog1 + (car (xml-parse-region (point-min) (point))) + (delete-region (point-min) (point)))) + stanzas))) + ;; Delete whitespace - it has already been skipped over by + ;; jabber-xml-skip-tag-forward + (let ((whitespace-starts + (save-excursion (skip-chars-backward " \t\r\n") (point)))) + (delete-region whitespace-starts (point))) + (unless (= (buffer-size) 0) + (error "Couldn't parse outgoing XML: %S; %S remaining" text (buffer-string)))) + (setq stanzas (nreverse stanzas)) + + ;; Now, let's handle the stanza(s). + (dolist (stanza stanzas) + (cond + ((stringp stanza) + ;; "Send" a stream start in return. + (fsm-send fsm (list :stream-start "42" "1.0")) + ;; If we have a stream start, see whether it wants XMPP 1.0. + ;; If so, send <stream:features>. + (when (string-match "version=[\"']" stanza) + (jabberd-send fsm + '(features + ((xmlns . "http://etherx.jabber.org/streams")) + ;; Interesting implementation details + ;; of jabber.el permit us to send all + ;; features at once, without caring about + ;; which step we are at. + (mechanisms + ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl")) + (mechanism () "DIGEST-MD5")) + (bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind"))) + (session ((xmlns . "urn:ietf:params:xml:ns:xmpp-session"))))))) + (t + (run-hook-with-args-until-success 'jabberd-stanza-handlers fsm stanza)))))) + +(defun jabberd-send (fsm stanza) + (jabber-log-xml fsm "receive" stanza) + (fsm-send fsm (list :stanza stanza))) + +(defun jabberd-sasl (fsm stanza) + "Pretend to authenticate the client by SASL." + (when (eq (jabber-xml-node-name stanza) 'auth) + (jabberd-send fsm '(success ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl")))) + t)) + +(defun jabberd-iq (fsm stanza) + "Handle IQs from the client." + (when (eq (jabber-xml-node-name stanza) 'iq) + (jabber-xml-let-attributes (type id) stanza + (cond + ((member type '("get" "set")) + (let* ((table (if (string= type "get") + jabberd-iq-get-handlers + jabberd-iq-set-handlers)) + (ns (jabber-iq-xmlns stanza)) + (function (cdr (assoc ns table)))) + (when function + (funcall function fsm stanza))))) + t))) + +(defun jabberd-iq-empty-success (fsm stanza) + "Send an empty IQ result to STANZA." + (jabber-xml-let-attributes (id) stanza + (jabberd-send + fsm + `(iq ((type . "result") (id . ,id)))))) + +(defun jabberd-iq-bind (fsm stanza) + "Do resource binding for the virtual server." + (let ((id (jabber-xml-get-attribute stanza 'id))) + (jabberd-send + fsm + `(iq ((type . "result") (id . ,id)) + (bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind")) + (jid () "romeo@montague.net/Orchard")))))) + +(defun jabberd-iq-auth-get (fsm stanza) + (jabber-xml-let-attributes (id) stanza + (jabberd-send + fsm + `(iq ((type . "result") (id . ,id)) + (query ((xmlns . "jabber:iq:auth")) + (username) (password) (digest) (resource)))))) + +(provide 'jabberd) diff --git a/tests/load-all.el b/tests/load-all.el new file mode 100644 index 0000000..77006d9 --- /dev/null +++ b/tests/load-all.el @@ -0,0 +1,8 @@ +;; Test that all files can be loaded + +(let* ((default-directory (expand-file-name (getenv "top_builddir"))) + (elc-files (file-expand-wildcards "*.elc" t))) + (dolist (f elc-files) + (load f nil t))) + +;; arch-tag: 509c4808-2e92-11dd-9c8c-000a95c2fcd0 diff --git a/tests/nick-change-fail.el b/tests/nick-change-fail.el new file mode 100644 index 0000000..b562db3 --- /dev/null +++ b/tests/nick-change-fail.el @@ -0,0 +1,89 @@ +;;; When the user tries to change nickname in an MUC room, and the +;;; server denies this, we should detect this instead of believing +;;; that the user was thrown out of the room. + +(require 'jabberd) + +(defconst ncf-room-name "orchard@romeo-and-juliet.shakespeare.lit" + "The MUC room used for this test.") + +(defun ncf-presence (fsm stanza) + "Stanza handler. +This function is a very simple MUC implementation. It allows a user +to enter the room named by `ncf-room-name' with the nick \"Romeo\"." + (jabber-xml-let-attributes (to) stanza + (when (and (eq (jabber-xml-node-name stanza) 'presence) + (string= (jabber-jid-user to) ncf-room-name)) + (let ((nick (jabber-jid-resource to))) + ;; Allow only the nick Romeo + (if (string= nick "Romeo") + (jabberd-send fsm + `(presence ((from . ,to)) + (x ((xmlns . "http://jabber.org/protocol/muc#user")) + (item ((affiliation . "none") + (role . "participant")))))) + (jabberd-send fsm + `(presence ((from . ,to) + (type . "error")) + (x ((xmlns . "http://jabber.org/protocol/muc#user"))) + (error ((code . "409") (type . "cancel")) + (conflict ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))))))))))) + +(add-hook 'jabberd-stanza-handlers 'ncf-presence) +(add-hook 'jabber-post-connect-hooks 'ncf-do) +(setq jabber-muc-disable-disco-check t) +(setq jabber-debug-log-xml t) + +(defvar ncf-done nil) +;; We need an extra variable for the error, as errors from timers are +;; ignored. +(defvar ncf-error nil) + +(defun ncf-assert (assert-this format &rest args) + (unless assert-this + (let ((msg (apply #'format format args))) + (setq ncf-error msg) + (error "%s" msg)))) + +(defun ncf-do (jc) + (setq ncf-done t) + + (jabber-muc-join jc ncf-room-name "Romeo") + ;; We need a delay here, so that the client can process the response + ;; stanza. + (sit-for 0.01) + (let ((buffer (jabber-muc-get-buffer ncf-room-name))) + (ncf-assert (get-buffer buffer) "Couldn't enter MUC room") + (ncf-assert *jabber-active-groupchats* "Entering room not recorded") + + ;; Now, do an unallowed nickname change. + (jabber-muc-join jc ncf-room-name "Mercutio") + (sit-for 0.01) + + ;; We should still consider ourselves to be in the room as Romeo + (ncf-assert (assoc ncf-room-name *jabber-active-groupchats*) + "We thought we left the room, but we didn't") + (ncf-assert (string= (cdr (assoc ncf-room-name *jabber-active-groupchats*)) "Romeo") + "We thought we changed nickname, but we didn't"))) + +(jabberd-connect) + +(with-timeout (5 (error "Timeout")) + (while (not ncf-done) + (sit-for 0.1))) +(when ncf-error + (princ + (format + "nick-change-fail test FAILED: %s + +" ncf-error)) + (princ "Conversation was:\n") + (with-current-buffer "*-jabber-xml-log-romeo@montague.net-*" + (princ (buffer-string))) + (let ((muc-buffer (get-buffer (jabber-muc-get-buffer ncf-room-name)))) + (if muc-buffer + (with-current-buffer muc-buffer + (princ "Contents of groupchat buffer:\n") + (princ (buffer-string))) + (princ "Groupchat buffer not created.\n"))) + (kill-emacs 1)) diff --git a/tests/parse-next-stanza.el b/tests/parse-next-stanza.el new file mode 100644 index 0000000..d4f57b0 --- /dev/null +++ b/tests/parse-next-stanza.el @@ -0,0 +1,18 @@ +;; Tests for jabber-xml-parse-next-stanza + +(require 'jabber-xml) + +(defun parse-it (text) + (with-temp-buffer + (insert text) + (jabber-xml-parse-next-stanza))) + +(unless (equal + (parse-it "<presence from='foo@example.com/resource' type='unavailable' to='bar@example.com'/>") + '((presence ((from . "foo@example.com/resource") (type . "unavailable") (to . "bar@example.com"))))) + (error "Testcase 1 failed")) + +(unless (equal + (parse-it "<presence from='foo@example.com/resource' ") + nil) + (error "Testcase 2 failed")) diff --git a/tests/skip-tag-forward.el b/tests/skip-tag-forward.el new file mode 100644 index 0000000..2e7bf44 --- /dev/null +++ b/tests/skip-tag-forward.el @@ -0,0 +1,23 @@ +;; Tests for jabber-xml-skip-tag-forward + +(require 'jabber-xml) +(require 'cl) + +(flet ((parses-p + (text) + (with-temp-buffer + (insert text) + (goto-char (point-min)) + (catch 'unfinished + (jabber-xml-skip-tag-forward) + (= (point) (point-max)))))) + + ;; 1. Just plain XML + (unless (parses-p "<stream:features><starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/><mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'><mechanism>ANONYMOUS</mechanism><mechanism>DIGEST-MD5</mechanism><mechanism>PLAIN</mechanism></mechanisms><register xmlns='http://jabber.org/features/iq-register'/></stream:features>") + (error "Testcase 1 failed")) + + ;; 2. XML with CDATA + (unless (parses-p "<message><body><![CDATA[<foo & bar>]]></body></message>") + (error "Testcase 2 failed"))) + +;; arch-tag: a99d8666-0e6b-11dd-bd33-000a95c2fcd0 |