Compare commits
38 Commits
14ed8b66e7
...
68b243297a
Author | SHA1 | Date |
---|---|---|
contrapunctus | 68b243297a | |
contrapunctus | 75a78f7788 | |
contrapunctus | a31d7920d7 | |
contrapunctus | d67762d2ea | |
contrapunctus | 526181feda | |
contrapunctus | f5c12686e6 | |
contrapunctus | b7e3fe1778 | |
contrapunctus | cdb4df5d22 | |
contrapunctus | 3f7ab8a55c | |
contrapunctus | 4e3d61d172 | |
contrapunctus | 6b88356333 | |
contrapunctus | b6bd3fee84 | |
contrapunctus | 2b3922f7b0 | |
contrapunctus | 10474fc47c | |
contrapunctus | 71c7560742 | |
contrapunctus | cd1dbb569e | |
contrapunctus | a25b4f4f43 | |
contrapunctus | 00a5124f03 | |
contrapunctus | 5127f2b86b | |
contrapunctus | 16339e80cd | |
contrapunctus | a2a1e72220 | |
contrapunctus | 590516da8f | |
contrapunctus | 764dd9fbd7 | |
contrapunctus | 7a9da48298 | |
contrapunctus | c26e97d217 | |
contrapunctus | b161b41989 | |
contrapunctus | 3b7e387956 | |
contrapunctus | 40fad6eea0 | |
contrapunctus | e7777c7f16 | |
contrapunctus | 216c5aab76 | |
contrapunctus | 150c9289de | |
contrapunctus | 812ed07d33 | |
contrapunctus | ae6c55f168 | |
contrapunctus | d0fe06c7d6 | |
contrapunctus | 4358b2223f | |
contrapunctus | ad14af4e9b | |
contrapunctus | ba61b8c884 | |
contrapunctus | 983b7cb9c4 |
142
README
142
README
|
@ -1,142 +0,0 @@
|
|||
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".
|
|
@ -1,439 +0,0 @@
|
|||
;;; 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
|
|
@ -1,107 +0,0 @@
|
|||
;; 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
|
231
jabber-ahc.el
231
jabber-ahc.el
|
@ -1,231 +0,0 @@
|
|||
;; 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 nil nil)))
|
||||
(jabber-get-disco-items jc to "http://jabber.org/protocol/commands"))
|
||||
|
||||
(add-to-list 'jabber-jid-service-menu
|
||||
(cons "Execute command" 'jabber-ahc-execute-command))
|
||||
(defun jabber-ahc-execute-command (jc to node)
|
||||
"Execute ad-hoc command. (JEP-0050)"
|
||||
(interactive (list (jabber-read-account)
|
||||
(jabber-read-jid-completing "Execute command of: " nil nil nil nil nil)
|
||||
(jabber-read-node "Node of command: ")))
|
||||
(jabber-send-iq jc to
|
||||
"set"
|
||||
`(command ((xmlns . "http://jabber.org/protocol/commands")
|
||||
(node . ,node)
|
||||
(action . "execute")))
|
||||
#'jabber-process-data #'jabber-ahc-display
|
||||
#'jabber-process-data "Command execution failed"))
|
||||
|
||||
(defun jabber-ahc-display (jc xml-data)
|
||||
(let* ((from (jabber-xml-get-attribute xml-data 'from))
|
||||
(query (jabber-iq-query xml-data))
|
||||
(node (jabber-xml-get-attribute query 'node))
|
||||
(notes (jabber-xml-get-children query 'note))
|
||||
(sessionid (jabber-xml-get-attribute query 'sessionid))
|
||||
(status (jabber-xml-get-attribute query 'status))
|
||||
(actions (car (jabber-xml-get-children query 'actions)))
|
||||
xdata
|
||||
(inhibit-read-only t))
|
||||
|
||||
(make-local-variable 'jabber-ahc-sessionid)
|
||||
(setq jabber-ahc-sessionid sessionid)
|
||||
(make-local-variable 'jabber-ahc-node)
|
||||
(setq jabber-ahc-node node)
|
||||
(make-local-variable 'jabber-buffer-connection)
|
||||
(setq jabber-buffer-connection jc)
|
||||
|
||||
(dolist (x (jabber-xml-get-children query 'x))
|
||||
(when (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data")
|
||||
(setq xdata x)))
|
||||
|
||||
(cond
|
||||
((string= status "executing")
|
||||
(insert "Executing command\n\n"))
|
||||
((string= status "completed")
|
||||
(insert "Command completed\n\n"))
|
||||
((string= status "canceled")
|
||||
(insert "Command canceled\n\n")))
|
||||
|
||||
(dolist (note notes)
|
||||
(let ((note-type (jabber-xml-get-attribute note 'type)))
|
||||
(cond
|
||||
((string= note-type "warn")
|
||||
(insert "Warning: "))
|
||||
((string= note-type "error")
|
||||
(insert "Error: ")))
|
||||
(insert (car (jabber-xml-node-children note)) "\n")))
|
||||
(insert "\n")
|
||||
|
||||
(when xdata
|
||||
(jabber-init-widget-buffer from)
|
||||
|
||||
(let ((formtype (jabber-xml-get-attribute xdata 'type)))
|
||||
(if (string= formtype "result")
|
||||
(jabber-render-xdata-search-results xdata)
|
||||
(jabber-render-xdata-form xdata)
|
||||
|
||||
(when (string= status "executing")
|
||||
(let ((button-titles
|
||||
(cond
|
||||
((null actions)
|
||||
'(complete cancel))
|
||||
(t
|
||||
(let ((children (mapcar #'jabber-xml-node-name (jabber-xml-node-children actions)))
|
||||
(default-action (jabber-xml-get-attribute actions 'execute)))
|
||||
(if (or (null default-action) (memq (intern default-action) children))
|
||||
children
|
||||
(cons (intern default-action) children)))))))
|
||||
(dolist (button-title button-titles)
|
||||
(widget-create 'push-button :notify `(lambda (&rest ignore) (jabber-ahc-submit (quote ,button-title))) (symbol-name button-title))
|
||||
(widget-insert "\t")))
|
||||
(widget-insert "\n"))))
|
||||
|
||||
(widget-setup)
|
||||
(widget-minor-mode 1))))
|
||||
|
||||
(defun jabber-ahc-submit (action)
|
||||
"Submit Ad-Hoc Command."
|
||||
|
||||
(jabber-send-iq jabber-buffer-connection jabber-submit-to
|
||||
"set"
|
||||
`(command ((xmlns . "http://jabber.org/protocol/commands")
|
||||
(sessionid . ,jabber-ahc-sessionid)
|
||||
(node . ,jabber-ahc-node)
|
||||
(action . ,(symbol-name action)))
|
||||
,(if (and (not (eq action 'cancel))
|
||||
(eq jabber-form-type 'xdata))
|
||||
(jabber-parse-xdata-form)))
|
||||
|
||||
#'jabber-process-data #'jabber-ahc-display
|
||||
#'jabber-process-data "Command execution failed"))
|
||||
|
||||
(provide 'jabber-ahc)
|
||||
|
||||
;;; arch-tag: c0d5ed8c-50cb-44e1-8e0f-4058b79ee353
|
514
jabber-alert.el
514
jabber-alert.el
|
@ -1,514 +0,0 @@
|
|||
;; 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
|
|
@ -1,211 +0,0 @@
|
|||
;;; 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
|
234
jabber-avatar.el
234
jabber-avatar.el
|
@ -1,234 +0,0 @@
|
|||
;;; 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
|
|
@ -18,7 +18,7 @@
|
|||
;; 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))
|
||||
(eval-when-compile (require 'jabber))
|
||||
|
||||
(defcustom jabber-awesome-args ", timeout=5"
|
||||
"Additional args to naughty."
|
||||
|
|
|
@ -1,248 +0,0 @@
|
|||
;; 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
|
100
jabber-browse.el
100
jabber-browse.el
|
@ -1,100 +0,0 @@
|
|||
;; 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
|
|
@ -1,23 +0,0 @@
|
|||
(require 'jabber-iq)
|
||||
(require 'jabber-xml)
|
||||
|
||||
(defun jabber-carbon-success (jc xml-data context)
|
||||
(when (equal "result" (jabber-xml-get-attribute xml-data 'type))
|
||||
(message "Carbons feature successfully enabled")))
|
||||
|
||||
(defun jabber-carbon-failure (jc xml-data context)
|
||||
(message "Carbons feature could not be enabled: %S" xml-data))
|
||||
|
||||
(add-to-list 'jabber-jid-service-menu
|
||||
(cons "Enable Carbons" 'jabber-enable-carbons))
|
||||
(defun jabber-enable-carbons (jc)
|
||||
"Send request to enable XEP-0280 Message Carbons"
|
||||
(interactive (list (jabber-read-account)))
|
||||
(jabber-send-iq jc
|
||||
nil
|
||||
"set"
|
||||
`(enable ((xmlns . "urn:xmpp:carbons:2")))
|
||||
#'jabber-carbon-success "Carbons feature enablement"
|
||||
#'jabber-carbon-failure "Carbons feature enablement"))
|
||||
|
||||
(provide 'jabber-carbons)
|
703
jabber-chat.el
703
jabber-chat.el
|
@ -1,703 +0,0 @@
|
|||
;; 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
|
||||
(or jabber-chatting-with jabber-group) jabber-chat-earliest-backlog)))
|
||||
(when backlog-entries
|
||||
(setq jabber-chat-earliest-backlog
|
||||
(jabber-float-time (jabber-parse-time
|
||||
(aref (car backlog-entries) 0))))
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(mapc 'jabber-chat-insert-backlog-entry (nreverse backlog-entries))))))
|
||||
|
||||
(add-to-list 'jabber-message-chain 'jabber-process-chat)
|
||||
|
||||
(defun jabber-get-forwarded-message (xml-data)
|
||||
(let* ((sent (car (jabber-xml-get-children xml-data 'sent)))
|
||||
(forwarded (car (jabber-xml-get-children sent 'forwarded)))
|
||||
(forwarded-message (car (jabber-xml-get-children forwarded 'message))))
|
||||
(when forwarded-message
|
||||
forwarded-message)))
|
||||
|
||||
(defun jabber-process-chat (jc xml-data)
|
||||
"If XML-DATA is a one-to-one chat message, handle it as such."
|
||||
;; For now, everything that is not a public MUC message is
|
||||
;; potentially a 1to1 chat message.
|
||||
(when (not (jabber-muc-message-p xml-data))
|
||||
;; Note that we handle private MUC messages here.
|
||||
(cl-destructuring-bind (xml-data chat-buffer)
|
||||
(if (car (jabber-xml-get-children xml-data 'sent))
|
||||
(let* ((fwd-msg (jabber-get-forwarded-message xml-data))
|
||||
(to (jabber-xml-get-attribute fwd-msg 'to)))
|
||||
(list fwd-msg
|
||||
(jabber-chat-create-buffer jc to)))
|
||||
(list xml-data nil))
|
||||
(let ((from (jabber-xml-get-attribute xml-data 'from))
|
||||
(error-p (jabber-xml-get-children xml-data 'error))
|
||||
(body-text (car (jabber-xml-node-children
|
||||
(car (jabber-xml-get-children
|
||||
xml-data 'body))))))
|
||||
;; First check if we would output anything for this stanza.
|
||||
(when (or error-p
|
||||
(run-hook-with-args-until-success 'jabber-chat-printers
|
||||
xml-data
|
||||
:foreign :printp))
|
||||
;; If so, create chat buffer, if necessary...
|
||||
(with-current-buffer (if (jabber-muc-sender-p from)
|
||||
(jabber-muc-private-create-buffer
|
||||
jc
|
||||
(jabber-jid-user from)
|
||||
(jabber-jid-resource from))
|
||||
(or chat-buffer
|
||||
(jabber-chat-create-buffer jc from)))
|
||||
;; ...add the message to the ewoc...
|
||||
(let ((node (ewoc-enter-last jabber-chat-ewoc
|
||||
(list (if error-p :error :foreign)
|
||||
xml-data
|
||||
:time
|
||||
(current-time)))))
|
||||
(jabber-maybe-print-rare-time node))
|
||||
|
||||
;; ...and call alert hooks.
|
||||
(dolist (hook '(jabber-message-hooks jabber-alert-message-hooks))
|
||||
(run-hook-with-args hook
|
||||
from (current-buffer) body-text
|
||||
(funcall jabber-alert-message-function
|
||||
from (current-buffer) body-text)))))))))
|
||||
|
||||
(defun jabber-chat-send (jc body)
|
||||
"Send BODY through connection JC, and display it in chat buffer."
|
||||
;; Build the stanza...
|
||||
(let* ((id (apply 'format "emacs-msg-%d.%d.%d" (current-time)))
|
||||
(stanza-to-send `(message
|
||||
((to . ,jabber-chatting-with)
|
||||
(type . "chat")
|
||||
(id . ,id))
|
||||
(body () ,body))))
|
||||
;; ...add additional elements...
|
||||
;; TODO: Once we require Emacs 24.1, use `run-hook-wrapped' instead.
|
||||
;; That way we don't need to eliminate the "local hook" functionality
|
||||
;; here.
|
||||
(dolist (hook jabber-chat-send-hooks)
|
||||
(if (eq hook t)
|
||||
;; Local hook referring to global...
|
||||
(when (local-variable-p 'jabber-chat-send-hooks)
|
||||
(dolist (global-hook (default-value 'jabber-chat-send-hooks))
|
||||
(nconc stanza-to-send (funcall global-hook body id))))
|
||||
(nconc stanza-to-send (funcall hook body id))))
|
||||
;; ...display it, if it would be displayed.
|
||||
(when (run-hook-with-args-until-success 'jabber-chat-printers stanza-to-send :local :printp)
|
||||
(jabber-maybe-print-rare-time
|
||||
(ewoc-enter-last jabber-chat-ewoc (list :local stanza-to-send :time (current-time)))))
|
||||
;; ...and send it...
|
||||
(jabber-send-sexp jc stanza-to-send)))
|
||||
|
||||
(defun jabber-chat-pp (data)
|
||||
"Pretty-print a <message/> stanza.
|
||||
\(car data) is either :local, :foreign, :error or :notice.
|
||||
\(cadr data) is the <message/> stanza.
|
||||
This function is used as an ewoc prettyprinter."
|
||||
(let* ((beg (point))
|
||||
(original-timestamp (when (listp (cadr data))
|
||||
(jabber-message-timestamp (cadr data))))
|
||||
(internal-time
|
||||
(plist-get (cddr data) :time))
|
||||
(body (ignore-errors (car
|
||||
(jabber-xml-node-children
|
||||
(car
|
||||
(jabber-xml-get-children (cadr data) 'body))))))
|
||||
(/me-p
|
||||
(and (> (length body) 4)
|
||||
(string= (substring body 0 4) "/me "))))
|
||||
|
||||
;; Print prompt...
|
||||
(let ((delayed (or original-timestamp (plist-get (cddr data) :delayed)))
|
||||
(prompt-start (point)))
|
||||
(case (car data)
|
||||
(:local
|
||||
(jabber-chat-self-prompt (or original-timestamp internal-time)
|
||||
delayed
|
||||
/me-p))
|
||||
(:foreign
|
||||
(if (and (listp (cadr data))
|
||||
(jabber-muc-private-message-p (cadr data)))
|
||||
(jabber-muc-private-print-prompt (cadr data))
|
||||
;; For :error and :notice, this might be a string... beware
|
||||
(jabber-chat-print-prompt (when (listp (cadr data)) (cadr data))
|
||||
(or original-timestamp internal-time)
|
||||
delayed
|
||||
/me-p)))
|
||||
((:error :notice :subscription-request)
|
||||
(jabber-chat-system-prompt (or original-timestamp internal-time)))
|
||||
(:muc-local
|
||||
(jabber-muc-print-prompt (cadr data) t /me-p))
|
||||
(:muc-foreign
|
||||
(jabber-muc-print-prompt (cadr data) nil /me-p))
|
||||
((:muc-notice :muc-error)
|
||||
(jabber-muc-system-prompt)))
|
||||
(put-text-property prompt-start (point) 'field 'jabber-prompt))
|
||||
|
||||
;; ...and body
|
||||
(case (car data)
|
||||
((:local :foreign)
|
||||
(run-hook-with-args 'jabber-chat-printers (cadr data) (car data) :insert))
|
||||
((:muc-local :muc-foreign)
|
||||
(let ((printers (append jabber-muc-printers jabber-chat-printers)))
|
||||
(run-hook-with-args 'printers (cadr data) (car data) :insert)))
|
||||
((:error :muc-error)
|
||||
(if (stringp (cadr data))
|
||||
(insert (jabber-propertize (cadr data) 'face 'jabber-chat-error))
|
||||
(jabber-chat-print-error (cadr data))))
|
||||
((:notice :muc-notice)
|
||||
(insert (cadr data)))
|
||||
(:rare-time
|
||||
(insert (jabber-propertize (format-time-string jabber-rare-time-format (cadr data))
|
||||
'face 'jabber-rare-time-face)))
|
||||
(:subscription-request
|
||||
(insert "This user requests subscription to your presence.\n")
|
||||
(when (and (stringp (cadr data)) (not (zerop (length (cadr data)))))
|
||||
(insert "Message: " (cadr data) "\n"))
|
||||
(insert "Accept?\n\n")
|
||||
(flet ((button
|
||||
(text action)
|
||||
(if (fboundp 'insert-button)
|
||||
(insert-button text 'action action)
|
||||
;; simple button replacement
|
||||
(let ((keymap (make-keymap)))
|
||||
(define-key keymap "\r" action)
|
||||
(insert (jabber-propertize text 'keymap keymap 'face 'highlight))))
|
||||
(insert "\t")))
|
||||
(button "Mutual" 'jabber-subscription-accept-mutual)
|
||||
(button "One-way" 'jabber-subscription-accept-one-way)
|
||||
(button "Decline" 'jabber-subscription-decline))))
|
||||
|
||||
(when jabber-chat-fill-long-lines
|
||||
(save-restriction
|
||||
(narrow-to-region beg (point))
|
||||
(jabber-chat-buffer-fill-long-lines)))
|
||||
|
||||
(put-text-property beg (point) 'read-only t)
|
||||
(put-text-property beg (point) 'front-sticky t)
|
||||
(put-text-property beg (point) 'rear-nonsticky t)))
|
||||
|
||||
(defun jabber-rare-time-needed (time1 time2)
|
||||
"Return non-nil if a timestamp should be printed between TIME1 and TIME2."
|
||||
(not (string= (format-time-string jabber-rare-time-format time1)
|
||||
(format-time-string jabber-rare-time-format time2))))
|
||||
|
||||
(defun jabber-maybe-print-rare-time (node)
|
||||
"Print rare time before NODE, if appropriate."
|
||||
(let* ((prev (ewoc-prev jabber-chat-ewoc node))
|
||||
(data (ewoc-data node))
|
||||
(prev-data (when prev (ewoc-data prev))))
|
||||
(flet ((entry-time (entry)
|
||||
(or (when (listp (cadr entry))
|
||||
(jabber-message-timestamp (cadr entry)))
|
||||
(plist-get (cddr entry) :time))))
|
||||
(when (and jabber-print-rare-time
|
||||
(or (null prev)
|
||||
(jabber-rare-time-needed (entry-time prev-data)
|
||||
(entry-time data))))
|
||||
(ewoc-enter-before jabber-chat-ewoc node
|
||||
(list :rare-time (entry-time data)))))))
|
||||
|
||||
(defun jabber-chat-print-prompt (xml-data timestamp delayed dont-print-nick-p)
|
||||
"Print prompt for received message in XML-DATA.
|
||||
TIMESTAMP is the timestamp to print, or nil to get it
|
||||
from a jabber:x:delay element.
|
||||
If DELAYED is true, print long timestamp
|
||||
\(`jabber-chat-delayed-time-format' as opposed to
|
||||
`jabber-chat-time-format').
|
||||
If DONT-PRINT-NICK-P is true, don't include nickname."
|
||||
(let ((from (jabber-xml-get-attribute xml-data 'from))
|
||||
(timestamp (or timestamp (jabber-message-timestamp xml-data))))
|
||||
(insert (jabber-propertize
|
||||
(format-spec jabber-chat-foreign-prompt-format
|
||||
(list
|
||||
(cons ?t (format-time-string
|
||||
(if delayed
|
||||
jabber-chat-delayed-time-format
|
||||
jabber-chat-time-format)
|
||||
timestamp))
|
||||
(cons ?n (if dont-print-nick-p "" (jabber-jid-displayname from)))
|
||||
(cons ?u (or (jabber-jid-username from) from))
|
||||
(cons ?r (jabber-jid-resource from))
|
||||
(cons ?j (jabber-jid-user from))))
|
||||
'face 'jabber-chat-prompt-foreign
|
||||
'help-echo
|
||||
(concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from " from)))))
|
||||
|
||||
(defun jabber-chat-system-prompt (timestamp)
|
||||
(insert (jabber-propertize
|
||||
(format-spec jabber-chat-foreign-prompt-format
|
||||
(list
|
||||
(cons ?t (format-time-string jabber-chat-time-format
|
||||
timestamp))
|
||||
(cons ?n "")
|
||||
(cons ?u "")
|
||||
(cons ?r "")
|
||||
(cons ?j "")))
|
||||
'face 'jabber-chat-prompt-system
|
||||
'help-echo
|
||||
(concat (format-time-string "System message on %Y-%m-%d %H:%M:%S" timestamp)))))
|
||||
|
||||
(defun jabber-chat-self-prompt (timestamp delayed dont-print-nick-p)
|
||||
"Print prompt for sent message.
|
||||
TIMESTAMP is the timestamp to print, or nil for now.
|
||||
If DELAYED is true, print long timestamp
|
||||
\(`jabber-chat-delayed-time-format' as opposed to
|
||||
`jabber-chat-time-format').
|
||||
If DONT-PRINT-NICK-P is true, don't include nickname."
|
||||
(let* ((state-data (fsm-get-state-data jabber-buffer-connection))
|
||||
(username (plist-get state-data :username))
|
||||
(server (plist-get state-data :server))
|
||||
(resource (plist-get state-data :resource))
|
||||
(nickname username))
|
||||
(insert (jabber-propertize
|
||||
(format-spec jabber-chat-local-prompt-format
|
||||
(list
|
||||
(cons ?t (format-time-string
|
||||
(if delayed
|
||||
jabber-chat-delayed-time-format
|
||||
jabber-chat-time-format)
|
||||
timestamp))
|
||||
(cons ?n (if dont-print-nick-p "" nickname))
|
||||
(cons ?u username)
|
||||
(cons ?r resource)
|
||||
(cons ?j (concat username "@" server))))
|
||||
'face 'jabber-chat-prompt-local
|
||||
'help-echo
|
||||
(concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from you")))))
|
||||
|
||||
(defun jabber-chat-print-error (xml-data)
|
||||
"Print error in given <message/> in a readable way."
|
||||
(let ((the-error (car (jabber-xml-get-children xml-data 'error))))
|
||||
(insert
|
||||
(jabber-propertize
|
||||
(concat "Error: " (jabber-parse-error the-error))
|
||||
'face 'jabber-chat-error))))
|
||||
|
||||
(defun jabber-chat-print-subject (xml-data who mode)
|
||||
"Print subject of given <message/>, if any."
|
||||
(let ((subject (car
|
||||
(jabber-xml-node-children
|
||||
(car
|
||||
(jabber-xml-get-children xml-data 'subject))))))
|
||||
(when (not (zerop (length subject)))
|
||||
(case mode
|
||||
(:printp
|
||||
t)
|
||||
(:insert
|
||||
(insert (jabber-propertize
|
||||
"Subject: " 'face 'jabber-chat-prompt-system)
|
||||
(jabber-propertize
|
||||
subject
|
||||
'face 'jabber-chat-text-foreign)
|
||||
"\n"))))))
|
||||
|
||||
(defun jabber-chat-print-body (xml-data who mode)
|
||||
(run-hook-with-args-until-success 'jabber-body-printers xml-data who mode))
|
||||
|
||||
(defun jabber-chat-normal-body (xml-data who mode)
|
||||
"Print body for received message in XML-DATA."
|
||||
(let ((body (car
|
||||
(jabber-xml-node-children
|
||||
(car
|
||||
(jabber-xml-get-children xml-data 'body))))))
|
||||
(when body
|
||||
|
||||
(when (eql mode :insert)
|
||||
(if (and (> (length body) 4)
|
||||
(string= (substring body 0 4) "/me "))
|
||||
(let ((action (substring body 4))
|
||||
(nick (cond
|
||||
((eq who :local)
|
||||
(plist-get (fsm-get-state-data jabber-buffer-connection) :username))
|
||||
((or (jabber-muc-message-p xml-data)
|
||||
(jabber-muc-private-message-p xml-data))
|
||||
(jabber-jid-resource (jabber-xml-get-attribute xml-data 'from)))
|
||||
(t
|
||||
(jabber-jid-displayname (jabber-xml-get-attribute xml-data 'from))))))
|
||||
(insert (jabber-propertize
|
||||
(concat nick
|
||||
" "
|
||||
action)
|
||||
'face 'jabber-chat-prompt-system)))
|
||||
(insert (jabber-propertize
|
||||
body
|
||||
'face (case who
|
||||
((:foreign :muc-foreign) 'jabber-chat-text-foreign)
|
||||
((:local :muc-local) 'jabber-chat-text-local))))))
|
||||
t)))
|
||||
|
||||
(defun jabber-chat-print-url (xml-data who mode)
|
||||
"Print URLs provided in jabber:x:oob namespace."
|
||||
(let ((foundp nil))
|
||||
(dolist (x (jabber-xml-node-children xml-data))
|
||||
(when (and (listp x) (eq (jabber-xml-node-name x) 'x)
|
||||
(string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:oob"))
|
||||
(setq foundp t)
|
||||
|
||||
(when (eql mode :insert)
|
||||
(let ((url (car (jabber-xml-node-children
|
||||
(car (jabber-xml-get-children x 'url)))))
|
||||
(desc (car (jabber-xml-node-children
|
||||
(car (jabber-xml-get-children x 'desc))))))
|
||||
(insert "\n"
|
||||
(jabber-propertize
|
||||
"URL: " 'face 'jabber-chat-prompt-system)
|
||||
(format "%s <%s>" desc url))))))
|
||||
foundp))
|
||||
|
||||
(defun jabber-chat-goto-address (xml-data who mode)
|
||||
"Call `goto-address' on the newly written text."
|
||||
(when (eq mode :insert)
|
||||
(ignore-errors
|
||||
;; `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
|
|
@ -1,137 +0,0 @@
|
|||
;; 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
|
|
@ -1,177 +0,0 @@
|
|||
;;; 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
|
|
@ -1,82 +0,0 @@
|
|||
;;; 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
|
405
jabber-conn.el
405
jabber-conn.el
|
@ -1,405 +0,0 @@
|
|||
;; 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))
|
||||
|
||||
(eval-and-compile
|
||||
(or (ignore-errors (require 'srv))
|
||||
(ignore-errors
|
||||
(let ((load-path (cons (expand-file-name
|
||||
"jabber-fallback-lib"
|
||||
(file-name-directory (locate-library "jabber")))
|
||||
load-path)))
|
||||
(require 'srv)))
|
||||
(error
|
||||
"srv not found in `load-path' or jabber-fallback-lib/ directory.")))
|
||||
|
||||
(defgroup jabber-conn nil "Jabber Connection Settings"
|
||||
:group 'jabber)
|
||||
|
||||
(defun jabber-have-starttls ()
|
||||
"Return true if we can use STARTTLS."
|
||||
(or (and (fboundp 'gnutls-available-p)
|
||||
(gnutls-available-p))
|
||||
(and (featurep 'starttls)
|
||||
(or (and (bound-and-true-p starttls-gnutls-program)
|
||||
(executable-find starttls-gnutls-program))
|
||||
(and (bound-and-true-p starttls-program)
|
||||
(executable-find starttls-program))))))
|
||||
|
||||
(defconst jabber-default-connection-type
|
||||
(cond
|
||||
;; Use STARTTLS if we can...
|
||||
((jabber-have-starttls)
|
||||
'starttls)
|
||||
;; ...else default to unencrypted connection.
|
||||
(t
|
||||
'network))
|
||||
"Default connection type.
|
||||
See `jabber-connect-methods'.")
|
||||
|
||||
(defcustom jabber-connection-ssl-program nil
|
||||
"Program used for SSL/TLS connections.
|
||||
nil means prefer gnutls but fall back to openssl.
|
||||
'gnutls' means use gnutls (through `open-tls-stream').
|
||||
'openssl means use openssl (through `open-ssl-stream')."
|
||||
:type '(choice (const :tag "Prefer gnutls, fall back to openssl" nil)
|
||||
(const :tag "Use gnutls" gnutls)
|
||||
(const :tag "Use openssl" openssl))
|
||||
:group 'jabber-conn)
|
||||
|
||||
(defcustom jabber-invalid-certificate-servers ()
|
||||
"Jabber servers for which we accept invalid TLS certificates.
|
||||
This is a list of server names, each matching the hostname part
|
||||
of your JID.
|
||||
|
||||
This option has effect only when using native GnuTLS in Emacs 24
|
||||
or later."
|
||||
:type '(repeat string)
|
||||
:group 'jabber-conn)
|
||||
|
||||
(defvar jabber-connect-methods
|
||||
`((network jabber-network-connect jabber-network-send)
|
||||
(starttls
|
||||
,(if (and (fboundp 'gnutls-available-p)
|
||||
(gnutls-available-p))
|
||||
;; With "native" TLS, we can use a normal connection.
|
||||
'jabber-network-connect
|
||||
'jabber-starttls-connect)
|
||||
jabber-network-send)
|
||||
(ssl jabber-ssl-connect jabber-ssl-send)
|
||||
(virtual jabber-virtual-connect jabber-virtual-send))
|
||||
"Alist of connection methods and functions.
|
||||
First item is the symbol naming the method.
|
||||
Second item is the connect function.
|
||||
Third item is the send function.")
|
||||
|
||||
(defun jabber-get-connect-function (type)
|
||||
"Get the connect function associated with TYPE.
|
||||
TYPE is a symbol; see `jabber-connection-type'."
|
||||
(let ((entry (assq type jabber-connect-methods)))
|
||||
(nth 1 entry)))
|
||||
|
||||
(defun jabber-get-send-function (type)
|
||||
"Get the send function associated with TYPE.
|
||||
TYPE is a symbol; see `jabber-connection-type'."
|
||||
(let ((entry (assq type jabber-connect-methods)))
|
||||
(nth 2 entry)))
|
||||
|
||||
(defun jabber-srv-targets (server network-server port)
|
||||
"Find host and port to connect to.
|
||||
If NETWORK-SERVER and/or PORT are specified, use them.
|
||||
If we can't find SRV records, use standard defaults."
|
||||
;; If the user has specified a host or a port, obey that.
|
||||
(if (or network-server port)
|
||||
(list (cons (or network-server server)
|
||||
(or port 5222)))
|
||||
(or (condition-case nil
|
||||
(srv-lookup (concat "_xmpp-client._tcp." server))
|
||||
(error nil))
|
||||
(list (cons server 5222)))))
|
||||
|
||||
;; Plain TCP/IP connection
|
||||
(defun jabber-network-connect (fsm server network-server port)
|
||||
"Connect to a Jabber server with a plain network connection.
|
||||
Send a message of the form (:connected CONNECTION) to FSM if
|
||||
connection succeeds. Send a message (:connection-failed ERRORS) if
|
||||
connection fails."
|
||||
(cond
|
||||
((featurep 'make-network-process '(:nowait t))
|
||||
;; We can connect asynchronously!
|
||||
(jabber-network-connect-async fsm server network-server port))
|
||||
(t
|
||||
;; Connecting to the server will block Emacs.
|
||||
(jabber-network-connect-sync fsm server network-server port))))
|
||||
|
||||
(defun jabber-network-connect-async (fsm server network-server port)
|
||||
;; Get all potential targets...
|
||||
(lexical-let ((targets (jabber-srv-targets server network-server port))
|
||||
errors
|
||||
(fsm fsm))
|
||||
;; ...and connect to them one after another, asynchronously, until
|
||||
;; connection succeeds.
|
||||
(labels
|
||||
((connect
|
||||
(target remaining-targets)
|
||||
(lexical-let ((target target) (remaining-targets remaining-targets))
|
||||
(labels ((connection-successful
|
||||
(c)
|
||||
;; This mustn't be `fsm-send-sync', because the FSM
|
||||
;; needs to change the sentinel, which cannot be done
|
||||
;; from inside the sentinel.
|
||||
(fsm-send fsm (list :connected c)))
|
||||
(connection-failed
|
||||
(c status)
|
||||
(when (and (> (length status) 0)
|
||||
(eq (aref status (1- (length status))) ?\n))
|
||||
(setq status (substring status 0 -1)))
|
||||
(let ((err
|
||||
(format "Couldn't connect to %s:%s: %s"
|
||||
(car target) (cdr target) status)))
|
||||
(message "%s" err)
|
||||
(push err errors))
|
||||
(when c (delete-process c))
|
||||
(if remaining-targets
|
||||
(progn
|
||||
(message
|
||||
"Connecting to %s:%s..."
|
||||
(caar remaining-targets) (cdar remaining-targets))
|
||||
(connect (car remaining-targets) (cdr remaining-targets)))
|
||||
(fsm-send fsm (list :connection-failed (nreverse errors))))))
|
||||
(condition-case e
|
||||
(make-network-process
|
||||
:name "jabber"
|
||||
:buffer (generate-new-buffer jabber-process-buffer)
|
||||
:host (car target) :service (cdr target)
|
||||
:coding 'utf-8
|
||||
:nowait t
|
||||
:sentinel
|
||||
(lexical-let ((target target) (remaining-targets remaining-targets))
|
||||
(lambda (connection status)
|
||||
(cond
|
||||
((string-match "^open" status)
|
||||
(connection-successful connection))
|
||||
((string-match "^failed" status)
|
||||
(connection-failed connection status))
|
||||
((string-match "^deleted" status)
|
||||
;; This happens when we delete a process in the
|
||||
;; "failed" case above.
|
||||
nil)
|
||||
(t
|
||||
(message "Unknown sentinel status `%s'" status))))))
|
||||
(file-error
|
||||
;; A file-error has the error message in the third list
|
||||
;; element.
|
||||
(connection-failed nil (car (cddr e))))
|
||||
(error
|
||||
;; Not sure if we ever get anything but file-errors,
|
||||
;; but let's make sure we report them:
|
||||
(connection-failed nil (error-message-string e))))))))
|
||||
(message "Connecting to %s:%s..." (caar targets) (cdar targets))
|
||||
(connect (car targets) (cdr targets)))))
|
||||
|
||||
(defun jabber-network-connect-sync (fsm server network-server port)
|
||||
;; This code will AFAIK only be used on Windows. Apologies in
|
||||
;; advance for any bit rot...
|
||||
(let ((coding-system-for-read 'utf-8)
|
||||
(coding-system-for-write 'utf-8)
|
||||
(targets (jabber-srv-targets server network-server port))
|
||||
errors)
|
||||
(catch 'connected
|
||||
(dolist (target targets)
|
||||
(condition-case e
|
||||
(let ((process-buffer (generate-new-buffer jabber-process-buffer))
|
||||
connection)
|
||||
(unwind-protect
|
||||
(setq connection (open-network-stream
|
||||
"jabber"
|
||||
process-buffer
|
||||
(car target)
|
||||
(cdr target)))
|
||||
|
||||
(unless (or connection jabber-debug-keep-process-buffers)
|
||||
(kill-buffer process-buffer)))
|
||||
|
||||
(when connection
|
||||
(fsm-send fsm (list :connected connection))
|
||||
(throw 'connected connection)))
|
||||
(file-error
|
||||
;; A file-error has the error message in the third list
|
||||
;; element.
|
||||
(let ((err (format "Couldn't connect to %s:%s: %s"
|
||||
(car target) (cdr target)
|
||||
(car (cddr e)))))
|
||||
(message "%s" err)
|
||||
(push err errors)))
|
||||
(error
|
||||
;; Not sure if we ever get anything but file-errors,
|
||||
;; but let's make sure we report them:
|
||||
(let ((err (format "Couldn't connect to %s:%s: %s"
|
||||
(car target) (cdr target)
|
||||
(error-message-string e))))
|
||||
(message "%s" err)
|
||||
(push err errors)))))
|
||||
(fsm-send fsm (list :connection-failed (nreverse errors))))))
|
||||
|
||||
(defun jabber-network-send (connection string)
|
||||
"Send a string via a plain TCP/IP connection to the Jabber Server."
|
||||
(process-send-string connection string))
|
||||
|
||||
;; SSL connection, we use openssl's s_client function for encryption
|
||||
;; of the link
|
||||
;; TODO: make this configurable
|
||||
(defun jabber-ssl-connect (fsm server network-server port)
|
||||
"connect via OpenSSL or GnuTLS to a Jabber Server
|
||||
Send a message of the form (:connected CONNECTION) to FSM if
|
||||
connection succeeds. Send a message (:connection-failed ERRORS) if
|
||||
connection fails."
|
||||
(let ((coding-system-for-read 'utf-8)
|
||||
(coding-system-for-write 'utf-8)
|
||||
(connect-function
|
||||
(cond
|
||||
((and (memq jabber-connection-ssl-program '(nil gnutls))
|
||||
(fboundp 'open-tls-stream))
|
||||
'open-tls-stream)
|
||||
((and (memq jabber-connection-ssl-program '(nil openssl))
|
||||
(fboundp 'open-ssl-stream))
|
||||
'open-ssl-stream)
|
||||
(t
|
||||
(error "Neither TLS nor SSL connect functions available"))))
|
||||
error-msg)
|
||||
(let ((process-buffer (generate-new-buffer jabber-process-buffer))
|
||||
connection)
|
||||
(setq network-server (or network-server server))
|
||||
(setq port (or port 5223))
|
||||
(condition-case e
|
||||
(setq connection (funcall connect-function
|
||||
"jabber"
|
||||
process-buffer
|
||||
network-server
|
||||
port))
|
||||
(error
|
||||
(setq error-msg
|
||||
(format "Couldn't connect to %s:%d: %s" network-server port
|
||||
(error-message-string e)))
|
||||
(message "%s" error-msg)))
|
||||
(unless (or connection jabber-debug-keep-process-buffers)
|
||||
(kill-buffer process-buffer))
|
||||
(if connection
|
||||
(fsm-send fsm (list :connected connection))
|
||||
(fsm-send fsm (list :connection-failed
|
||||
(when error-msg (list error-msg))))))))
|
||||
|
||||
(defun jabber-ssl-send (connection string)
|
||||
"Send a string via an SSL-encrypted connection to the Jabber Server."
|
||||
;; It seems we need to send a linefeed afterwards.
|
||||
(process-send-string connection string)
|
||||
(process-send-string connection "\n"))
|
||||
|
||||
(defun jabber-starttls-connect (fsm server network-server port)
|
||||
"Connect via an external GnuTLS process to a Jabber Server.
|
||||
Send a message of the form (:connected CONNECTION) to FSM if
|
||||
connection succeeds. Send a message (:connection-failed ERRORS) if
|
||||
connection fails."
|
||||
(let ((coding-system-for-read 'utf-8)
|
||||
(coding-system-for-write 'utf-8)
|
||||
(targets (jabber-srv-targets server network-server port))
|
||||
errors)
|
||||
(unless (fboundp 'starttls-open-stream)
|
||||
(error "starttls.el not available"))
|
||||
(catch 'connected
|
||||
(dolist (target targets)
|
||||
(condition-case e
|
||||
(let ((process-buffer (generate-new-buffer jabber-process-buffer))
|
||||
connection)
|
||||
(unwind-protect
|
||||
(setq connection
|
||||
(starttls-open-stream
|
||||
"jabber"
|
||||
process-buffer
|
||||
(car target)
|
||||
(cdr target)))
|
||||
(unless (or connection jabber-debug-keep-process-buffers)
|
||||
(kill-buffer process-buffer)))
|
||||
(if (null connection)
|
||||
;; It seems we don't actually get an error if we
|
||||
;; can't connect. Let's try to convey some useful
|
||||
;; information to the user at least.
|
||||
(let ((err (format "Couldn't connect to %s:%s"
|
||||
(car target) (cdr target))))
|
||||
(message "%s" err)
|
||||
(push err errors))
|
||||
(fsm-send fsm (list :connected connection))
|
||||
(throw 'connected connection)))
|
||||
(error
|
||||
(let ((err (format "Couldn't connect to %s: %s" target
|
||||
(error-message-string e))))
|
||||
(message "%s" err)
|
||||
(push err errors)))))
|
||||
(fsm-send fsm (list :connection-failed (nreverse errors))))))
|
||||
|
||||
(defun jabber-starttls-initiate (fsm)
|
||||
"Initiate a starttls connection"
|
||||
(jabber-send-sexp fsm
|
||||
'(starttls ((xmlns . "urn:ietf:params:xml:ns:xmpp-tls")))))
|
||||
|
||||
(defun jabber-starttls-process-input (fsm xml-data)
|
||||
"Process result of starttls request.
|
||||
On failure, signal error."
|
||||
(cond
|
||||
((eq (car xml-data) 'proceed)
|
||||
(let* ((state-data (fsm-get-state-data fsm))
|
||||
(connection (plist-get state-data :connection)))
|
||||
;; Did we use open-network-stream or starttls-open-stream? We
|
||||
;; can tell by process-type.
|
||||
(case (process-type connection)
|
||||
(network
|
||||
(let* ((hostname (plist-get state-data :server))
|
||||
(verifyp (not (member hostname jabber-invalid-certificate-servers))))
|
||||
;; gnutls-negotiate might signal an error, which is caught
|
||||
;; by our caller
|
||||
(gnutls-negotiate
|
||||
:process connection
|
||||
;; This is the hostname that the certificate should be valid for:
|
||||
:hostname hostname
|
||||
:verify-hostname-error verifyp
|
||||
:verify-error verifyp)))
|
||||
(real
|
||||
(or
|
||||
(starttls-negotiate connection)
|
||||
(error "Negotiation failure"))))))
|
||||
((eq (car xml-data) 'failure)
|
||||
(error "Command rejected by server"))))
|
||||
|
||||
(defvar *jabber-virtual-server-function* nil
|
||||
"Function to use for sending stanzas on a virtual connection.
|
||||
The function should accept two arguments, the connection object
|
||||
and a string that the connection wants to send.")
|
||||
|
||||
(defun jabber-virtual-connect (fsm server network-server port)
|
||||
"Connect to a virtual \"server\".
|
||||
Use `*jabber-virtual-server-function*' as send function."
|
||||
(unless (functionp *jabber-virtual-server-function*)
|
||||
(error "No virtual server function specified"))
|
||||
;; We pass the fsm itself as "connection object", as that is what a
|
||||
;; virtual server needs to send stanzas.
|
||||
(fsm-send fsm (list :connected fsm)))
|
||||
|
||||
(defun jabber-virtual-send (connection string)
|
||||
(funcall *jabber-virtual-server-function* connection string))
|
||||
|
||||
(provide 'jabber-conn)
|
||||
;; arch-tag: f95ec240-8cd3-11d9-9dbf-000a95c2fcd0
|
|
@ -1,143 +0,0 @@
|
|||
;; 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
|
1006
jabber-core.el
1006
jabber-core.el
File diff suppressed because it is too large
Load Diff
652
jabber-disco.el
652
jabber-disco.el
|
@ -1,652 +0,0 @@
|
|||
;; 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
|
245
jabber-events.el
245
jabber-events.el
|
@ -1,245 +0,0 @@
|
|||
;;; 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
|
251
jabber-export.el
251
jabber-export.el
|
@ -1,251 +0,0 @@
|
|||
;;; 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
|
|
@ -1,125 +0,0 @@
|
|||
;; 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
|
|
@ -19,7 +19,7 @@
|
|||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
|
||||
(eval-when-compile (require 'jabber-alert))
|
||||
(eval-when-compile (require 'jabber))
|
||||
|
||||
(condition-case e
|
||||
(progn
|
||||
|
@ -31,5 +31,3 @@
|
|||
|
||||
(provide 'jabber-festival)
|
||||
;; arch-tag: 8922D096-5D07-11D9-B4C2-000A95C2FCD0
|
||||
|
||||
|
||||
|
|
|
@ -1,68 +0,0 @@
|
|||
;; 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
|
|
@ -1,46 +0,0 @@
|
|||
;;; 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
|
|
@ -1,131 +0,0 @@
|
|||
;; 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
|
|
@ -1,337 +0,0 @@
|
|||
;; 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
|
213
jabber-iq.el
213
jabber-iq.el
|
@ -1,213 +0,0 @@
|
|||
;; 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
|
|
@ -1,176 +0,0 @@
|
|||
;; 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
|
|
@ -1,62 +0,0 @@
|
|||
;; 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
|
|
@ -18,7 +18,7 @@
|
|||
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
(require 'dbus nil t)
|
||||
(eval-when-compile (require 'jabber-alert))
|
||||
(eval-when-compile (require 'jabber))
|
||||
|
||||
(defcustom jabber-libnotify-icon ""
|
||||
"Icon to be used on the notification pop-up. Default is empty"
|
||||
|
|
|
@ -1,83 +0,0 @@
|
|||
;; 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
|
207
jabber-menu.el
207
jabber-menu.el
|
@ -1,207 +0,0 @@
|
|||
;; 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
|
||||
'(or (eq jabber-display-menu t)
|
||||
(and (eq jabber-display-menu 'maybe)
|
||||
(or (bound-and-true-p jabber-account-list)
|
||||
(bound-and-true-p jabber-connections))))))
|
||||
|
||||
(defvar jabber-jid-chat-menu nil
|
||||
"Menu items for chat menu")
|
||||
|
||||
(defvar jabber-jid-info-menu nil
|
||||
"Menu item for info menu")
|
||||
|
||||
(defvar jabber-jid-roster-menu nil
|
||||
"Menu items for roster menu")
|
||||
|
||||
(defvar jabber-jid-muc-menu nil
|
||||
"Menu items for MUC menu")
|
||||
|
||||
(defvar jabber-jid-service-menu nil
|
||||
"Menu items for service menu")
|
||||
|
||||
(defun jabber-popup-menu (which-menu)
|
||||
"Popup specified menu"
|
||||
(let* ((mouse-event (and (listp last-input-event) last-input-event))
|
||||
(choice (widget-choose "Actions" which-menu mouse-event)))
|
||||
(if mouse-event
|
||||
(mouse-set-point mouse-event))
|
||||
(if choice
|
||||
(call-interactively choice))))
|
||||
|
||||
(defun jabber-popup-chat-menu ()
|
||||
"Popup chat menu"
|
||||
(interactive)
|
||||
(jabber-popup-menu jabber-jid-chat-menu))
|
||||
|
||||
(defun jabber-popup-info-menu ()
|
||||
"Popup info menu"
|
||||
(interactive)
|
||||
(jabber-popup-menu jabber-jid-info-menu))
|
||||
|
||||
(defun jabber-popup-roster-menu ()
|
||||
"Popup roster menu"
|
||||
(interactive)
|
||||
(jabber-popup-menu jabber-jid-roster-menu))
|
||||
|
||||
(defun jabber-popup-muc-menu ()
|
||||
"Popup MUC menu"
|
||||
(interactive)
|
||||
(jabber-popup-menu jabber-jid-muc-menu))
|
||||
|
||||
(defun jabber-popup-service-menu ()
|
||||
"Popup service menu"
|
||||
(interactive)
|
||||
(jabber-popup-menu jabber-jid-service-menu))
|
||||
|
||||
(defun jabber-popup-combined-menu ()
|
||||
"Popup combined menu"
|
||||
(interactive)
|
||||
(jabber-popup-menu (append jabber-jid-chat-menu jabber-jid-info-menu jabber-jid-roster-menu jabber-jid-muc-menu)))
|
||||
|
||||
(provide 'jabber-menu)
|
||||
|
||||
;;; arch-tag: 5147f52f-de47-4348-86ff-b799d7a75e3f
|
|
@ -1,98 +0,0 @@
|
|||
;; 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
|
|
@ -1,85 +0,0 @@
|
|||
;;; 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
|
|
@ -1,188 +0,0 @@
|
|||
;;; 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
|
1171
jabber-muc.el
1171
jabber-muc.el
File diff suppressed because it is too large
Load Diff
|
@ -20,7 +20,7 @@
|
|||
|
||||
;; Built on jabber-libnotify.el.
|
||||
|
||||
(eval-when-compile (require 'jabber-alert))
|
||||
(eval-when-compile (require 'jabber))
|
||||
(unless (string< emacs-version "24.1") ;notifications.el preset since Emacs 24.1
|
||||
(require 'notifications)
|
||||
|
||||
|
|
|
@ -1,35 +0,0 @@
|
|||
;;; 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
|
|
@ -1,61 +0,0 @@
|
|||
;; 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)
|
|
@ -1,565 +0,0 @@
|
|||
;; 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
|
|
@ -1,61 +0,0 @@
|
|||
;;; 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
|
|
@ -18,7 +18,7 @@
|
|||
;; 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))
|
||||
(eval-when-compile (require 'jabber))
|
||||
|
||||
(defun jabber-ratpoison-message (text &optional title)
|
||||
"Show MSG in Ratpoison"
|
||||
|
@ -27,7 +27,7 @@
|
|||
(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)
|
||||
|
||||
|
|
|
@ -1,144 +0,0 @@
|
|||
;; 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
|
893
jabber-roster.el
893
jabber-roster.el
|
@ -1,893 +0,0 @@
|
|||
;; 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
|
321
jabber-rtt.el
321
jabber-rtt.el
|
@ -1,321 +0,0 @@
|
|||
;;; 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
|
157
jabber-sasl.el
157
jabber-sasl.el
|
@ -1,157 +0,0 @@
|
|||
;; 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
|
|
@ -18,7 +18,7 @@
|
|||
;; 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))
|
||||
(eval-when-compile (require 'jabber))
|
||||
|
||||
(defcustom jabber-sawfish-display-time 3
|
||||
"Time in seconds for displaying a jabber message through the
|
||||
|
@ -29,8 +29,8 @@ Sawfish window manager."
|
|||
(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"
|
||||
(start-process-shell-command
|
||||
"jabber-sawfish" nil "echo"
|
||||
(concat "'(progn (require (quote timers)) (display-message \""
|
||||
(or title text)
|
||||
"\")(make-timer (lambda () (display-message nil)) "
|
||||
|
|
|
@ -18,7 +18,7 @@
|
|||
;; 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))
|
||||
(eval-when-compile (require 'jabber))
|
||||
|
||||
(defun jabber-screen-message (text &optional title)
|
||||
"Show MSG in screen"
|
||||
|
|
116
jabber-search.el
116
jabber-search.el
|
@ -1,116 +0,0 @@
|
|||
;; 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
|
|
@ -1,70 +0,0 @@
|
|||
;; 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
|
|
@ -1,61 +0,0 @@
|
|||
;;; 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
|
|
@ -1,92 +0,0 @@
|
|||
;; 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
|
678
jabber-socks5.el
678
jabber-socks5.el
|
@ -1,678 +0,0 @@
|
|||
;; 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
|
200
jabber-time.el
200
jabber-time.el
|
@ -1,200 +0,0 @@
|
|||
;; 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
|
|
@ -18,7 +18,7 @@
|
|||
;; 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))
|
||||
(eval-when-compile (require 'jabber))
|
||||
|
||||
(defun jabber-tmux-message (msg)
|
||||
"Show MSG in tmux"
|
||||
|
|
|
@ -1,75 +0,0 @@
|
|||
;; 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
|
771
jabber-util.el
771
jabber-util.el
|
@ -1,771 +0,0 @@
|
|||
;; 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)
|
||||
(require 'password-cache)
|
||||
(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-string input jid-completion-table t))
|
||||
(symbol-name (cdr (assoc-string input jid-completion-table t)))
|
||||
(and (not (zerop (length input)))
|
||||
input))))
|
||||
|
||||
(when chosen
|
||||
(case resource
|
||||
(full
|
||||
;; If JID is bare, add the highest-priority resource.
|
||||
(if (jabber-jid-resource chosen)
|
||||
chosen
|
||||
(let ((highest-resource (get (jabber-jid-symbol chosen) 'resource)))
|
||||
(if highest-resource
|
||||
(concat chosen "/" highest-resource)
|
||||
chosen))))
|
||||
(bare-or-muc
|
||||
;; If JID is full and non-MUC, remove resource.
|
||||
(if (null (jabber-jid-resource chosen))
|
||||
chosen
|
||||
(let ((bare (jabber-jid-user chosen)))
|
||||
(if (assoc bare *jabber-active-groupchats*)
|
||||
chosen
|
||||
bare))))
|
||||
(t
|
||||
chosen)))))
|
||||
|
||||
(defun jabber-read-node (prompt)
|
||||
"Read node name, taking default from disco item at point."
|
||||
(let ((node-at-point (get-text-property (point) 'jabber-node)))
|
||||
(read-string (concat prompt
|
||||
(if node-at-point
|
||||
(format "(default %s) " node-at-point)))
|
||||
node-at-point)))
|
||||
|
||||
(defun jabber-password-key (bare-jid)
|
||||
"Construct key for `password' library from BARE-JID."
|
||||
(concat "xmpp:" bare-jid))
|
||||
|
||||
(defun jabber-read-password (bare-jid)
|
||||
"Read Jabber password from minibuffer."
|
||||
(let ((found
|
||||
(and (fboundp 'auth-source-search)
|
||||
(nth 0 (auth-source-search
|
||||
:user (jabber-jid-username bare-jid)
|
||||
:host (jabber-jid-server bare-jid)
|
||||
:port "xmpp"
|
||||
:max 1
|
||||
:require '(:secret))))))
|
||||
(if found
|
||||
(let ((secret (plist-get found :secret)))
|
||||
(copy-sequence
|
||||
(if (functionp secret)
|
||||
(funcall secret)
|
||||
secret)))
|
||||
(let ((prompt (format "Jabber password for %s: " bare-jid)))
|
||||
;; Need to copy the password, as sasl.el wants to erase it.
|
||||
(copy-sequence
|
||||
(password-read prompt (jabber-password-key bare-jid)))))))
|
||||
|
||||
(defun jabber-cache-password (bare-jid password)
|
||||
"Cache PASSWORD for BARE-JID."
|
||||
(password-cache-add (jabber-password-key bare-jid) password))
|
||||
|
||||
(defun jabber-uncache-password (bare-jid)
|
||||
"Uncache cached password for BARE-JID.
|
||||
Useful if the password proved to be wrong."
|
||||
(interactive (list (jabber-jid-user
|
||||
(completing-read "Forget password of account: " jabber-account-list nil nil nil 'jabber-account-history))))
|
||||
(password-cache-remove (jabber-password-key bare-jid)))
|
||||
|
||||
(defun jabber-read-account (&optional always-ask contact-hint)
|
||||
"Ask for which connected account to use.
|
||||
If ALWAYS-ASK is nil and there is only one account, return that
|
||||
account.
|
||||
If CONTACT-HINT is a string or a JID symbol, default to an account
|
||||
that has that contact in its roster."
|
||||
(let ((completions
|
||||
(mapcar (lambda (c)
|
||||
(cons
|
||||
(jabber-connection-bare-jid c)
|
||||
c))
|
||||
jabber-connections)))
|
||||
(cond
|
||||
((null jabber-connections)
|
||||
(error "Not connected to Jabber"))
|
||||
((and (null (cdr jabber-connections)) (not always-ask))
|
||||
;; only one account
|
||||
(car jabber-connections))
|
||||
(t
|
||||
(or
|
||||
;; if there is a jabber-account property at point,
|
||||
;; present it as default value
|
||||
(cdr (assoc (let ((at-point (get-text-property (point) 'jabber-account)))
|
||||
(when (and at-point
|
||||
(memq at-point jabber-connections))
|
||||
(jabber-connection-bare-jid at-point))) completions))
|
||||
(let* ((default
|
||||
(or
|
||||
(and contact-hint
|
||||
(setq contact-hint (jabber-jid-symbol contact-hint))
|
||||
(let ((matching
|
||||
(find-if
|
||||
(lambda (jc)
|
||||
(memq contact-hint (plist-get (fsm-get-state-data jc) :roster)))
|
||||
jabber-connections)))
|
||||
(when matching
|
||||
(jabber-connection-bare-jid matching))))
|
||||
;; if the buffer is associated with a connection, use it
|
||||
(when (and jabber-buffer-connection
|
||||
(jabber-find-active-connection jabber-buffer-connection))
|
||||
(jabber-connection-bare-jid jabber-buffer-connection))
|
||||
;; else, use the first connection in the list
|
||||
(caar completions)))
|
||||
(input (completing-read
|
||||
(concat "Select Jabber account (default "
|
||||
default
|
||||
"): ")
|
||||
completions nil t nil 'jabber-account-history
|
||||
default)))
|
||||
(cdr (assoc input completions))))))))
|
||||
|
||||
(defun jabber-iq-query (xml-data)
|
||||
"Return the query part of an IQ stanza.
|
||||
An IQ stanza may have zero or one query child, and zero or one <error/> child.
|
||||
The query child is often but not always <query/>."
|
||||
(let (query)
|
||||
(dolist (x (jabber-xml-node-children xml-data))
|
||||
(if (and
|
||||
(listp x)
|
||||
(not (eq (jabber-xml-node-name x) 'error)))
|
||||
(setq query x)))
|
||||
query))
|
||||
|
||||
(defun jabber-iq-error (xml-data)
|
||||
"Return the <error/> part of an IQ stanza, if any."
|
||||
(car (jabber-xml-get-children xml-data 'error)))
|
||||
|
||||
(defun jabber-iq-xmlns (xml-data)
|
||||
"Return the namespace of an IQ stanza, i.e. the namespace of its query part."
|
||||
(jabber-xml-get-attribute (jabber-iq-query xml-data) 'xmlns))
|
||||
|
||||
(defun jabber-message-timestamp (xml-data)
|
||||
"Given a <message/> element, return its timestamp, or nil if none."
|
||||
(jabber-x-delay
|
||||
(or
|
||||
(jabber-xml-path xml-data '(("urn:xmpp:delay" . "delay")))
|
||||
(jabber-xml-path xml-data '(("jabber:x:delay" . "x"))))))
|
||||
|
||||
(defun jabber-x-delay (xml-data)
|
||||
"Return timestamp given a delayed delivery element.
|
||||
This can be either a <delay/> tag in namespace urn:xmpp:delay (XEP-0203), or
|
||||
a <x/> tag in namespace jabber:x:delay (XEP-0091).
|
||||
Return nil if no such data available."
|
||||
(cond
|
||||
((and (eq (jabber-xml-node-name xml-data) 'x)
|
||||
(string= (jabber-xml-get-attribute xml-data 'xmlns) "jabber:x:delay"))
|
||||
(let ((stamp (jabber-xml-get-attribute xml-data 'stamp)))
|
||||
(if (and (stringp stamp)
|
||||
(= (length stamp) 17))
|
||||
(jabber-parse-legacy-time stamp))))
|
||||
((and (eq (jabber-xml-node-name xml-data) 'delay)
|
||||
(string= (jabber-xml-get-attribute xml-data 'xmlns) "urn:xmpp:delay"))
|
||||
(let ((stamp (jabber-xml-get-attribute xml-data 'stamp)))
|
||||
(when (stringp stamp)
|
||||
(jabber-parse-time stamp))))))
|
||||
|
||||
(defun jabber-parse-legacy-time (timestamp)
|
||||
"Parse timestamp in ccyymmddThh:mm:ss format (UTC) and return as internal time value."
|
||||
(let ((year (string-to-number (substring timestamp 0 4)))
|
||||
(month (string-to-number (substring timestamp 4 6)))
|
||||
(day (string-to-number (substring timestamp 6 8)))
|
||||
(hour (string-to-number (substring timestamp 9 11)))
|
||||
(minute (string-to-number (substring timestamp 12 14)))
|
||||
(second (string-to-number (substring timestamp 15 17))))
|
||||
(encode-time second minute hour day month year 0)))
|
||||
|
||||
(defun jabber-encode-legacy-time (timestamp)
|
||||
"Parse TIMESTAMP as internal time value and encode as ccyymmddThh:mm:ss (UTC)."
|
||||
(if (featurep 'xemacs)
|
||||
;; XEmacs doesn't have `universal' argument to format-time-string,
|
||||
;; so we have to do it ourselves.
|
||||
(format-time-string "%Y%m%dT%H:%M:%S"
|
||||
(time-subtract timestamp
|
||||
(list 0 (car (current-time-zone)))))
|
||||
(format-time-string "%Y%m%dT%H:%M:%S" timestamp t)))
|
||||
|
||||
(defun jabber-encode-time (time)
|
||||
"Convert TIME to a string by 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)))
|
||||
(timezone (if (eq (aref time 19) ?.)
|
||||
;; fractions are optional
|
||||
(let ((timezone (cadr
|
||||
(split-string (substring time 20)
|
||||
"[-+Z]"))))
|
||||
(if (string= "" timezone)
|
||||
"Z"
|
||||
timezone))
|
||||
(substring time 19))))
|
||||
;; timezone is either Z (UTC) or [+-]HH:MM
|
||||
(let ((timezone-seconds
|
||||
(if (string= timezone "Z")
|
||||
0
|
||||
(* (if (eq (aref timezone 0) ?+) 1 -1)
|
||||
(* 60 (+ (* 60 (string-to-number (substring timezone 1 3)))
|
||||
(string-to-number (substring timezone 4 6))))))))
|
||||
(encode-time second minute hour day month year timezone-seconds))))
|
||||
|
||||
(defun jabber-report-success (jc xml-data context)
|
||||
"IQ callback reporting success or failure of the operation.
|
||||
CONTEXT is a string describing the action.
|
||||
\"CONTEXT succeeded\" or \"CONTEXT failed: REASON\" is displayed in
|
||||
the echo area."
|
||||
(let ((type (jabber-xml-get-attribute xml-data 'type)))
|
||||
(message (concat context
|
||||
(if (string= type "result")
|
||||
" succeeded"
|
||||
(concat
|
||||
" failed: "
|
||||
(let ((the-error (jabber-iq-error xml-data)))
|
||||
(if the-error
|
||||
(jabber-parse-error the-error)
|
||||
"No error message given"))))))))
|
||||
|
||||
(defconst jabber-error-messages
|
||||
(list
|
||||
(cons 'bad-request "Bad request")
|
||||
(cons 'conflict "Conflict")
|
||||
(cons 'feature-not-implemented "Feature not implemented")
|
||||
(cons 'forbidden "Forbidden")
|
||||
(cons 'gone "Gone")
|
||||
(cons 'internal-server-error "Internal server error")
|
||||
(cons 'item-not-found "Item not found")
|
||||
(cons 'jid-malformed "JID malformed")
|
||||
(cons 'not-acceptable "Not acceptable")
|
||||
(cons 'not-allowed "Not allowed")
|
||||
(cons 'not-authorized "Not authorized")
|
||||
(cons 'payment-required "Payment required")
|
||||
(cons 'recipient-unavailable "Recipient unavailable")
|
||||
(cons 'redirect "Redirect")
|
||||
(cons 'registration-required "Registration required")
|
||||
(cons 'remote-server-not-found "Remote server not found")
|
||||
(cons 'remote-server-timeout "Remote server timeout")
|
||||
(cons 'resource-constraint "Resource constraint")
|
||||
(cons 'service-unavailable "Service unavailable")
|
||||
(cons 'subscription-required "Subscription required")
|
||||
(cons 'undefined-condition "Undefined condition")
|
||||
(cons 'unexpected-request "Unexpected request"))
|
||||
"String descriptions of XMPP stanza errors")
|
||||
|
||||
(defconst jabber-legacy-error-messages
|
||||
(list
|
||||
(cons 302 "Redirect")
|
||||
(cons 400 "Bad request")
|
||||
(cons 401 "Unauthorized")
|
||||
(cons 402 "Payment required")
|
||||
(cons 403 "Forbidden")
|
||||
(cons 404 "Not found")
|
||||
(cons 405 "Not allowed")
|
||||
(cons 406 "Not acceptable")
|
||||
(cons 407 "Registration required")
|
||||
(cons 408 "Request timeout")
|
||||
(cons 409 "Conflict")
|
||||
(cons 500 "Internal server error")
|
||||
(cons 501 "Not implemented")
|
||||
(cons 502 "Remote server error")
|
||||
(cons 503 "Service unavailable")
|
||||
(cons 504 "Remote server timeout")
|
||||
(cons 510 "Disconnected"))
|
||||
"String descriptions of legacy errors (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
|
|
@ -1,137 +0,0 @@
|
|||
;;; 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
|
550
jabber-vcard.el
550
jabber-vcard.el
|
@ -1,550 +0,0 @@
|
|||
;;; 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
|
|
@ -19,65 +19,6 @@
|
|||
;; 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)
|
||||
|
||||
|
|
|
@ -1,76 +0,0 @@
|
|||
;; 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
|
363
jabber-widget.el
363
jabber-widget.el
|
@ -1,363 +0,0 @@
|
|||
;; 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
|
|
@ -18,7 +18,7 @@
|
|||
;; 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))
|
||||
(eval-when-compile (require 'jabber))
|
||||
|
||||
(defvar jabber-wmii-color "#ffffff #335577 #447799"
|
||||
"Color specification as needed by the wmii window manager for the jabber alert messages.")
|
||||
|
@ -34,7 +34,7 @@
|
|||
(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
|
||||
|
|
|
@ -19,7 +19,7 @@
|
|||
;; 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))
|
||||
(eval-when-compile (require 'jabber))
|
||||
|
||||
(defcustom jabber-xmessage-timeout 15
|
||||
"Timeout in seconds for xmessage alerts.
|
||||
|
|
289
jabber-xml.el
289
jabber-xml.el
|
@ -1,289 +0,0 @@
|
|||
;; 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
|
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue