pax_global_header00006660000000000000000000000064147634533740014532gustar00rootroot0000000000000052 comment=30c023b6b54601594d347956cc2918e7841e5ed4 emacs-jabber/000077500000000000000000000000001476345337400134115ustar00rootroot00000000000000emacs-jabber/.dir-locals.el000066400000000000000000000000511476345337400160360ustar00rootroot00000000000000((org-mode . ((org-tags-column . -60)))) emacs-jabber/.gitignore000066400000000000000000000002501476345337400153760ustar00rootroot00000000000000*.elc *~ Makefile Makefile.in aclocal.m4 config.log config.status configure elc-stamp *.tar* *.zip /jabber-autoloads.el /jabber-pkg.el jabber.info emacs-jabber.schemas emacs-jabber/.travis.yml000066400000000000000000000006231476345337400155230ustar00rootroot00000000000000env: - EMACS=emacs23 - EMACS=emacs24 before_install: # PPA for stable Emacs packages - sudo add-apt-repository -y ppa:cassou/emacs # PPA for Automake 1.12 - sudo add-apt-repository -y ppa:dns/gnu - sudo apt-get update -qq - sudo apt-get install -qq -yy ${EMACS}-nox texinfo automake script: - emacs --version - automake --version - autoreconf -i - ./configure - make all check emacs-jabber/CHANGELOG.org000066400000000000000000000261641476345337400154220ustar00rootroot00000000000000#+TITLE: Changelog All notable changes to this project will be documented in this file. The format is based on [[https://keepachangelog.com/en/1.0.0/][Keep a Changelog]]. * New features in jabber.el latest git :PROPERTIES: :CUSTOM_ID: new-features-jabberel-latest-git :END: ** Enable carbons by default :PROPERTIES: :CUSTOM_ID: enable-carbons-by-default :END: Enable support for XEP-0280 (message carbons) by default. ** Support for reading passwords from netrc/authinfo files :PROPERTIES: :CUSTOM_ID: support-reading-passwords-from-netrc-authinfo-files :END: Use "machine example.com login username password s3cret port xmpp". ** Provide MUC presence announcement formatting :PROPERTIES: :CUSTOM_ID: provide-muc-presence-announcement-formatting :END: Provide customization to limit, highlight, or deemphasize MUC presence announcements. See the manual for details (info "(jabber) Presence announcements"). ** Support for roster's groups roll state saving :PROPERTIES: :CUSTOM_ID: support-rosters-groups-roll-state-saving :END: ** Full support for XEP-0012 :PROPERTIES: :CUSTOM_ID: full-support-xep-001 :END: Response of idle time. ** Support for XEP-0202 :PROPERTIES: :CUSTOM_ID: support-xep-020 :END: Entity Time for request/response time as main method. ** Support for automatic MUC nicks colorization :PROPERTIES: :CUSTOM_ID: support-automatic-muc-nicks-colorization :END: See "Customizing the chat buffer" in the manual. ** XML Console :PROPERTIES: :CUSTOM_ID: xml-console :END: Log all received/sending XML stanzas into special buffer. Also can be used to send custom XML stanzas manually. ** Autoaway :PROPERTIES: :CUSTOM_ID: autoaway :END: Support for list of autoaway methods. Support for Xa. See section "Autoaway" in manual. ** MUC :PROPERTIES: :CUSTOM_ID: muc :END: MUC participants list format is now customizable: see jabber-muc-print-names-format in manual. Also, participants sorted by role. ** Treat XML namespace prefixes correctly :PROPERTIES: :CUSTOM_ID: treat-xml-namespace-prefixes-correctly :END: A change in the Google Talk server has brought to light the fact that jabber.el didn't handle XML namespace prefixes correctly. This should be fixed by the new jabber-xml-resolve-namespace-prefixes function. * [0.8] :PROPERTIES: :CUSTOM_ID: v0.8 :END: ** Added :PROPERTIES: :CUSTOM_ID: added :END: *** Support for multiple accounts :PROPERTIES: :CUSTOM_ID: support-multiple-accounts :END: Configuration variables have changed. See section "Account settings" in the manual. *** Activity mode improved :PROPERTIES: :CUSTOM_ID: activity-mode-improved :END: Customizable face for personal messages added, list of unwanted (banned) JIDs added *** Simple automatic answering machine :PROPERTIES: :CUSTOM_ID: simple-automatic-answering-machine :END: Realized as alert. Can match regexp and answer with predefined string *** OSD alerts (message, MUC, MUC-personal) :PROPERTIES: :CUSTOM_ID: osd-alerts-message,-muc,-muc-personal :END: *** Family of personal MUC alerts added :PROPERTIES: :CUSTOM_ID: family-personal-muc-alerts-added :END: See section "Standard alerts" in manual. *** MUC nicks completion :PROPERTIES: :CUSTOM_ID: muc-nicks-completion :END: See section "Groupchat" in manual. *** Automatic reconnection :PROPERTIES: :CUSTOM_ID: automatic-reconnection :END: Not enabled by default; See "Reconnecting" section in manual. *** Support for XEP-0085 :PROPERTIES: :CUSTOM_ID: support-xep-008 :END: This means "contact is typing" notifications when chatting with Gajim or Google Talk users, among others. See "Typing notifications" section in the manual. *** Option: hide offline contacts in roster :PROPERTIES: :CUSTOM_ID: option-hide-offline-contacts-roster :END: See "The roster buffer" in manual. *** Clean history from chat buffers :PROPERTIES: :CUSTOM_ID: clean-history-from-chat-buffers :END: See jabber-truncate-* functions and new options for jabber-alert-muc-hooks and jabber-alert-message-hooks. See section "Message history" in manual too. *** MUC bookmarks :PROPERTIES: :CUSTOM_ID: muc-bookmarks :END: See jabber-edit-bookmarks function and "Bookmarks" section in manual. *** Name of browse buffers customizable :PROPERTIES: :CUSTOM_ID: name-browse-buffers-customizable :END: See "Services" section in manual. *** Subscription requests are sent to chat buffers :PROPERTIES: :CUSTOM_ID: subscription-requests-are-sent-to-chat-buffers :END: Subscription requests now displayed in chat buffers. See "Presence subscription" section in manual. *** Option: hide avatar in chat buffer :PROPERTIES: :CUSTOM_ID: option-hide-avatar-chat-buffer :END: `jabber-chat-buffer-show-avatar'. *** Gmail notifications :PROPERTIES: :CUSTOM_ID: gmail-notifications :END: (Not documented nor autoloaded) *** GConf-based installation of URI handler :PROPERTIES: :CUSTOM_ID: gconf-based-installation-uri-handler :END: See "XMPP URIs" in manual. * [0.7.1] :PROPERTIES: :CUSTOM_ID: v0.7.1 :END: ** Added :PROPERTIES: :CUSTOM_ID: v0.7.1-added :END: *** STARTTLS :PROPERTIES: :CUSTOM_ID: starttls :END: *** SRV records :PROPERTIES: :CUSTOM_ID: srv-records :END: Requires No Gnus. *** Message composition buffer :PROPERTIES: :CUSTOM_ID: message-composition-buffer :END: Try jabber-compose. *** XMPP URIs are handled :PROPERTIES: :CUSTOM_ID: xmpp-uris-are-handled :END: See manual for setup. *** Autoaway :PROPERTIES: :CUSTOM_ID: autoaway-1 :END: *** MUC features :PROPERTIES: :CUSTOM_ID: muc-features :END: **** Don't display alerts for your own messages :PROPERTIES: :CUSTOM_ID: dont-display-alerts-your-own-messages :END: See jabber-muc-alert-self. **** Presence changes are sent to MUC rooms too :PROPERTIES: :CUSTOM_ID: presence-changes-are-sent-to-muc-rooms-too :END: **** Check room features before joining :PROPERTIES: :CUSTOM_ID: check-room-features-before-joining :END: *** Avatars :PROPERTIES: :CUSTOM_ID: avatars :END: Viewing and publishing JEP-0153 avatars (vCard-based) is now supported. *** File transfer :PROPERTIES: :CUSTOM_ID: file-transfer :END: *** Sound files per contact for alerts :PROPERTIES: :CUSTOM_ID: sound-files-per-contact-alerts :END: *** Per-user history files changed :PROPERTIES: :CUSTOM_ID: per-user-history-files-changed :END: For some time after 0.7 these file names erroneously contained double quotes. If you have used the CVS version you'll need to rename your history files manually. *** New function: jabber-send-directed-presence :PROPERTIES: :CUSTOM_ID: new-function-jabber-send-directed-presence :END: *** Entity time supported (XEP-0090) :PROPERTIES: :CUSTOM_ID: entity-time-supported-xep-0090 :END: *** Last activity supported (XEP-0012) :PROPERTIES: :CUSTOM_ID: last-activity-supported-xep-0012 :END: * [0.7] :PROPERTIES: :CUSTOM_ID: v0.7 :END: ** Added :PROPERTIES: :CUSTOM_ID: v0.7-added :END: *** SSL connections possible :PROPERTIES: :CUSTOM_ID: ssl-connections-possible :END: See variable `jabber-connection-type'. *** Chat buffers rewritten :PROPERTIES: :CUSTOM_ID: chat-buffers-rewritten :END: New modular design gives increased extensibility. **** Received URLs are displayed :PROPERTIES: :CUSTOM_ID: received-urls-are-displayed :END: **** Long lines are filled :PROPERTIES: :CUSTOM_ID: long-lines-are-filled :END: See jabber-chat-fill-long-lines. **** Rare timestamps are printed by default :PROPERTIES: :CUSTOM_ID: rare-timestamps-are-printed-by-default :END: See jabber-print-rare-time and jabber-rare-time-format. *** MUC features :PROPERTIES: :CUSTOM_ID: muc-features-1 :END: **** Different default nicknames for different MUC rooms :PROPERTIES: :CUSTOM_ID: different-default-nicknames-different-muc-rooms :END: See jabber-muc-default-nicknames. **** Autojoin MUC rooms on connection :PROPERTIES: :CUSTOM_ID: autojoin-muc-rooms-on-connection :END: See jabber-muc-autojoin. **** Change nickname :PROPERTIES: :CUSTOM_ID: change-nickname :END: Actually simply an alias from jabber-muc-nick to jabber-muc-join. **** Invitations :PROPERTIES: :CUSTOM_ID: invitations :END: Both sending and receiving invitiations is supported. **** Basic affiliation change support :PROPERTIES: :CUSTOM_ID: basic-affiliation-change-support :END: (Not finished) **** Private MUC messages :PROPERTIES: :CUSTOM_ID: private-muc-messages :END: **** Support for setting and displaying topic :PROPERTIES: :CUSTOM_ID: support-setting-displaying-topic :END: *** Global key bindings :PROPERTIES: :CUSTOM_ID: global-key-bindings :END: Global keymap under C-x C-j. *** Vcard viewer and editor :PROPERTIES: :CUSTOM_ID: vcard-viewer-editor :END: *** Roster export :PROPERTIES: :CUSTOM_ID: roster-export :END: *** Message events (JEP-0022) :PROPERTIES: :CUSTOM_ID: message-events-jep-0022 :END: *** Easy way to define external notifiers :PROPERTIES: :CUSTOM_ID: easy-way-to-define-external-notifiers :END: See define-jabber-alert. Alerts for Festival (speech synthesis), Sawfish, and xmessage added. *** Activity mode improved :PROPERTIES: :CUSTOM_ID: activity-mode-improved-1 :END: Can now display count in frame title. Update hook added. *** Roster display optimized :PROPERTIES: :CUSTOM_ID: roster-display-optimized :END: *** Optionally use per-contact history files :PROPERTIES: :CUSTOM_ID: optionally-use-per-contact-history-files :END: *** Jabber menu in menubar not enabled by default :PROPERTIES: :CUSTOM_ID: jabber-menu-menubar-not-enabled-by-default :END: Call jabber-menu to have it there. *** Flyspell in chat buffers :PROPERTIES: :CUSTOM_ID: flyspell-chat-buffers :END: Flyspell will only spell check what you're currently writing. *** Different time formats for instant and delayed messages :PROPERTIES: :CUSTOM_ID: different-time-formats-instant-delayed-messages :END: See `jabber-chat-time-format' and `jabber-chat-delayed-time-format'. You can see the complete timestamp in a tooltip by holding the mouse over the prompt. *** Chat buffers in inactive windows are scrolled :PROPERTIES: :CUSTOM_ID: chat-buffers-inactive-windows-are-scrolled :END: *** Roster is sorted by name also :PROPERTIES: :CUSTOM_ID: roster-is-sorted-by-name-also :END: * [0.6.1] :PROPERTIES: :CUSTOM_ID: v0.6.1 :END: ** Added :PROPERTIES: :CUSTOM_ID: v0.6.1-added :END: *** Message history :PROPERTIES: :CUSTOM_ID: message-history :END: Set jabber-history-enabled to t to activate it. *** Backlogs :PROPERTIES: :CUSTOM_ID: backlogs :END: If you have history enabled, the last few messages are inserted when you open a new chat buffer. *** Activity tracking on the mode line :PROPERTIES: :CUSTOM_ID: activity-tracking-on-mode-line :END: Activate it with M-x jabber-activity-mode. *** Receive an alert when a specific person goes online :PROPERTIES: :CUSTOM_ID: receive-alert-when-specific-person-goes-online :END: Use it with M-x jabber-watch-add. *** Support for /me in chats (xep-0245, except XHTML-IM) :PROPERTIES: :CUSTOM_ID: support-me-chats-xep-0245,-except-xhtml-im :END: As in "/me laughs" etc. *** Message alerts for current buffer can be disabled :PROPERTIES: :CUSTOM_ID: message-alerts-current-buffer-can-be-disabled :END: Set jabber-message-alert-same-buffer to nil to do that. *** Basic moderation support in MUC :PROPERTIES: :CUSTOM_ID: basic-moderation-support-muc :END: *** MUC alerts are separated from ordinary message alerts :PROPERTIES: :CUSTOM_ID: muc-alerts-are-separated-from-ordinary-message-alerts :END: Customize jabber-alert-muc-hooks to get your desired behaviour. emacs-jabber/DEV.org000066400000000000000000000163551476345337400145520ustar00rootroot00000000000000#+TITLE: jabber.el Developer Documentation * Description :PROPERTIES: :CUSTOM_ID: description :END: ** Debugging tips :PROPERTIES: :CUSTOM_ID: debugging-tips :END: Useful tips for debugging: - There is a buffer called ~*fsm-debug*~ that displays all transitions and errors during the event handling. - There is a =jabber-debug= customization group. - You can set the [[file:jabber.org::#debug-log-xml][jabber-debug-log-xml]] custom variable to ~t~ to enable the XML debug console. - The XML console is a buffer called ~*-jabber-console-ACCOUNT-*~ by default. Enable ~jabber-debug-log-xml~ and switch to that buffer to see the incoming and outgoing XML stanzas. See [[file:jabber.org::#xml-console-mode][xml-console-mode]]. ** fsm.el - the Finite State Machine library :PROPERTIES: :CUSTOM_ID: fsm :END: fsm.el implements functions to define multiple [[https://en.wikipedia.org/wiki/Finite-state_machine][finite state machines]] (FSM), their states, and all the events associated to each of them. The following is a list of the most important functions or macros defined in this library: - ~(define-state-machine name &key start sleep)~ - ~(define-state fsm-name state-name arglist &body body)~ - ~(define-enter-state fsm-name state-name arglist &body body)~ - ~(define-fsm name &key strat sleep states ...)~ - ~(fsm-send fsm event &optional callback)~ - ~(fsm-call fsm event)~ It is required a name and the starting state to define a new FSM. The ~define-state-machine~ creates a new function called ~start-NAME~. Its ~start~ argument is a function argument and body definition used by the created function. The result of the new function must be a list ~(STATE STATE-DATA [TIMEOUT])~ which is the starting state of the machine. See [[file:jabber.org::*jabber-connection][jabber-connection]] section for an example. Its ~:start~ parameter explicitly mentioned, and its value is a list with the arguments ( ~(username server resource ...)~ ), a docstring ( ~"Start a jabber connection."~ ) and the body of the ~start-jabber-connection~ function. The machine requires states. They are defined with the ~define-state~ function. ** The jabber-connection FSM :PROPERTIES: :CUSTOM_ID: jabber-connection-fsm :END: jabber.el use a finite state machine (FSM) to track the current Jabber connection step. It defines a FSM called [[file:jabber.org::#fsm-connection][jabber-connection]] (or ~jc~ when it is used as parameter in functions) and several states along with their sentinels. The Org-mode tag ~:fsm:~ is used at jabber.org headlines to describe FSM definitions. *** States :PROPERTIES: :CUSTOM_ID: states :END: The following graph shows the states and their transitions, as of commit [[https://codeberg.org/emacs-jabber/emacs-jabber/commit/dddcccb926f422b03d22a66b60db46f1266eb141][dddcccb926]] (2021-03-20). The nodes represent the states and the arrows are events. All states have filter and sentinel events that do not change the FSM state. Also, they have a ~:do-disconnect~ event that change the FSM to the ~nil~ state except for the ~connecting~ state. Some state changes depend on the event and the data received, in this case, the event name has a number added. For instance, ~:stream-start1~, ~:stream-start2~ and ~:stream-start3~ is the same event (~:stream-start~) but triggers different states changes depending on the data received. #+name: fig:states #+BEGIN_SRC graphviz-dot :file images/states-dot.png :exports results :tangle no digraph "jabber-connection" { nil; connecting -> connected [label=":connected"]; connecting -> nil [label=":connection-failed"]; connecting -> defer [label=":do-disconnect"]; connected -> "connected" [label=":filter, :sentinel, :stream-start1,"]; connected -> "register-account" [label=":stream-start2, :stanza1"]; connected -> "legacy-auth" [label=":stream-start3"]; connected -> "starttls" [label=":stanza2"]; connected -> "sasl-auth" [label=":stanza3"]; "register-account" -> "register-account" [label=":stanza"]; starttls -> connected [label=":stanza"]; "legacy-auth" -> "legacy-auth" [label=":stanza"]; "legacy-auth" -> "session-established" [label=":authontication-success"]; "legacy-auth" -> "nil" [label=":authentication-failure"]; "sasl-auth" -> "sasl-auth" [label=":stanza"]; "sasl-auth" -> "legacy-auth" [label=":use-legacy-auth-instead"]; "sasl-auth" -> bind [label=":authentication-success"]; "sasl-auth" -> nil [label=":authentication-failure"]; bind -> bind [label=":stream-start, :stanza1"]; bind -> nil [label=":stanza2, :bind-failure, :session-failure"]; bind -> "session-established" [label=":bind-success, :session-success"]; "session-established" -> "session-established" [label=":stanza; :roster-update, :timeout, :send-if-connected"]; } #+END_SRC #+caption: Implemented states in the Jabber FSM. #+RESULTS: fig:states [[file:images/states-dot.png]] ** Stanza processing :PROPERTIES: :CUSTOM_ID: stanza-processing :END: The following is a brief summary about the stanza processing. 1. The ~:session-established~ state is reached. 2. The FSM receives the event ~:stanza~ at the ~:session-established~ state. 3. If no error has been found, call ~jabber-process-input~. See [[file:jabber.org::*jabber-process-input][jabber-process-input]] section. 4. Select one of the following variables depending on the type of message received: ~jabber-iq-chain~, ~jabber-presence-chain~ and ~jabber-message-chain~. All of them contains a list of functions that process its type of message. 5. Call all of their functions with the jabber connection and XML data as parameters . 6. Continue in the same state. * How-to guides :PROPERTIES: :CUSTOM_ID: how-to-guides :END: ** How to contribute to jabber.el :PROPERTIES: :CUSTOM_ID: how-to-contribute :END: # TODO - add steps for developers on Windows 1. Fork the repository, then clone your fork. #+BEGIN_SRC shell :tangle no mkdir ~/git/ && cd ~/git/ git clone https://codeberg.org/YOUR-ACCOUNT/emacs-jabber #+END_SRC + You can also send patches to [[mailto:wgreenhouse@tilde.club][wgreenhouse@tilde.club]], using [[https://git-send-email.io/][git-send-email]]. In that case, you don't need to fork the repository or create an account. 2. Optionally, evaluate the following to install additional development tools (requires MELPA to be set up as package source) - #+BEGIN_SRC emacs-lisp :tangle no (mapcar #'package-install '(package-lint relint nameless)) #+END_SRC 3. Make your edits, then run =make dev= to run the byte compiler and linters. Try to address any warnings they emit. 4. Try to follow [[https://cbea.ms/git-commit/#seven-rules][the seven rules of a great Git commit message]] in your commits. 5. Update the documentation. 1. Add your name to the [[#contributors][list of contributors]]. 2. Document user-facing changes in [[file:CHANGELOG.org][CHANGELOG.org]] and . 3. Update the [[file:README.org][user-facing documentation]] (this file). + Try to follow the [[https://diataxis.fr/][Diataxis Framework]]. 4. Update the [[file:DEV.org][developer documentation]]. + Try to follow the [[https://diataxis.fr/][Diataxis Framework]]. 6. Push and create your PR. emacs-jabber/Makefile000066400000000000000000000017671476345337400150640ustar00rootroot00000000000000.phony: all autoload compile lint clean build: autoload compile dev: autoload compile lint autoload: emacs -q --batch --eval="(require 'package)" \ --eval="(package-generate-autoloads \"jabber\" \"lisp\")" compile: emacs -q -Q -L . -L lisp -L lisp/jabber-fallback-lib --batch \ --eval="(setq print-length nil load-prefer-newer t)" \ -f batch-byte-compile lisp/*.el lint-check-declare: for file in lisp/*.el ; do \ emacs -q -Q --batch --eval="(check-declare-file \"$$file\")" ; \ done lint-checkdoc: for file in lisp/*.el ; do \ emacs -q -Q --batch --eval="(checkdoc-file \"$$file\")" ; \ done lint-package-lint: emacs -Q --batch \ --eval='(package-initialize)' --eval="(require 'package-lint)" \ -f 'package-lint-batch-and-exit' $(wildcard lisp/*.el) lint-relint: emacs -Q --batch \ --eval='(package-initialize)' --eval="(require 'relint)" \ -f 'relint-batch' "lisp" lint: lint-check-declare lint-checkdoc lint-package-lint lint-relint clean-elc: -rm lisp/*.elc clean: clean-elc emacs-jabber/README.org000066400000000000000000000357321476345337400150710ustar00rootroot00000000000000#+TITLE: jabber.el - an XMPP client for Emacs #+DESCRIPTION: Documentation #+startup: inlineimages * Description :PROPERTIES: :CUSTOM_ID: explanation :END: jabber.el is an [[http://xmpp.org][XMPP]] client for Emacs. XMPP (also known as 'Jabber') is an IETF-standard federated instant messaging protocol. To try it out, see the [[#how-to-install][install instructions]]. ** Why XMPP? :PROPERTIES: :CUSTOM_ID: why-xmpp :END: XMPP is the only instant messaging protocol which simultaneously - 1. has most features you expect from modern chat - offline messages, multi-device support, file transfer, message correction, A/V calls, end-to-end encryption, etc. (Excludes IRC, Tox, Briar, etc.) 2. is federated, rather than centralized. (Excludes WhatsApp, Discord, Telegram, Signal, ...) 3. has highly efficient server implementations. A single XMPP server on a Raspberry Pi can serve thousands of users. (Excludes Matrix.) 4. has a rich ecosystem of FOSS clients and servers. (Excludes WhatsApp, Discord, Telegram, Signal, ...) 5. is an established IETF standard. (Excludes Matrix, Tox, Telegram, Signal, ...) 6. is governed and evolved by an open community of users and developers. 7. has outlasted all competition over 24 years. (Unless IRC counts.) ** Differences from [[https://github.com/legoscia/emacs-jabber][upstream]] :PROPERTIES: :CUSTOM_ID: upstream-differences :END: 1. More features - [[https://xmpp.org/extensions/xep-0363.html][XEP-0363: HTTP File Upload]], [[https://xmpp.org/extensions/xep-0280.html][XEP-0280: Message Carbons]] 2. Support for XEmacs and old Emacs versions has been dropped 3. The external dependency =hexrgb.el= has been replaced with =color.el= (which is part of Emacs) 4. The deprecated =cl= library has been replaced with =cl-lib= 5. Build system has been changed from Autotools to a =Makefile= 6. =lexical-binding= is used in all files 7. Lots of cleanup by addressing =checkdoc= and byte-compiler warnings - addition/improvement of docstrings, function/variable declarations, etc ** Community :PROPERTIES: :CUSTOM_ID: community :END: New resources + [[https://codeberg.org/emacs-jabber/emacs-jabber/][project page]] + chat: https://xmpp.link/#emacs@conference.conversations.im?join (general Emacs and jabber.el talk) + chat: https://xmpp.link/#jabber-el@conference.hmm.st?join (jabber.el developement) Old resources + [[http://sourceforge.net/projects/emacs-jabber][project page]] + [[http://emacs-jabber.sourceforge.net][home page]] + [[http://www.emacswiki.org/cgi-bin/wiki/JabberEl][wiki page]] + mailing list: * http://lists.sourceforge.net/lists/listinfo/emacs-jabber-general * http://dir.gmane.org/gmane.emacs.jabber.general + chat: jabber.el@conference.jabber.se and emacs@conference.jabber.ru (Russian, English) ** Requirements :PROPERTIES: :CUSTOM_ID: requirements :END: jabber.el requires GNU Emacs 27.1 or later. Two required libraries, =fsm.el= and =srv.el=, are present in [[file:lisp/jabber-fallback-lib/][lisp/jabber-fallback-lib/]]. ** Encrypted connections :PROPERTIES: :CUSTOM_ID: encrypted-connections :END: 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. ** Usage :PROPERTIES: :CUSTOM_ID: usage :END: 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 :PROPERTIES: :CUSTOM_ID: configuration :END: 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. By default, jabber.el logs all MUC presence announcements to the chat buffer. With the advent of mobile clients that frequently lose and regain network connectivity, the user left/joined messages can flood the chat. Customize =jabber-muc-decorate-presence-patterns= to hide or deemphasize presence announcements. See the manual for details [[info:jabber#Presence announcements][(info "(jabber) Presence announcements")]]. ** File transfer :PROPERTIES: :CUSTOM_ID: file-transfer :END: 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 :PROPERTIES: :CUSTOM_ID: xmpp-uris :END: 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". ** Design :PROPERTIES: :CUSTOM_ID: design :END: As a XMPP client, jabber.el is mostly just a face in the crowd, except that it uses buffers where GUI clients have windows. There is a roster buffer, and to chat with someone you open a chat buffer, and there are buffers for interaction with servers and services. Then again, jabber.el delivers excellent console performance and customizable hooks (if you have speech synthesizer software, hook it up to your presence alerts). ** Troubleshooting :PROPERTIES: :CUSTOM_ID: troubleshooting :END: Common connection issues When a connection fails, there is usually a message in the echo area describing the failure. If the echo area has already been cleared, check the ~*Messages*~ buffer. Here are some of the common connection failure modes: *** No response beyond "Connecting..." :PROPERTIES: :CUSTOM_ID: no-response-beyond-connecting :END: #+begin_example Connecting to :5222... #+end_example This is likely a DNS lookup failure. Check the XMPP server name in ~jabber-account-list~. *** STARTTLS negotiation failed :PROPERTIES: :CUSTOM_ID: starttls-negotiation failed :END: When attempting to connect to, for instance, example.com, one of the following messages: #+begin_example user@example.com: connection lost: ‘STARTTLS negotiation failed: GnuTLS error: #, nil’ #+end_example = or = #+begin_example gnutls.el: (err=[nil] Symbol has no numeric gnutls-code property) boot: ... #+end_example likely indicates the server example.com's SSL certificate has expired. To confirm this, =M-x set-variable RET gnutls-log-level RET 1 RET=, then try to connect again. Check the =*Messages*= buffer for messages of the form: #+begin_example gnutls.c: [1] (Emacs) verification: certificate has expired #+end_example or other verification failed messages. *** Connection lost :PROPERTIES: :CUSTOM_ID: connection-lost :END: A message of the form: #+begin_example user@example.com: connection lost: ‘connection broken by remote peer’ #+end_example may arise from connecting to the wrong port, for example attempting a =STARTTLS= connection to a direct =TLS= port (often 5223). *** Authentication failure :PROPERTIES: :CUSTOM_ID: authentication-failure :END: #+begin_example STARTTLS encryption required, but disabled/non-functional at our end #+end_example This likely means that the "gnutls" package is not available. Check #+begin_src emacs-lisp (gnutls-available-p) #+end_src if that returns ~nil~, consult #+begin_src emacs-lisp (info "(emacs-gnutls) Help For Users") #+end_src for more details and potential mitigation. ** Further reading :PROPERTIES: :CUSTOM_ID: further-reading :END: Documentation for developers is present in [[file:DEV.org][DEV.org]]. * How-to guides :PROPERTIES: :CUSTOM_ID: how-to-guides :END: See also - [[file:DEV.org::#how-to-guides][how-to guides in the developer documentation]]. ** How to install jabber.el :PROPERTIES: :CUSTOM_ID: how-to-install :END: *** from MELPA :PROPERTIES: :CUSTOM_ID: from-melpa :END: 1. Add the MELPA repositories to your Emacs - https://melpa.org/#/getting-started 2. Type =M-x package-install RET jabber RET= If all goes well, =jabber.el= commands like =jabber-connect= should now be available in the =M-x= menu. *** from source with package-vc :PROPERTIES: :CUSTOM_ID: install-package-vc :END: 1. Ensure you have =git=, =makeinfo= (part of the =texinfo= package), and Emacs 29.1 or newer. 2. Add the following lines to your =init.el= - #+begin_src emacs-lisp (unless (package-installed-p 'jabber) (require 'package-vc) (package-vc-install '(jabber :url "https://codeberg.org/emacs-jabber/emacs-jabber" :branch "production" :lisp-dir "lisp" :doc "README.org"))) #+end_src Alternatively, if you have already cloned the =jabber.el= repository, you can use the following snippet to install from that repository: #+begin_src emacs-lisp (unless (package-installed-p 'jabber) (require 'package-vc) (add-to-list 'package-vc-selected-packages '(jabber :url "https://codeberg.org/emacs-jabber/emacs-jabber" :branch "production" :lisp-dir "lisp" :doc "README.org")) ;; Change the path below to the location of your local jabber.el repository. (package-vc-install-from-checkout "~/.local/src/emacs-jabber" "jabber")) #+end_src In your =init.el=, type =M-x eval-buffer RET=. If all goes well, =jabber.el= commands like =jabber-connect= should now be available in the =M-x= menu. The documentation for =jabber.el= should also be installed. *** manually from source :PROPERTIES: :CUSTOM_ID: from-source :END: 1. Ensure you have =git=, and Emacs 27.1 or newer 2. Clone the repository by typing the following into a terminal - #+BEGIN_SRC shell git clone https://codeberg.org/emacs-jabber/emacs-jabber cd ~/emacs-jabber/ make #+END_SRC 3. Add the following lines to your =init.el= - #+BEGIN_SRC emacs-lisp (add-to-list 'load-path "~/emacs-jabber/lisp/") (load "~/emacs-jabber/lisp/jabber-autoloads") #+END_SRC ...and, while still in your =init.el=, type =M-x eval-buffer RET=. If all goes well, =jabber.el= commands like =jabber-connect= should now be available in the =M-x= menu. To install the Info documentation, copy =jabber.info= to =/usr/local/info= and run ="install-info /usr/local/info/jabber.info"=. ** How to register an account :PROPERTIES: :CUSTOM_ID: how-to-register :END: If you don't have an XMPP account, you need to register one. 1. Set up your own server, or use a public server. Curated lists of public servers may be found at https://compliance.conversations.im/old/ and https://providers.xmpp.net/. 2. If your server supports In-Band Registration, you can register from Emacs - 1. Press =C-u C-x C-j C-c=, or =C-u M-x jabber-connect=. 2. Enter your desired JID in the form =username@server.tld=. 3. Fill out and send the registration form. 3. If your server does not support In-Band Registration, register on the server website. ** How to chat with jabber.el :PROPERTIES: :CUSTOM_ID: how-to-chat :END: 1. Connect to your server by typing =C-x C-j C-c= (or =M-x jabber-connect=). Enter your JID and password. 2. Open a chat buffer in one of the following ways - + Place point on a contact in the roster buffer, and hit =RET=. + Press =C-x C-j C-j= (=M-x jabber-chat-with=) and enter a JID in the minibuffer. - This can also be used to join MUCs. 3. In the chat buffer, type your message and hit =RET= to send it. + To insert a newline in your message, press =C-j=. 4. If you wish to disconnect, type =M-x jabber-disconnect= or =C-x C-j C-d=. * To disconnect just one account, type =M-x jabber-disconnect-one= or =C-u C-x C-j C-d=. * Credits :PROPERTIES: :CUSTOM_ID: credits :END: ** Developers :PROPERTIES: :CUSTOM_ID: developers :END: + Tom Berger + Magnus Henoch + Kirill A. Korinskiy + Detlev Zundel - wmii support + Evgenii Terechkov ** Contributors :PROPERTIES: :CUSTOM_ID: contributors :END: + Georg Lehner - network transport functions + Anthony Chaumas-Pellet + Jérémy Compostella + Mathias Dahl - history logging - watch functionality + Mario Domenech Goulart - sawfish support - xmessage support + Nolan Eakins + Ami Fischman - Chat State Notifications + François Fleuret + David Hansen + Adam Sjøgren - notifications.el support + Rodrigo Lazo - notifications.el support - libnotify.el support + Justin Kirby + Carl Henrik Lunde - network transport functions - activity tracking + Olivier Ramonat + Andrey Slusar + Valery V. Vorotyntsev - GMail notifications + Milan Zamazal + Xavier Maillard + Vitaly Mayatskikh + Alexander Solovyov + Demyan Rogozhin - XML console mode + Michael Cardell Widerkrantz - tmux support + Case Duckworth (acdw) - [[https://codeberg.org/emacs-jabber/emacs-jabber/pulls/2][PR #2]] + Hugh Daschbach (hdasch) - MUC presence announcements - Enable XEP-0280 (message carbons) by default ** Maintainers :PROPERTIES: :CUSTOM_ID: maintainers :END: + wgreenhouse - 2021 resurrection + cngimenez - HTTP Upload support - documentation for FSM and its use in this project + contrapunctus - literate Org migration - Makefile (shoutout to tomasino of #team@irc.tilde.chat for the Makefile-debugging help) - migration back to traditional source files emacs-jabber/doap.xml000066400000000000000000000321511476345337400150600ustar00rootroot00000000000000 jabber.el jabber.el - an XMPP client for Emacs jabber.el - Μία XMPP εφαρμογή για το Emacs jabber.el is an XMPP client for Emacs. XMPP (also known as 'Jabber') is an IETF-standard federated instant messaging protocol. Η jabber.el είναι μία XMPP εφαρμογή για το Emacs. Το XMPP (γνωστό και ως 'Jabber') είναι ένα ομοσπονδιακό πρωτόκολλο άμεσων μηνυμάτων από τον IETF. 2023-09-09 Emacs Lisp Linux Windows Android macOS wgreenhouse cngimenez contrapunctus partial 2.13.1 Forms in incoming messages are not interpreted. See each specific protocol for whether forms are accepted in that context. Cancel messages are probably not consistently generated when they should be. This is partly a paradigm clash, as jabber.el doesn't use modal dialog boxes but buffers which can easily be buried. complete 0.3.1 complete 1.3.1 complete 2.0 NEXT complete 1.6.0 NEXT complete 1.4 0.7 complete 2.5.0 partial 2.13.1 Requesting affiliation lists is not implemented. complete 1.2 complete 1.2 partial 1.3.0 complete 1.2 complete 1.3 partial 1.6.0 0.8.0 Currently jabber.el cannot act as a server, not even on on Emacsen that support server sockets (GNU Emacs 22 and up). partial 1.5 Sending such URLs or doing anything with iq stanzas is not supported. complete 1.3.0 partial 2.4 URL redirections are not. complete 2.5 complete 1.1.1 Currently this is only used for file transfer. complete 1.1.4 partial 2.1 0.8 Currently only active/composing notifications are sent though all five notifications are handled on receipt. complete 1.0 complete 1.2 0.7.1 complete 1.4 complete 1.1 complete 1.2 jabber.el doesn't check service discovery results before sending a stream initiation request. partial 1.3.1 Hashes of received files are not checked. Ranged transfers and In-band bytestreams are not supported. complete 1.6.0 0.8.0 complete 1.0.1 complete 1.1 complete 1.1.0 0.7.1 The pixel size limits on avatars are not enforced. complete 2.0.1 complete 2.0 NEXT complete 2.0 partial 1.0 0.6.1 except XHTML-IM complete 1.0.1 NEXT complete 1.0 complete 1.1.0 0.8.0 0.9 NEXT 0.8 2009 emacs-jabber/emacs-jabber-uri-handler000077500000000000000000000001611476345337400200600ustar00rootroot00000000000000#!/bin/sh # Pass XMPP URIs to jabber.el. See `(jabber)XMPP URIs'. emacsclient -e "(jabber-handle-uri \"$1\")" emacs-jabber/gconf/000077500000000000000000000000001476345337400145055ustar00rootroot00000000000000emacs-jabber/gconf/Makefile.am000066400000000000000000000010401476345337400165340ustar00rootroot00000000000000schemadir = $(GCONF_SCHEMA_FILE_DIR) schema_DATA = emacs-jabber.schemas CLEANFILES = $(schema_DATA) EXTRA_DIST = emacs-jabber.schemas.in emacs-jabber.schemas: emacs-jabber.schemas.in Makefile sed -e "s|@""libexecdir@""|$(libexecdir)|" < $(srcdir)/emacs-jabber.schemas.in > emacs-jabber.schemas install-data-local: GCONF_CONFIG_SOURCE=$(GCONF_SCHEMA_CONFIG_SOURCE) $(GCONFTOOL) --makefile-install-rule $(schema_DATA) uninstall-local: GCONF_CONFIG_SOURCE=$(GCONF_SCHEMA_CONFIG_SOURCE) $(GCONFTOOL) --makefile-uninstall-rule $(schema_DATA) emacs-jabber/gconf/emacs-jabber.schemas.in000066400000000000000000000026671476345337400210050ustar00rootroot00000000000000 /schemas/desktop/gnome/url-handlers/xmpp/enabled /desktop/gnome/url-handlers/xmpp/enabled emacs-jabber bool true Whether the specified command should handle "xmpp" URLs True if the command specified in the "command" key should handle "xmpp" URLs. /schemas/desktop/gnome/url-handlers/xmpp/command /desktop/gnome/url-handlers/xmpp/command emacs-jabber string @libexecdir@/emacs-jabber-uri-handler "%s" The handler for "xmpp" URLs The command used to handle "xmpp" URLs, if enabled. /schemas/desktop/gnome/url-handlers/xmpp/needs_terminal /desktop/gnome/url-handlers/xmpp/needs_terminal emacs-jabber bool false Run the command in a terminal True if the command used to handle this type of URL should be run in a terminal. emacs-jabber/images/000077500000000000000000000000001476345337400146565ustar00rootroot00000000000000emacs-jabber/images/states-dot.png000066400000000000000000003771741476345337400174760ustar00rootroot00000000000000PNG  IHDR  {bKGD IDATxy\e6"l*"Bni9XYoNئ5i6eMej9i*&( lAU9~y= < 999uCB\~B""""""""""YODDDDDDDDDD?&""""""""""Y&""""""""""Y/Fcc#QUUZn3Æ SWnfDD'iZ!==8TJ_t P(nnn4hT຺fff2j𥥥(..Fqq1J%.^fTV6 ȑ#ajj*laAMDD_mm-q9sDCC#F2Xo}Fcذaѣ1zhbr'""""" j""]4 Ξ= 11NV-|}}1rH"00077;vT*,dff"%%999h40`@VDDDDDDtw`AMDDj8up;v @PPBBB`߸z*RRRǏ#)) %%%ѣ1eL2'N DDDDDDtXPQ+**ݻxTVVSLAdd$BCC }}}u#G ..022BHHLiӦaܸqP(rG%"""""5|b֭8z(LMM1aDEE!** ,6r>|qqqػw/ iӦa6m IDDDDDD j"">/^_[";;NNN3gΝɓ'w4l߾۷oGzz:1{l(  w<""""""XPQ(++|/՘1c-Z3g@x$ӧOcӦMP__ٳg㥗^¸qFDDDDDDbAMDDwk׮ŦM`ee%KѨijj??'ODtt4VXI&YODD7UVVb1bv܉w}.\rebbz'N}҂{HII;ɀ5uVŗ_~ ///ܹ9Ο?%KTxGDGG#>>3ϠJhDDDDDDԃuX^^~a$''cɒ%xaee%w,/B> ͓;u?nADDg7HII|rB… </_F#w4""""""f,Y1115k'w$VO`͚5rGظq#k_3f@MMܱq""_Xf ֯_%Kߙ>}:?}/_q9u̙3 ¾}`ii)w$""""""zYPM}7xW_;Ndaac"!!aaa''Nrss`B;u-AMDDO?^zt/qWm۶aϞ=ذaqp5k޼y8wRSSahhB 66;v@qq1 ãqEEE077GHH-Z@BB^}U1{7|{B__Xt)okYoߎ;wBTxaaaѩOpXXXɸo>vFlܸhiiQ>@JJ `̙x:żC+V~/ƦODDDDDD݆+/bǎxe)[ZZ0w\̛7Xd f͚#G`o:n/'Nj*j>|/Fuu5x _Y%R0{l}YL4 k֬?Je7aZ FFFmۆx@g?33f@II ~6?}t,Ď;P]]ݩud߼y3`…:cG //.r'ƍLcQy "^EEE066n#Fh3ٹ͸vCTv3,zzzX`AǗA"33_W* 066cǻ ??K3+++ j""j FFFPThnnns1Hfccch4\ q>>>_O144!T*T*t)v_ """""[|QHKKCEEE[P 22B ljj%KR:%K`̘1Ҟpmˏ"h4TVVb˖-+W^xilF_~ZKu;233)DDDDDDԷ)BDD=Q[[Ԡ 555:ZoFuu5jjjT*hAxGgANN|||PSSJc޼y7w%'A__YYYx駑JDDDGŢE0i$磨#<ҩk֬$%%駟ٳg Fb,]V۵k8q"6oތ:NsV~ K.ECCqe<3طoC_y]BDGGʕ+HNN_['"""""lfAMDԋT*\rEUUUIoo,[755u aff>8tl{%V!l|}}uREjjxwww :9noowwN=zα"011"77vvvTTT'nnnP%ƌK.sNox $$$ 88X DDDDDDmXPv[eeeۻ@lmmammS2ƦX: ٳ Add$mCCîP/p/s8q"v㹾 ,^1y??u/C#"v !peTTT/_˗uJJV2[YYN昝lmmoy{{cϞ=:u*e899gT*l߾6m¢Ec?؈_|GhZkXz5VZr.DԯiZ¹L*+**P^^rhs8{{v[vvv7ݪ7:{,Ν:l۶ !!!rG.Ro?q9XZZ>cYjkkpBoOعq"TUUATJkP:711+\\\`kk [[ۛ~oC=⥗^/ SSScQj(**R-t.v؁{?3&"""""&Jeee())Ayy9[W>WTT|86l؀'z j"lnbT*1ưϸmחqvСCXj>0XӧOtKiiixc 0/"}ىK&ιz* QRRbiˍ2\ pvv:mlld݉D^{ȑ#׿?0FZƯM6a׮]B>>>9r$z j"jkkQTTbZDWWWKMMM1p@aРApsspqq 333gE=ԩSOO?ARâE0eO⫯·~rL2>(q!-- >1cH7??? 4HQcAMԟTUU!??6磪JkbbņG ґԄX|8p1}t̟?SN#66[nѣGGyO>$<<}vvv9s0ydnrP8qvڅ_~9990`̙'O}kkk.)))8}4^  |uuu2dΝya„ Raݺ… BF׺uuPP""""""}XP&pB477СCZWC;88<?VYYx>>Ҟ֭[;::ʚcAMp9?ͭ777 :mhWWWgA p9r'Nٳgj1d 88~~~c؍3g 99ǏGzz:j5 c„ Eg_@BPȜ_`AMJ%Ν;6%t]]ksk-̋QWSS'NHJJɓ'Q^^pvvѣ1zh5 Fagg's꾣 yyyFFF222|h4aر?~]] iii8ut;>>RC aY@D]JPয়~Ÿ' jkkEHFFaii ???-B-Էj={HKK 邂!`jjSD:t(h",F8s N:T>}gΜAcc#1j( ((=z ]58}4ӥ[ff&ahh___5J*G"dǂ:SNIujj*`dd???iu`` FCCCc)h4y>ZFObAMwƋ1&&& 1bΞƍ0aAMRT:{s:u hjj1c`̘1󃋋ܱ:5u:11 8}4^Қ"sT*Μ9̙3PTرc(#G/D籠hpYNBCCCupp0&""""ނ5uZ_SRR 3FeMDw%$ 7MDDDDD jsB")) Ǐɓ'J ^^^,`AME{//\XPSHet+W7n˭7%~5f,Hf,nD:u Z...:#*,5#ZZZ`ee0>\DDDDDw&]555HHHѣG:`aa "$$Ǐqz=t7hiiAnnJd477 G^?~-ҿ;T*<<<(L6 rG%""&][\Һ ;vNi B!wd"""""<}ٳgw^èÐ!CBzɼ!Q/łkh4={V>y$T*lll0b„ ;21ԽFcǰk.ٰܹ@HHTJ:5Qz*N:SZgee\\\.AAA01191݀uoQ^^ݻw_޽{QWWѣGc̙AHHIDDĂgĉ8q`ر AHH&LAcA-Lڵ qqq8t (w};"!DjɑJcǎ̙3Ppssꐐp5QbAݓX(.. fΜ3g"::r$".Ă~kD>|000 #G;.݌uwknnƾ}uVܹ555ŬY &@OOODDMXP JHHHй (צr%""""[MMMؿRzxG0l0#QaAM7q5Q`AU/w؁zbx&wD"" Ν;xweND}qq?~G8p BCC1a" rǽkYYYXl233$9j5z)xxx`ݞ.@}QJJ ;Bhh(z-̟?4m7<#XhQ?'<==P(277Gdd$"##c>{;V I[rrrS:gUU[CӧOdĂ w1f+X`GDDԧ; .\ʼn'DGcc#,]|1<<&&&2pttٳgaaa!w>ȑ#;Ɍ-466b׮]gXYYa 4!+++DEE!** !ҤU_5^u`̘1*I&Qt3rG """kVѣGDss3^㏸x""rj 8X`lllw8::":: ,O>mxn:g[]z| : &&?:5˗K  ĺun%%%㏑SSSDGG'QW100@`` cϟѣGO>V7BCC &[=7nD||޷ovq-[&&& … ۼp}b8:: ,);23ٳ| }}}bҥ066gپ};v R kkkDDDoO?>Ccc#Μ9I&q}͈."H!DYYx뭷 G}$***FDD}O?:pBxbR ֭w_|"77q_yu9/ȑ#ŦMΝ;< ?\:g !DAA>|ׯW^FFFb֬YBVwj~??,E||8}m3--M '''GX|rq }}}1uԮ"uZ~rJ#aee%;#9"zGVZ%͛' c_+VXG all*J̙3Ge˖;v7  0Ggye/(ݷn:/VX!v-6o,"""HNNi;w͛7{W( wujn7fZpXzصkxWB>MGY /X'ÇNͯP 1j(CEDDDw}A}q cccagg'-[&222EDDwւ:==]( add$Jtdd ?󸒒ahh(N:3ѣ:v)s BdeeI j3'N(#G_~ >NɓxWd9BHkT*qqn:1g  -^uqAqUvVضmt ֮]3>99YhSP\RW9~%aff&DCC-tB1gΜ6 D|||uƪj'>ۚ[k_T2e ۝CGƿkx7uƦ B3Bsss&_uSSزej`رbƍmNB+.^(ݗ'v{ QWW'nwkkk1t6cG),#Fh3T.;sΜ@[RR‚yyyoO> >زe|1o\sqqDyyy#FhS4H.]j3@~/"##unׯs ~A=uTajj*~NUUUm2y\QTTԩݘB3"339td|kWJzzz;:?!XPBJ_|>STWWu#F|4hPǍ8v`z !!!{K>s{s[Ntfn7y[VTY`6/++VEff&;4?"""Ć sN899gO> Q?fnnиvﯭםZ!C){j;<<?W---BQ\7$>,p5/* *Jܬ󱁁R~o477o.!Dy+شi>S$''coƴi0̭+WBhwOGDDDt@"66ǏGTT W_+Wd9MDD 233qU1uT߿_զ-++CAA\]]ammrDDD`ҤI:{^@*4 &M… :uN!++ :dAM%j*߿W\xbTWWW_EPPq}GJJoP B %%E羖 !N8N< BqӿsJLL .]cccFjj*~6O<9{9{]2zZ 776߃kkkn:XYYux~t{ǰ}n.w]A؈O?Çܹs1l0"99 .ǣ>z ---ۨeˠVj/222234 K,AKK ֮]# MLLfW^۱f0k -:;'Ob:9^xTWW㥗^V`!p=^þ}PUU'N`ŊP(Xf `gg{HJJ^u:[h\zzzҿc“W^yݿXz5LLLl2\|Y:vZ'-st7wyGs!My[lƍes*W),YJxvv6,Y1cSmQTTFJlٲvvv=2'"""EdՉիW '''ajj*z)'w,"".& 022JRg̗_~)\\\NNN"88Xdddt\PPb˖-Ҙ~ADFF }}}aii)"##Err8uꔈB___DFF͛7wz|Z {{{,*{ׄ?ֹh4bŊH8:: 󤯯/lmmEddطo_羘Dwl0!:5\B={UUU0` rUߥKPXX!C3笭Evv60j(6>>>^|ϗ޻w/ `ff#** 011///ǥK澖ddd^^^FZZ\sm Q\\ 333OtyJrC Mٚ*䛍konHMMCСC:ީG9VTT"_̯MZlA}Ulذk׮ESS.]e˖OˆW&"ˮ/ۇ/cƌATTSSSQ ꖖ|Xjjkkh"X+WbAMDw+RD!!!YYY:uXX&NkkkQw j!mۆW_}/^ŋꫯQhDDD7ł>|XƍäI0ydL0+z}NHHeː|o*w,""?Ă:tF||<Ο?ccc`ɘSɂ5Q]] ""QQQ9s&IDDD\AG}غu+%"" j"ERaCRCZ]=uTXYY?Zbx׿}LLLDDDFRR###I AS[[CIuvv6&cǎ>NDDDD]{ z<ػw/6n܈ vשdcٲeP(JEDDQRR"mr\t NNN{1m4DGGIDDDDw+J%fϞ/_~ĉ4DDDRĠAjo:>.]ڃɈv#66v‘#G ___̚5 QQQ8q"IDDDWuOA}L6 СCDDDĉxӒZOOJ=TCC=8"++  ELL ̙!C/ĉ>}:]DDD,^݂Z__8p ɈK{Wݻ:[6m,--IDDDԛumAc֬YǶm`jjUOMDD'TUU---mǗ_~{QRHKKIMM>Ə/mB!wT"""ޤ 길8̞=fа+ϙ9s& Fs就)r>|XΘ8q"bbb;;;cɭk Ǐ#::s~ }}GDD'x衇pX`2&#""9h4$''c޽ػw/9s&f̘???S ꌌ DFF",, ?3WNQ{{{455Ie2&#"ޠ qqqؽ{7vލr <3f̙31yd'YA]PPPxyyasY`m&Emff $"6233k.رc022Bxx8p}KDDDD W"<<ZGUW#""vڅYf_|2""8tbccsN1115k&N###cu+_8$%%aذajiijkkN*s*""K4 ;]v!..)))077=܃Yfa֬Ypqq;&ѝo#22;y/ƍacc˗/@HDDԇ#..ؿ?ZZZ( ,, SYVV[bɒ%ݔ:_P;v 'NￏKvW0""^Iբhhh@}}=j5t!==VԩSh"033akk 333 -*JIZ{;t݃?c?u?4 *++QQQW܌imm sss888e'""\A}UcС:<QoVT*QXXrBUVVըACCEȟ IDAT=>`eeKKKwaM^a A6ʐ!@ʼnZYjV}U^uխuj*BUq*la({( p3>%&'>'!''h@SSS::w.]MBHCHH\???С>sL0y{!44O."($$$ !!o޼㫪BSS022annssst!½̙/",,:# B$''#&&111HJJBJJ RRR TVVګ@CCꢋTTTyyyCYY;v<񠬬,v\ RTTr(**Bqq1 PPP|dgg#++ YdcAWWׇuSSS@NNiBH+Wٳп=SLAΝ055OZZE^=c {.>}xeeeEwߜUWW"ߧeee|~^fff"++KTNHH@jj*B!`ee[[[888XBH{:00 ⋦F!ԙ@ @TTBBB!*HƊ`UWW!DE\]]]nl&C7;;HNN|>D BHHH@__&&&055EaccBڦW\Aii)z 777$$$:3g~۷o#00ԩakk+t222|(//GDDBCC3<{ O>>غu+=z777lٲFFF\G#BZO<3g"66BH$퍣GRRR5j&OQFC\G$uǏ鉳g"55pwwǬYuDB!pUv޾***8z(Ǝ\[4,[ Xx1֭[G{bB!u!Cs5g(B!mLFF9C!==#Gė_~1c@QQx BNBYYL>:!OL>ظq#Ν iiic(8x ֬Y===xxx'!Tݽ9BiCbbbݻӦM˗/iӦQqpbϞ=x)ѻwoqBHm۶ }􁖖°`*N@ZZ=BCC޽{cǎ\"BZZ PRRȑ#3!6 11f͂%q!`֭6cױcG̙3w1f7n:!:*++Ì3j*l޼:VghhX|9f͚rcB!-ZjoooAFF9BiŊh"ݻ8z(^x3fZP~pE<~***pqqAu4B!PTTÇ~~~XdISHHH`ҥ1bsBij\://jjj8s &NE.B!̍70w\a͘9s&}>.\pL6 yyyPUU2D555AGG***\&v  ŭ[`iiuV2dC!j$ǏǫWE0B!DYY.\#G`ĉؿ?:wu,B ڵ k׮E`aa2.~Z^^ҥ v KKKXZZ ZZZBpMܾ}\Gj>}cB K,[E(B!Dvv6&L0=z&L:n† 222\:u*p 0@t[~~>|>|>RSST|ϟ?GVV@MM 666pvvب3ܹPRR¥K[r%CBMM >בڍ#GockjjbͶ<`|׸xbc8~8K޽Xlt邩SƍbsNhkkcΝ1b6n<}F~jIIIˇ^[IIIlܸÇǣGЫW/#B!-BIII 022"!nǎ Źs8M͞={`ee3f4h1{lٳgߣN(++Hckk:|RFi1 >j׮]prr!CRozn\\\ЧO޽(BHQmu~~>@IIBirss믿bŊ;c t|>444`nnSظv)))ر#zٳgC]]5kֈsU?~ׯ_$ jn/iiiPRRB1k,(((ԫgΜ<\4XRR7ol9KJJp!ܾ}?Qj8iii>|8nnnkېܿ+v؁OBUUcƌI4ZZZu:_KW^^W~F}!44:taھ>/5^ϙ3]ӦMêUP^^ިB!{?^~MBڹ3׬-//gcǎelɒ%LJyzz2񘇇G.]:Č:{c,vmӧM61???zjؔ)SDo{+++cGfRRRlҥח߿iiinݺz/99ݾ}1+++vmvmvΝ3??1)))j*z올l<3n86x&9vpp0SPP`K.e1VPPO͛cƲ۷o;ݻ9..N^z;''`ӦM]<JtgϞ$%%nݺ1555{nV^ddd+ruڕۗ8p]z}WҲ^cQScՕihhk׮C1CCC&v䶴d#Gd'a_||Xz4k]$&&2֭[~lB!:]@}EqBH ʾf?uVѣ۵kXM6`LGG;vl!C0P_n})xlcuؑ9998N9E}v gSN1iijcX~w&++^zc222,--MR"n2l5k wwf؞={[BBBVPP?~Ꮏ1lڵbmO,Y¾[vo޼aյsGEE*JKK@CCC?ڗ*9F SmYǤJK-P߿ijj6,v;jꆼzk]4ɱ !Vz̙3~#BcĄ~^===zm111,%%E]FFFvU(/\ #;k`999c.P ̬ĄuTTPYURRdddӧco711Z(P1Ĥm vnݺ}u~ߋ 355ebmߝFFF[ZZ2 >@]ԷUfXǦH}K^aXNj>ϐYYYhhhTk:UeAAA_NNPm Uׯ_N}ϫ](y&VX@[[{ɓ'r Ћr14t룶H} .͛@QQŋGeeeMxv}՚:::kgaaѨcԐ>5\KUPPEE&9vbb"@OOm}locccHHHٳg%q ::߯KcQS)yN5޽{7w?UǎE?g/_.z ʕ+oͦ~T>Dqq1zYB!EyUj$BH|/pB٘1c=KPPe:t`k׮LOO?t@ `1Μc΢؊+ݾÇ=gښu1Pؠ2fbb´ɓn9===ر#spp`zzzllȐ!1gggm۶OxLRRxBvafnn}D6vX&##o1cl߾}ٙIJJ2EEĔ Vm~~~lŊɉ`ٙγn:&!!홒۷oXcǎ1322b^^^6'Ov~A8 nϖ-[ՙ1ӧcl՞? BBB3STTdٙyzz~tj{ zcos{mcSH}]N]]ɱ={2[[[6d֫W/ 08pdΌ1eeeÙsvvf*svvfh^ IDAT!!![cѧ3sttdDc|~9XcCTVVUV1z d***ٙ?9>ucYrenH!py 'OnBH{V^^<~=£GTUUakk [[[t+W3g6{d|X4#v򰰰[g9??O>ko``###ܹsGz555ԫu)))HII2!''IGLL¨9+** TTT JJJ ENN6335ocILL=+ݻwFNNcxtL>`Ϟ=Ç1`6K i Pmfff666PQQ?##044q?---"ONNF||}akk  mۆKi|{P>4Ȩ:埒<Ϟ=k׮b4f= >Z_ƽs}w2!77zzzË/ w5aaai푓Sm [[[(++טʧѧC!%% :t!ϩưb xxx ..N,i|%%%066̙3i&B!-' !z5ӧ(++*zGGG888F?dwލW6Zz iiiJfյcڵk8u|}}%K`…Z;ƍP<{E>8hIc9 ###ŏ?lmv܉u!>>7, !vȳigBڜ,ܹswE@@ׯx<֦MWWW7n\stAIIIϑCO> Xa$%%֍@O"((u***п8q&Lh*/^ӧOqe*6#wظ|N?6n܈I&}M$556m‚ 8M!fPBHUYYgϞxx<Я_? :Z?֭[q;@ڼǏcرBaa!rssjA__zzz(++Cnn.RRRPZZ UUUcǎѣ̽!֭­[j\4P( #B!--A!mIVV|||pܼyyyy0661b 4z]vaҥ8q"G3GUVVb۶mX~=QRR TVV~~`ABBrrr ())ENN]tvЌWBApp0e˖aƍ\iSVZ;v:!Ғ%$$ 47b011i/ZVVV3g,,,k.79IL8ni]WZZ իWHMM7 ^Bff&B~ Յ& ]]]t]t!++#@!-WϞ=q!̞=駟&l۶ [lcǨ8M!Ԁ Ԅ %&&ԩSBhh(TTT0j(,\#F@ǎ5ϰasZ 3fcǰqF۷Ys+==7oacc "&&7nχ$$$$DByF:999Dzz:EE파 |DEE555Ŋ:::ⵞS6e̙ǢEҥKԪmٲV޽{_sBi@M!ׯSN!((jjjpss iiiN)((`޽:u*-['''|ذa8F[PQQ7߈m@ܸqW\Ajj*$%%mѠRRRx!==]ߧO_EFFjjj5.)bll,*p+))5(;!4~dDGGm~V^^sĉػw/,Xu$B!Ţ5 !|2O\v 7nN ΋?`ݺux1cԨQR;={Xj͛99766w[lHIIA(SNi|Xaa!RRRT"-- |>HIIAFFX]EE]t ٺW"/amm tڕH˗/1}t#G:!Ғ&%''?ѣG!CǏou_|{쁿? 1w\̞=\G#.]pm!-- 077EΝ;}6nݺ{!-- MؓƓSm&322Dw;j_=fiӦ!..Ν u1˖-)oXXXpBi@M!-P(˗qA\v 9s&s|9< 47n:uu<@Bٳgqdeea3g&L2ܿ ݻwQ^^ccc :NNNą T'Oƴi```P}Z CŠAh{Dˈ? wgbʊ6sllB'O`ѢE ԩSFFF\T||<֮]ӧOcعs'E!&T&deeѣسg^~ɓ'c尴:ZyX>}`Ĉ9r$lmmL,55׮]õk\bɘ2eJ?œ{Ν;sBBB  aeeCbذapvv|#)--EZZZExmnk׮!FϟNJ+777,[ \jV!!!ضmΞ= ###lݺ&L:!QB[ZZlق#G@AAw}MMMq͛7qㆨ--- 8NNNׯ[í]JJ,ϟCpvv`jjݻwqmܼyϟ? aÆ֖`nZg`˗*bW/bћHS^^^ضm0d̞=ƍӆQii).^?7oބ--[777HIIqBi@M!%==[lÇ˗c֬YСZ={ׯ޽{>rssѩS'NNNٳ'lmmuVaaa  iiiI4?\>uuu 4Cň#߬ں7oހ#99HJJBRR(< a`` FFFҢ7ic~:8WBQQSNŔ)SЧOVree%߿OOO>}9r$;pBi @M!M-##[nšC+Wo,Z PpQ:((Ν;vvvuF[ٳgx%B!ѻwoc[Z#>>?JKK֯>|8m-RuIIIAEE@ZZ622jq1BHedd"""1c`̘14hX'u|||燬,XZZbƌpwwGΝH!%T&RRR{bӦMŋpB1HrrrD֪Kdd$$%%a``SSS044n.^3Ɛ$"::111KII @OOOokk6*))ݻw?ƍx9deeѯ_? 6 #F 1ۥ옘ڪԸ|1LLL BZ(\t .]£G !!;;;8;;}Y)z ?F@@zcbر033:&!VQBc gΜ\-t3(+++FGGpZZZՅ6бcGL4 jjjԄ[N@l%33HMMEJJ 4deeѭ[7fff077*=j|.reBSSÇ+Fjfu^-RHbb\Q[MMMѲ!UCCC RUwŝ;wacc[[[XXXQҐ8DDDٳg EFFx<,--1p@Q]CCIrB!D  !1=~?#=z3f`ƍFr $|ƍQa<աCQQ:u<塢fr !%%%V -++Cqq@4(((@~~>Q\\"++ o޼񠡡.]@OO}==V|}}Ƞ_~=z4ƏOkW`HKKuvbb"B!3߽e@_Thh(bbbD?`ll,zXSSjjjPPP@N )))sGaa!^~Ldgg#++ (--}|Bi@M!!??k׮]vw\"Ɂ8HJJׯ? X"yyy(..FQQ-2[~ ~]UС`oo%%%@AAܹ3Dsuuu|pUA^^1zh\$uTZZx$$$ ~]TTmJ___T622{=P>/^NLL ,*FF"D?k&*p>uall J!T&O磼v´iӸD:t `f ǣcǎ\@UVaٲe\i>|???\t QQQPSS1zh3\$5߽$%%Y5mhllݻe~!Bi@M! +,]'NZ-Dnn.k.DEEAFF<'Nhqo(OD||>())vRfffy#!B!uCjB"?0|l۶,ޭX[nx<ܿŮW_!,, T P(s!..3f зo_Zôb]:;;ݺuZVVB!bPB*<<_~%RRRp!L4H4h} VXIIIc PYY)v֮]uq.]#22fff\!K.ٳ>:t Ǐ"I WVV/_߽o?Wpmii D!BZ+*PBHm0aDFFɓ=z4בHܼy'NDqq1ǃ&ZźB&&&=z4uRG)))x".\@Ȉ3fLx%77qqqՊ/^@FF խV666!N!BZ2*PBHMBBB0n8\G"upQ̛7ƍرc.V>y$KS۱a|tԉ8233q%?7oބ,Ǝ/...:"irrrs/^[666mJ!BFjByӧ1k, <NבG0/`Æ Xl6m l۶ +Vǃ=zԪ1͛s|7o'N͛7WWWaȑ0it]:&&YYYtUT*`wB!T&w߿?/^[Ǣ["|Wz*9wwwΝ#GիG)n޼yuF|?gϞEPPttt0qDɩUBZ'>X ** ARRB!`hhݻfff0779ԸO!B*PBH[bʕزe -[uR3f py8;;Wk#pq|7$tϟ?G=p :8EFF̙3Dtt4 0e̘1"ͮ|>_luxx8BCCQXXPQQ\iFB!T&-[;v`Xp!בH222|2LMMd }}}xzzr4p={HHH]rc1$''#::QQQ}Zצ޽;,,,DSSSZoB!| !P(ķ~'NSL:k׮ap9(++sI;v CJJ 455CP(ݻwqi;wprr—_~ 777s|DGG#22R\Hxx8QYY )))tVVV077۽{wrB!p Ԅ1رc8nݺHD***q1@[[9s&̸GHTTT &&֑Fyy9$$$`hh(Z"VVV !BH5!}ڳg-Z#G`\!L4 >ĉ'0~x#50  :XJJ N:C!!!pww;TUUGH ŋ2HJJ[n`mm]挄B! !1k,l߾/:/_FϞ=ę={ǎ: i!B!߿'NP(+̙!Cl{UVV"))Il'O ::hXZZȈB! !틟Ǝcݺu\!q L<fffx"ĩݻwcHOO}0}t|Wirss'V EVVݻCBBB! !CAAzN:Ν;:@ ŋ~[ׯicĈťKBZJܾ}71yd_~\#$''ŋ ógXTVVBAAѣУGX[[CAA؄B! !mP(رc`pԂ6C'N`HKK:qH+3gѣ C_cΜ9PQQ:!ͮ111xhgϐ lYU-,,MSB!EjBH۷fl߾oF>}Cjf.]בZ"hii~üyCZСC򂴴4Ms֖hp1<{ aaa Ehh(*** z{{{XZZBJJB! !m?\\\pa|7\!q&Msss N4ܹs(Xq߾}x0gL6 ;v:!-F^^X]Lȋ/PZػ௺;IuD!: C)JN6e3/i 0a9 %V)UTBE:Gc[!~>>u_뾺~ߟ)v*%Ŏc1p1xSNpppq"G"!!h۶-wwcƍ9s&Fm۶AMMmG}tx!<ѣGhѢlllgAKKKx""={[l#GдiS7&MBǎŎXTQQa+W ::?2ڷo/W8^ !!Ɠ'O`dd{{{;珩CXp!n߾`0M\f5^3gĞ={;zBdd$ 8;;N8۷Ǐ JJJ0uToXt):VcSXX}}}l޼~q???|ǰÔ)S8\8w,--ŎY/•+WzjHRt-+++ƍzj䠼bb@knݺ+++lڴ ޵7n`ҤI3f >ZYڵkooo|r3f7ﾫmgffbȑz*vލaÆ+\xH$bPRR‘#Gdx߲e V\bP@@ Ç_ĄL&É'qF>}&&&2e >3TWEkq 8ڵƍŎRo}M8iii8q\aÆ[<;v,>|5cL, cQZ|9jVPPsɩ){¢J#~zv^ÇCEE/^Uo#66Νk_6 ӧOǏdv2U>{ZL"#11۷o_fB׮]ŎX'H`ee+++;@բիWǏCEE]tAaoo=zcǎPPP4,(((;Fы7g4iҤJ;TTTp/ѩS'c0@Q1Vݻ{⫯jgkC=wD˖-k}{,--Q'wŐ!CPZZ@4-[xKMM>_]vXr%ܹ5k˰F>}pAq+,Z;6l@hh(۷1112e ,-- 777,\ǎCffOZenn6mT{_EE KZiX}=cΎ; JUKKKqׇF)ꫯp)..ڵkuEFF7n&M+nڴ XZZbٲeXv-^  2򉉉8qs7o\nȚdx ɓk|MTTT`XjO~ᵾ}ZXDZk.#;;D?RDÇѣHKKT*3&LPe{a׮]Enn.ڷoO?ݺuyv'Oo'N@EE „ Ϟ= <G~kMSu?ƾ}^ꄄSLUb ;wD`` $ _M 9x`>7}d`zP5͌1`k׎f͚UƎK'ORÃiӦMtI_ؘtuueڲe O>BBB($$e/_N 4c :~8ܹvJ:::/,w- M 8~W:z(}l",E:tYy{[3sL$555sVUbb"}AZZZ4sLJII;cV^^ʕ+iOHII,--ۛvEqqq$Ď/^L#F;wmk׮%DBϧ'NЁٙTTT(22RSS)$$ԨSNٳg(33BBBёРAhѢEtqZr%L*))͙3hӦMd``@ڵ oRRRA?|@+,ǏOk֬cǎ 4#OOOZnИ1cmڴF6ћ<իW_ꔖRݩGTRRR"uuL;v,-_;F , 5j\nTJ'N;// >\;ijՊ$c{M@kTn޼Ir?C BiiiDDFo[ʕ+U^ #""-XmϚ5>sl!*KRRPPk׮ mO>ޟGGGѣGi夯OYM6H0c1N>ёTUU IR0`-Z=*|QZd2~AC,'Oy"޴iSrtt|6ZKR"P*-- ZdW^%>|@U;KU]*uV۷Oh/++#}}}~syZm}N۟/޳***hرdiiI***ܼy*{~#F@%%PVV#Fvz%=ϟ'bӦM}<f͚rl޼WGҸzR_5n޼,TTTceggWgWcO mOO63sL8q۷oG~j%CupI,^}|W,ccc 4~~~JUxxxƺu駟oٳ1~wb\ԤI8::Qh@xx8q%4k쵶[ wޅ">*?x2 ptt.bbbO?޽{ o{_@"T_EEE|yU[j>oj^W]Sjr~(..СCPJ-YsjXC&Jza @555j۶-ݽ{WE=JKJJ[n$HhΜ9tQa1=(JGUգGJUڳܜ7o^fd'\чKٳhذaJ۶m{ׄL&8ښo[E=8@dmmM;vӧOSHHm۶oeK2&r~М9s}E:D/~6mc;ɓIMM7oN˖-31vS\\/4f211v,^V\\Laaa4|200 uu*5A\d29sʼ,"_#FӧOhnnnbuqqMx>TUںu+UYh>U_ܹs EEEɵd2"EEE:zhdxf`5Μ9Sܺu߿Њ+a |...D!!!>*x]ii)׏Ԫ7TU:vlRnގJfffz^믿s… i\flbmf֭[:T{aa!ƍ)SLh?'kmڴڌŋBQQx7n… oܦLܹr?寜aXj>}#GR={ FFF@=^?̙3B[\\.]\ʂʡ-RRR@D8p;uꔰ|EE~7 􄵵5#HLL ZZZѣxw̚5 B[EE,Y/...o>/^;w`ҥƎׯw^˖-ၕ+W",,  RNNN7oޛk˷~>@u;,, +WDyyv5{{ݻwQQQ,BGG_|94iiӦ!++Kh~:M]BII &&&Axx\~~>_穿Gu^;TUU1i$>}Uַb Gnc={`ҥLLԣG%uuuy Ӷmۄ F!7I&c~yvXKKK@DnX7ڎL&#===@'ر#SϞ=‚TUUiU^HCCڷoODBť.]nݺ:Y[[SΝI[[.\(A@VVVdooO]t#Gҥ y{{W۷SBB6 ڻw/?BRŅ~Go?_ʫ^t{;I$Mr\ԛ۷ѿ=+'紵yѭ[HUUc"===:|+eta=WKT|رSE.X 43XwBoܺu ***h۶\L&ý{mmm@EEuddd 55U&6)))۷ ###!..=AYYIIIrڵ+-nffL>w'''ad033Chh(***NEEE߻w#GD||| tҥܹ555CSSu͛сv*Y޽wYf055ZeȀ实Dlm۶Õ+WMMM!J%nll ccf&M@ IDATTNnݠ߫ `ooǏqꘪ&ǀ Ξ=+׮6mT9թS'8CdYYYvU&ad:t ԌFc޼yFDDQs ͚5áC`ee%vwZEEdL6M80,ZgΜ#Ν c1jGhh(o\t O|RTXgϞ(&mllW1ր())>>>Ç5k@[[k׮3tttP\\,vtVO"77Qc.P3^]\\`̝;ƑduO>B||QUKкukxyy'N;c5H$XYY[(X߾}7oBSSvvv7o~`1XjX!J'vFgǎѣqʕNcmm mmm5Z=z@@@"##ahhwww8::̙3bGc!SSS; qml߾]tC0dgϞ3gcF ԌFC[[999bh4cĉ8q"Μ9-[=D"3Y׭[7=zA䄐1j)ƍ;v֭[HOO?郐 6 zzz¤I瀌1XjXs5ȑ# "v,}sxjNG@@.\555;c+WDdd$rssqIxxxʕ+򂾾>???ac5 \f5:::AEEQݻw{PWWGDDŎjwŎ[ puuիWŎ#0`P~>򂞞< c1Vq1hw;JTPPѣGc8q"`ll,v, ϋ gϞӧ ;;;xzzbGc1}}}ؿ?CV)X1c ԌFp 4`=d 렠 1{gq1h@WW7o;Jyf ZBLL (v$zjSPP~xlܸ~~~011y$c-Z޽;vK.+tttзo_|w CYYرcwc9Ď deea>}:KPX 9::HOO; cSRR77`˖-033êUPRR"v<ƘHZn1c`ǎHJJBJJ lقm_3tttk"::' f1 3͌1 … ;J1c@QQ;\\\ĎjI~~>ttt#Fz%++ WƆ ```ocƌcHRR`AOO={ [[[c2cAkT'Om2 !!!r,^Gtt4---XYY!,, 0uTabcLTXr%]^zO?E^.v4X=bjj ooo޽۷l24i+VZl OOOlݺ'f1f5*w܁1Ν;&M`سg233Q^^D"vDѤ`шŠ+#v$VKd2n޼HDFF" wEYY$ QVV#G`Сbeވ̙3q9|GXr%Ď*** !44%%%055ŀQccꊲ2<|***(--w@ooonCΝŎj˗ѿBQQJJJ1Xt-'d 3ӧc;cx .\ kkkX&M1@kݻCa޽+J?F:u*݋/=TUUŎjYq9TTTxawak׮a̘1~:VXӧ3wݓ'Oо}{ddd@&'H'`Νc ̙3 `֬YPQQ;c(//GLL0~ٳgADrW;;;l1;Akwjn݊ݻCYY;D]]֭R%%%Akkװl2,_VVV8qرclmm1w\>}ؿ?lmm WWWV•+W#cF ԌFE8rH!];w:u*̙ϣCbb"D,^VVjހ2|||)))bGc5"9r$~$%%Xnj*غu+߿/vdcV{XճgOl۶7~~~ŋٿ6nXL&Hky$&Lo۷ؑX=SPPvѣGdhҤ ÇbbG}'''@ǎENX׷o_DGG_~%zk׮1H$ܹsqiddd`ž} aŻw =y0LXYY 1zh|)1kxXyfL:dEnn.rrrPZZǏ z)**B* 5mh֬pSTʰl2,]~WX$ɐ|?͛71i$|O&r{mmm]KK PUU}O(̜9~--1X"00aaa())AΝK.UQVV.h+..FQQYwnU<455ȟU./Jscc@k4JKKDHKK_w‰gm҂T*Zj-[e˖hݺ5 affSSS(++z0f$%%aܬ@ZZRRR"33<L塰P ڦ MMM4k hѢѼys@__-Z@6m`ll 55:XC"ɰ}v̞=-Z-[пc1Ƙ'Oܹs8uN<$VD"L&ôiӰz[YY[nn. QPP\*m(,,DYYӼwuQQp5[=srrj󲼼<ʫnͭ=D]]*7===! ѲeK.h3jXVQQhիBQZZZ@[Ѿ}{hhhȭ޽{hժ[y&nݺ%ӯ_|())cǎ-ڵke˖!** K.Ō3RF %%/_FLL _x$%%&&&rEʛ ZhQ'Fjj\=99)))}ûe˖%:uݻSN|uc /Oeeel۶ ؑcLάYiӦ~d̙3jIIyAe' !##<JDKK U'֬Y3>)ꬬ,dff goW=|PP600mӦpڲeF3c^5c~dٳgq9!?? lllЭ[75$"Bbb"{dd$^z}-\p-33JJJ077PypEDsPOHH@||ƍAAEEE亂7oȑ#8z(QQQ+++}A޽+v/_FHHBBBpE :t('f'Xv-JJJPPPl_fU5c튌o 77G}www4o\xÇq1۷!!!ƨQ駟Vx^dd$:?ׯ_<<<0p@[q%:u ']]]]cذa4hP75cm@||<"""hĠ:t5ann ͛qh ={@{2 ǏǏ? XXXƍK_qAܹѰs(==~n۶-0x`A-KNNѣGq1={Ę1c$v<^ۣG0m4ϰn:hjj1H"::ϟGXX.\l]vd!XA||0ە+Wp TTT999|(ccu۶mÚ5k!C/\\\Ď֨={ׯG@@1{lL8_᧟~B`` qơgϞbc߱k.$$$ ޘ0a444Ďk9t&O T={kc!88OLSSS pttDNx,Vo"<<.\ŋqEiӦ޽;\\\{G|2p1VX`ݻ?>>>h׮D_۷oG6mtR9 bGkJKK~Ypuuń 0tPKsNٳ ds lڴ CNNz///9Z;c#"~~~w0i$7ZZZbGdcoܹs`ll ___.~So߆'RSSggg#Ŷmлwo#:v}šC`ffssshiiASS͚5`hhVZUV044aPPPݻѷo_#1L&C`` ~G5j|_ IDAT d2?{޽{!H0~xс.Xj۷o>S 2v킺ؑ <~ƍC@@vڅQF*//Ǵi/?ǺuдiSchΝ4i0L&CNN?~|ddd@& 7oFFFp3664LƑ#G7o+kdd2كe˖֭[߿? <{E999رc~'$''ݧ]]]BOOFFFhݺ5ЦMn[E{;@.)((qU|||0|^70i${ef1b͛aiiY+foرc>|8O5kp%+\x 0k,lڴ '(J^^^F{M]׶B }w܁T*E0qD;wf͚?3f?LCaʕ deeѣGs߿{!##Cx&:v fii 333>c=? J3{ ֭cRqqQlllԔ8@diiI7n|<)$$>@nݪ%%%B&L tZ[7{3.\ uuu8q"d24=zYd2M06mJfy O>(_GuQHHM:_%Jrtt$}}}ŋyf$}}}@4f D\zڵkG(v(%%455Ȉ6l@diiIJJJw^#[wܡÇz)..NHIMMaÆѱcĎ!LF臨mے-]ʪ,W\\LB[n3fmۖJ4p@(88 ExF5@͛G...T^^^$HΝ;o9YUN"? mt޽WZ󞓏OF,YzdjjJ z$$$ m߾^leԋ5ѿڷoOO<;N;v,QllQT]?[N5ѿemRVVkC&QLL dooO}bŊ^˼=VӨQHAAΝ+rm{iڴibǨ>z_N(>>^=##IOO***FСCMtIȑ#&NZ>hŊN={?._L7n>ڴiCHIIK?{ECdȔ d #PܫVu:>:ZmmZ֢h-jFE@/K h@PC9}n;9O.Ϗp8uQT7ޏݻvC Fjj* ͑ z1@OOY/m=Mxܹ%%%8z($%%KUU"""W}`믿 |_8y$;sssqkٳ~ءX%$$0l0| &`޽0447ZZZ:5wi?Cu=?8~8<<}Tau($&&;0`߿?P\\ 3H퍙3gbوǸqM28x`^O=KO}?deeyfšHHH>|8V^ӧO#77O}RaeeE-LMMaÆ>ztuuϟ?ٳgѿ|'4h|||&(J/LLL/ѧObԩ9rd$$$0tP,^ڞ0)֯_̜*jbccqIބT= СC000x$P][O~~>`ƍسg ((ҨwZZZ2e $bo3(ܹs8<`hh+W U=|}}Eui=Cpp0={uuu7f͂,.OCf#~WuJݻ5k0@RR;v,o<>ZXXqMm/7| vd7 o0sLL>nnnJ~oFBBTTT0yd̞=)c,]544pb:5'~-6o#'1 ř3gYYY899?:GA]]ݻ777/;Z ::_}k׮ĉ Aii)!|2@ŋqBII ...Xd lj'p=cȐ!Xx1lll2}M됖',Y&:tᐗǤI0nFoӦyp7:lٲn.,, _~%~G[N09'GEE0i$̘1CXZPPC!99222pqq~I&1wmݺ|::8)Llr,/P^^]]]`޼yׯ[+--:ƌyAZZ~z.\?pQ>}ps6ɛ;)((3f &Odux}}i0m4cϞ=XlN:}}II ;xf͂;sL0a222|[p!? ((YYY,YҥK;͛ggg:t999Ŋ+`kk˔?w~v;v,l"R @pcP?xzz2{!dڴiߟ\t^HHH?XԩSə3gM<<<&;!Dp¤3f+V+W#GO:Tg׮]DBBL>?:u >ۗ>ބT &aaa$,,q.yu=?kKK %JJJԔ8q/HII+VWاlKdܹĉdȑd„ t Ą["_~!7o$;'Lod:)))w 矓k׮ǏKKK7>GHXX۷/144$#G$+qY`:t&Ơ]i͚5̬[.DCCڵ}6!f"/^$W\akd e61xȴ02{lMGԭmQSSHJJ"HJJJչl2bj}+~Wu"ZZ}{ǻ%Tc޽{E:u&###ag  Ç$%%HHHiiiRXXHm?= ,%ΎYHlmm^{q@QcFTT$|owrD]] ΝcDCCCG}''v2e@Bmoll$۶m#ȷ~|BB' FETUUü=,kii!zzz9}4++vZgmZ!ȑ#‚u9什wԓ{9+@^?| 7kkk@`"Çy]̫u3.̶h(BCw-/(( RRRL~@ro+woHP&œ;n=նmۈvL:\PP@tuu @3eN>Mt&o֭[mgkkc$!ۛoybb"@ QQQ/e'ׯ{ŋp TIO<?쯿6o߱cvWn|eX,-Z.-1&Lf”j,rrr4i>}z"l:+˔)S<^-}ALL 0f@DDj(1_-ÛbȐ!]^2,AxxHYr%uڶ4h>I0RxiNNN222b&jJrرcd%;viЕ~Qzlq1+3Jv6OOO 44HOOGFFt~#=}}}!c郁e˖aر8t[@u>gggš_~pppK~ }++z:eۥs%K=omm ###\|^s# zxxo3gX||/>iiiHJJ2ぶ^zߦ;vM@Yۨms!)))|'Xj|}}{N]s}xx%%%XEk< u%c^"[c2w\[bdggw]sw;622B}}=JKK!p>3g`׮]0441uTL8Q #G >>ϟ?gAOS̅ e,X_u@^"OȻ]ľ\UUs|eKhѢ6'ho.l:+K[f?͛aÆaڵǏ'ҡXѶ;oKCCCc:'0F`` K.aժUo-ԏprrBrr2 L: 111oL޷A.\, KUUuuuHII᫯֭[ ;vmvi 꾟7!˫Չzϟ3=;[UU0hРv˼+2L4 z*=J4222?aoo5k8u:;_qqq~:8oϟy6l6ddd҂۷;Y$իqaL>̓$$$p9>|?}m7AYۨ: ;dz 33? xUָ\kjkk IQb<懥D9_y< s xHKK.p hkk3̚5 f“'OxyyaرvP 888fLMMf&M\\.\''';vL,1PON_|||٩_W5J;W-8 Ν;f¶^?۷6]ȑ#r8u/^  3MD$J\\zڻ^C FRRR5w\/'NԩSLWpssCvv6n߾L6 ?#_GOcU %%ܖ>ܽ{ꫯpMHHH`СSSS|I(]a)*Q|y'Q|n:ۮ]зo_yDt~&̜9ts*r8.e˖!88qqqptt!mdҤI(** {n$$$Neiii֢EpEꑐ#p.ZYY ooo(**qy̚5 FbY[gljޓ#Gۻ ;\ w(bmm %%%<...߭Hbrrri IDATHMMS/%%E:;8)JoCc 5OCCƍ\.55U 3B[[D?UG#F`~TL/_عsg/{/\W^ė/yuۆcʔ)ӧO ۷o3θ*??'O.^ĒKvK 絟 .`ĉ eZ 8p<͛x'$q-OXZZ 5FrgO1x`ڵ 2,]ZB/ZO.74rwɷ^]]]?3_B|Q#++ѣG߿ٳg>CoWfnsbccAb!)) ϟ?g^۷ow('m]򺺋lllpnصk3)BzzzLQ®STڵk`Ց8ݸqeee]2SO?ﾃ2Gaʕ̏{ʕ+Ǐ k.z;...֥ܹ3f@^^,::{Ass3,55cސ!CgΜ野}ի[}!V^ KKKlHJJeee|H*++q…4t66=ķ~Hܸq -[;w.֯_ q#2YYY|֭[>/^t۷/6l؀rlڴ[VV]v }YIQb eee{nTTT0C/<߼y3߿/rXz5o>lPWW͛7͚fLՑ#q ٳge'OX(:|6m.]UVx2e <Ȕχ7 ͆6ynܸ=7<]/jxyy׮] ^SS$ѻ2=괉L3f ի)S)))bjjJ,--پ}{̈"|)..fʍ3‚oݺu‚ d*O˙MF #dܹC$ "ĄbRUUE8_3gҖbp8L%%%dر8p qtt$FFFdŊ0`p8m)--p8C{{{ϋ(=99XXX6M FL&NH6l@kkk2o޼vJu=???fӧO75552h H􈊊 پ};r|emFX,!JJJСCs>>>DMM;;;beeEFMFAWWW믿p8"))I!֭k37oLA8#"6Mq?4ȨQ<%DFFZp[DBȄ bffFɲeg}F;;;rJf c[grdĈS๢"}vm6[__Okb͛rrr2 ҤBDt~/..$&&C$p8ϏD^^p8f@O}}=?>a]^p\Fs1>LLLL:qpp DFF̟?_0 ˓!C---2gB!< Ņp86{.!rrrʊXXXeeem6Vll,155%dСޞ 6̚5 Æ #˖-k?+++vJJ p8DIIX,pk]glmS{u%$$ }2p@bȸqHjjkݛ<}1cƐzqLJUUUbooO 9s _e"--MՉ-144$AAADRRx!^کIace[}D9DKK{{{AۑrvvvDII 8P!/eeeLN,,,ȭ[F8E>w ݻGɂ Hrr2?>$k׮:?Lttt"?t@͙edDNNXXXL w,%F2fҧObkkKHLL !1xݺuDFFbbbB/_N剢"p8dÆ ֖ zzzfC\\\J8IKK#K,!9"#AgΜ9sx0E !ƍKP`ѢE Ǐ߫%[9ûmGxks(**Bnn.aff&\\\Ƀ^Ϊ*;r 3\(1/{ucBff&4ASSG*++CbС fϞܡcI9":8)Lnz,rHOOGyy9tuu۝QrPSSQ#b6lE:whכqԩS溡3gę3g^WCC+W@BB+W.k L؈l8p`!̽SYYL466Ctt4ӳr82ylmmډ噻/'I~4AMQH^ɓ'#((z 0uTq%222`gg+W~w8Ts]g}h޽dNuGA^^f̘~'9Ea„ 8u3EQ]©S,:]hh( ѣ?`ƍb͸\.كm۶AAALbgȑy:RRRPDFF#GĜ9s0E޽i)I&aڴiXhbbblck`5k{###>|}444~zqD4i<== SSSfwqRTT$!<<.]B||.**͛%K9B7~:VX|B[@aa!GBBP]] 5555vP(EnnnBtttrLub8;;CFF>kbÆ T///hkk {޽{zhkkcĉ>}:۽՘z,L4 r lmmE*PTT5k`֭PPPwXo-??_51x`X,cذa8v"Ջܽ{1RSS!!!Ƽ, k'++aÆgE(EuӧOEEE/// &&W닏?3gđ#GzEbG;{nBbzʴwӧO :VVVpvv3Gza̙燉';$Up޽rrrX|9/_ΌLQTa֭*1ڢE`ff###`РAh)W j:.''^^^(..ƥK0bqDƝ;w0}t# ེ}TXnG})));$?+Wċ/:1oHz555aŊE;$u??@yy9f̘kAܡQ;عs'䎯3&999򺉢GLL lmm;,\.;ޫ3f RRR`ccwww|NXRfoX|9$%%1k, 2bCII&^AJJ ǎî]dرC!QT]v!//GEzz:aee~z$.HZ zzzXt)9s/wɱٯH(|4AMQ[QTT˗yflذ=wXWWWl޼[lKދ ߆.^\|C ?qFu7o ֭… 3g ##Ϟ=-ZLh())E !m6mڄCoڵk%222裏hc޽044ߏ|qIQbE;wgap8ڵk#G6f͚G"??8v>fIII;={&fQTC($''cHOO_| 6@QQQaJ~Æ wX=F]]pm'|7B^^^!RD7w^cڴi^AXXBBBb&Y ̞=;@Q=ŋ1oǏnR555!$$t*++aggcbرptt|cPzו"$$AAA ē'O`bbٳgcΜ9033yGXXSe˖uv(GǠ(s555buV|BFO$p[nڵk{Jss3߿X"..GSS塢zx, Xb֮] MMMqO O7|P ,, vªU:9jz7aԩ>|8.^ġnµkl(**ƍØ1cd{/X=ƍSҲSFDDtuuѩ(JMPS5IYTQQǏ%%%Xf 6oތ~;nWXXDGG#>> %%b% [[[`޽(**¨Ql2L2C=x'O0uTlܸvvvVEUU:m'k׮A]]]!Q,#88AAAlmm ''' >222^ /s>rhjjb̘1򂇇*EQ&)Z8x =F|GOann. ï ___`ٲeXv-Z(,,D||}[__g͛>ÇZK􆢨#7 RԻwEtt4n߾;wrrrF+++]Ī HLL۷qm<|\.FFFpttȑ# qKQTנ jGuu5?ǰ… 1o<_Spi} &!!!tzGB;w &&wAZZ!PVV󰴴stHNNFRR}􁭭-F '''8::һu( j!QQQŹsPSSwwwxyyˋhGNNP&9ɹJNMMhii G~~>fadd$0`N+)) /_ƕ+WEEE=F¨Q0t"f[n!;;ZZZÇ PSSQ ƽzh(񩫫˗qyÆ äI6_ jkkq]իw1~x̘1'O~osw3:>>iiir҂455rSšppplmmڭc! nBDDˡ777p8Ғ>Rff&bcc0fޞBQ=GEE&L,ܺu N܌4$%%޽{HKKCZZ 0FFF011a``}}n>߳gϐ\dee!==>DFF0221`ii +++:$EQ jzFDDD ׮]CVV1|pp8***KCTT"##F 4&M\]]$3V%%%Abb")ut$%%!,, aaaFee%ddd`ii ;;; >011ՓB"..(--͆5#v`ɸwnݺKKKqDQTijjBff&Ґ$#?~b:}}}38p 444~F<{ Cnn.rrrtvv6c~h&)MPS3!""DFF@__ְ 0`|.< G!##?FCC`РA|vhhhtk/2HIIaȐ!pvvQPP۷o#,, ۷/zH+++ImKnlll(((0= 0p@hjj2cuuuJ<}/^/PPP'O0(**b8IƛbС033[AQTgihhٳ7nQ!QՃTUU!??O>Eaa!PPP omm-$UUU"Я_?(((0yy<(//Gee%QUU*/^@IIIASS:::MEu5(UVVLGѣGDee%SNZZZZZPWWG~ %%%JJJs3~~~↢(/͛7'''qDQ{&$nØILKk.IJJ9+ǻ=K4WVVn(a4AMQEj$%%~!!bzF Att4bbb7~ܠ.Q,<<ǏÇ;zf̞= C((z6(ꭚ4p\d#,&}-dggfҒގGw^|ӧOGLL BCCamm-((˯wIQ˴ --gt\\ xxx`ӦMСC/DXX gϞ 899y+#;w.JKKzj?wHE8{,<==1~xTaQEQEQ=AMQMbZ&ܺw)X,DDD ::PQQ3\]]^;!նСCz*Ǝ+p(!jjj0~x 22((yEQ:^2sJJJfaddė4pDEE Á+\]]1tPX,1ɸ\.,Xk׮!88ÇwHEpwwGEE"##-((&)%刋Ctt4gϞARR|h;;;2m=dGpp0QVVuuu1?bl%.jjjMǜ(ϋ/fDFF((9h(Brr2_TY`bB.2 鐐҄4eTDDDD!QC C~EQEQ35EQTOԄgt|||8,X;;;CJJliiARRBCC lڴ cǎR7ގ"""ѣG֭[PSSwXEsEnn.֯_]]]̜9S!QEQEQbBEQBBrr2߸ѩLba899rrrB;55nbƑ€ၿ GFiե0wXE6mBaa!.\MMM8;;;$((J EQhjjBFFbbbrd4(rк: 88.]Bzz:xxxֶZGQf#44NHQb֬Y ATT,,,EQEQս$En---HKK(**‚IFCdggvQ__kkkxzzbĉ>|8$%%;uճ, wHEuuu@aa!ܹCﲠ((]hޥIDۨE߾}aee; wիWx^^^􄮮n'z"=--- C(())aJ C((MPSjݻwQ\\ 6 ###d=ߪgϞڵkqPYY L8&L[AQO--- E_ɓ'ĉޝ՘ҦҢ&N*bI"13acg6ca6>>'*Ѿ*)JhSuCKуsu}x\?q!BȇAjBӧHHH &}􁳳3WVPPhAPPN:gBZZ}0l0XXX4yܹs,!p9 2ׯǼyC!BAiBm`[n1mb_@ wСCNN OOOk׮IQǎ#F'O ߱!<իh"t^^^|G"B!͌fPBZj -Jʊ;6Krŋ 9 2 yG/pI߿#F;!g1|8{,nܸSSS#B!CK|BZ\qcbbP^^%%%4&{.~w^^^0ai=iBHMM +ڵ ۶mÔ)SDً/RDDD@EEHB!yQPP ѣѧOBRReuVZ#G@__~~~Ϡ2VHIIa066ƴiPXXoXٳ'&L B! !DII  ]m*++7oNB_|p㡭WDB!Bndff" C>}о}{XYYaو3o$%%.\ڢ?@RR[n;J ???DEE!&&8>3gEe!ѣ1Z޽wIWW~~~@HH&VVV Aaa{aL0MuPRRLLLOrm۶ ***8q"M!BPF8uW`СLLL0e\xݺuۑb?/uw|b׮]_y]N -- صkWLMMb~[Vq64]]]\v 8p }j۷;:uw6apwwGMMqiiiԴIãGƼ>4YYYȨmJJJ ˗eB!2#** ͛7/!гgOI^vvv?~<9JKK>}CeAllY%e!MK^^탑fϞw_~ /3x/^4P7`ɒ%>|8-gC!5!mPii)ߺ̙3ѧOڵ;rJKKqHHHңG#pZR" YݻwǤICGGh4:C|h/_Gb޼yܾ B!u5!*ܾ}044ѣG@ 455޽gpa1[[[L>\E!::_`;vp0aʕ^~@֯__/CQQ֯_cذa3fLvϞ=Þ={p@GG9r$$%_k֬ykߍemlCr 88ԩ7]UUUqn,ԄƏYYwqE1gK.AJJ 8p w|BKa׮]HOOGEElll z@CZZ6666mZ̠#Gѣ(,,!&O۷osa߾}^n o>DDD 77:::AAA&&&OлwoL2wھ7g$&&TTTpĉ(}L6ѿ M6ں^g" O>-Z~olㅅ5(yz{]]sEEE011̙3:Frrrظq#<==qiq!B!{͡CX !@uu5KJJblܹٙ3LYY9;;s2w鱥Kֻ3fJO?$$$؂ ؙ3g؞={ SWWg\8m6-Y;6rHxBB?g,88 RQQaݺuc^^^l׮]ɓlر ۶mP۬,fjj:t6lN:Ŗ,YdeeСCYuu5ct=jԨz}72egg3sss֯_ς؎;9SPP`ok2˩Sؚ5k"eO|8;t;~8={6`'Of>cʕ+bbbԩSY߾}Yhh[A\>O>jE?~?g̘N<ɶm444XΝYyy[WUU`6k, [2uuzr z^^G^_swˋ`ׯ_X7 L!BZT&{;y$[b0`STTd \1:))Eb{Y`,77;h"6uTL]] :Txddd"#c/ U***LBBpǪ jk׮ ߰aF~9SRR׷Y_/ 1\΃ e58%<<\ɓ'6|z}:> eزe˄GGGWkGq׎$ιjLNNۗ=|hHݛg:>dbfE+PO6IJJ+ :X 0`PgϞ1===^xh } y{{ -//gLRRegg cXtt4w,88`^^^rWLJ1 III)Ԧ7:bLmǍ't|ڵ ;}tj?u/5ys3o={ƴ-P߽{ɱ-[ !Bis !-Çq)aС҂F:::Xf ]2DEE?/u&q|Ν;]]]t޽mHKK۷ֺ9s&VZ%VMM !!!͞:w,L4իWaffVocAB}LB",, tzmС'PPP t(s1 }@EEjjj8t¸vvvr{Kc*N;QQϩ9}ڴiGvv6lllpwuq~wCQQw|ƍ8q"ݻ&Mv>䖰^׉Bm1dȐz}+(( ,, B\ywիWLMM1tP;w[r?\4jN^^^Bw'}<׮]/5q#qM\v0tFsu3gʕ+QZZ*B!֠&z)61LIIO>Xd xNzEDDO>o̬1===￸t3@RR>}HII5kn--zdeeQYY}((({Zz[JJJyǴ.ŋ:={\Mkɓ'{feXZZ]vt{BGGNNNj'===5x-Ν;b5kVZP0#ε#긊NkGsTUUqQlڴ =Μ9So"c"##Kbɒ%HII˗/c=q7Mgggwv4r!?ݻwܹsiiiܹsSNWWW駟L?^ݛB\>l8ב8kBlX`6l؀ pY !BHB'F\\v؁SGh׮zj|8~7 :xzjjj'OOMMmYv555bc IDATݻ"gckk ťޒW^Źs޹8.Y젬dnFt xzz… bdIIIW8{ۤE;w`ܸq^U ;wb޽{\;ĹvD='q]HHH`ܹFmm-lmmq~#U<&K.ٳg!!!nݺa~g.W߾}rrr+We+q+FEE'>>ޱ[{ŤI0`783n7ݶ{n|gB,XJlܸ֭W_}999Y\?Goذ+V)ۇ&5Ĺ]sIII"9sPUUUov7!Bi=@MH3zbѢEuܰk.$%%!??AAAXr%ѱcG?~l^0afΜC~~>6-- 000&Ξ=bg6x;w4ׯ#22b<~g`ɒ%n;v~7. w*//5k֠9͂IIIprr{7… ,/^ٳQUUu52:t%|^]nDkGq׎$ι \~+V7|>DbȐ!|q{{{cgΜA\\\>zj^QPP}}}nW_}SSS^Z(gQQLw~Dg͚MMMlذA8xȑ uխ= ,nk;k,?Dll,w<99}1cЩS'_pfΜ)9 1}{1=D8בEC܉'~1:u*~w%N!BH+b &4"??>}Xyyy1 0;;;6c DV]]w\cXjjj3 &++rsswfL^^۳=z3GGGk1XϞ=5p444q~LRR1i&ccnnnLJJoߞ(X화ssscʫ:t322bڼkoʺiӦz>}LGG3XRR;sSdg***аIuO>e~-`ƬW^L__+VZ^;8DvD='qϽ)2@ʕ+YEEH?7rH͞=[xyy9b%bӦMcg=9s&cϳ}2%%%&...,!!A\6|p&##úv홲27n+**zkT [㙵5fݻwglܸqlҥ 2АՋu҅͘1`͍=1؃aƆ+V4x^+N51e fll̴X׮]%{ c1fbb0kkkq7of 4h󗖖2777~FNs :w ¾ڲ70YYYk׮FB!cŸ}=|0Ǝۤ%cкѷnc[7O>pvv"iY.^4lCVVB+**bC__III)//Gzz:jjj`mm \v{B򐝝Ν;s3)fm<Cjj*Ν; {zΝz* mV[[4SN n%8oBhhhK.B g|R[[BMM FFFG_'#ʸӮkGsܛBMM 6l؀˗7onHLL-dddݞBGG>@YYYhFpii)233Q]] }}7~bx9#ې1TTT=RDGG λ]`ddmmm̛77nDJJ ,,,!++ DUUВ ...B"== 055}㿏999000@rrryL+++ IIItڕېիBkY=qqqB`j C^޹Q7׫D4zzzhRPPc/njpB!Ң5!Ajj*WFdd$*++={NNN;2QPP wzܽ{gFPPƌk6ٲ" ___ސsuuE||< ,Z6M6!((?7n܀q!B~eҊ CCCQ\\ EEEӦM@ ,KҺ{9 ̙38}4,X |wXh7oʕ+}vnk׮aժUZ~/^bݺuo#޽{[n5!BH+C3IS$$$ ::aaaz*=z)))C p_1tݼyw^WEEOPRR1yhK/ɓ'066FNNJJJ_cٲeͺ;w`ff+++aȑضm[8m߾ ,@nn.TUUC!BDCK| oFXXvF׭ݫW/Q$%%ںuU !|^۷oGΝ?bԨQZ%4OB[[7nĔ)SC!BDCj0** PQQ:vw\ƒ\!$$|!ݻXl8]~q6q#cǎE^^BBBB!BDCjqx}pBFFݻw61uɫcPVVƆ 0ydBx~ 71o|G#ԩSAFFC!BGj">>+F_v kp={BNNȤ~WBZ{?; bڴiPPP;!UUU… xbB!QlHKK61 Ejj*jkk֍[;ZMMȤ7n***p1BZl_;wD1sL,\|G#ԩSHB!Q,BFGGŋPVV5Wvqq6qG`ʕػw/Bi>|uaPPP30k,w*((޸w C!Bގ Ԅ?}u@FFfff&;2?xtuuCi?~-[`֭())q`򊊊 hiia՘3gq!BQ|&!`ʠ{b̘1|!8t֭[D8;;c޼y1bG駟"??.]; !By;*PukG6n3L8GGG7o; ! ů3ggƔ)Sw4Bڴ@L2PRR;!By3*P111(//Gѽ{w###RϷ~3g 99(V*996l޽{'b033;!mңG'Oۛ8B!ͨ@MēHnvtDD>MDH3Ddd$v܉ VG@@߿GGGbܸqPWW;!Rzz:u놪+))JE!BAkPlꨛ[n1-Ѵn4inݺ_~gYiiiѣG8!Exx8~TUUOhcEB?`ڵnvUUU}TB!-@egg#""AEE}988Ќ,B^~ٳgo}Bee%$%%?`:BH[TZZ#GW^ƏO?={;!ѥK<|nELL !BP5y9bbb ]{AJJ B-,,FH#_χLFi޽ݻw܁1ƎczՄ4ѣ5jT㒒3f 8C*B!TnrssꈊBEEaooϭUUU*alpǣ{8!Ý;w`dd1c`„ ;!-'֣_իWB! -Eii)㹂ntnKG… 2djjj,R;w!!"""p!?E1vX3|G$Ÿs,-- RRRؾ};&Oc2B!*P󡦦RaaaEmmm !//wdB>zgϞŰaP]]-'%%]va„ <#au+?8|0`ll ooo=ΐ;&!Zt)~W /_}B! “'OpuDDD눊Bii)`oo^z ر#q i;QF1==!a555z*?'N ++ '|777HKK]tAnn. {АdB!Tn0`ll-!YYYB^q;,fΜ 6BDǏHHHAAQQ|0ǎÈ#TTEExNE!B^A+W 44˃&!Y͛ ^^^8p ,--IڈRѣGx1 PXXBٳgܛ4gPTT:ѡCukjjcǎԩ!M!vTWVV0bܹ8fRTTK.aÆ ^xYYYpe}}}hiiAGGPQQfKͶU]\\<ѣG hii={D~DBǏq:u OFQQӓ8#ŋrrrC //>yTWTT rrrPUUf9@RRU1\|Fͼ~UݱZpŋx9W o^mmmt Ӄ1LLL`ddyy&yB!V ⨨$$$N/$ $$$ѣ8<"##=z􀤤$&O 7JϞ=Cll,n޼7oΆ2Aaȑh qqqx".^Px0` C]]﨤۷T\]݌:ummmcǎlJ[ѣG> ؘڵ+`ffψB!YQZ}n݊Xw^8p000A0p@jjjZHJJ1==Νq%TUU~)F&P^^0\x.]Bll,nnnpuuE>}KqBll,RSSQUUiiiĄ\Wp5115_SVV&T5559ukkkXZZ|'Bi*T₭[bԩ|!Plܸǎ2 ___߿E*//ŋ'N@AA&L йsgBڀ" Arr2$$$`eeWWW:::|G%賓FXX^An`iiiggGo6Y)))HNNLMMEmm-TUUaooggg899ASS؄B! Ԣxlll`ll]"c ǏNJ+WWW̞=Ço;?~;w֭[C=~~~077;! )((@XXBBBTWW ...puuE^ХKF"88 ;wFFFܾ={xN6rKEFF͛w ۷/GoB!(VZk"%%|!K.aň˜1cߣG|j8z(~G~~~|EEZu˂pppf|:;;:<+)) pe#55pttD߾}䄞={Ҿ-Ǐ͛D׮]bTTTJ!*P7&;;7|wB`jkko>!???#̙Ӭ:BHc*++DDD <<ِ%ЫW/899ܜۊl={NQSS=z}􁧧'IPni899a1bM! ԍ1bRSSYYYBCUU[lATTTয়~/kkk‚XCdd$qxx8?%%%@ p_T~OXo L\~䊊'Nٳ(--F/ՄB&""zBPPCQyy9̙իw֭[4isN7HҠ*$$$ ** шBRR;;;C Ąi/_F0j(rrr|G$<@pp0N8#Gĉ1|p(((B!mߦ@hh(Q!"z! wÆ ;*++7`ӦMXp!֮]KEBHPUU۷o#:3 IDAT:BEEڷo.]Ғimkk&ߌ|]FF~wݻĉ1d4 RYYӧOcϞ=___,XFFF|#BHA7|2WŅ8ܻwBPPb8p'N֥&JHHH@||<DBJJ A=`mmnݺsm⍹h]GfϞ?ZZZ|G#G-[ ''F·~ [[[B!G78p jjjp%BD ggghhhܹs={#Gİað6Q!|c u_YYYEEEXXX ֭,--ahhCCCq L>JJJMgbb"k?o0zhHKK7ImÇvZaРAXnuw4B!|@ݐxܹs;!eeeӧc *ߑZ` 4:::Шw2Ը/uuuMVP!S ))Iڷo t]vE.]`nn33f[y1cTTT`̙3Waa!VXm۶k֬׭I;wK.E\\OϟC[[PSSСMo~B!]P!Ǐǭ[C/ipܼy|iك/Cm%%%(**BQQ QPPTUUѵkW\!U)..Frr2T!;;!t邮]]t1:u^3-[~ f͚ BGGG~ۇyAFF?&LIIwEțbPTT===HHHBmeeeN::u9`aaAkB!M@|cǎ0aqĶyf9r`iiD}\r{Ž{P]] 8q\x1_%K"*o1qD:tn ?˗j*/w&{ܹطoRRRбcǷFff&WIJJ¥K_~3f |||m!!m]^^/_ Z~TVV"''+\gff"33 @__ܗtuufĉػw/jjjc222`aܸqX|9/^ysN̙3?#f^^hZk,[ 7oƌ3@VVEEEx 򐝝 ;;ٸ}6!))Ν; pwwy9B!(T~o~ h׮qvVVV;[ݿsŔ)S0dGbԨQ?><==m۶ɓ'"9%&&"++ Cg}{6)4ǏƍæM޻###SL/TWWc̙066ŋ;ë󑒒E!99/^h`ee^zGJJ .\/^:Ν9s@EEɲҖUUUaӦMXv-P]]jc9ݻwusrr*W622*d` i>dddP]]#F`ժU=++ #F@ff&vލO>YczКǎäI`ffom_SSw"11)))HLL͛7q] >|8w΂B!-A:t K.l|GyT sttXǏ3lʔ)m*(ztttXmm-w,,,L>tNEEE Ϛ$+_/^̴ӧO_'R|&##LMM4ë䚼Ǐ3 }e˖1UUUֱcG&HXߠAZs4>Ǥy__|dLOOIIIsα[o51555`RRRLQQM_222LBByyycАuޝedd|sX^/t=c3+++fddݻN}dee16i$fhh0￳6q#XB!;@{͛};&PJKK>}QeAll,TQܹsB[>Z95ϟcǎ?>ڷo[MMM}||`mmcϞ=՗VZ bql޼222MkPZZd}>Ǥy_~-ABVV055m"ng}huk}B wEOKkzmƀ0x`\~]f ___0Z }|}}|r4i6քBH[A077Qڔ=z@AAZV&|%SS:r={3f;;;w.8d=UUUlݺǎ1iҤ6d!Mӭ JnÐO?Zs$D,8}4 1k֬KBBؾ};>|;v˰Ė-[(1!BZ2Aȑ#2eJÇ#-- 1b,Z/'Oرaʕ^nXSQZ`` BCCׯׯGLL 1l03^gϞaϞ=r JJJooo9뛴Y}7M_`SN㡪*87eBhjjǏ;ϛSVVƏiӦ|n#z+Wƍ2aDu(//͛*8::bΜ9P,]ky;aϞ=8wЫW/̙3ކؾ};Q]] ;;;̟?x9zڴi w;l0;v 3fΜ/_Ç yyy8;;or$&&rRRRtR1?s q%1'N@EE1;v 'ODnn.TTT/L#11033äI|Ϟ=ݻw#((|[Ϲ5:u;v`ذa6m\\\޻OyyyL8Ǐի1|$&&b֭B*|]ee%</ѣGԄ'Fm(X^߹sÇ@!|T^_A$~3fJO?$$${ # b*H[D,QcbI1~ըIL4^Ѩ *EcC,PPKr?|+ms]\0{ݳΞþkvio>fooXll,޽{rJnyBB;s Ə-֟۸q# b+WdӓUVV2^7kGhozښ9sܹY[[6mڰǏKt%((L]]988Fَ zIq}mLII7۷dg[ne}PXpviYhh(g1Ο?پ}XJJJǢ%em˫I dlÆ {yzz2CCCyfvYcfffu9֍gb]ty eCe؟)qB!9LoժUcǎ.::1eee-_h9sȺLOOyzz,sNN,c;`owb[MLNNqf{YwРA v72쯿j풒Qmq]@uuueɁ2%%%q7Kxx@v5$\W;u\n_^^^\XXn߾Gqq1%8v E{yy^!C0[_3~Yݻ @LF$mgdd0Ϫ!?έӥK6p@ە0###*\]]ԹkXEE[z5~GFF2999sPPa@d]777/mܹ[& Y#344d={s_$c}x6=I59"1 ?xijj^z%&*PlwfXv'|¶nʢP(u'$ aR-[0lذa"%_Pƍ"߿߿ q.w^֦Mhi矙ήWZZ[EDDx_бnL?[~TTիm/2B!9::9s4궏?1ӧOkÃiii,kNyАBBj0GGG޽Hےd}ZƦo߾qҵkZ700`Ums|N8\]]E~޼ү$\W;.Pwܹrw~#11foojcLOOsW`1p+Aclܹ HQĄ`YYY5ieeդŋ3''&k{lՌ1ƲE>l0֦Mv!V^^-byyy"[JbWJWf6Çk?rW׶dnnn Yޯ_??11sƍc;Fݧ,f=G<]]5:uڷo/uc2 -[bbb=u>P"+$ymgXnjYkZ~$ŨZ1=z0YK!66`M~QQSRR.xWqq1e]taaaa"}[= |Hs̆Z)iB!8LcPFTT֮]ۨ[YYXfjj'N $$(..ĠBP*էI۔E&IHHpubF?ՙ:tPǹ:K]3wHJJ>\T֭[ù7M=RV\FFFPTپ}{"99vvvbqHOO 7LNNtĦ!Ika}o My4vz eeeBNN]d -DWiqMgϞOgddTkE~$Ş={ 'ODBB,--q9b̘1z͚CK=GVV˗cРA0113F &H544ЫW/ǣ7nW5B!DjT_|qE*UTT7|1cpo.VZׯ1ƭ_}̫D)--JT633@_UU$U]to)@.YpWS(555Oj}TWĈ999%ZW ,+))AII &l(|¸$&&bĉu{֭[q]9s~cRɡBY;ye7&Mpqlٲ坟_ަ^gGZH$--ec6mܹSNgϞ2@ZWjj$kQ%%%$_7 44'6oތ_ ,)7kI}{>Tb$dffںup98uΝaaah߾}ۑ{<5 @!4G5 ՟VVVz`ktMX[[COOO*텇#22}~ն겳E?zW՝|3_mmmdeea5>QZZZgѤ!---ƢXX^^ѣGcPRR8K8qoʀW[>ڵ,M[\lHS_Gzzzr#77066eff"%%&&&?#''~ի@~ Km[@۶mׯ#33u3j(޽pqq ͛SSSlܸQ,RИ6m0va8wLMMѥKb׮]8y$B!oCCC)K4ѣd>Ws7^Gş OOOn5k~54oh۶-.\'''p$ymwppPRR ::Fےs/zxx>CX[[cǎݻwqI%phjjJJJֆtuuߵkkhh`aѢE077[)VZ#G@GG~!>C 2'N|rϟ7i?[ ࣏>q%q¡Cp&@!4W5.Y~2×7n$QTTO?g掙q=hmt8{,௿ufffPTT6y ܹsG&.UUU_)))Xr%*++oᲔa޼ydvu,)Iņ4;;;ܼyQ_2hYp!V^-oYXd w쫪r&~x! Xj}E, Æ DΏ80j cee/^@("''ǎ O?6m`޼y"W?|̓=sss֭[z8q]I5>5tT?ΑO}Rѣ@tuSgϞP۷{ׯ3B!ۣR?1PkUYY444؎;uטI1|}}SUUe{f={dC a}eؠA֭[Ou<c}LAAջ59_cɓ'LEE`...5&Y300`'O(Cpeee\zuN)))LSSJCq_ۅB![bSVVfW^Ғ?)((Ç/iNbkL~ڐַ˗3---Aa [YRR}6;s ;p۸q#OSVVfΎk׎{|G[[3%%%ڵkttt6m&dc͘?0 LQQ{=\#BZrbu /^k޽{ppp@ttBw <pttJ/^&]RQQA~PZZ8Bڊ|=9;;111"mm5ߩS'"E{bbb `mm mmmܿyyy)l2>h߾}'3PTT#GH|L$UZZ'O@(rrrv=z|$##033 ONNFbbH{{{޽{"---wi qm6̚5 صk~W|pBb' qlڴ .\ÜܻwPTTDVVҐ4$%%!55999_]]h۶- [[[١SN033XDKUUpClJzB!-ܑxt߯akc,Yyyy42!-#wE*,,Dǎ|r,[Ldi&<|ʨ l Xl q 2DB?˗/GXXXCfƌ8|0w\t ׮]Ú5kj,2d~g,]T&Y:uꄓ'Oo߾2fku9;SNڵk}v(--u ~:qaaȐ!Xb; 3T虚Ld<{ Ϟ=JĄ̌+\W[ۇلBygGĵX}UDnn4!-7|?K.o@4¯*̚5 ɛ|}}uVpWTTx=~fm^|c׮]HLLw5ċeHOO}Qqwc?sIlYYY兞={x}add?I?_~m6t҅ƒ%K0|pBt sUUU!55Ud@ @dd$nܸp 77֘:u*O^/%//cccs^mrss3<+Z?{ O+nѭѵkWtԩ'!B'5D6mp||咙#Fm۶طoQ!+***N4I >>X~=ڷo[ʕ+PRR oSTT@ @ @tt4.^ׯ_:&OKuB!1/`ʕ=z4|}}woѣGѹsg#>>=z={`kkۤ۟>x!7I6mj-\[[[ G!Zx=F3b >BɔNo(F#VZUVE(--3rrrPRR|C(6x['''DGG FFF6lFѣG0BL4 ?0zh#ɓ'1gdgg)++ݻwG=`kk gggtE^nn.W~p@999tݺu##μB{:v={JfB!I&H۶mܹs'2!… OިO>D޽accSdXBNZZ/^#G7n ߱H+ 5rrr&{_$$$p똘DFF">>UUU)X;::s4L!U/=1S}k ܼyƢ#?>݋`Yb᫯–-[Ǐ#55JJJ j'Os2HK!!aaaX`bbb0e,^ D*bccoѣ͛<\xW^Eqq4(yVTT{!22y!*++`ݫW/tڕքBWlڴ |//_q!SLSQFYٳ Pȍ5]H8888=!TUUa5 K. H t5/8}4ve˖aʔ)"ߘ x_s… (,,2*++kꝤ}'cDDDp?(--mڴ;2!"mO8oooCUU`2sN,YDdffBH% _bظq#̙wfӦMcǎCpp0"""Ayyy8{,rss,2i˗BMUU/ƍӧM'BWWxÇo>ܽ{...Xt)F%P^B|2.]WJJJ8{, &=i=0#==***ݻ7gggByWaootޝ`2?СCxQ!Rؽ{7444śEEE8z(XcǏԩS8unݺUUUxxxeeepݻtBi];wĉ §~aÆAAAxĹso>AQQǏ_|s˗/c4G$$$v.]Da2dѳgOBHKT{Z @GG[lix%-qMB$??ظq#bbbЩS'l۶ |G)@_~֭C߾}q7xl9s~~~p*++#F@CC !>!(((Sp@WWC Q0vXhjjPii).^`"##z¬Y0qD:Ztŋ8s RRR`hhÇÆ 1 !q^[nرcCӑg***<ƌ#Gĉ8uLY"mKٳg#11k֬7|EEE)))AHHp)_~G}SS&HO!)$$$y&TTTѣGfff|G$Mٳgx" 8;; Ǐ0p}>}AAAs ///7m۶;&!R K.ٳg-P23n8|G!H W^űcp1SLE f?>.]*㌊·~ӧOcСضmxV_u燀[n'|+++lBHBPPqEnnnJIIAhh(3^^^􄡡!1I™3gpi={4h|||0~x:!47uO<>֖u0`mmm۶"nܸGѣ>cL<:t󶥥غu+6l؀J|3g:v(=h޽{cݺu:thm ϟ?޽{>>>t! y&WмuѥK8;;O>ӧzI53eeewܹ;w͛x TTT}зo_c8}4;ӧO|NǣM6|G$B.Pgff.\hc:88`Ĉ駟BCUUn߾Ǐɰ +,,ĦMedffb̘19s&[QÖ-[ 0/ѣe:9NEE.] We(̙3|rBP^^ ((ܹ3Wѣ;oC 7oaddͲX3g8<0a̟?|ǃP(č7ܘ&Lx/&ֆ1'OΝ;\()):uݻ{ ,--[PZD!66111ógjjjٳ'we E%33/`ggc!Y@=m4<}aaa %3:uxbٳggϢz`ggdNHHÇqBGG:t(йs&v}***/ܹsu၏?cƌiWN8qDBH#UUU!))+>xqqqx!***zzz%,--۷oSSVRRT !!HHH~ݺu-!9y ܸqv¿ ---|嗘3g]\@!DV/P8qHKKkRBܻw/^ŋqe0 ooo71J||<Ξ=sʕ+())ЧO١K.ԶǏ#>>j055Űa0l0COOOjەRѣ8s *++"رcwDB!RPYY$ܺ:::h׮LMMabbk``==="7G^Bnn. ==HKKCZZRSS+v---affEEE233uVl۶ e05!Çq5;w.]«W`nnCbС2dH+W9!!BСCt066F۶m&QRRrTVV999BVVӑĽaUSS=>}ښc m ѣGq9())a̘1OAo !Djj*WMOOGJJ 222srrPYY)r;EEEA__jjjс աhjjB]]---j_z*B^(++Caa!Q^^| ''ׇ1ڷokbbvqy:4Weee8x 6l؀/^`Xr%-B!_QFAII 'OU(5!M1$DGGunܸ|hhh͍+Jw҅)//GBB?~Ǐ#55/_DFF^|빅D6m eeeCOOFFF044D۶mann+++t۷$|G`` 8⣏>”)SB!޾"'''%%%Gyy9QPP2qJA(\ @]zl%%%hhh@CC҂:TTT555sW{s?oB%o>[YYY={6V^]A!HI;w믿˗/u sŒ%KBH# $$%%ٳgHLLӧOB}E~Я_?U/^/ѵkWL0'Om pB!-:v;wĺu ''_'O !HKLkN 1l|/_Dff&4 @PUU9aaa[[[vvv40۷qA=z/_ &O oo76!C__{ŤICH5k`˖-߿?n [[[cBi.P@aaa"XXX/eBTUVVիWx jǍ\]c`hȟ+FW𸷤  ?'OB SNرcJ|B! ˜1c###jDEEaΜ9+zjBHuDwӦM… Ǎ=SPP@W^%%%(**@ @^^PZZׯx,0M6ֆ6 ]]]XYY܄\aI8~8|}}1ak~)M+++BiΝ;*N"e~:6l؀5k 22{!Pb]A]PPo={,rɄ 郍74yyyܬŨ@~~>***PTTnv@Bn٫WPQQ!R,~ e QTT&7 ACCJJJ&QSS uuub "!M+993 fĉwSݻMJfFm'iz IDATח(D ʐn?^mT%%%BruXKK hӦ 455b8el1UUUҥK*xzzb֬Y2d=!=tW\ACHɓ'ʕ+8vFw$B!-WQQQٳgS'|G!@rr2233KdgghCKKKzh꫊ԄNdBH󔛛DΝ1m4L6 |#"c?6n܈4 ={6݋۷cƌ|G"r_xxxnP2_ !!/^;{iiiHIIArr2 x=##UUUmttt1 Xf``===—B~~><==_ݝ&!뇭[c V{n||G"2HV矱a$''q>.]˗/|Gi c$$$ӧx){zz:O=%%%cǎ055iߍBD***;w"$$>}:̙CfBH+KKK>;!5k`СCC!@N:a͚5XhQS~ x QZ2 &&qqqÇ3:uKKKt;w9ڵk:ؘj$4Ǐc޽ؽ{7 EcUBH+~zHOO c ӦMɓ'q5BH&Y-ZG"11ML&݋磸(-FII šAnн{wt 666033k !u(//G`` v܉/K.1c B }B{Æ Cjj*߿6mBH%y:%%رcMDd6lrsswf)33v @===8::r?ߑ !D,QQQرc_TVVb„ ={6F!ѵkW\p|!佖nݺa駟C!@ ~)n߾=4C\\whY(..ƕ+Wp9\p>lmm1`_~033;*!HEaa!>۷#** z‚ 0qD())B/^ ???$&&҅4۶m pm888BHԸÇakkSNӳ)Daa!p18INN?N>0TTTC---cBH_Ç_|͛Bi@EEڷo +W;!@UU BHԸ5xzz"33njLikk~̙3"Sϟ?qqܺu 9r$Bx;v`(**,YB߶!fØ:u*={SSSB˗/ 7n܀3q!4?G=>Ǐ??~\d}HMM;LTTT077Ǻu`eedffСC2e  !=])))عs'"##ѣG 0~~~ |G$;wbԨQT&;T=~ްݻwg<}V<B;ڵ+mۆ/^`ٲeػw/0o<<{xƞ={h"(((R 333|G! SVZ"_#sEvv6QYaa!-[;;;>>;!7b|G!<;!f FFFXd ֯_id]=zsw燮]b׮]C^bB!PQQԩS#9rqqq'nܸw>>X`:vEsΈ6k"%%EI*++1sL_^ylmmvZիb.99x!Ν)S ""bQ~5ks1{L8::b(**-Sky"Zs{#Mc͚5ŋR]bڵĕ+WPUUwz5Ms.>|8֮]wﶈ^xc|GiVY! ֳgO*++|grrr,00(:y$SPP`˖-cUUURm{l޼yRm/ӧOg#FԩS 8p`mޞnVVSRRb;wn,Y+?C(++#<<1ѣG5Ǜ>} !S6~ך}o 1j(̞=nnn9s&~f?-֏֭ sE~0e㴨>t}YeiNYW%** 999pqq q 0@ۖTCYkk* !zuoVakk*GGfxzzbزe q^ B!y/NW;1ީ_4η׌bz*N8իwҺzm۶ j6֢9=nSHǩSЩS't SBH$jXt)駟͛PRRjMI#6mw 1bرcPT.t;dSN&9z(mۆR38::r넅aժU?۷ΝCEE[gԨQ]vbgOhh(B!fϞ-7oFXXCOO@cuy(++7Vooǎ Eee%pBVoz¶CB^^ݺu֭[4ޯ8p{q۷ocҥ^! O>#$$`! `ɓ DZZ1p@|MvJCjd͆ka!((xӧ6=?F[&O 777o߾ػw/>#n+M-ZCIjo>6RRR`hh]bҤI"I֓_N:q3ӹ)D,_K,Až8) Bl۶HAsܜ'\>9I'׷bm>I;Sii)HzX:~Z" qa\pyyy077DŽ 0w\hiiP([qeSLٳ;M"L9B@$))iii/37!.^LU"_d,''r~)5k{~`jjjlժU̙3駟f,&&1XFF gZZZl,<Co;11ϘÇ38T9UmEڦbD" fnZN^U3EAkhq;OϗiGʶbUi )Z ]_[r=]pUTT wy B̆ c|;}4ۿ?`/U6&&Pjikh\'`B]`_|qqq㱙3g{ŴxS&6Eש̱.Yn6l U6770[[[V]]-EgKlLKKM2E<wɱ7H-ohh` b?RT}+usqmsLSSݺuK͵Ye?Shɓeڑ'ʶQEcwܴֆ:W".\ȜYCC}6xLCCeggse/_z-36uT7nܐI22XEE$cs344d<%%%q뙡!:tT`?ROUk뮮fzzz2V4֦IaILM.?f3:3Gl}'RcccY>ʶEUr#GdXDDT72lӦMJ2NH7 jX̦NXQQQgo]ٻﾫ0cOfe+VP|~~ 6;xTOxVRR"UBY%֯_8咋,YH}3}KJ[bh_gWߌ=TSSPe1Yii)"uhmm|mJ%xXppƍ/dc1{{{@nO777eexS&6Eש̱.ｑĔ+‰'dZ,--L}Uo<u睼_>wוTu+u?Q옶չdhsYe?S:+AݴIk|NTD2;nZkCUϊB+z%LKKܹ[v}.U.55U]ƍcR:+A$LJs%Һ֭L’<< ::SL#`ذam_7:džWW6Nk\D{u6ۿyyy?>&O{ŲlwLiH`|(r!뙮W!,X-kv$lmmq \x$$$"UF^;А:$mLrpp@aa!>|(^[^C;;~ &szzzBGG/^ʕ+1rHX[[# &M?}i^*WTTčԝ;w@}}'D:=A )s (K2زeط~T9UuʝmmD"6sLfjj*7.E3Eψ殡%iG~(F"m-ܞXz{_4/3{{Vg؜9sd:u* dc)_zUnbʕ+c`ƕ72c >rkjj\J{dccD"nkcj:zmm-?~<;wX:~IIIa?`_}Lh*SАɽϸVtwBml5k%%%]i*aժU/zg}ٳgK ܲ$0dnquuEff&D"pQ@MM NNN())׹8qD_K;xKLLDaa1ܸq?<455ocԨQR??yW_}QF)|PWW|ZO~Q__kv7֭NJ+PZZ ɷWnketvC"%%111ܲ?ͷmذXt)wҥK1x`a :WxS&6Eש̱.φ ˗[֭[Xpa c߾}駟t_ʼc?ԱqQܹO?Tyӹu6~1ưtR_?1`K4mmLQ3kϓĪHjK='^+W\o͛7s=G'L_y,Zggg|ܼy\{YsUUUشiXuuu)::7n܀ף ~!wҥKQ__|~R-mqL˗/bjhhʕ+빽tFSYY#G $$DjyRRFi;֫2+deeaRw>)t{]elܸq#,\Pt=ۧb1333c[neܜ0^|E 0BCCsuueRݸqyxx0ǼذaؠAܹs6h pBȂ)~i?3ƞj+Ϗ\0MMMLx`ffb`o[iڃzLMMֶ>̂.e۷ogvvvlСؘp{29dӺ/CÇ3sss=?6fXppOpp07y~5 cO&uwwgϏ;w2???΂Ν;Opp}ve:::lȐ!ۛkJ17EcStkbC aח0}}}n:\T_oo!11 <_UcM fooώ?.^E˩s]מ딭6z@ Qۚڬ2אmynk;R}h뺛UF^R;*^+uuuÃM4I[n1444Xvv6|߾}̌iiiC!C1cưÇ3lȑl۶m\?3cccϼfffƂ׹k׮e|>2CCCyfcdLMM`Ypp0gjjj,88>|[?̬ :t(344dѣ\X7o,01 6YXXaÆ6sGTyy9裏svvf#F`Ą[Nm+vWe۷2SSS6l0ĜF}Rv ~1A >>AAAxw_w[t1̛7066mϟ?HLLT|bРAr{Я_?nq}Y9>|\ ?Fjj*@__z#d&455[ܯLp^ `eeaÆ-Ni}gffr(hjjbĈARRD"HHHZ%lmmƓ#!!pss!nݺݭ`mm 777#/@GGG'3id$D")tSU `:tSErGŬYl . t#]}}=z-:t ^xUDiK.aشi,Yp! KP{ｇݻw#""~~~ C۷w6g͚tvy999m0|UCǖ-[CWW| ,XmmmUF:בs?<쳪yyyO?#G:B!=j 7nq5XZZ*)k֬Ç[;[JJ q1̜9KI!)((uw^wŋ4 ]JJJ|2Bqm̝; C"ACCƌpöB! 8qS:BBBiӦZpƍȌY6mGGGL6KG!w277Ƕm#,^;v@~믷:?(9MكXYY!66ӄ`WFLL ?NiB!JSiÇx TF}}}_R/x#YZZO?EFFlقׯC ƍ !}X,ƹsSOa…Xl.^(5!gٻw/;l۶Mc !Tz \xT4440~xv>^{ӷE!o›oD 88_~%lll0n8@(:LBHp|puuń |PWWWux6:y$~m|'xWT!JcP7yIJeT/~xxx`̘1زeKmBEhh(8;w..\ح&,&l%%%r .]ӧO#-- ֘7oz-xxx:DBH;?~Ǜo[:B!=j'Ioիq̞=[eqGŬY:eׯ_G@@bbb()@!=~كxzzbܹx!=H$BRRbbbk׮֭[`aȐ!0aONBH;ڵ K,Ei&x>DFFƌӧcԩVux999@FF233#ӧOC$[DǏL ++ :χ58::t=!ͪqF|Ŗ-[0sLUE!9 jѣ!e֮]]v_QXX~۷oozzzY. !`hh7W_= BVmm-"## SNԩS1j(Iz dff";;йBnn.D"SSSX[[vvv@ P^Bz#XǏ㣏>BAA.]UVBJJP@vv6F \pVVVR=z[n۷W^y?sqss}BH#P=zwޅ)y;ӦMsB:X,F~~>c#;;Cvv6󑕕%9AKK 666+++RBO^[okpBZKP@VVƌ .ήCc׮] c b\BMM ǁZ]߳>g6<áC0o޼vN!twwEXXΜ9(b1&Mĉ1dUH2!??999ɑIBKoY[[VVV%lll`aa[[['5Tw"M(q]̚5 6l!JLP@^^Ə2\x...۷c-xxpV׷h"ٳ}ݘ@ ȑ#q…6K!Teee8<Μ9 < U&ajjjPRRdggYYY R7665acckkkwe4!Ǩ޽{? 77G}:4B!}[MPO&czg˫ֽdܹSLS3gĉ'Z]׆ gHJJ;!13g̙3qx< c6lT*b%%%Gaa! PPP<R^s033d[XX‚G'*<Ν;k.b,\~߉L!QNPOƉ8q"q9x{{-C899)^HI&!<<\ngc"BJ#,, gϞţG;SN$mZZZR=}lkk MMM)!P(ɓ'{n\xXd yBHw[M[n!44Rn޼0 ͹z*ƌ#Ӌzذa~zxW{n B|ՈCTT.\HAAA;v,ƍp_=d~QRR"W3d(fccc&'OÇqyL6 /"&NH5BIzWx2ҪU7?\#F+W^={oJ-2dz9 `llT+!BZWSScǎéD(--EIIoEz87M4q=jnGXOOOE{O!DJ={GAXXD"Ə^xӦM6!%'"))IǏQҥKcD"'zoaJoB!mSSSk׮ܐ ׯ1zh9C{XWUUM27-oYyyu*hntɰ!Ahh(N:K.#G /ٳgD!B!;ԋ/Ʈ]Drc<VVVHMMRD4iùq.SRRzs=իxJmB!n… pDEEVVV:t(̐S\\:Rx?4!iii EHH1c`ԩ6mT"!ґz_nc͚5Xn/--СC888ѣGs"yyyCii)D"***Ѐaaa_1p@X[[ӷ݄BH'DYYLO妽}L,add###+]\41֢1rաԠ|> }^ H I N IDAT @nTVV"<<aaa8waff'bԩ8q" A!7] 갰0L>(v̛ܹ7xn憁 քB,/ѫ]]]oQWW~Ϸ  Gra}}=*++OKz~F&)_ZZzzK8ymll XZZ033yD[c> ǖ-[!O)//Gee% :8\^^MjG2sEEE%cK%%cCCClJ,wOb)))G\\|> ZaHb>ݻwNII&TSStrrB{Az*<|P#>Ԅ <<<///*ދO("!!Cll,nݺ4|p`Ĉ!]! j8Kw wtSqU,\_}%"!h:"bH4;ƲKϦ_(LȈ郲%=FFFpqqƴ򂷷7,--4FX ׯK4#99HNNFrr2􄛛T/U GO1)))HNNFRRRSSQ__>'''xxx4hHmpm.-I(BOOC /:dB! j;Y#Fmzo1\%Q Ґ7oJf ???vsc*6;;;J LHH@]]7m:twwV!%%%7oñ~z?QRG(,,īgbÆ XbC"1 ܰ555\rUUU\rY8$''ݖ,n\X2.\644t;.233;w 11 {.䄁r====I\QFq-;acc%W^^"##ܼyܸݒ!Q ]]NH$䬒ʠwww"00AAA2227_|ElIIIHJJ;wpܾ}GGGx{{1`BZ}+A'Ǐu63?⣏>… yfҬ憷hʕP uc333}x?Ib^S()w^,\" b1^u|2VÇW"22݃ aÆq ioov' cxQYY 333aȑ OM򙞞 6`߾}hhhܹsqFnn.7ƼdxDN 8KDK҆!Bڤ$SSS1zh㯿C4'O1yd4>@C`` &Nɓ'w;vxr___*b"55)))HIIAjj*߿Mxjbb-PPDBQHHP ((fff8{lH0"">,͛CtBnZ(O ڛPɄ=w$Ҹ/777n1X,w}իWr8}4Μ9(@`` ƍ#GZZZӄOzY߽{tΞ=R 0SLIO+um (,,ڢ"IT4@'''puu|1F!n'SO033SuH]̙31cVZO?Tҭ+= 喴qK hBHihh@zzLZ2mk{aʕ022Bbb"~ ==8q"&M &Ntg ™3gpi$&&B__'O/ &4{푔 6r<W\Azz:$%=544WWW.ݿt(!һEpQt;wbŸx"FpQZyy9jkkPVVjաը&૮Fee%WNDFuu5[ܦ.ttt@GGFFFߒIeIȍ .1B\FFF %Ԅ?~~a6mi22Bt>}GAdd$0|̞=^^^000@BBknhֆsssޞ%g~~>|r$&&*A+⫯ݻF}}=444 dC|>7G]]C A@@0|pJZ>]>FFFSOwE^^}DGGcJϽ3A-9s~Pu8SNaƌx7 8(--q'B!\]]Ϸڋ:!!wQYY}v,\bqQRRP*TUUA(+W^^:TTT4;nlYYYM455!,===hjj:::Ԅ1,644tuuMMM@WW!ԩSСC1tPX|9ۇ㫯CQ `kk GGG:N1qD7on V-:1cN:% jc"22%_cﾋ"?BAAx<455QWW_~{Ezz:q]!::ȑ#1c 5KvJگqw:l)y(ߛLom^6lݻwy&\]]VtE;T}>+?p222[o:777l_CCv؁\"44[nŕ+W fnn$I߲2BTTTp=P__rnYyy9B!7^MM ***  QVV%+**P__R044&<&Ԅsc---M0Bӧc7ob٨ѣG1gFs#99zzzDDDBapBw%SSS|wx7ocظq#OzEGGڵk@NNSIk׮!::ϟǶm`ddɓ'cΜ92e ;N:z?گ;aK1ssw|oFjj*H0dȐ.'NW&>#Fpߜt>@^{5|_o> ''cŵ6a]s$=[x yCQHl\s iB!}Jdd$&M9rVVVGy>ysww˗bɒ%HKK÷~ 888Œ30c |7HOOǩSpI̙3dhjjvծBIskԺ2ze:""oٲǎxzzbL6 =\miŋ-[Ν;2\z&F @OOeldd@}}}.lee@n444!/ ';!Wݽ{'Nĉq.=.]G"##ZZZ =,j{`\ Wpdⓗ:VZ4J?|ffa?Y^{͞kD||s5x0ϔyPa}}=1zhwDOB>EEEؾ};QUU̚5KC95qF?~JCܹsfګsCJۭ͛oc굾[lAZZYH$ŋ>>>:3^{ \M6aٲeظq#kĴGWӎ&MBmmmڵ >>>`*-˒۷㧟~BEEIIIJU:SƔo_~%`--Z]IIIZqwf{~ذa~7TV(cwCڀ)Tڋ~[nEjj*lmm1qD.^HiiiH4a/O:tV^fΜix5JKK)$$Q?E#FcԩSi锐@sΥŋӊ+?-[֭[iϞ=BGL:s ]|JJJjc1RMÇ'Ripڵzj[oQjj*޽bcc֖233t4i$ Rrr2mܸO>tu4$]ii)ȑ# W(4ydSRRmٲÃ~Wyʕ+oH$'|Ҡ2u=PZZQ)--ѣB>dmmM'ND#XL;wԉ122<==iرPrr2&ի]vM'cKD4yd^lYYYԷ1Z]]M<Y[[[oEɴ~z:t(=$H :w+WD"ϛ4ߢ"zGښ;aKӦMj]N;r>JRJMMF-"4uT{LSL/T-eY&NH˗/裏WxzNZ}^*1rHa{yy9Q߾}]خ;88}k}绡muQ-S{17sѪU/Zd M>֬YC3ڸqVLƔvvֱ1E}#)> m4:uT<ݻwӸqH$_7:Rig>n:33P~~%JI$ѹsmuuuD֛ޒDDK.%///zA|noƆ̙%12uU}IDATc?H$gZ:ۗbccՑ' y@+VJE"Njt#K/_NhʕZiKJJ|}}N'%z!@s撓)<<\cƌ!wwwR(Z### ޽[k o>@;rZw\\N}S , j*9Jp={V4oLئRߟЮ]Jd2 4H+clgz0Fg?SO7S~6Zno~Zۛhft3&}Gn{#2]a@%Jw:#""H&MoO?\]]NȠy摗h Pb5kVcג%K(22aldooO;wFaӧR cdee%74OCrD'&]{:yA+%"|Z?k׮5[=L ?PVVHzg𻹹UUUi7t#Ǭe}kiȸzٳ'[n } 1K iDDt-:sVKSCG;MMMDtg# S1ӧG}׼,EEEzgL_ea9^ۊjRT:죌=ߍmCc֞:;@]PP}̘1***>\0~[rs_G'C7cx{1ԉ:yifk{M򨰰P+:#m0⼚ud:ۜPTT%7n߾ 2111ڵkq)$%%a߾}85 ﾫlwww9s6mBQQ@DtEE2{Έ***PPPFGԲ5Ykۘz}q H$k^rYJKK͒ BwmYol@#a톆L<@Ϟ=;; .k_KU8U핡>3d2t7BCC>;[LQ-󴵵X,1e2dH?-_gB{B0\2dN^]φ0u;v*_{,q5Ree=婫}pH$1x`XW\'N@R5c1TT{i2 _~%>dff"55֭Ê+o><#D"J!npƤZrبju(< 9"2K=W_ŦM0m4̘1Dػw/6m"yOcc޼jjj2vԜ1666P(P(ZoZ/̙3ӧY~:N8UVƒD{;{ 4cc*Sc'jD"jqݹyՑTmux/0 H;17s\6޹h ___D0uLvͱO]7^M(''ҷdСCI*kPGDD ڱc_2ST1W\|hǎ qqqt m$h¶?uHJJI& KJߞJOO׉)22RY(xb`Э""WWW6lg}bV^Mȑ#:e={j=ۘ%>:{̈׷1:j(@V:BA7n TJW6yW^Hׯ:-Y{>.]h Jtg P `*jL_eAd9eHﯳLM}}=9::uQƜiCSi+&"?~̙cwIrb19;;\.L:}4rrvv&XLrvM6lIAZd 9jrssu֙m1n߾MC !???#wM6QXXd26lD"3g<ɓE4h 0`;Ｃ5#< IAr | q 4hSTT3-_\xZnnN_|ݙAyMtt4-Y:3u=%''PϞ='^)<-7cǎaFͲcl|>}Cjӭ[p5!00έ-,,Daa!z聠 u*϶ҕ!''G+ΌZ߯YYYZлwo=zTkwә777iFDr JJJP\~] OOOaDÇG}}=Ν;J 3i5|xQ@@ۭ6^J%rrrT* T3gΠгgO}%a„ (,,R J%Ȩ^#99Yx. 0w\ܺu %%%8p׺>zݿ1DGGCRC AJJJ7hsضhHQT|2ggg:uJثW/!A EEEhllDnn.t9 mCM;۞Skz):uJk{PPR9@ܜژvZ=h1e}3Lkmd2V؜zxx ((ՙ⦼ Cg>BywG>}ڡtWp~7Kcn@Pi&L:ׯbY@CC`׮]PPTZiN:(W*ů ;v EEEѣ0uTL0>?,YǏcȐ!|Ե}{Pw"*HpaKrW(**B߾}vZ$$$X:cu#={6saŊtX.P]]^{ ;v@SSD"Zcʕ+C^^rrrܹsP(prrˆ#0j(r 2يL7n <<| f̘ap;mSf;@\Çcܸqf͚G… H$1cLcc#6oތ+W/ϟK38tjub1<==QZZ*<4h HvJ-oyfdffBTbxg /X:NԵ}P>|dff&KwwI믿1c̬jkkgaݺu(..G}cسg{=;wΨI$7O?4BBB'''3Ec{H.,,Ddd$~i_XDmm-CA$Y:$cJ%ߏ۷pvvO7nķ~kpZƳ>l߾c1elll0}tK./#G"88Ǒ#GhPcz={}bbb5k`„ ؈[n!)) ,!k}J%JJJ1t ,͛zt_~[nŏ?XKc1ӧOcϞ=HMMٳg䄇~'Nĉc/FJJ RSSQPP///L8SL Z|Rرc8rOКa=b8qKc{F^CCV#>>@RRƌc̊pB]{Ŕ)S,c1Ƙ"%%?3ѿ"&&Fd[??~8y$8!::VV鶬 8z(~GO>3qIc1v?;cضm|IKd f޽{uV~("c1 HKK?ǏԩShjjB޽+ Zeu@ii)N8t?~OFSSѣGGY_^^L?,3cu PwfR/\k֬EbŊ6oS\v 3f@NNۇcZ:$cCVVN8!믿 ::Z ,Oƺ*ԩSAD رc1rHrX:\cj Àc[:Nۻw/o1cdJ%,dee!77JΈDTT0899Y:l̪ ř3gs@ἈưaУG Gc1㩧B^^|M,Zaʕ+7o<]1c- eee!;; _~Gxx8777 GΘq… 8wΟ?#// "}5?c1v;3q֮]X|9z)bK֮R^ׯG޽i&=a1cYJ•+W5w<== sX{jjjsE\z* ׯGGGK1c#j",];wDpp0,Y'|vvvMGaa!6l؀͛7o&^yn6c1Ƙ9… ťKWBP, X񁟟yk!~: Q\\W m(--D"mO> Cxx8BBB`kkk0cP7w%|صk_|9+J>|}RSS!o`Μ9ppphl1c:Z"W]!5ѫW/WyH}}=nݺ7n@QQP\\B qvvF@@Y{+'0c PsM|WqÔ)St 555HKKCbb"QYYo={6&O3'c1ƺHcc#f(..FAAJJJ$2 2 ={d2) WWWXf~P]]JTUU7n@YYJKKQRR[nT}e2 ___󃿿?-T:cPEVĉHLLq5HR &&QQQ߿?|||:&\x9998y$222pij >ӦMôih1c1R())AYYnܸRa͛5" V7prr =zpuu@oF}}=QSSz֢Z t߫R򵶶L&f7<1c8<@m;v 8~8nnn۷/OOOHRH$888@"MMMAuu5 qMO߶Fxx8r9FQF¥f1cV[[2TTTh oFmmmy;88R=T +++Z0moo5*\ɩgTUUo<ܲZR)\; 0cuuu_fH$8::Gd6f1cԝQ^^lA;%%%~:n޼j466 ߚwgggCXX"""Я_?H$K1c媫QWW:TUU UUU:3 ڮpg䆆jaqa}4yNNNZ4 VVVJZyb0s\3\3NNNpppf)1cw-f1c1c1f,c1c1cP3c1c1f1c1c1ft1c1c1;?$k1IENDB`emacs-jabber/jabber.texi000066400000000000000000003377331476345337400155510ustar00rootroot00000000000000\input texinfo @c -*-texinfo-*- @c %**start of header @setfilename jabber.info @settitle jabber.el manual 0.8.0 @c %**end of header @dircategory Emacs @direntry * jabber.el: (jabber). Emacs XMPP (Jabber) client @end direntry @copying This manual is for jabber.el, version 0.8.0. Copyright @copyright{} 2004, 2005, 2006, 2007, 2008, 2009 Magnus Henoch, Tom Berger. @quotation Permission is granted to make and distribute verbatim copies or modified versions of this manual, provided the copyright notice and this permission notice are preserved on all copies. @end quotation @end copying @titlepage @title jabber.el @subtitle instant messaging for XMPP (Jabber) @author by Magnus Henoch and Tom Berger @page @vskip 0pt plus 1filll @insertcopying @end titlepage @contents @ifnottex @node Top, Introduction, (dir), (dir) @top jabber.el manual @insertcopying @end ifnottex @menu * Introduction:: * Basic operation:: * Groupchat:: * Composing messages:: * File transfer:: * Services:: * Personal information:: * Avatars:: * Time queries:: * Useful features:: * Message history:: * Typing notifications:: * Roster import and export:: * XMPP URIs:: * Customization:: * Hacking and extending:: * Protocol support:: * Concept index:: * Function index:: * Variable index:: @end menu @node Introduction, Basic operation, Top, Top @chapter Introduction jabber.el is an XMPP (Jabber) client running under Emacs. For more information on the open instant messaging protocol, please visit @uref{http://xmpp.org}. As a XMPP client, jabber.el is mostly just a face in the crowd, except that it uses buffers where GUI clients have windows. There is a roster buffer, and to chat with someone you open a chat buffer, and there are buffers for interaction with servers and services. Then again, jabber.el delivers excellent console performance and customizable hooks (if you have speech synthesizer software, hook it up to your presence alerts). jabber.el does not yet support PGP encryption, sending and receiving roster items, and various other things. @menu * Contacts:: @end menu @node Contacts, , , Introduction @section Contacts @itemize @bullet @item There is a web page at @uref{http://emacs-jabber.sf.net/}. @item There is a Sourceforge project page at @uref{http://sourceforge.net/projects/emacs-jabber}, with bug and patch trackers. @item There is a mailing list: @email{emacs-jabber-general@@lists.sourceforge.net}, @uref{https://lists.sourceforge.net/lists/listinfo/emacs-jabber-general}, @uref{http://dir.gmane.org/gmane.emacs.jabber.general} @item There is a chat room, @code{jabber.el@@conference.jabber.se}. If you have successfully connected, you can join it by typing @kbd{M-x jabber-muc-join} and entering the address. @end itemize @node Basic operation, Groupchat, Introduction, Top @chapter Basic operation This chapter is intended as an introduction to basic usage of jabber.el. If you have used XMPP before and are familiar with the terminology, you might find it a bit too basic---in that case, just skim it, making sure to pick up the commands mentioned. I'll assume that you have already successfully installed jabber.el; if not, consult the @file{README} file. Also, make sure you have @code{(require 'jabber)} or @code{(load "jabber-autoloads")} in your @file{.emacs}. There are a handful of global keybindings for common commands. They start with @kbd{C-x C-j}, and you can get a list of them by typing @kbd{C-x C-j C-h}. @menu * Do you have a Jabber account?:: * Registering an account:: * Connecting:: * Chatting:: * Presence:: * Presence subscription:: * Roster buffer:: @end menu @node Do you have a Jabber account?, Registering an account, , Basic operation @section Do you have a Jabber account? Jabber has become rather popular as an instant messaging technology. Several sites use it, but often not under the names ``Jabber'' or ``XMPP''. Examples: @itemize @bullet @item Google Talk uses Jabber. If you have a Gmail address, you can use it as a Jabber ID. @xref{Account settings}, for Google-specific configuration. @item LJ Talk (of Livejournal) uses Jabber. Your Jabber ID is @samp{@var{ljusername}@@livejournal.com}. @end itemize @node Registering an account, Connecting, Do you have a Jabber account?, Basic operation @section Registering an account @cindex Registering an account If you do not yet have a Jabber account, you can register one. The registration processes for various servers differ, but many servers support so-called ``in-band registration'', which is described in this section. To register an account, type @kbd{C-u M-x jabber-connect} and enter your desired JID in the form @samp{@var{username}@@@var{server}}. You will be presented with a registration form to fill out and send. There the username you chose will be prefilled. After registration, you can connect to the server as usual. @node Connecting, Chatting, Registering an account, Basic operation @section Connecting @findex jabber-connect-all @findex jabber-connect @findex jabber-disconnect-one @findex jabber-disconnect @cindex Connecting Now, type @kbd{C-x C-j C-c} and enter your JID and password. If you successfully connect, jabber.el will download your roster and display it in a buffer called @code{*-jabber-roster-*}. By default, you will appear as ``online'' to your contacts. To change this to e.g. ``away'', type @kbd{M-x jabber-send-presence} or @kbd{C-x C-j C-p}. @xref{Presence}, for more information. To disconnect, type @kbd{M-x jabber-disconnect} or @kbd{C-x C-j C-d}. Use @kbd{M-x jabber-disconnect-one} to disconnect just one account (or just type @kbd{C-u C-x C-j C-d}). If you don't want to type your JID every time you connect, you can save it in the variable @code{jabber-account-list}. @xref{Account settings}. If you configure more than one account, all of them will be connected when you type @kbd{C-x C-j C-c}, as that key is bound to @code{jabber-connect-all}. To connect only one account, possibly one that's not in your list, type @kbd{M-x jabber-connect} or @kbd{C-u C-x C-j C-c}. @node Chatting, Presence, Connecting, Basic operation @section Chatting @cindex Chatting @findex jabber-chat-with There are several ways to open a chat buffer. The shortest way is to put point over the person you want to chat with in the roster display and hit RET. You can also use the function @code{jabber-chat-with}. This function is bound to @kbd{C-x C-j C-j} in the global keymap. You will be asked to enter a JID in the minibuffer. You can also enter the roster name of one of your contacts. All JIDs and names in your roster can be tab-completed. You can also use menus to access commands. In the roster display, you can access several menus through keystrokes or mouse clicks. You can bring one big menu up by pressing the second mouse button, or you can bring up the ``chat menu'' by typing @kbd{C-c C-c}. If you do the latter while point is on a roster entry, that entry will be the default value when you are asked for whom to chat with. Now, try opening a chat with someone. A buffer named @code{*-jabber-chat-:-@var{person}-*} will be created and selected. Type your message at the end of the buffer, and hit @kbd{RET} to send it. To include a newline in your message, use @kbd{C-j}. When you receive a message from someone, you will see a red indicator in the mode line. You can click this indicator with the mouse, or type @kbd{C-x C-j C-l} to switch to the relevant buffer. @xref{Tracking activity}. @node Presence, Presence subscription, Chatting, Basic operation @section Presence @cindex Presence @cindex Sending presence @findex jabber-send-presence @findex jabber-send-default-presence @vindex jabber-default-show @vindex jabber-default-status @vindex jabber-default-priority @dfn{Presence} is the Jabber term for letting other people know that you are online, and additionally how ``available'' you are. There are three elements to presence: availability state (called ``show''), status message, and priority. Your show state may either be empty (meaning simply ``online''), or one of @code{away}, @code{xa}, @code{dnd} and @code{chat}, meaning ``away'', ``extended away'' (i.e. away for an extended period), ``do not disturb'', and ``free for chat'', respectively. This information is available to everyone subscribing to your presence, but technically it does not restrict anyone's actions. You can chat with people even if you claim to be away. The status message is a short text complementing your show status, such as ``at home'', ``working'', ``phone'', ``playing games'' or whatever you want. It is sent to everyone subscribing to your presence, but not all clients prominently display it to the user. The priority is only interesting if you are running more than one Jabber client at a time accessing the same account. @xref{Resources and priority}. To set your presence, use the function @code{jabber-send-presence} (bound to @kbd{C-x C-j C-p}). It can be called both interactively and in Lisp code. For the latter case, use something like @code{(jabber-send-presence "away" "idle for 10 minutes" 10)}. There are a few shortcuts: @table @kbd @item C-x C-j C-a Send ``away'' presence (with prefix argument, specify status text) @item C-x C-j C-x Send ``extended away'' presence (with prefix argument, specify status text) @item C-x C-j C-o Send default presence (see below) @end table By default, jabber.el sets your presence when you connect. If you want it not to do that, remove @code{jabber-send-current-presence} from @code{jabber-post-connect-hooks}. If you want to change the presence that is sent, change the variables @code{jabber-default-show}, @code{jabber-default-status} and @code{jabber-default-priority}. With jabber.el, you can set your presence remotely. @xref{Ad-Hoc Commands}. @menu * Resources and priority:: * Directed presence:: @end menu @node Resources and priority, Directed presence, , Presence @subsection Resources and priority @cindex Resource @cindex Priority Every connection to an account has a specific name, a @dfn{resource}. The account itself has a JID of the form @samp{@var{username}@@@var{server}} (a @dfn{bare JID}), but the connections have JIDs of the form @samp{@var{username}@@@var{server}/@var{resource}} (a @dfn{full JID}). You can choose the resource name yourself by entering a JID of the latter form at the connection prompt (@pxref{Connecting}), or by configuring it in @code{jabber-account-list} (@pxref{Account settings}) Each session has a @dfn{priority}. The priority determines what happens when a message is sent to the bare JID (i.e. without specifying what connection should receive message). Such messages are delivered to the connection with the highest non-negative priority value. If there are no connections, or if all connections have negative priority, the message is either stored on the server for later delivery or bounced to the sender, depending on the server configuration. If there are several connections with the same priority, the behaviour depends on the server. Some server implementations deliver the message to all such connections, while others choose one connection depending on certain rules. Note that these rules do not apply when a message is sent to a full JID. Such messages are sent to the specified resource, if it is still connected, and otherwise treated as messages to the bare JID. In the chat buffers of jabber.el, messages are sent to whatever JID the last message came from (usually a full JID), or to the bare JID if no message has been received yet. Other clients may have different behaviour. @node Directed presence, , Resources and priority, Presence @subsection Directed presence @cindex directed presence @cindex send directed presence @findex jabber-send-directed-presence You can send ``directed presence'' with @kbd{M-x jabber-send-directed-presence}. This is mostly useful to manage transports---sending directed presence is a way to turn them on and off. You can also send directed presence to an annoying contact to appear as away or offline to that contact. Note, however, that in both of these cases, all subscribed entities will get your next global presence update. @node Presence subscription, Roster buffer, Presence, Basic operation @section Presence subscription @cindex Presence subscription @cindex Subscribing to someone's presence @findex jabber-send-subscription-request Having permission to view the presence status of a person is called @dfn{subscribing to his presence}. Presence subscription between two persons can be asymmetric. Subscription state is shown in the roster display by arrows (@pxref{Customizing the roster buffer}). A left-pointing arrow means that the contact can see your presence (``from''). A right-pointing arrow means that you can see the contact's presence (``to''). The most common case is mutual subscription, a double-ended arrow (``both''). When jabber.el receives a presence subscription request, it will present it to you in a chat buffer, and offer you to choose subscription mode and send a subscription request back to that person. The ``Mutual'' button accepts the request and sends a reciprocal request.@footnote{If this request is superfluous, the server will drop it without bothering the contact.} The ``One-way'' button accepts the request, but doesn't ask for a subscription in return. The ``Decline'' button declines the request. To request subscription to someone, type @kbd{M-x jabber-send-subscription-request}. You will be prompted for the JID to send it to. This command can also be accessed through the Roster menu, by typing @kbd{C-c C-r} in the roster buffer. After that, you will probably want to give the contact a more readable name. The command for that is @code{jabber-roster-change}, which is also available in the Roster menu or by typing @kbd{e} on a person in the roster buffer. @node Roster buffer, , Presence subscription, Basic operation @section The roster buffer @cindex Roster buffer, basics @cindex Menus @cindex Key bindings The roster buffer is called @code{*-jabber-roster-*}. It simply contains a list of the contacts on your roster. If you have several accounts connected, contacts will be grouped by account. In the roster buffer, any command which requires a JID will default to the JID under point when called. These commands can be called through either keyboard menus or mouse menus. To open a menu with the mouse, simply press the second mouse button over the JID in question.@footnote{For some reason, mouse menus don't work in XEmacs. Patches are welcome.} This will bring up a menu with all available actions. The keyboard menus are split into categories: Chat, Roster, Information, MUC (Multi-User Chat, or groupchat) and Services, opened by @kbd{C-c C-c}, @kbd{C-c C-r}, @kbd{C-c C-i}, @kbd{C-c C-m} and @kbd{C-c C-s}, respectively. @vindex jabber-roster-show-bindings A list of keybindings is displayed at the top of the roster buffer. You can turn it off by setting @code{jabber-roster-show-bindings} to nil. @findex jabber-display-roster You can call @code{jabber-display-roster} (bound to @kbd{g}) to redisplay your roster according to changed preferences (@pxref{Customizing the roster buffer}). This will not refetch your roster from the server. Refetching the roster is usually not needed, since updates are pushed to clients automatically. You can choose not to have the roster updated automatically on presence changes (@pxref{Presence alerts}). In that case, you need to call @code{jabber-display-roster} manually. @vindex jabber-show-offline-contacts @cindex Hiding offline contacts @cindex Offline contacts, hiding Please note, that by default offline contacts showed in roster as any others. To hide them, you can use @kbd{o} in roster buffer. To permanently hide them, customize @code{jabber-show-offline-contacts} variable. @node Groupchat, Composing messages, Basic operation, Top @chapter Groupchat @cindex Groupchat @cindex MUC @cindex Chatrooms The groupchat menu can be accessed by typing @kbd{C-c C-m} in the roster buffer. You can also type the commands directly, as will be shown here. @findex jabber-muc-join @cindex Joining a groupchat @cindex Changing nickname @cindex Nickname, changing To join a groupchat, type @kbd{M-x jabber-muc-join}. You will be prompted for the groupchat to join, and your nickname in the groupchat. This nickname doesn't need to have any correlation to your JID; in fact, groupchats are usually (but not always) configured such that only moderators can see your JID. You can change your nickname with @kbd{M-x jabber-muc-nick}. @xref{Configuration}, for setting default nicknames. @cindex Query groupchat @vindex jabber-muc-disable-disco-check When trying to join a room, jabber.el first sends a service discovery info request to the room, to find out whether it exists and what features are enabled (in particular whether the room is password-protected). However, this can cause problems with some buggy MUC services (or services that respond in a way that jabber.el doesn't expect). A workaround for that is to set @code{jabber-muc-disable-disco-check} to @code{t}; however, the bug should be unearthed and fixed. Groupchat messages will be displayed in a buffer called @code{*-jabber-groupchat-:-@var{groupchat}-*}. By default, the buffer name is based on the JID of the chat room. If you want a shorter name, you can add the chat room to your roster and give it a name, using the command @kbd{M-x jabber-roster-change}. The groupchat buffer works much like the chat buffer. It has its own class of alerts (@pxref{Customizing alerts}), and uses activity tracking (@pxref{Tracking activity}). @vindex jabber-muc-completion-delimiter @vindex jabber-muc-looks-personaling-symbols @cindex Groupchat completion @cindex Nick completion in groupchat Also, to save from repeating unnesesary typing you can press @kbd{Tab} key to complete nick of a groupchat member that you are talking with. You can customize your form of personal talking in MUC (@code{jabber-muc-completion-delimiter}) and form of personal talking to you (@code{jabber-muc-looks-personaling-symbols})---see ``jabber-chat'' customization group. Defaults are sane, so it is unlikely that you would want to change this, but... it is Emacs! By default presence updates are logged in the groupchat buffer. Presence updates include announcements when a member joins or leaves a room, as well as moderator actions, like kicks or bans. These announcements can clutter up the group discussion, especially when other participants using mobile clients experiencing frequent network disconnect and reconnects. Which of these announcements and how they are rendered can be configured (@xref{Presence announcements}). @cindex Topic, MUC @findex jabber-muc-set-topic To change the topic of a groupchat, type @kbd{M-x jabber-muc-set-topic}. The current topic is shown in the header line. @findex jabber-muc-leave To leave a groupchat, type @kbd{M-x jabber-muc-leave}. @findex jabber-muc-get-config If you are the owner of a groupchat, you can change its configuration by typing @kbd{M-x jabber-muc-get-config}. A configuration form will be rendered in new buffer. @findex jabber-muc-names @vindex jabber-muc-print-names-format To see which people are in a groupchat, type @kbd{M-x jabber-muc-names}. This gives a list of nicknames, ``affiliations'', and possibly JIDs according @code{jabber-muc-print-names-format}, sorted by ``roles''. @xref{MUC Administration}, for the meaning of roles and affiliations. @menu * Configuration:: * Presence announcements:: * Invitations:: * Private messages:: * MUC Administration:: @end menu @node Configuration, Invitations, , Groupchat @section Configuration @vindex jabber-muc-default-nicknames @vindex jabber-muc-autojoin @findex jabber-muc-autojoin @cindex Default MUC nickname @cindex Autojoin chat rooms @cindex Bookmarks, MUC @findex jabber-edit-bookmarks You can configure jabber.el to use a certain nickname for a certain room, or to automatically join a certain room when you connect. You can do this either by storing bookmarks on the server or by setting Emacs variables. Type @kbd{M-x jabber-edit-bookmarks} to add bookmarks. You can specify the JID of the conference, the name of the conference (not used by jabber.el), whether to automatically join the room, your desired nickname (or leave empty), and the room password (or leave empty). The default nickname for groupchats is the username part of your JID. If you don't use bookmarks, you can set different nicknames for different groups by customizing @code{jabber-muc-default-nicknames}. There you specify the JID of the group, and your preferred nickname. Automatically joining certain rooms when connecting can be accomplished by setting @code{jabber-muc-autojoin} to a list containing the JIDs of the rooms you want to enter. To disable this feature, remove @code{jabber-muc-autojoin} from @code{jabber-post-connect-hooks}. Please note, that @code{jabber-muc-default-nicknames} and @code{jabber-muc-autojoin} are machine-local, but apply to @emph{all} accounts---if you connect several accounts, both will try to connect to the same chat rooms, or use the same nickname. This will lead to confusion. @node Presence announcements @section Presence announcements @vindex jabber-muc-decorate-presence-patterns To limit, highlight, or deemphasize presences announcement messages, customize the variable @code{jabber-muc-decorate-presence-patterns}. @code{jabber-muc-decorate-presence-patterns} is a list of pairs consisting of a regular expression and a face. When a presence announcement matches a regular expression pattern, it will be displayed with the associated face. If the face is @code{nil}, the announcement will not be added to the groupchat. For example, the customization: @example '(jabber-muc-decorate-presence-patterns '(("\\( enters the room ([^)]+)\\| has left the chatroom\\)$") ("." . jabber-muc-presence-dim))) @end example This suppresses display of membership changes (join and leave events) and deemphasizes moderator action to set them off from surrounding chat messages. @node Invitations, Private messages, Configuration, Groupchat @section Invitations @cindex Invitations @findex jabber-muc-invite You can invite someone to a groupchat with @kbd{M-x jabber-muc-invite} (also available in the MUC menu). Pay attention to the order of the arguments---as both users and rooms are just JIDs, it is technically possible to invite a room to a user, but that's probably not what you want. When you receive an invitation, it appears in the chat buffer along with two buttons, ``Accept'' and ``Decline''. Pressing ``Accept'' enters the room, as you would expect. Pressing ``Decline'' gives you an opportunity to state the reason why you're not joining. @node Private messages, MUC Administration, Invitations, Groupchat @section Private messages @cindex Private MUC messages @findex jabber-muc-private You can open a private chat with a participant in a chat room with @kbd{M-x jabber-muc-private} (or by using the MUC menu). This creates a buffer with the name @code{*-jabber-muc-priv-@var{group}-@var{nickname}-*} (customizable by @code{jabber-muc-private-buffer-format}), which behaves mostly like an ordinary chat buffer. This buffer will also be created if someone sends a private message to you. Private MUC messages use the same alerts as normal chat messages. @xref{Message alerts}. @node MUC Administration, , Private messages, Groupchat @section Administration Administration of a MUC room mostly consists of managing roles and affiliations. Roles are temporary, and apply until the user leaves the room. Affiliations are permanent, and based on JIDs. @subsection Roles @findex jabber-muc-set-role @cindex Kicking, MUC @cindex Voice, MUC @cindex Moderator, MUC @cindex Roles, MUC If you have moderator privileges, you can change the role of a participant with @kbd{M-x jabber-muc-set-role}. Kicking means setting the role to ``none''. Granting and revoking voice are ``participant'' and ``visitor'', respectively. ``moderator'' gives moderator privileges, obviously. The possible roles are: @table @samp @item moderator Has voice, can change other people's roles. @item participant Has voice. @item visitor Doesn't have voice (can't send messages to everyone, but can send private messages) @item none Not in room. @end table @subsection Affiliations @findex jabber-muc-set-affiliation @cindex Affiliations, MUC @cindex Banning, MUC If you have admin or owner privileges, you can change the affiliation of a user with @kbd{M-x jabber-muc-set-affiliation}. Affiliation is persistent, and based on JIDs. Depending of your affiliation and the MUC implementation, you might not be allowed to perform all kinds of changes, and maybe not in one step. Affiliations are: @table @samp @item owner Can destroy room, appoint admins, make people members, ban people. @item admin Can make people members or ban people. @item member Can enter the room, and has voice by default. @item none Rights depend on room configuration. The room might be members-only, or grant voice only to members. @item outcast Banned from the room. @end table @node Composing messages, File transfer, Groupchat, Top @chapter Composing messages @findex jabber-compose @cindex composing messages @cindex message composition The chat buffer interface can be inconvenient for some purposes. As you can't use @kbd{RET} to insert a newline (use @kbd{C-j} for that), writing a longer message can be painful. Also, it is not possible to include a subject in the message, or send the message to multiple recipients. These features are implemented by the message composing tool. Type @kbd{M-x jabber-compose} to start it. In the buffer that comes up, you can specify recipients, enter a subject, and type your message. @node File transfer, Services, Composing messages, Top @chapter File transfer @cindex File transfer @cindex Sending files jabber.el has limited support for file transfer. The most important limit is that files sent and received are kept in buffers, so Emacs must be able to allocate enough memory for the entire file, and the file size must be smaller than the maximum buffer size.@footnote{The maximum buffer size depends on in the variable @code{most-positive-fixnum}. On 32-bit systems, this is 128 or 256 megabytes, depending on your Emacs version.} jabber.el is able to exchange files with most Jabber clients (and also some MSN transports), but notably not with the official Google Talk client. The Google Talk client uses a different file transfer protocol which, at the time of this release, has not been published. @menu * Receiving files:: * Sending files:: @end menu @node Receiving files, Sending files, , File transfer @section Receiving files Receiving files requires no configuration. When someone wants to send a file to you, you are asked (through @code{yes-or-no-p}) whether you want to accept the file. If you answer yes, you get to choose where to save the file. If the sender's client is correctly configured (this is often not the case; see below), the file transfer will start. Currently, the only way to watch the progress is to inspect the buffer of the file being transfered; @kbd{C-x C-b} is one way of doing that. @xref{List Buffers, , Listing Existing Buffers, emacs, GNU Emacs Manual}. When the transfer is done, the message ``@var{file} downloaded'' appears in the echo area, and the buffer is killed. @c This truly sucks... If this doesn't happen, it is most likely the sender's fault. The sender needs to have a public IP address, either directly, through port forwarding (in which case the client needs to be configured with the real public IP address), or through an XEP-0065 proxy. If you have activated XML logging (@pxref{Debug options}), you can see the IP address that the other client is asking you to connect to there. Often you will find that this is an internal IP address (often starts with @code{192.168}). See the documentation of the sender's client for setting this up. @node Sending files, , Receiving files, File transfer @section Sending files @cindex proxy, file transfer @cindex file transfer proxy @cindex XEP-0065 proxy To send a file to someone, you need an XEP-0065 proxy.@footnote{This requirement is not inherent in the protocol, only in the current file transfer implementation of jabber.el, and in Emacs versions earlier than 22.} If your Jabber server hosts such a proxy, it will be found automatically, otherwise it needs to be manually configured. You can check whether your Jabber server has a proxy with @kbd{M-x jabber-get-disco-items}; see @ref{Service discovery}. @vindex jabber-socks5-proxies @findex jabber-socks5-query-all-proxies To configure a proxy manually, customize the variable @code{jabber-socks5-proxies}. Putting @code{proxy.jabber.se} there should work. Type @kbd{M-x jabber-socks5-query-all-proxies} to see if the proxies answer. @findex jabber-ft-send Now, you can type @kbd{M-x jabber-ft-send} to send a file to someone. You need to enter the correct full JID, including resource, to get this right. If the contact is logged in with only one client, and you can see it online, just typing the JID or roster name is enough. If you run the command from a chat buffer, the JID of the contact is given as the default value. If the contact has several clients online, you probably want to send the file to a particular one. If you run this command from within a chat buffer, the default target will be the one that last sent a message to you. If you just type a bare JID or a roster name, the client with the highest priority will get the file. If the contact accepts the file, and the contact's client succeeds in connecting to the proxy, jabber.el will send the file through the proxy. During this time, your Emacs will be blocked, so you might want to avoid sending large files over slow connections. @node Services, Personal information, File transfer, Top @chapter Services @cindex Browse buffers Not every Jabber entity is a physical person. There are many automatic entities, called servers, services, components, agents, transports and other names. The use of these is described here. The functions described in this chapter use @dfn{browse buffers}. Browse buffers are named @code{*-jabber-browse-:-@var{service}-*}, sometimes with a numerical suffix. The different menus have the same keybindings as in the roster buffer, and if you call a function operating on a JID while point is over a JID, that JID will be the default value, so you don't have to type it or copy it yourself. You can change the buffer name template by customizing the variable @code{jabber-browse-buffer-format}. @menu * Commands:: * Your home server:: * Transports:: * User directories:: * MUC services:: @end menu @node Commands, Your home server, , Services @section Commands A small number of commands is used for almost all interaction with Jabber services. Essentially, they are all the same: you request a form from the server, fill it in, and send it back. Most of these commands are available under the Service menu, which is opened by typing @kbd{C-c C-s}. Service discovery is under the Info menu instead, which is available under @kbd{C-c C-i}. @menu * Registration:: * Search:: * Ad-Hoc Commands:: * Service discovery:: * Browsing:: @end menu @node Registration, Search, , Commands @subsection Registration @cindex Registration @findex jabber-get-register You can get a registration form for a service by typing @kbd{M-x jabber-get-register} and entering the JID of the service. On success, you get a single-stage form to fill in. There are two buttons at the bottom of the form, ``Submit'' and ``Cancel registration''. ``Submit'' does what you would expect it to, but ``Cancel registration'' cancels any existing registration with the service. Whichever of them you choose, you get a message in the echo area informing whether the operation succeeded. @node Search, Ad-Hoc Commands, Registration, Commands @subsection Search @cindex Search @findex jabber-get-search You can get a search form for a service by typing @kbd{M-x jabber-get-search}. This gives you a single-stage form to fill in. After you press the ``Submit'' button at the bottom, the search results will be displayed in the same buffer. @node Ad-Hoc Commands, Service discovery, Search, Commands @subsection Ad-Hoc Commands @cindex Ad-Hoc Commands @findex jabber-ahc-get-list @findex jabber-ahc-execute-command jabber.el supports a subset of XEP-0050, the standard for Ad-Hoc Commands. As the name implies, this can be used for just about anything. In particular, it is used not only by services, but also by clients (e.g. Psi, and jabber.el itself). To find which commands are available, run ``Request command list'' (@code{jabber-ahc-get-list}).@footnote{This is the same thing as a disco items request to the node @code{http://jabber.org/protocol/commands}.} To run a command from the list, put point over it and run ``Execute command'' (@code{jabber-ahc-execute-command}), accepting the defaults for JID and node. (If you already know those, you could of course enter them yourself.) What happens next depends on the command and the service. In some cases, the service just responds that the command has been run. You may also get a form to fill out. This form may have multiple stages, in which case there are ``Next'' and ``Previous'' buttons for navigating between stages. You may also see ``Complete'', which runs the command skipping any remaining stages of the form, and ``Cancel'', which cancels the command. Currently, jabber.el uses ad-hoc commands for setting presence remotely. If you realize that you forgot to set your client to ``away'' with a low priority, you can do it remotely from any JID from @code{jabber-account-list}. So, you can add disabled JIDs in @code{jabber-account-list} to allow them control your presence.@footnote{Most Jabber servers also support kicking a client off the net by logging in with another client with exactly the same resource.} @node Service discovery, Browsing, Ad-Hoc Commands, Commands @subsection Service discovery @cindex Service discovery @findex jabber-get-disco-items @findex jabber-get-disco-info Service discovery is used to find information about servers, services and clients. There are two kinds of requests: find @dfn{info} about a Jabber entity---i.e. its identity and supported features---and find @dfn{items} related to an entity, where the definition of ``related'' is left to the entity itself. The commands to execute such requests are @code{jabber-get-disco-info} and @code{jabber-get-disco-items}, respectively. These commands can be accessed from the Info menu, which is opened by typing @kbd{C-c C-i}. The commands accept a JID and optionally a ``node''. The result of such a command is displayed in a browse buffer. For an info request, the result just lists the identities and features of the entity. For an item request, the related items are listed. The items may be JIDs, or JIDs with a node. If you put point on one of the items, its JID and node will be the default value for any Jabber command. If you think that the interface to service discovery is awkward and should be replaced with something better, you are completely right. @node Browsing, , Service discovery, Commands @subsection Browsing @cindex Browsing @findex jabber-get-browse Before service discovery, browsing was the way to find information about Jabber entities. Nowadays it is all but superseded, but jabber.el still supports it. You can use it by typing @kbd{M-x jabber-get-browse}. It works much like service discovery. @node Your home server, Transports, Commands, Services @section Your home server @cindex Password change @cindex Changing password @cindex Account removal @cindex Removing an account You can interact with your Jabber server to change your password or remove your account. Both of these can be accomplished by typing @kbd{M-x jabber-get-register} and typing the JID of your server; @pxref{Registration}. @node Transports, User directories, Your home server, Services @section Transports to other IM networks @cindex Gateways @cindex Transports @cindex MSN transport @cindex ICQ transport @cindex AIM transport Some Jabber services make it possible to communicate with users on other instant messaging networks (e.g. MSN, ICQ, AIM), in effect turning your Jabber client into a multi-protocol client. These are called @dfn{gateways} or @dfn{transports}. They work by impersonating you on the legacy network; therefore you need to provide your username and password through registration. @subsection Finding a transport To use such a transport, you first need to find one, obviously. Sometimes your home server provides the transports you need, but you are not limited to those; in principle you can use any transport on the Jabber network. Some transports only accept local users, though. Transports are generally mentioned on the web page of the Jabber server in question. You can also find transports from within the client; @pxref{Service discovery}. @subsection Registering with a transport To register with a transport, type @kbd{M-x jabber-get-register} and enter the JID of the transport. This will open a registration form where you get to fill in your login information; @pxref{Registration}. You can later use this same form to change the information or cancel your registration. After you have registered, the transport will request presence subscription. It needs that to know when you are online, and synchronize your presence on the legacy network. @subsection Contact list Once you are registered, the transport will transfer the contact list from the legacy service. From the Jabber side, it appears as if lots of people suddenly request presence subscription to you. This is somewhat inconvenient, but it is currently the only way that the transport can influence your Jabber contact list, as it is an entity external to your server.@footnote{Of course, jabber.el could do more to alleviate this inconvenience.} When you have accepted these presence subscriptions, the contacts from legacy networks appear as if they were Jabber contacts. @subsection Finding users Some legacy networks have a global database of users, and some transports support searching that database. In that case, you can search for other users with @kbd{M-x jabber-get-search}; @pxref{Search}. @node User directories, MUC services, Transports, Services @section User directories There are some Jabber user directories, usually abbreviated JUDs. The most well-known one is @samp{users.jabber.org}. You can register with such a directory to let other people find you (@pxref{Registration}), and you can search the directory (@pxref{Search}). @node MUC services, , User directories, Services @section MUC services MUC services (Multi-User Chat, chat rooms) are usually not operated by these commands, but by commands specific to the MUC protocol; @pxref{Groupchat}. However, some MUC services offer nickname registration through the registration protocol (@pxref{Registration}), and other commands; @pxref{Ad-Hoc Commands}. @node Personal information, Avatars, Services, Top @chapter Personal information @cindex vCard @cindex Personal information @findex jabber-vcard-get @findex jabber-vcard-edit The Jabber way of handling personal information (name, addresses, phone numbers, etc) is ``vCards'' encoded in XML.@footnote{@xref{XEP-0054}.} You can get information about a user by running @kbd{M-x jabber-vcard-get}, @kbd{M-x jabber-muc-vcard-get} if you in MUC (also available in the MUC menu), and you can edit your own information by running @kbd{M-x jabber-vcard-edit}. The form for editing your information can be slightly confusing---you are allowed to enter any number of addresses, phone numbers and e-mail addresses, each of which has a set of orthogonal properties. You can add and remove items with the @samp{[INS]} and @samp{[DEL]} buttons, respectively. This is also where you set your avatar (@pxref{Avatars}). The size of your avatar file is limited to 8 kilobytes. @node Avatars, Time queries, Personal information, Top @chapter Avatars @cindex avatars @vindex jabber-vcard-avatars-retrieve @vindex jabber-vcard-avatars-publish @vindex jabber-avatar-cache-directory @vindex jabber-chat-buffer-show-avatar jabber.el supports viewing and publishing avatars according to XEP-0153, vCard-Based Avatars. By default, if you have an avatar in your vCard (@pxref{Personal information}), it will be published for others to see, and if other people publish their avatars, they will be displayed in the roster buffer and in the header line of chat buffers, if your Emacs can display images. Otherwise, jabber.el will not fetch avatars at all. To disable retrieval of other people's avatars, set @code{jabber-vcard-avatars-retrieve} to nil. To disable publishing of your own avatar, set @code{jabber-vcard-avatars-publish} to nil. To disable avatars in chat buffer header lines, set @code{jabber-chat-buffer-show-avatar} to nil. There are a number of restrictions on avatar images in the specification. Most of them are not enforced by jabber.el. @itemize @bullet @item The image should be smaller than 8 kilobytes; this is enforced by jabber.el. @item The image height and width should be between 32 and 96 pixels; the recommended size is 64 by 64 pixels. @item The image should be square. @item The image should be in either PNG, GIF, or JPEG format. (jabber.el will behave incorrectly if the image is not in a format supported by Emacs.) @end itemize Avatars are cached in the directory specified by @code{jabber-avatar-cache-directory}, by default @file{~/.emacs.d/jabber-avatar-cache/}.@footnote{The default directory used to be @file{~/.jabber-avatars}. If this directory already exists, it will be used.} The cache is never cleaned, so you might want to do that yourself from time to time. @node Time queries, Useful features, Avatars, Top @chapter Time queries @cindex time query @findex jabber-get-time With @kbd{M-x jabber-get-time}, you can ask what time an entity (client, server or component) thinks it is, and what time zone it thinks it is in. @cindex last online @findex jabber-get-last-online You can query a server about when a certain user was last seen online. Use @kbd{M-x jabber-get-last-online} for that. @cindex uptime, query @cindex idle time, query @findex jabber-get-idle-time You can also ask a client about how long a user has been idle with @kbd{M-x jabber-get-idle-time}. Not all clients answer such queries, e.g. jabber.el doesn't. This command can also tell the uptime of a server or component. The first of these commands uses the old Entity Time protocol (@pxref{XEP-0090}). It has been superseded by XEP-0202, but jabber.el doesn't implement the newer protocol yet. The latter two commands use the Last Activity protocol (@pxref{XEP-0012}). @node Useful features, Message history, Time queries, Top @chapter Useful features jabber.el includes a number of features meant to improve the user interface and do other useful things. @menu * Autoaway:: * Modeline status:: * Keepalive:: * Reconnecting:: * Tracking activity:: * Watch buddies:: * Spell checking:: * Gmail notifications:: * Saving groups roll state:: @end menu @node Autoaway, Modeline status, , Useful features @section Autoaway @cindex autoaway @cindex idle @cindex xprintidle @vindex jabber-autoaway-methods @findex jabber-current-idle-time @findex jabber-xprintidle-program @findex jabber-termatime-get-idle-time @vindex jabber-autoaway-timeout @vindex jabber-autoaway-xa-timeout @vindex jabber-autoaway-status @vindex jabber-autoaway-xa-status @vindex jabber-autoaway-priority @vindex jabber-autoaway-xa-priority It is possible to automatically set your status to ``away'' or ``xa'' when you haven't used your computer for a while. This lets your contacts know that you might not answer immediately. You can customize timeouts (@code{jabber-autoaway-timeout}, @code{jabber-autoaway-xa-timeout}), statuses (@code{jabber-autoaway-status}, @code{jabber-autoaway-xa-status}) and priorityes (@code{jabber-autoaway-priority}, @code{jabber-autoaway-xa-priority}) to set. To activate this feature, add @code{jabber-autoaway-start} to @code{jabber-post-connect-hooks}, e.g: @example (add-hook 'jabber-post-connect-hooks 'jabber-autoaway-start) @end example There are different methods to find how long you have been ``idle''. The method(s) to use is specified by @code{jabber-autoaway-methods} (obsoleted @code{jabber-autoaway--method} will also work). The value of this variable should be a list functions that returns the number of seconds you have been idle (or nil on error). Minimum of values, returned by these functions, is used as ``idle'' time, so default should works well. Three functions are provided (all used by default). @itemize @bullet @item @code{jabber-current-idle-time} is used if your Emacs has the @code{current-idle-time} function (which was introduced in Emacs 22). Note that this method only measures the time since you last interacted with Emacs, and thus disregards activity in other programs. @item @code{jabber-xprintidle-get-idle-time} uses xprintidle @footnote{@uref{http://www.dtek.chalmers.se/~henoch/text/xprintidle.html}} program, if found. You can also manually set @code{jabber-xprintidle-program} to the correct file path. This method uses the same method as @uref{http://www.jwz.org/xscreensaver,XScreensaver} to find your idle time. @item @code{jabber-termatime-get-idle-time} used on GNU/Linux terminals. It uses the access time of the terminal device as a measure of idle time. @end itemize @node Modeline status, Keepalive, Autoaway, Useful features @section Modeline status @cindex Modeline @findex jabber-mode-line-mode @vindex jabber-mode-line-mode @vindex jabber-mode-line-compact By typing @kbd{M-x jabber-mode-line-mode} you toggle display of some status in mode lines. The information is your own presence status, and some numbers showing the status of your roster contacts. By default, there are three numbers, for ``online'' (chatty and online), ``away'' (away, extended away and do not disturb) and offline contacts. If you set @code{jabber-mode-line-compact} to nil, you get a complete breakdown of presence status. That gives you six numbers indicating the number of chatty, online, away, extended away, dnd, and offline contacts, respectively. @node Keepalive, Reconnecting, Modeline status, Useful features @section Keepalive @cindex Keepalive @cindex Detecting lost connections Sometimes network connections are lost without you noticing. This is especially true with Jabber, as it is quite reasonable to keep the connection open for a long time without either sending or receiving any data. On the other hand, the server may want to do the same kind of detection, and may expect the client to send something at regular intervals. If you want to detect a lost connection earlier, or make sure that the server doesn't drop your connection, you can use the keepalive functions. These come in two flavours: whitespace pings and XMPP pings. @subsection Whitespace pings @cindex Whitespace pings A @dfn{whitespace ping} is a single space character sent to the server. This is often enough to make NAT devices consider the connection ``alive'', and likewise for certain Jabber servers, e.g. Openfire. It may also make the OS detect a lost connection faster---a TCP connection on which no data is sent or received is indistinguishable from a lost connection. @findex jabber-whitespace-ping-start @findex jabber-whitespace-ping-stop Type @kbd{M-x jabber-whitespace-ping-start} to start it, and @kbd{M-x jabber-whitespace-ping-stop} to stop it. The former is in @code{jabber-post-connect-hooks} by default; @pxref{Hooks}. @vindex jabber-whitespace-ping-interval The frequency of whitespace pings is controlled by the variable @code{jabber-whitespace-ping-interval}. The default value is once every 30 seconds. @subsection XMPP pings These functions work by sending a ping request to your server once in a while (by default every ten minutes), and considering the connection lost if the server doesn't answer within reasonable time (by default 20 seconds). @findex jabber-keepalive-start @findex jabber-keepalive-stop Type @kbd{M-x jabber-keepalive-start} to start it, and @kbd{M-x jabber-keepalive-stop} to stop it. You may want to add @code{jabber-keepalive-start} to @code{jabber-post-connect-hooks}; @pxref{Hooks}. @vindex jabber-keepalive-interval @vindex jabber-keepalive-timeout You can customize the interval and the timeout with the variables @code{jabber-keepalive-interval} and @code{jabber-keepalive-timeout}, respectively. @findex jabber-ping You can also manually ping some client/server by using @kbd{M-x jabber-ping}. Note that pong will be displayed according @code{jabber-alerts-info-messages-hooks} (default is echo in minibuffer). @node Reconnecting, Tracking activity, Keepalive, Useful features @section Reconnecting @cindex Reconnect @cindex Automatic reconnection @vindex jabber-auto-reconnect jabber.el supports automatic reconnection to Jabber server(s) upon lost connection. By default it is off. To turn on, customize the @code{jabber-auto-reconnect} variable. This is of limited use if you have to type your password every time jabber.el reconnects. There are two ways to save your password: you can set it in @code{jabber-account-alist} (@pxref{Account settings}), and you can use @file{password-cache.el}, which is available in recent versions of Gnus and in Emacs 23. Note that you probably want to customize @code{password-cache-expiry} if you use the latter. @node Tracking activity, Watch buddies, Reconnecting, Useful features @section Tracking activity @cindex Activity @findex jabber-activity-mode @vindex jabber-activity-make-strings @vindex jabber-activity-query-unread @vindex jabber-activity-count-in-title @vindex jabber-activity-count-in-title-format When you're working on something important you might want to delay responding to incoming messages. However, when you're done working, will you remember them? If you're anything like me, you'll have a lot of buffers in your Emacs session, and a Jabber chat buffer can easily get lost. When @code{jabber-activity-mode} is enabled (by default, it is), Emacs keeps track of the buddies which have messaged you since last you visited their buffer, and will display them in mode line. As soon as you visit their buffer they disappear from the mode line, indicating that you've read their message. If your mode line fills over because of these notifications, you can customize @code{jabber-activity-make-strings} to shorten them to the shortest possibly unambiguous form. If you try to exit Emacs while you still have unread messages, you will be notified and asked about this. If you don't like that, set @code{jabber-activity-query-unread} to nil. If you want to display the number of unread buffers in the frame title, set @code{jabber-activity-count-in-title} to t. The format of the number can be changed through @code{jabber-activity-count-in-title-format}. To hide activity notifications for some contacts, use @code{jabber-activity-banned} variable - just add boring JIDs (as regexps) here. For complete customizability, write a hook function for @code{jabber-activity-update-hook}. From that function, you can take action based on @code{jabber-activity-jids}, @code{jabber-activity-mode-string}, and @code{jabber-activity-count-string}. @node Watch buddies, Spell checking, Tracking activity, Useful features @section Watch buddies @cindex Watch @cindex Online notifications @findex jabber-watch-add @findex jabber-watch-remove Sometimes you might be waiting for a certain person to come online, and you don't want that occasion to get lost in the noise. To get an obtrusive message when that happens, type @kbd{M-x jabber-watch-add} and select the person in question. You can enter a comment, to remember why you added the watch. You will get a message whenever that person goes from offline to online. jabber.el will remember this for the rest of your Emacs session (it's not saved to disk, though), but if you want to get rid of it, type @kbd{M-x jabber-watch-remove}. @node Spell checking, Gmail notifications, Watch buddies, Useful features @section Spell checking @cindex flyspell @cindex Spell checking You can activate spell checking in a chat buffer with @kbd{M-x flyspell-mode}. It will check only what you are currently writing, not what you receive or what you have already sent. You may want to add @code{flyspell-mode} to @code{jabber-chat-mode-hook}. For more information about Emacs spell checking, @pxref{Spelling, , Checking and Correcting Spelling, emacs, GNU Emacs Manual}. @node Gmail notifications, Saving groups roll state, Spell checking, Useful features @section Gmail notifications @cindex Gmail notifications If you are connected to a Google Talk account, you can receive notifications when a new Gmail message arrives. Gmail notifications are enabled by adding the following line to your @file{.emacs}: @example (add-hook 'jabber-post-connect-hooks 'jabber-gmail-subscribe) @end example Default behavior is to display a message that mentions the number of received gmails. You can customize this behavior by providing your own @code{jabber-gmail-dothreads} function. Example: @example (eval-after-load "jabber-gmail" '(defun jabber-gmail-dothreads (threads) "Process elements. THREADS is a list of XML sexps corresponding to elements. See http://code.google.com/apis/talk/jep_extensions/gmail.html#response" (osd "gmail: %d" (length threads)))) ;;; It's usually a good idea to have a shortcut for querying GTalk server. (global-set-key (kbd " g") 'jabber-gmail-query) ;;; The definition of `osd' function used by `jabber-gmail-dothreads'. ;;; `osd_cat' is shipped with the X OSD library ;;; [http://www.ignavus.net/software.html]. (if (and (display-graphic-p) (file-executable-p "/usr/bin/osd_cat")) (defun osd (fmt &rest args) "Display message on X screen." (let ((opts "-p bottom -A center -l 1 \ -f '-adobe-helvetica-bold-r-*-*-24-*-*-*-*-*-iso10646-1'") (msg (apply 'format (concat fmt "\n") args))) (start-process "osd" nil shell-file-name shell-command-switch (format "echo %s | osd_cat %s" (shell-quote-argument msg) opts)))) (defalias 'osd 'message)) @end example @node Saving groups roll state, , Gmail notifications, Useful features @section Saving groups roll state @cindex Saving groups roll state You can save roster's groups rollup/rolldown state between sessions. To do this you need to add @code{jabber-roster-save-groups} to @code{jabber-pre-disconnect-hook} and @code{jabber-roster-restore-groups} to @code{jabber-post-connect-hooks}, respectively. State saved in private storage on server-side (for each account). Note that state restoring working by rolling up groups, rolled up at state saving (by default, all groups rolled down). Also note that at now, @code{jabber-pre-disconnect-hook} run only with @code{jabber-disconnect} (not with @code{jabber-disconnect-one}). @node Message history, Typing notifications, Useful features, Top @chapter Message history @cindex History @cindex Backlog @findex jabber-truncate-top @findex jabber-truncate-muc @findex jabber-truncate-chat @vindex jabber-history-enabled @vindex jabber-history-muc-enabled @vindex jabber-global-history-filename @vindex jabber-use-global-history @vindex jabber-history-dir @vindex jabber-history-enable-rotation @vindex jabber-history-size-limit @vindex jabber-backlog-number @vindex jabber-backlog-days @vindex jabber-log-lines-to-keep If you want a record of messages sent and received, set @code{jabber-history-enabled} to t. If you also want record MUC groupchat messages, set @code{jabber-history-muc-enabled} to t. Messages will be saved in one file per contact in the directory specified by the variable @code{jabber-history-dir} (the default is @file{~/.emacs.d/jabber-history}). If you prefer to store messages for all contacts in a single file, set @code{jabber-use-global-history} to @code{t} and set @code{jabber-global-history-filename} as required.@footnote{Using a global history file used to be the default. If the file specified by @code{jabber-global-history-filename} exists, @code{jabber-use-global-history} will default to @code{t} to support existing installations.} When you open a new chat buffer and have entries in your history file, the last few messages you recently exchanged with the contact in question will be inserted. You can control how many messages with @code{jabber-backlog-number} (by default 10), and how old messages with @code{jabber-backlog-days} (by default 3 days). @findex jabber-chat-display-more-backlog If you want to see more messages, use the function @code{jabber-chat-display-more-backlog}, available in the Chat menu. This is currently the only way to view the message history, apart from opening the history files manually. @cindex Rotation of history files @cindex History file rotation If you worry about your history file(s) size, you can enable history rotation feature by setting the variable @code{jabber-history-enable-rotation} to @code{t} (default is @code{nil}). This feature ``rotates'' your history files according to the following rule: When @code{jabber-history-size-limit} (in kilobytes) is reached, the @var{history-file} is renamed to @file{@var{history-file}-@var{number}}, where @var{number} is 1 or the smallest number after the last rotation. For example, suppose you set the @code{jabber-history-size-limit} variable to 512 and you chat with your buddy @samp{foo@@jabber.server} using the per-contact strategy to store history files. So, when the history file (@file{foo@@jabber-server}) reaches 512K bytes, it will be renamed to @file{foo@@jabber-server-1} and @file{foo@@jabber-server} will be set empty. Next time @file{foo@@jabber-server} grows to 512K bytes, it will be saved as @file{foo@@jabber-server-2} and so on. Although the example was presented with the per-contact history file strategy, history rotation works for both per-contact and global history logging strategies. @cindex Truncate @cindex Truncation If you also want to keep chat and groupchat buffers from growing too much, you can customize @code{jabber-alert-message-hooks} and @code{jabber-alert-muc-hooks} by adding truncation upon receiving message (@code{jabber-truncate-chat} and @code{jabber-truncate-muc}, respectively). The truncation limit may be set by customizing the variable @code{jabber-log-lines-to-keep}. @node Typing notifications, Roster import and export, Message history, Top @chapter Typing notifications There are two protocols for ``contact is typing'' notifications in Jabber. jabber.el supports both of them, displaying various information in the header line of chat buffers. @section Message events @cindex Composing @cindex Delivered @cindex Displayed @vindex jabber-events-request-these @vindex jabber-events-confirm-delivered @vindex jabber-events-confirm-displayed @vindex jabber-events-confirm-composing The older protocol is called Message Events (@pxref{XEP-0022}). Besides typing notification, it lets you know what happens to the messages you send. These states are possible: @itemize @bullet @item @samp{In offline storage} (the user will receive it on next logon) @item @samp{Delivered} to user's client (but not necessarily displayed) @item @samp{Displayed} to user @item User is @samp{typing a message} @end itemize The first state is only reported by servers; the other three are reported by clients. jabber.el can report all three of them, and can display all four; not all clients support all states, though. If you don't want jabber.el to send out this information about you, set the variables @code{jabber-events-confirm-delivered}, @code{jabber-events-confirm-displayed}, and/or @code{jabber-events-confirm-composing} to nil. You can make jabber.el not to request such information by customizing @code{jabber-events-request-these}. @section Chat states @vindex jabber-chatstates-confirm The newer protocol is called Chat States (@pxref{XEP-0085}). Rather than dealing with individual messages, it describes the state of the chat session between two people. The following states are possible: @itemize @bullet @item Active (the default state, not displayed) @item Inactive @item Composing @item Paused (i.e., taking a short pause in composing) @item Gone @end itemize jabber.el can display all five states, but only ever sends ``active'' and ``composing'' itself. To customize sending of chat states, customize the variable @code{jabber-chatstates-confirm}. @node Roster import and export, XMPP URIs, Typing notifications, Top @chapter Roster import and export @findex jabber-export-roster @findex jabber-import-roster @cindex Export roster @cindex Import roster Your roster is saved on the Jabber server, and usually not in the client. However, you might want to save the roster to a file anyway. The most common reason for this is probably to copy it to another account. To export your roster to a file, type @kbd{M-x jabber-export-roster}. A buffer will appear in which you can edit the data to be exported. Changes done in that buffer will not affect your real roster. To import your roster from a file, type @kbd{M-x jabber-import-roster}. You will be able to edit the data before importing it. Items not in the roster will be added; items in the roster will be modified to match imported data. Subscriptions will be updated. The format of the roster files is the XML used by roster pushes in the XMPP protocol, in UTF-8 encoding. @node XMPP URIs, Customization, Roster import and export, Top @chapter XMPP URIs @cindex URIs @cindex URLs @cindex links @cindex xmpp: links @cindex Mozilla integration @cindex web browser integration @cindex browser integration @findex jabber-handle-uri Many web page authors use links starting with @samp{xmpp:} for JIDs. Your web browser could be made to pass such links to jabber.el, so that such links are actually useful and not just decoration. How to do that depends on your operating system and web browser. For any of these methods, you need to make sure that you are running the Emacs server. @xref{Emacs Server, , Using Emacs as a Server, emacs, GNU Emacs Manual}, though the simplest way to start it is to customize the variable @code{server-mode}. @section GNOME The jabber.el distribution contains a GConf schema which tries to set up handling of @samp{xmpp:} URIs. It is installed by @samp{make install}. This may or may not work, depending on your GConf configuration and other installed applications. To check, try running: @example gconftool --get /desktop/gnome/url-handlers/xmpp/command @end example This should print something like: @example /usr/local/libexec/emacs-jabber-uri-handler "%s" @end example This setting is picked up by most GNOME or GTK based web browsers, including Firefox. @section Mozilla and Unix If you use a Mozilla-based web browser on a Unix-like operating system, and the GConf method above doesn't work, you can set it up manually by following these steps: @enumerate @item Note the path of the @file{emacs-jabber-uri-handler} file in the jabber.el distribution, and make sure it is executable. @item Set the Mozilla preference @samp{network.protocol-handler.app.xmpp} to the path of @file{emacs-jabber-uri-handler}. There are two ways to do this: @itemize @item Go to the URL @samp{about:config}, right-click in the list, choose ``New string'', and enter @samp{network.protocol-handler.app.xmpp} and the path in the following dialogs. @item Open or create the file @file{user.js} in your Mozilla profile directory (in the same directory as @file{prefs.js}), and add the following line: @example user_pref("network.protocol-handler.app.xmpp", "@var{/path/to}/emacs-jabber-uri-handler"); @end example Restart Mozilla for this change to take effect. @end itemize @end enumerate @section Other systems If you know how to pass an XMPP URI from your browser to the function @code{jabber-handle-uri}, your contribution for this section would be appreciated. @node Customization, Hacking and extending, XMPP URIs, Top @chapter Customization @findex jabber-customize @cindex Customization jabber.el is intended to be customizable for many tastes. After all, this is Emacs. To open a customization buffer for jabber.el, type @kbd{M-x jabber-customize}. @menu * Account settings:: * Menu:: * Customizing the roster buffer:: * Customizing the chat buffer:: * Customizing alerts:: * Hooks:: * Debug options:: @end menu @node Account settings, Menu, , Customization @section Account settings @cindex Username @cindex Resource @cindex Password @cindex JID @cindex Network server @vindex jabber-account-list All account settings reside in the variable @code{jabber-account-list}. Usually you only need to set the JID, in the form @samp{username@@server} (or @samp{username@@server/resource} to use a specific resource name). These are the other account options: @table @asis @item Disabled If the account is disabled, @code{jabber-connect-all} will not attempt to connect it. You can still connect it manually with @code{jabber-connect}. @item Password You can set the password of the account, so you don't have to enter it when you connect. Note that it will be stored unencrypted in your customization file. @item Network server If the JID of the Jabber server is not also its DNS name, you may have to enter the real DNS name or IP address of the server here. @item Connection type This option specifies whether to use an encrypted connection to the server. Usually you want ``STARTTLS'' (@code{starttls}), which means that encryption is activated if the server supports it. The other possibilities are ``unencrypted'' (@code{network}), which means just that, and ``legacy SSL/TLS'' (@code{ssl}), which means that encryption is activated on connection. @item Port If the Jabber server uses a nonstandard port, specify it here. The default is 5222 for STARTTLS and unencrypted connections, and 5223 for legacy SSL connections. @end table @subsection For Google Talk @cindex Google Talk If you have a very new version of @file{dns.el},@footnote{Specifically, you need Emacs 23, or No Gnus 0.3.} you can connect to Google Talk just by specifying your Gmail address as JID. Otherwise, you also need to set ``network server'' to @kbd{talk.google.com} and ``connection type'' to ``legacy SSL''. See also @ref{Gmail notifications}. @subsection Upgrade note Previous versions of jabber.el had the variables @code{jabber-username}, @code{jabber-server}, @code{jabber-resource} and @code{jabber-password}. These are now obsolete and not used. @node Menu, Customizing the roster buffer, Account settings, Customization @section Menu @vindex jabber-display-menu @cindex Menus There is a Jabber menu on the menu bar with some common commands. By default, it is displayed only if you are connected, or if you have configured any accounts. You can set the variable @code{jabber-display-menu} to @code{t} or @code{nil}, to have the menu displayed always or never, respectively. The default behaviour corresponds to the setting @code{maybe}. @findex jabber-menu Earlier, the way to have the menu appear was to call the function @code{jabber-menu}. It still works, but is considered obsolete. @node Customizing the roster buffer, Customizing the chat buffer, Menu, Customization @section Customizing the roster buffer @cindex Roster buffer, customizing @cindex Sorting the roster @vindex jabber-roster-sort-functions @code{jabber-roster-sort-functions} controls how roster items are sorted. By default, contacts are sorted first by presence, and then alphabetically by displayed name. @vindex jabber-sort-order @code{jabber-sort-order} controls how roster items are sorted by presence. It is a list containing strings corresponding to show status (@pxref{Presence}) or @code{nil}, which represents offline. @vindex jabber-show-resources @code{jabber-show-resources} controls when your contacts' resources are shown in the roster buffer. The default is to show resources when a contact has more than one connected resource. @vindex jabber-roster-line-format @code{jabber-roster-line-format} specifies how the entry for each contact looks. It is a string where some characters are special if preceded by a percent sign: @table @code @item %a Avatar of contact, if any @item %c @samp{*} if the contact is connected, or @samp{ } if not @item %u Subscription state---see below @item %n Nickname of contact, or JID if no nickname @item %j Bare JID of contact (without resource) @item %r Highest-priority resource of contact @item %s Availability of contact as a string ("Online", "Away" etc) @item %S Status string specified by contact @end table @code{jabber-roster-show-title} controls whether to show a "Jabber roster" string at the top of the roster buffer. You need to run @kbd{M-x jabber-display-roster} after changing this variable to update the display. @code{%u} is replaced by one of the strings given by `jabber-roster-subscription-display'. @vindex jabber-resource-line-format @code{jabber-resource-line-format} is nearly identical, except that the values correspond to the values of the resource in question, and that the @code{%p} escape is available, which inserts the priority of the resource. @vindex jabber-roster-buffer @code{jabber-roster-buffer} specifies the name of the roster buffer. If you change this, the new name will be used the next time the roster is redisplayed. @vindex jabber-roster-show-bindings @code{jabber-roster-show-bindings} controls whether to show a list of keybindings at the top of the roster buffer. You need to run @kbd{M-x jabber-display-roster} after changing this variable to update the display. @node Customizing the chat buffer, Customizing alerts, Customizing the roster buffer, Customization @section Customizing the chat buffer @cindex Chat buffer @cindex Timestamps @cindex Faces, chat buffer You can customize the look of the prompts in the chat buffer. There are separate settings for local text (i.e. what you write) and foreign text (i.e. what other people write). @vindex jabber-chat-text-local @vindex jabber-chat-text-foreign @code{jabber-chat-text-local} and @code{jabber-chat-text-foreign} determine the faces used for chat messages. @vindex jabber-chat-prompt-local @vindex jabber-chat-prompt-foreign @vindex jabber-muc-colorize-local @vindex jabber-muc-colorize-foreign @vindex jabber-muc-nick-saturation @vindex jabber-muc-nick-value @vindex jabber-muc-participant-colors @cindex Nick coloring @code{jabber-chat-prompt-local} and @code{jabber-chat-prompt-foreign} determine the faces used for the prompts. You can also turn on automatic colorization of local (@code{jabber-muc-colorize-local}) and/or foreign (@code{jabber-muc-colorize-foreign}) prompts. By default it is off. You can correct and save for future use auto-generated colors by customizing @code{jabber-muc-participant-colors}, @code{jabber-muc-nick-saturation} and @code{jabber-muc-nick-value}, if you wish. @vindex jabber-chat-local-prompt-format @vindex jabber-chat-foreign-prompt-format @code{jabber-chat-local-prompt-format} and @code{jabber-chat-foreign-prompt-format} determine what text is displayed in the prompts. They are format strings, with the following special sequences defined: @table @code @item %t The time when the message was sent or received @item %n The nickname of the user. For the foreign prompt, this is the name of the contact in the roster, or the JID if no name set. For the local prompt, this is the username part of your JID. @item %u The username of the user (i.e. the first part of the JID). @item %r The resource. @item %j The bare JID of the user @end table @cindex Timestamp format @vindex jabber-chat-time-format @code{jabber-chat-time-format} defines how @code{%t} shows time. Its format is identical to that passed to @code{format-time-string}. @xref{Time Conversion, , Time Conversion, elisp, GNU Emacs Lisp Reference Manual}. @vindex jabber-chat-delayed-time-format @code{jabber-chat-delayed-time-format} is used instead of @code{jabber-chat-time-format} for delayed messages (messages sent while you were offline, or fetched from history). This way you can have short timestamps everywhere except where you need long ones. You can always see the complete timestamp in a tooltip by hovering over the prompt with the mouse. @cindex Rare timestamps @vindex jabber-print-rare-time @vindex jabber-rare-time-format @vindex jabber-chat-text-local By default, timestamps are printed in the chat buffer every hour (at ``rare'' times). This can be toggled with @code{jabber-print-rare-time}. You can customize the displayed time by setting @code{jabber-rare-time-format}. Rare timestamps will be printed whenever time formatted by that format string would change. @cindex Header line of chat buffers @vindex jabber-chat-header-line-format @vindex jabber-muc-header-line-format You can also customize the header line of chat buffers, by modifying the variable @code{jabber-chat-header-line-format}. The format of that variable is the same as that of @code{mode-line-format} and @code{header-line-format}. @xref{Mode Line Format, , Mode-Line Format, elisp, GNU Emacs Lisp Reference Manual}. For MUC buffers, @code{jabber-muc-header-line-format} is used instead. @vindex jabber-chat-fill-long-lines @cindex Filling long lines in chat buffer The variable @code{jabber-chat-fill-long-lines} controls whether long lines in the chat buffer are wrapped. @node Customizing alerts, Hooks, Customizing the chat buffer, Customization @section Customizing alerts @cindex Alert hooks @findex define-jabber-alert When an event happens (currently including presence changes, incoming messages, and completed queries) you will usually want to be notified. Since tastes in this area vary wildly, these alerts are implemented as hooks, so you can choose which ones you want, or write your own if none fit. Actually, if you don't want to write your own, stop reading this section and just read @ref{Standard alerts}. Many kinds of alerts consist in displaying a text message through a certain mechanism. This text message is provided by a function which you can rewrite or replace. If this function returns @code{nil}, no message is displayed, and non-textual alerts refrain from action. If you want to write alert hooks that do nothing except displaying the supplied message in some way, use the macro @code{define-jabber-alert}. For example, if @var{foo} is a function that takes a string as an argument, write @example (define-jabber-alert foo "Display a message in a fooish way" 'foo) @end example @noindent and all details will be taken care of for you. The hooks take different arguments depending on category. However, they all have in common that the last argument is the result of the message function. The message function for each category takes the same arguments as the corresponding hooks, except for that last argument. Alert hook contributions are very welcome. You can send them to the mailing list, or to the Sourceforge patch tracker. @xref{Contacts}. Alert hooks are meant for optional UI things, that are subject to varying user tastes, and that can be toggled by simply adding or removing the function to and from the hook. For other purposes, there are corresponding general hooks, that are defvars instead of defcustoms, and that are meant to be managed by Lisp code. They have the same name as the alert hooks minus the @code{-alert} part, e.g. @code{jabber-message-hooks} vs @code{jabber-alert-message-hooks}, etc. @menu * Standard alerts:: * Presence alerts:: * Message alerts:: * MUC alerts:: * Info alerts:: @end menu @node Standard alerts, Presence alerts, , Customizing alerts @subsection Standard alerts @cindex Alerts @cindex Scroll Thirteen alerts are already written for all four alert categories. These all obey the result from the corresponding message function. The @code{beep} alerts simply sound the terminal bell by calling @code{ding}. They are disabled by default. The @code{echo} alerts display a message in the echo area by calling @code{message}. They are enabled by default. The @code{switch} alerts switch to the buffer where the event occurred (chat buffer for incoming messages, roster buffer for presence changes, browse buffer for completed queries). They are disabled by default. Take care when using them, as they may interrupt your editing. The @code{display} alerts display but do not select the buffer in question, using the function @code{display-buffer}. @xref{Choosing Window, , Choosing a Window for Display, elisp, GNU Emacs Lisp Reference Manual}, for information about customizing its behaviour. This is enabled by default for info requests. @cindex Sound effects The @code{wave} alerts play a sound file by calling @code{play-sound-file}. No sound files are provided. To use this, enter the names of the sound files in @code{jabber-alert-message-wave}, @code{jabber-alert-presence-wave} and @code{jabber-alert-info-wave}, respectively. You can specify specific sound files for contacts matching a regexp in the variables @code{jabber-alert-message-wave-alist} and @code{jabber-alert-presence-wave-alist}. @cindex Screen terminal manager The @code{screen} alerts send a message through the Screen terminal manager@footnote{See @uref{http://www.gnu.org/software/screen/}.}. They do no harm if called when you don't use Screen. @cindex Tmux terminal manager The @code{tmux} alerts send a message through the tmux terminal manager@footnote{See @uref{http://tmux.sourceforge.net/}.}. @cindex Ratpoison window manager @cindex Window manager, Ratpoison The @code{ratpoison} alerts send a message through the Ratpoison window manager@footnote{See @uref{http://ratpoison.sourceforge.net/}.}. They do no harm if used when you're not running X, but if you are running X with another window manager, the ratpoison processes will never exit. Emacs doesn't hold on to them, though. @cindex Sawfish window manager @cindex Window manager, Sawfish The @code{sawfish} alerts send a message through the Sawfish window manager. @cindex wmii window manager @cindex Window manager, wmii The @code{wmii} alerts display a message through the wmii window manager. @cindex awesome window manager @cindex Window manager, awesome The @code{awesome} alerts display a message through the awesome window manager. However, to work it needs naughty (i.e. @code{require("naughty")} in rc.lua). @cindex xmessage @vindex jabber-xmessage-timeout The @code{xmessage} alerts send a message through the standard @code{xmessage} tool. The variable @code{jabber-xmessage-timeout} controls how long the alert appears. @cindex OSD The @code{osd} alerts send a message onto your screen using XOSD.@footnote{XOSD can be found at @uref{http://www.ignavus.net/software.html}. You also need @file{osd.el} from @uref{http://www.brockman.se/software/osd.el}.} @cindex notifications.el The @code{notifications} alerts send a message using Emacs built-in package @file{notifications.el}. Note that @file{notifications.el} first appear in Emacs 24.1, so they are disabled by default. @cindex libnotify @cindex notification-daemon The @code{libnotify} alerts send a message onto your screen using @code{notification-daemon}. @cindex Festival speech synthesis @cindex Speech synthesis, Festival The @code{festival} alerts speak the message using the Emacs interface of the Festival speech synthesis system@footnote{See @uref{http://www.cstr.ed.ac.uk/projects/festival/}.}. @cindex Autoanswerer The @code{autoanswer} alert is kind of special: it will not show you message/muc alert, but instead will automaticaly answer to sender. See variable `jabber-autoanswer-alist' description for details. @cindex Scroll chat buffers Additionally, for one-to-one and MUC messages, there are @code{scroll} alerts (enabled by default), that aim to do the right thing with chat buffers that are visible but not active. Sometimes you want point to scroll down, and sometimes not. These functions should do what you mean; if they don't, it's a bug. Also, in MUC you can use a family of so-called ``personal'' alerts. They are like other MUC alerts, but fire only on incoming messages addresed directly to you (also known as ``private messages''). One example of such an alert is @code{jabber-muc-echo-personal}, which shows a note for an MUC message only if it was addressed to you. Some of these functions are in the @file{jabber-alert.el} file, and the others are in their own files. You can use them as templates or inspiration for your own alerts. @node Presence alerts, Message alerts, Standard alerts, Customizing alerts @subsection Presence alerts @vindex jabber-alert-presence-message-function @findex jabber-presence-default-message Set @code{jabber-alert-presence-message-function} to your desired function. This function should look like: @example (defun @var{function} (@var{who} @var{oldstatus} @var{newstatus} @var{statustext}) ... ) @end example @var{who} is the JID symbol (@pxref{JID symbols}), @var{oldstatus} and @var{newstatus} are the previous and current stati, respectively, and @var{statustext} is the status message if provided, otherwise nil. @var{oldstatus} and @var{newstatus} can be one of @code{""} (i.e. online), @code{"away"}, @code{"xa"}, @code{"dnd"}, @code{"chat"}, @code{"error"} and @code{nil} (i.e. offline). @var{newstatus} can also be one of @code{"subscribe"}, @code{"subscribed"}, @code{"unsubscribe"} and @code{"unsubscribed"}. The default function, @code{jabber-presence-default-message}, returns @code{nil} if @var{oldstatus} and @var{newstatus} are the same, and in other cases constructs a message from the given data. Another function, @code{jabber-presence-only-chat-open-message}, behave just like @code{jabber-presence-default-message}, but only if conversation buffer for according JID is already open. Use it to show presence notifications only for ``interesting'' contacts. All presence alert hooks take the same arguments plus the additional @var{proposed-alert}, which is the result of the specified message function. This last argument is usually the only one they use. @node Message alerts, MUC alerts, Presence alerts, Customizing alerts @subsection Message alerts @vindex jabber-alert-message-function @findex jabber-message-default-message Set @code{jabber-alert-message-function} to your desired function.@footnote{Logically it should be @code{jabber-alert-message-message-function}, but that would be really ugly.} This function should look like: @example (defun @var{function} (@var{from} @var{buffer} @var{text}) ... ) @end example @var{from} is the JID symbol (@pxref{JID symbols}), @var{buffer} is the buffer where the message is displayed, and @var{text} is the text of the message. The default function, @code{jabber-message-default-message}, returns ``Message from @var{person}'', where @var{person} is the name of the person if specified in the roster, otherwise the JID. All message alert hooks take the same arguments plus the additional @var{proposed-alert}, which is the result of the specified message function. @vindex jabber-message-alert-same-buffer If you don't want message alerts when the chat buffer in question is already the current buffer, set @code{jabber-message-alert-same-buffer} to nil. This affects the behaviour of the default message function, so you'll have to reimplement this functionality if you write your own message function. @node MUC alerts, Info alerts, Message alerts, Customizing alerts @subsection MUC alerts @vindex jabber-alert-muc-function @vindex jabber-muc-alert-self @findex jabber-muc-default-message Set @code{jabber-alert-muc-function} to your desired function. This function should look like: @example (defun @var{function} (@var{nick} @var{group} @var{buffer} @var{text}) ... ) @end example @var{nick} is the nickname, @var{group} is the JID of the group, @var{buffer} is the buffer where the message is displayed, and @var{text} is the text of the message. The default function, @code{jabber-muc-default-message}, returns ``Message from @var{nick} in @var{group}'' or ``Message in @var{group}'', the latter for messages from the room itself. All MUC alert hooks take the same arguments plus the additional @var{proposed-alert}, which is the result of the specified message function. By default, no alert is made for messages from yourself. To change that, customize the variable @code{jabber-muc-alert-self}. @node Info alerts, , MUC alerts, Customizing alerts @subsection Info alerts @vindex jabber-alert-info-message-function @findex jabber-info-default-message Info alerts are sadly underdeveloped. The message function, @code{jabber-alert-info-message-function}, takes two arguments, @var{infotype} and @var{buffer}. @var{buffer} is the buffer where something happened, and @var{infotype} is either @code{'roster} for roster updates, or @code{'browse} for anything that uses the browse buffer (basically anything except chatting). The info alert hooks take an extra argument, as could be expected. @node Hooks, Debug options, Customizing alerts, Customization @section Hooks jabber.el provides various hooks that you can use for whatever purpose. @table @code @vindex jabber-post-connect-hooks @item jabber-post-connect-hooks This hook is called after successful connection and authentication. By default it contains @code{jabber-send-current-presence} (@pxref{Presence}). The hook functions get the connection object as argument. @vindex jabber-lost-connection-hooks @item jabber-lost-connection-hooks This hook is called when you have been disconnected for unknown reasons. Usually this isn't noticed for quite a long time. The hook is called with one argument: the connection object. @vindex jabber-pre-disconnect-hook @item jabber-pre-disconnect-hook This hook is called just before voluntary disconnection, i.e. in @code{jabber-disconnect}, the command to disconnect all accounts. There is currently no hook for disconnection of a single account. @vindex jabber-post-disconnect-hook @item jabber-post-disconnect-hook This hook is called after disconnection of any kind, possibly just after @code{jabber-lost-connection-hook}. @vindex jabber-chat-mode-hook @item jabber-chat-mode-hook This hook is called when a new chat buffer is created. @vindex jabber-browse-mode-hook @item jabber-browse-mode-hook This hook is called when a new browse buffer is created. @vindex jabber-roster-mode-hook @item jabber-roster-mode-hook This hook is called when the roster buffer is created. @end table @node Debug options, , Hooks, Customization @section Debug options These settings provide a lot of information which is usually not very interesting, but can be useful for debugging various things. @vindex jabber-debug-log-xml @cindex XML console @code{jabber-debug-log-xml} activates XML console. All XML stanzas sent and received are logged in the buffer @code{*-jabber-console-@var{jid}-*} (and to specified file if value is string). Also this buffer can be used to send XML stanzas manually. @vindex jabber-console-name-format Format for console buffer name. %s mean connection jid. Default value is @code{*-jabber-console-%s-*}. @vindex jabber-console-truncate-lines Maximum number of lines in console buffer. Use this option to prevent over bloating size of buffer. Set value to 0 if you want to keep all stanzas in buffer, but it's not recommended and may be unsafe. @vindex jabber-debug-keep-process-buffers Usually, the process buffers for Jabber connections are killed when the connection is closed, as they would otherwise just fill up memory. However, they might contain information about why the connection was lost. To keep process buffers, set @code{jabber-debug-keep-process-buffers} to @code{t}. @node Hacking and extending, Protocol support, Customization, Top @chapter Hacking and extending This part of the manual is an attempt to explain parts of the source code. It is not meant to discourage you from reading the code yourself and trying to figure it out, but as a guide on where to look. Knowledge of Jabber protocols is assumed. @menu * Connection object:: * XML representation:: * JID symbols:: * Listening for new requests:: * Sending new requests:: * Extending service discovery:: * Chat printers:: * Stanza chains:: @end menu @node Connection object, XML representation, , Hacking and extending @section Connection object @cindex connection object @cindex account object @cindex FSM Each Jabber connection is represented by a ``connection object''. This object has the form of a finite state machine, and is realized by the library @code{fsm}.@footnote{So far, this library is only distributed with jabber.el. The author hopes that it could be useful for other projects, too.} The various states of this object are defined in @file{jabber-core.el}. They describe the way of the connection through the establishing of a network connection and authentication, and finally comes to the @code{:session-established} state where ordinary traffic takes place. These details are normally opaque to an extension author. As will be noted, many functions expect to receive a connection object, and functions at extension points generally receive such an object in order to pass it on. The following functions simply query the internal state of the connection: @defun jabber-connection-jid connection The @code{jabber-connection-jid} function returns the full JID of @var{connection}, i.e. a string of the form @code{"username@@server/resource"}. @end defun @defun jabber-connection-bare-jid connection The @code{jabber-connection-bare-jid} function returns the bare JID of @var{connection}, i.e. a string of the form @code{"username@@server"}. @end defun @node XML representation, JID symbols, Connection object, Hacking and extending @section XML representation @cindex XML representation The XML representation is the one generated by @file{xml.el} in Emacs, namely the following. Each tag is a list. The first element of the list is a symbol, the name of which is the name of the tag. The second element is an alist of attributes, where the keys are the attribute names in symbol form, and the values are strings. The remaining elements are the tags and data contained within the tag. For example, @example Fnord @end example is represented as @example (foo ((bar . "baz")) (frobozz nil "") "Fnord ") @end example Note the empty string as the third element of the @code{frobozz} list. It is not present in newer (post-21.3) versions of @file{xml.el}, but it's probably best to assume it might be there. @defun jabber-sexp2xml xml-sexp This function takes a tag in list representation, and returns its XML representation as a string. You will normally not need to use this function directly, but it can be useful to see how your sexps will look when sent to the outer, non-Lisp, world. @end defun @defun jabber-send-sexp connection sexp This function sends @var{sexp}, an XMPP stanza in list representation, and sends it over @var{connection}. You will normally use the functions @code{jabber-send-presence}, @code{jabber-send-message} and @code{jabber-send-iq} instead of this function. @end defun @node JID symbols, Listening for new requests, XML representation, Hacking and extending @section JID symbols @vindex jabber-jid-obarray JIDs are sometimes represented as symbols. Its name is the JID, and it is interned in @code{jabber-jid-obarray}. A roster entry can have the following properties: @table @code @item xml The XML tag received from the server on roster update @item name The name of the roster item (just like the XML attribute) @item subscription The subscription state; a string, one of @code{"none"}, @code{"from"}, @code{"to"} and @code{"both"} @item ask The ask state; either @code{nil} or @code{"subscribe"} @item groups A list of strings (possibly empty) containing all the groups the contact is in @item connected Boolean, true if any resource is connected @item show Presence show value for highest-priority connected resource; a string, one of @code{""} (i.e. online), @code{"away"}, @code{"xa"}, @code{"dnd"}, @code{"chat"}, @code{"error"} and @code{nil} (i.e. offline) @item status Presence status message for highest-priority connected resource @item resources Alist. Keys are strings (resource names), values are plists with properties @code{connected}, @code{show}, @code{status} and @code{priority}. @end table Incoming presence information is inserted in @code{resources}, and the information from the resource with the highest priority is inserted in @code{show} and @code{status} by the function @code{jabber-prioritize-resources}. @node Listening for new requests, Sending new requests, JID symbols, Hacking and extending @section Listening for new requests @findex jabber-send-iq @findex jabber-process-iq @findex jabber-signal-error @vindex jabber-iq-get-xmlns-alist @vindex jabber-iq-set-xmlns-alist To listen for new IQ requests, add the appropriate entry in @code{jabber-iq-get-xmlns-alist} or @code{jabber-iq-set-xmlns-alist}. The key is the namespace of the request, and the value is a function that takes two arguments, the connection object, and the entire IQ stanza in list format. @code{jabber-process-iq} reads these alists to determine which function to call on incoming packets. For example, the Ad-Hoc Commands module contains the following: @example (add-to-list 'jabber-iq-set-xmlns-alist (cons "http://jabber.org/protocol/commands" 'jabber-ahc-process)) @end example To send a response to an IQ request, use @samp{(jabber-send-iq @var{connection} @var{sender} "result" @var{query} nil nil nil nil @var{id})}, where @var{query} is the query in list format. @code{jabber-send-iq} will encapsulate the query in an IQ packet with the specified id. To return an error to the Jabber entity that sent the query, use @code{jabber-signal-error}. The signal is caught by @code{jabber-process-iq}, which takes care of sending the error. You can also use @code{jabber-send-iq-error}. @node Sending new requests, Extending service discovery, Listening for new requests, Hacking and extending @section Sending new requests @findex jabber-send-iq @findex jabber-process-iq To send an IQ request, use @code{jabber-send-iq}. It will generate an id, and create a mapping for it for use when the response comes. The syntax is: @example (jabber-send-iq @var{connection} @var{to} @var{type} @var{query} @var{success-callback} @var{success-closure} @var{failure-callback} @var{failure-closure}) @end example @var{success-callback} will be called if the response is of type @samp{result}, and @var{failure-callback} will be called if the response is of type @samp{error}. Both callbacks take three arguments, the connection object, the IQ stanza of the response, and the corresponding closure item earlier passed to @code{jabber-send-iq}. @findex jabber-report-success @findex jabber-process-data Two standard callbacks are provided. @code{jabber-report-success} takes a string as closure item, and reports success or failure in the echo area by appending either @samp{succeeded} or @samp{failed} to the string. @code{jabber-process-data} prepares a browse buffer. If its closure argument is a function, it calls that function with point in this browse buffer. If it's a string, it prints that string along with the error message in the IQ response. If it's anything else (e.g. @code{nil}), it just dumps the XML in the browse buffer. Examples follow. This is the hypothetical Jabber protocol ``frob'', for which only success report is needed: @example (jabber-send-iq connection "someone@@somewhere.org" "set" '(query ((xmlns . "frob"))) 'jabber-report-success "Frobbing" 'jabber-report-success "Frobbing") @end example This will print ``Frobbing succeeded'' or ``Frobbing failed: @var{reason}'', respectively, in the echo area. The protocol ``investigate'' needs to parse results and show them in a browse buffer: @example (jabber-send-iq connection "someone@@somewhere.org" "get" '(query ((xmlns . "investigate"))) 'jabber-process-data 'jabber-process-investigate 'jabber-process-data "Investigation failed") @end example Of course, the previous example could have used @code{jabber-report-success} for the error message. It's a matter of UI taste. @node Extending service discovery, Chat printers, Sending new requests, Hacking and extending @section Service discovery Service discovery (XEP-0030) is a Jabber protocol for communicating features supported by a certain entity, and items affiliated with an entity. jabber.el has APIs for both providing and requesting such information. @menu * Providing info:: * Requesting info:: @end menu @node Providing info, Requesting info, , Extending service discovery @subsection Providing info Your new IQ request handlers will likely want to advertise their existence through service discovery. @vindex jabber-advertised-features To have an additional feature reported in response to disco info requests, add a string to @code{jabber-advertised-features}. @vindex jabber-disco-items-nodes @vindex jabber-disco-info-nodes By default, the service discovery functions reject all requests containing a node identifier with an ``Item not found'' error. To make them respond, add the appropriate entries to @code{jabber-disco-items-nodes} and @code{jabber-disco-info-nodes}. Both variables work in the same way. They are alists, where the keys are the node names, and the values are lists of two items. The first item is the data to return --- either a list, or a function taking the connection object and the entire IQ stanza and returning a list; in either case this list contains the XML nodes to include in the @code{} node in the response. @findex jabber-my-jid-p The second item is the access control function. An access control function receives the connection object and a JID as arguments, and returns non-nil if access is to be granted. If nil is specified instead of a function, access is always granted. One such function is provided, @code{jabber-my-jid-p}, which grants access for JIDs where the username and server (not necessarily resource) are equal to those of the user, or one of the user's configured accounts. @node Requesting info, , Providing info, Extending service discovery @subsection Requesting info jabber.el has a facility for requesting disco items and info. All positive responses are cached. To request disco items or info from an entity, user one of these functions: @defun jabber-disco-get-info jc jid node callback closure-data &optional force Get disco information for @var{jid} and @var{node}. A request is sent asynchronously on the connection @var{jc}. When the response arrives, @var{callback} is called with three arguments: @var{jc}, @var{closure-data}, and the result. The result may be retrieved from the cache, unless @var{force} is non-nil. If the request was successful, or retrieved from cache, it looks like @code{(@var{identities} @var{features})}, where @var{identities} and @var{features} are lists. Each identity is @code{["@var{name}" "@var{category}" "@var{type}"]}, and each feature is a string denoting the namespace of the feature. If the request failed, the result is an @code{} node. @end defun @defun jabber-disco-get-items jc jid node callback closure-data &optional force Get disco information for @var{jid} and @var{node}. A request is sent asynchronously on the connection @var{jc}. When the response arrives, @var{callback} is called with three arguments: @var{jc}, @var{closure-data}, and the result. The result may be retrieved from the cache, unless @var{force} is non-nil. If the request was successful, or retrieved from cache, the result is a list of items, where each item is @code{["@var{name}" "@var{jid}" "@var{node}"]}. The values are either strings or nil. If the request failed, the result is an @code{} node. @end defun If you only want to see what is in the cache, use one of the following functions. They don't use a callback, but return the result directly. @defun jabber-disco-get-info-immediately jid node Return cached disco information for @var{jid} and @var{node}, or nil if the cache doesn't contain this information. The result is the same as for @code{jabber-disco-get-info}. @end defun @defun jabber-disco-get-items-immediately jid node Return cached disco items for @var{jid} and @var{node}, or nil if the cache doesn't contain this information. The result is the same as for @code{jabber-disco-get-items}. @end defun In the future, this facility will be expanded to provide information acquired through XEP-0115, Entity capabilities, which is a protocol for sending disco information in @code{} stanzas. @node Chat printers, Stanza chains, Extending service discovery, Hacking and extending @section Chat printers @vindex jabber-chat-printers @vindex jabber-muc-printers @vindex jabber-body-printers @cindex Chat printers @cindex Body printers Chat printers are functions that print a certain aspect of an incoming message in a chat buffer. Included are functions for printing subjects (@code{jabber-chat-print-subject}), bodies (@code{jabber-chat-print-body}, and @code{jabber:x:oob}-style URLs (@code{jabber-chat-print-url}). The functions in @code{jabber-chat-printers} are called in order, with the entire @code{} stanza as argument. As described in the docstring of @code{jabber-chat-printers}, these functions are run in one of two modes: @code{printp}, in which they are supposed to return true if they would print anything, and @code{insert}, in which they are supposed to actually print something, if appropriate, using the function @code{insert}. For MUC, the functions in @code{jabber-muc-printers} are prepended to those in @code{jabber-chat-printers}. Body printers are a subgroup of chat printers. They are exclusive; only one of them applies to any given message. The idea is that ``higher-quality'' parts of the message override pieces included for backwards compatibility. Included are @code{jabber-muc-print-invite} and @code{jabber-chat-normal-body}; functions for XHTML-IM and PGP encrypted messages may be written in the future. The functions in @code{jabber-body-printers} are called in order until one of them returns non-nil. @node Stanza chains, , Chat printers, Hacking and extending @section Stanza chains @vindex jabber-message-chain @vindex jabber-iq-chain @vindex jabber-presence-chain If you really need to get under the skin of jabber.el, you can add functions to the lists @code{jabber-message-chain}, @code{jabber-iq-chain} and @code{jabber-presence-chain}. The functions in these lists will be called in order when an XML stanza of the corresponding type arrives, with the connection object and the entire XML stanza passed as arguments. Earlier functions can modify the stanza to change the behaviour of downstream functions, but remember: with great power comes great responsibility. @node Protocol support, Concept index, Hacking and extending, Top @appendix Protocol support @cindex Supported protocols These are the protocols currently supported (in full or partially) by jabber.el. @menu * RFC 3920:: XMPP-CORE * RFC 3921:: XMPP-IM * XEP-0004:: Data Forms * XEP-0012:: Last Activity * XEP-0020:: Feature Negotiation * XEP-0022:: Message Events * XEP-0030:: Service Discovery * XEP-0045:: Multi-User Chat * XEP-0049:: Private XML Storage * XEP-0050:: Ad-Hoc Commands * XEP-0054:: vcard-temp * XEP-0055:: Jabber Search * XEP-0065:: SOCKS5 Bytestreams * XEP-0066:: Out of Band Data * XEP-0068:: Field Standardization for Data Forms * XEP-0077:: In-Band Registration * XEP-0078:: Non-SASL Authentication * XEP-0082:: Jabber Date and Time Profiles * XEP-0085:: Chat State Notifications * XEP-0086:: Error Condition Mappings * XEP-0090:: Entity Time * XEP-0091:: Delayed Delivery * XEP-0092:: Software Version * XEP-0095:: Stream Initiation * XEP-0096:: File Transfer * XEP-0146:: Remote Controlling Clients * XEP-0153:: vCard-Based Avatars * XEP-0199:: XMPP Ping * XEP-0245:: The /me Command @end menu @node RFC 3920, RFC 3921, , Protocol support @section RFC 3920 (XMPP-CORE) Most of RFC 3920 is supported, with the following exceptions. SASL is supported only when an external SASL library from FLIM or Gnus is present. As SASL is an essential part to XMPP, jabber.el will send pre-XMPP stream headers if it is not available. None of the stringprep profiles are implemented. jabber.el changes JIDs to lowercase internally; that's all. jabber.el doesn't interpret namespace prefixes. The @code{xml:lang} attribute is neither interpreted nor generated. SRV records are used if a modern version of @code{dns.el} is installed. @node RFC 3921, XEP-0004, RFC 3920, Protocol support @section RFC 3921 (XMPP-IM) Most of RFC 3921 is supported, with the following exceptions. Messages of type ``headline'' are not treated in any special way. The @code{} element is not used or generated. Sending ``directed presence'' is supported; however, presence stanzas received from contacts not in roster are ignored. Privacy lists are not supported at all. jabber.el doesn't support XMPP-E2E or ``im:'' CPIM URIs. @node XEP-0004, XEP-0012, RFC 3921, Protocol support @section XEP-0004 (Data Forms) XEP-0004 support is good enough for many purposes. Limitations are the following. Forms in incoming messages are not interpreted. See each specific protocol for whether forms are accepted in that context. ``Cancel'' messages are probably not consistently generated when they should be. This is partly a paradigm clash, as jabber.el doesn't use modal dialog boxes but buffers which can easily be buried. @code{} elements are not enforced. The field types ``jid-single'', ``jid-multi'' and ``list-multi'' are not implemented, due to programmer laziness. Let us know if you need them. @node XEP-0012, XEP-0020, XEP-0004, Protocol support @section XEP-0012 (Last Activity) jabber.el can generate all three query types described in the protocol. However, it does not answer to such requests. @node XEP-0020, XEP-0022, XEP-0012, Protocol support @section XEP-0020 (Feature Negotiation) There are no known limitations or bugs in XEP-0020 support. @node XEP-0022, XEP-0030, XEP-0020, Protocol support @section XEP-0022 (Message Events) jabber.el understands all four specified kinds of message events (offline, delivered, displayed, and composing) and by default requests all of them. It also reports those three events that make sense for clients. @node XEP-0030, XEP-0045, XEP-0022, Protocol support @section XEP-0030 (Service Discovery) Service discovery is supported, both as client and server. When used in the code, service discovery results are cached indefinitely. @node XEP-0045, XEP-0049, XEP-0030, Protocol support @section XEP-0045 (Multi-User Chat) jabber.el supports parts of XEP-0045. Entering, leaving and chatting work. So do invitations and private messages. Room configuration is supported. Changing roles of participants (basic moderation) is implemented, as is changing affiliations, but requesting affiliation lists is not yet supported. @node XEP-0049, XEP-0050, XEP-0045, Protocol support @section XEP-0049 (Private XML Storage) jabber.el contains an implementation of XEP-0049; It is used for bookmarks and roster's groups roll state saving. @node XEP-0050, XEP-0054, XEP-0049, Protocol support @section XEP-0050 (Ad-Hoc Commands) jabber.el is probably the first implementation of XEP-0050 (see @uref{http://article.gmane.org/gmane.network.jabber.devel/21413, post on jdev from 2004-03-10}). Both the client and server parts are supported. @node XEP-0054, XEP-0055, XEP-0050, Protocol support @section XEP-0054 (vcard-temp) Both displaying other users' vCards and editing your own vCard are supported. The implementation tries to follow the schema in the XEP accurately. @node XEP-0055, XEP-0065, XEP-0054, Protocol support @section XEP-0055 (Jabber Search) XEP-0055 is supported, both with traditional fields and with Data Forms (@pxref{XEP-0004}). As the traditional fields specified by the XEP is a subset of those allowed in XEP-0077, handling of those two form types are merged. @xref{XEP-0077}. @node XEP-0065, XEP-0066, XEP-0055, Protocol support @section XEP-0065 (SOCKS5 Bytestreams) XEP-0065 is supported. Currently jabber.el cannot act as a server, not even on on Emacsen that support server sockets (GNU Emacs 22 and up). Therefore it relies on proxies. Proxies have to be entered and queried manually. Psi's ``fast mode'' (@uref{http://delta.affinix.com/specs/stream.html}), which gives greater flexibility with regards to NAT, is not implemented. @node XEP-0066, XEP-0068, XEP-0065, Protocol support @section XEP-0066 (Out of Band Data) jabber.el will display URLs sent in message stanzas qualified by the @code{jabber:x:oob} namespace, as described in this XEP. Sending such URLs or doing anything with iq stanzas (using the @code{jabber:iq:oob} namespace) is not supported. @node XEP-0068, XEP-0077, XEP-0066, Protocol support @section XEP-0068 (Field Standardization for Data Forms) XEP-0068 is only used in the context of creating a new Jabber account, to prefill the username field of the registration form. @node XEP-0077, XEP-0078, XEP-0068, Protocol support @section XEP-0077 (In-Band Registration) In-band registration is supported for all purposes. That means registering a new Jabber account, changing Jabber password, removing a Jabber account, registering with a service, and cancelling registration to a service. Data forms are supported as well. URL redirections are not. jabber.el will not prevent or alert a user trying to change a password over an unencrypted connection. @node XEP-0078, XEP-0082, XEP-0077, Protocol support @section XEP-0078 (Non-SASL Authentication) Non-SASL authentication is supported, both plaintext and digest. Digest is preferred, and a warning is displayed to the user if only plaintext is available. @node XEP-0082, XEP-0085, XEP-0078, Protocol support @section XEP-0082 (Jabber Date and Time Profiles) The DateTime profile of XEP-0082 is supported. Currently this is only used for file transfer. @node XEP-0085, XEP-0086, XEP-0082, Protocol support @section XEP-0085 (Chat State Notifications) XEP-0085 is partially supported. Currently only active/composing notifications are @emph{sent} though all five notifications are handled on receipt. @node XEP-0086, XEP-0090, XEP-0085, Protocol support @section XEP-0086 (Error Condition Mappings) Legacy errors are interpreted, but never generated. XMPP style error messages take precedence when errors are reported to the user. @node XEP-0090, XEP-0091, XEP-0086, Protocol support @section XEP-0090 (Entity Time) jabber.el can query other entities for their time, and return the current time to those who ask. @node XEP-0091, XEP-0092, XEP-0090, Protocol support @section XEP-0091 (Delayed Delivery) The time specified on delayed incoming messages is interpreted, and displayed in chat buffers instead of the current time. @node XEP-0092, XEP-0095, XEP-0091, Protocol support @section XEP-0092 (Software Version) The user can request the version of any entity. jabber.el answers version requests to anyone, giving ``jabber.el'' as name, and the Emacs version as OS. @node XEP-0095, XEP-0096, XEP-0092, Protocol support @section XEP-0095 (Stream Initiation) XEP-0095 is supported, both incoming and outgoing, except that jabber.el doesn't check service discovery results before sending a stream initiation request. @node XEP-0096, XEP-0146, XEP-0095, Protocol support @section XEP-0096 (File Transfer) Both sending and receiving files is supported. If a suitable program is found, MD5 hashes of outgoing files are calculated and sent. However, hashes of received files are not checked. Ranged transfers are not supported. In-band bytestreams are not yet supported, even though XEP-0096 requires them. @node XEP-0146, XEP-0153, XEP-0096, Protocol support @section XEP-0146 (Remote Controlling Clients) The ``set-status'' command in XEP-0146 is supported. @node XEP-0153, XEP-0199, XEP-0146, Protocol support @section XEP-0153 (vCard-Based Avatars) vCard-based avatars are supported, both publishing and displaying. The pixel size limits on avatars are not enforced. @node XEP-0199, XEP-0245, XEP-0153, Protocol support @section XEP-0199 (XMPP Ping) XEP-0199 is fully supported. @node XEP-0245, ,XEP-0199, Protocol support @section XEP-0245 (/me Command) XEP-0245 is partially supported (except XHTML-IM). @node Concept index, Function index, Protocol support, Top @unnumbered Concept index @printindex cp @node Function index, Variable index, Concept index, Top @unnumbered Function index @printindex fn @node Variable index, , Function index, Top @unnumbered Variable index @printindex vr @bye emacs-jabber/lisp/000077500000000000000000000000001476345337400143605ustar00rootroot00000000000000emacs-jabber/lisp/deprecated/000077500000000000000000000000001476345337400164605ustar00rootroot00000000000000emacs-jabber/lisp/deprecated/README.org000066400000000000000000000003071476345337400201260ustar00rootroot00000000000000#+TITLE: Deprecated Features Anything listed here is no longer maintained, will not be tangled and compiled at build time, and may lose compatibility with existing features. Here there be dragons. emacs-jabber/lisp/deprecated/jabber-ft-client.el000066400000000000000000000051161476345337400221150ustar00rootroot00000000000000;;; jabber-ft-client.el --- send file transfer requests, by JEP-0096 -*- lexical-binding: t; -*- ;; 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 ;;; Code: (eval-when-compile (require 'cl-lib)) (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)) (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) ;;; jabber-ft-client.el ends hereemacs-jabber/lisp/deprecated/jabber-ft-common.el000066400000000000000000000035401476345337400221260ustar00rootroot00000000000000;;; jabber-ft-common.el --- Common functions for sending and receiving files (JEP-0096) -*- lexical-binding: t; -*- ;; Copyright (C) 2006, 2008 Magnus Henoch ;; Author: Magnus Henoch ;; 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) ;;; jabber-ft-common.el ends hereemacs-jabber/lisp/deprecated/jabber-ft-server.el000066400000000000000000000116711476345337400221500ustar00rootroot00000000000000;;; jabber-ft-server.el --- handle incoming file transfers, by JEP-0096 -*- lexical-binding: t; -*- ;; 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)))))) (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) ;;; jabber-ft-server.el ends hereemacs-jabber/lisp/deprecated/jabber-gmail.el000066400000000000000000000075601476345337400213260ustar00rootroot00000000000000;;; jabber-gmail.el --- Gmail notifications via emacs-jabber -*- lexical-binding: t; -*- ;; Copyright (C) 2008 Magnus Henoch ;; Copyright (C) 2007 Valery V. Vorotyntsev ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License ;; as published by the Free Software Foundation; either version 2 ;; of the License, or (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Usage: ;; Add the following line to your ~/.emacs: ;; ;; (require 'jabber-gmail) ;; ;; If you prefer on demand loading ;; [http://a-nickels-worth.blogspot.com/2007/11/effective-emacs.html]: ;; ;; (autoload 'jabber-gmail-query "jabber-gmail") ;; (autoload 'jabber-gmail-subscribe "jabber-gmail") ;; (add-hook 'jabber-post-connect-hook 'jabber-gmail-subscribe) ;; ;; You may wish to bind a shortcut for `jabber-gmail-query' ;; ;; (global-set-key (kbd " g") 'jabber-gmail-query) ;; ;; or to customize `jabber-gmail-dothreads' ;; ;; (defun jabber-gmail-dothreads (ts) ;; (let ((msg (format "%d new messages in gmail inbox" (length ts)))) ;; (message msg) ;; (jabber-screen-message msg))) (require 'jabber-util) (require 'jabber-iq) (require 'jabber-xml) (require 'jabber-chat) ;;;###autoload (defun jabber-gmail-subscribe (jc) "Subscribe to gmail notifications. See http://code.google.com/apis/talk/jep_extensions/usersettings.html#4" (interactive (list (jabber-read-account))) (jabber-send-iq jc (jabber-connection-bare-jid jc) "set" '(usersetting ((xmlns . "google:setting")) (mailnotifications ((value . "true")))) #'jabber-report-success "Gmail subscription" #'jabber-process-data "Gmail subscription") ;; Looks like "one shot" request is still needed to activate ;; notifications machinery. (jabber-gmail-query jc)) (add-to-list 'jabber-iq-set-xmlns-alist (cons "google:mail:notify" #'jabber-gmail-process-new-mail)) (defun jabber-gmail-process-new-mail (jc xml-sexp) "Process new gmail notification. See http://code.google.com/apis/talk/jep_extensions/gmail.html#notifications" (let ((from (jabber-xml-get-attribute xml-sexp 'from)) (id (jabber-xml-get-attribute xml-sexp 'id))) ;; respond to server (jabber-send-iq jc from "result" nil nil nil nil nil id)) (jabber-gmail-query jc)) ;;;###autoload (defun jabber-gmail-query (jc) "Request mail information from the Google Talk server (a.k.a. one shot query). See http://code.google.com/apis/talk/jep_extensions/gmail.html#requestmail" (interactive (list (jabber-read-account))) (jabber-send-iq jc (jabber-connection-bare-jid jc) "get" '(query ((xmlns . "google:mail:notify"))) #'jabber-gmail-process-mailbox nil #'jabber-process-data "Gmail query" "gmail-query")) (defun jabber-gmail-process-mailbox (_jc xml-sexp &rest _ignore) "Process gmail query response. See http://code.google.com/apis/talk/jep_extensions/gmail.html#response" (let ((ts (jabber-xml-node-children (car (jabber-xml-get-children xml-sexp 'mailbox))))) (when ts (jabber-gmail-dothreads ts)))) (defun jabber-gmail-dothreads (threads) "Process elements. THREADS is a list of XML sexps, corresponding to elements. See http://code.google.com/apis/talk/jep_extensions/gmail.html#response" (message "%d new messages in gmail inbox" (length threads))) (provide 'jabber-gmail) ;;; jabber-gmail.el ends hereemacs-jabber/lisp/deprecated/jabber-si-client.el000066400000000000000000000053751476345337400221260ustar00rootroot00000000000000;;; jabber-si-client.el --- send stream requests, by JEP-0095 -*- lexical-binding: t; -*- ;; 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 ;;; Code: (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) ;;; jabber-si-client.el ends hereemacs-jabber/lisp/deprecated/jabber-si-common.el000066400000000000000000000037311476345337400221320ustar00rootroot00000000000000;;; jabber-si-common.el --- stream initiation (JEP-0095) -*- lexical-binding: t; -*- ;; Copyright (C) 2006 Magnus Henoch ;; Author: Magnus Henoch ;; 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) ;;; jabber-si-common.el ends here emacs-jabber/lisp/deprecated/jabber-si-server.el000066400000000000000000000073621476345337400221540ustar00rootroot00000000000000;;; jabber-si-server.el --- handle incoming stream requests, by JEP-0095 -*- lexical-binding: t; -*- ;; 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 nil (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) ;;; jabber-si-server.el ends hereemacs-jabber/lisp/deprecated/jabber-socks5.el000066400000000000000000000615401476345337400214420ustar00rootroot00000000000000;;; jabber-socks5.el --- SOCKS5 bytestreams by JEP-0065 -*- lexical-binding: t; -*- ;; 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 ;;; Code: (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-lib)) (defvar jabber-socks5-pending-sessions nil "List of pending sessions. Each entry is a list, containing: * Stream ID * Full JID of initiator * State machine managing the session") (defvar jabber-socks5-active-sessions nil "List of active sessions. Each entry is a list, containing: * Network connection * Stream ID * Full JID of initiator * Profile data function") (defcustom jabber-socks5-proxies nil "JIDs of XEP-0065 proxies to use for file transfer. Put preferred ones first." :type '(repeat string) :group 'jabber ; :set 'jabber-socks5-set-proxies) ) (defvar jabber-socks5-proxies-data nil "Alist containing information about proxies. Keys of the alist are strings, the JIDs of the proxies. Values are \"streamhost\" XML nodes.") (jabber-disco-advertise-feature "http://jabber.org/protocol/bytestreams") (add-to-list 'jabber-si-stream-methods (list "http://jabber.org/protocol/bytestreams" 'jabber-socks5-client-1 'jabber-socks5-accept)) (defun jabber-socks5-set-proxies (symbol value) "Set `jabber-socks5-proxies' and query proxies. This is the set function of `jabber-socks5-proxies-data'." (set-default symbol value) (when jabber-connections (jabber-socks5-query-all-proxies))) (defun jabber-socks5-query-all-proxies (jc &optional callback) "Ask all proxies in `jabber-socks5-proxies' for connection information. If CALLBACK is non-nil, call it with no arguments when all proxies have answered." (interactive (list (jabber-read-account))) (setq jabber-socks5-proxies-data nil) (dolist (proxy jabber-socks5-proxies) (jabber-socks5-query-proxy jc proxy callback))) (defun jabber-socks5-query-proxy (jc jid &optional callback) "Query the SOCKS5 proxy specified by JID for IP and port number." (jabber-send-iq jc jid "get" '(query ((xmlns . "http://jabber.org/protocol/bytestreams"))) #'jabber-socks5-process-proxy-response (list callback t) #'jabber-socks5-process-proxy-response (list callback nil))) (defun jabber-socks5-process-proxy-response (_jc xml-data closure-data) "Process response from proxy query." (let* ((query (jabber-iq-query xml-data)) (from (jabber-xml-get-attribute xml-data 'from)) (streamhosts (jabber-xml-get-children query 'streamhost))) (let ((existing-entry (assoc from jabber-socks5-proxies-data))) (when existing-entry (setq jabber-socks5-proxies-data (delq existing-entry jabber-socks5-proxies-data)))) (pcase-let ((`(,callback ,successp) closure-data)) (when successp (setq jabber-socks5-proxies-data (cons (cons from streamhosts) jabber-socks5-proxies-data))) (message "%s from %s. %d of %d proxies have answered." (if successp "Response" "Error") from (length jabber-socks5-proxies-data) (length jabber-socks5-proxies)) (when (and callback (= (length jabber-socks5-proxies-data) (length jabber-socks5-proxies))) (funcall callback))))) (define-state-machine jabber-socks5 :start ((jc jid sid profile-function role) "Start XEP-0065 bytestream with JID. SID is the session ID used. PROFILE-FUNCTION is the function to call upon success. See `jabber-si-stream-methods'. ROLE is either :initiator or :target. The initiator sends an IQ set; the target waits for one." (let ((new-state-data (list :jc jc :jid jid :sid sid :profile-function profile-function :role role)) (new-state ;; We want information about proxies; it might be needed in ;; various situations. (cond ((null jabber-socks5-proxies) ;; We know no proxy addresses. Try to find them by disco. 'seek-proxies) ((null jabber-socks5-proxies-data) ;; We need to query the proxies for addresses. 'query-proxies) ;; So, we have our proxies. (t 'initiate)))) (list new-state new-state-data nil)))) (defun jabber-socks5-accept (jc jid sid profile-function) "Remember that we are waiting for connection from JID, with stream id SID" ;; asking the user for permission is done in the profile (add-to-list 'jabber-socks5-pending-sessions (list sid jid (start-jabber-socks5 jc jid sid profile-function :target)))) (define-enter-state jabber-socks5 seek-proxies (fsm state-data) ;; Look for items at the server. (let* ((jc (plist-get state-data :jc)) (server (jabber-jid-server (jabber-connection-jid jc)))) (jabber-disco-get-items jc server nil (lambda (_jc fsm result) (fsm-send-sync fsm (cons :items result))) fsm)) ;; Spend no more than five seconds looking for a proxy. (list state-data 5)) (define-state jabber-socks5 seek-proxies (fsm state-data event _callback) "Collect disco results, looking for a bytestreams proxy." ;; We put the number of outstanding requests as :remaining-info in ;; the state-data plist. (cond ;; We're not ready to handle the IQ stanza yet ((eq (car-safe event) :iq) :defer) ;; Got list of items at the server. ((eq (car-safe event) :items) (dolist (entry (cdr event)) ;; Each entry is ["name" "jid" "node"]. We send a disco info ;; request to everything without a node. (when (null (aref entry 2)) (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 (car (nth 2 event)) 'error) (let ((identities (car (nth 2 event)))) ;; Is it a bytestream proxy? (when (cl-dolist (identity identities) (when (and (string= (aref identity 1) "proxy") (string= (aref identity 2) "bytestreams")) (cl-return t))) ;; Yes, it is. Add it to the list. (push (nth 1 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) (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"))) ) (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 (cl-dolist (pending-session jabber-socks5-pending-sessions) (when (and (equal sid (nth 0 pending-session)) (equal jid (nth 1 pending-session))) (cl-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 (cl-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) ;; (cl-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 (nth 1 event))) ;; This is either type "set" (with a list of streamhosts to ;; use), or a "result" (indicating the streamhost finally used ;; by the other party). (cond ((string= (jabber-xml-get-attribute xml-data 'type) "set") ;; A "set" makes sense if we're the initiator and offered ;; Psi's "fast mode". We don't yet, though, so this is only ;; for target. (dolist (streamhost (jabber-xml-get-children (jabber-iq-query xml-data) 'streamhost)) (jabber-xml-let-attributes (jid host port) streamhost ;; This is where we would attempt to support zeroconf (when (and jid host port) (start-jabber-socks5-connection jc initiator-jid target-jid jid (plist-get state-data :sid) host port fsm)))) (list 'wait-for-connection (plist-put state-data :iq-id (jabber-xml-get-attribute xml-data 'id)) 30)) ((string= (jabber-xml-get-attribute xml-data 'type) "result") ;; The other party has decided what streamhost to use. (let* ((proxy-used (jabber-xml-get-attribute (jabber-xml-path xml-data '(query streamhost-used)) 'jid)) ;; If JID is our own JID, we have probably already detected ;; what connection to use. But that is a later problem... (streamhosts (cdr (assoc proxy-used jabber-socks5-proxies-data)))) ;; Try to connect to all addresses of this proxy... (dolist (streamhost streamhosts) (jabber-xml-let-attributes (jid host port) streamhost (when (and jid host port) (start-jabber-socks5-connection jc initiator-jid target-jid jid (plist-get state-data :sid) host port fsm))))) (list 'wait-for-connection state-data 30)))))))) (define-state-machine jabber-socks5-connection :start ((jc initiator-jid target-jid streamhost-jid sid host port socks5-fsm) "Connect to a single XEP-0065 streamhost." (let ((coding-system-for-read 'binary) (coding-system-for-write 'binary)) ;; make-network-process, which we really want, for asynchronous ;; connection and such, was introduced in Emacs 22. (if (fboundp 'make-network-process) (let ((connection (make-network-process :name "socks5" :buffer nil :host host :service (string-to-number port) :nowait t :filter (fsm-make-filter fsm) :sentinel (fsm-make-sentinel fsm)))) (list 'wait-for-connection (list :jc jc :connection connection :initiator-jid initiator-jid :target-jid target-jid :streamhost-jid streamhost-jid :sid sid :socks5-fsm socks5-fsm) 30)) ;; So we open a stream, and wait for the connection to succeed. (condition-case nil (let ((connection (open-network-stream "socks5" nil host (string-to-number port)))) (set-process-filter connection (fsm-make-filter fsm)) (set-process-sentinel connection (fsm-make-sentinel fsm)) (list 'authenticate (list :jc jc :connection connection :initiator-jid initiator-jid :target-jid target-jid :streamhost-jid streamhost-jid :sid sid :socks5-fsm socks5-fsm) nil)) (error (list 'fail '() nil))))))) (define-state jabber-socks5-connection wait-for-connection (_fsm state-data event _callback) (cond ((eq (car-safe event) :sentinel) (let ((string (nth 2 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 (nth 2 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 (nth 1 event)) (list 'fail state-data nil)))) ((eq (car-safe event) :sentinel) (list 'fail state-data nil)))) (define-enter-state jabber-socks5-connection connect (_fsm state-data) "Send connect command." (let* ((sid (plist-get state-data :sid)) (initiator (plist-get state-data :initiator-jid)) (target (plist-get state-data :target-jid)) (hash (sha1 (concat sid initiator target)))) (process-send-string (plist-get state-data :connection) (concat (string 5 1 0 3 (length hash)) hash (string 0 0))) (list state-data 30))) (define-state jabber-socks5-connection connect (_fsm state-data event _callback) "Receive response to connect command." (cond ((eq (car-safe event) :filter) (let ((string (nth 2 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) (pcase-let ((`(,_ ,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 (nth 1 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 (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 (nth 1 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 (nth 2 event)) (fsm-send fsm (list :sentinel (nth 1 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 (nth 1 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 (nth 1 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)) ;; (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 ;; (lambda (data) ;; (process-send-string proxy-connection data)))) (provide 'jabber-socks5) ;;; jabber-socks5.el ends hereemacs-jabber/lisp/jabber-activity.el000066400000000000000000000414421476345337400177660ustar00rootroot00000000000000;;; jabber-activity.el --- show jabber activity in the mode line -*- lexical-binding: t; -*- ;; Copyright (C) 2004 Carl Henrik Lunde - ;; 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 'cl-lib) (require 'jabber-core) (require 'jabber-util) (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 to show a string in the modeline. 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) (defcustom jabber-activity-shorten-minimum 1 "Length of the strings returned by `jabber-activity-make-strings-shorten'. All strings returned by `jabber-activity-make-strings-shorten' will be at least this long, when possible." :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"))) (defcustom jabber-activity-count-in-title nil "If non-nil, display number of active JIDs in frame title." :type 'boolean :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 :set #'(lambda (var val) (if (not (and (featurep 'jabber-activity) (bound-and-true-p jabber-activity-mode))) (custom-set-default var val) (jabber-activity-mode -1) (custom-set-default var val) (jabber-activity-mode 1)))) (defcustom jabber-activity-show-p 'jabber-activity-show-p-default "Function that checks if the given JID should be shown on the mode line. Predicate function to call to check if the given JID should be shown in the mode line or not." :type 'function) (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) (defcustom jabber-activity-banned nil "List of regexps of banned JID" :type '(repeat string)) (defface jabber-activity-face '((t (:foreground "red" :weight bold))) "The face for displaying jabber-activity-string in the mode line") (defface jabber-activity-personal-face '((t (:foreground "blue" :weight bold))) "The face for displaying personal jabber-activity-string in the mode line") (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) ;; Global reference declarations (declare-function jabber-chat-get-buffer "jabber-chat.el" (chat-with)) (declare-function jabber-muc-get-buffer "jabber-muc.el" (group)) (declare-function jabber-muc-private-get-buffer "jabber-muc.el" (group nickname)) (declare-function jabber-muc-sender-p "jabber-muc.el" (jid)) (declare-function jabber-muc-looks-like-personal-p "jabber-muc-nick-completion.el" (message &optional group)) (defvar jabber-silent-mode) ; jabber.el ;; (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 (cl-dotimes (i len) (when (not (eq (aref s1 i) (aref s2 i))) (cl-return i))) ;; Substrings, equal, nil, or empty ("") len))) (defun jabber-activity-make-strings-shorten (jids) "Return an alist of (JID . short-names). This is acquired by running `jabber-activity-make-string' on JIDS, and then shortening the names as much as possible such that all strings still are unique and at least `jabber-activity-shorten-minimum' long." (let ((alist (sort (mapcar #'(lambda (x) (cons x (funcall jabber-activity-make-string x))) jids) #'(lambda (x y) (string-lessp (cdr x) (cdr y)))))) (cl-loop for ((_prev-jid . prev) (cur-jid . cur) (_next-jid . next)) on (cons nil alist) until (null cur) collect (cons cur-jid (substring cur 0 (min (length cur) (max jabber-activity-shorten-minimum (1+ (jabber-activity-common-prefix cur prev)) (1+ (jabber-activity-common-prefix cur next))))))))) (defun jabber-activity-find-buffer-name (jid) "Find the name of the buffer that messages from JID would use." (or (and (jabber-jid-resource jid) (get-buffer (jabber-muc-private-get-buffer (jabber-jid-user jid) (jabber-jid-resource jid)))) (get-buffer (jabber-chat-get-buffer jid)) (get-buffer (jabber-muc-get-buffer jid)))) (defun jabber-activity-show-p-default (jid) "Return non-nil if JID should be hidden. A JID should be hidden when there is an invisible buffer for JID, and JID is not in `jabber-activity-banned'." (let ((buffer (jabber-activity-find-buffer-name jid))) (and (buffer-live-p buffer) (not (get-buffer-window buffer 'visible)) (not (cl-dolist (entry jabber-activity-banned) (when (string-match entry jid) (cl-return t))))))) (defun jabber-activity-make-name-alist () "Rebuild `jabber-activity-name-alist' based on currently known JIDs." (let ((jids (or (mapcar #'car jabber-activity-name-alist) (mapcar #'symbol-name *jabber-roster*)))) (setq jabber-activity-name-alist (funcall jabber-activity-make-strings jids)))) (defun jabber-activity-lookup-name (jid) "Lookup JID in `jabber-activity-name-alist'. Return a (jid . string) pair suitable for the mode line, creating an entry if needed." (let ((elm (assoc jid jabber-activity-name-alist))) (or elm (progn ;; Remake alist with the new JID (setq jabber-activity-name-alist (funcall jabber-activity-make-strings (cons jid (mapcar #'car jabber-activity-name-alist)))) (jabber-activity-lookup-name jid))))) (defun jabber-activity-mode-line-update () "Update the string shown in the mode line using `jabber-activity-make-string'. Update the string shown in the mode line using `jabber-activity-make-string' on JIDs where `jabber-activity-show-p'. Optional not-nil GROUP mean that message come from MUC. Optional TEXT used with one-to-one or MUC chats and may be used to identify personal MUC message. Optional PRESENCE mean personal presence request or alert." (setq jabber-activity-mode-string (if jabber-activity-jids (mapconcat (lambda (x) (let ((jump-to-jid (car x))) (jabber-propertize (cdr x) 'face (if (member jump-to-jid jabber-activity-personal-jids) 'jabber-activity-personal-face 'jabber-activity-face) ;; XXX: XEmacs doesn't have make-mode-line-mouse-map. ;; Is there another way to make this work? 'local-map (when (fboundp 'make-mode-line-mouse-map) (make-mode-line-mouse-map 'mouse-1 (lambda () (interactive "@") (jabber-activity-switch-to jump-to-jid)))) '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 (cl-delete-if-not jabber-activity-show-p jabber-activity-jids)) (setq jabber-activity-personal-jids (cl-delete-if-not jabber-activity-show-p jabber-activity-personal-jids)) (ignore-errors (jabber-activity-mode-line-update))) (defun jabber-activity-add (from _buffer _text _proposed-alert) "Add a JID to mode line when `jabber-activity-show-p'." (when (funcall jabber-activity-show-p from) (add-to-list 'jabber-activity-jids from) (add-to-list 'jabber-activity-personal-jids from) (jabber-activity-mode-line-update))) (defun jabber-activity-add-muc (_nick group _buffer text _proposed-alert) "Add a JID to mode line when `jabber-activity-show-p'." (when (funcall jabber-activity-show-p group) (add-to-list 'jabber-activity-jids group) (when (jabber-muc-looks-like-personal-p text group) (add-to-list 'jabber-activity-personal-jids group)) (jabber-activity-mode-line-update))) (defun jabber-activity-presence (who _oldstatus newstatus _statustext _proposed-alert) "Add a JID to mode line on subscription requests." (when (string= newstatus "subscribe") (add-to-list 'jabber-activity-jids (symbol-name who)) (add-to-list 'jabber-activity-personal-jids (symbol-name who)) (jabber-activity-mode-line-update))) (defun jabber-activity-kill-hook () "Query the user if is sure to kill Emacs when there are unread messages. Query the user as to whether killing Emacs should be cancelled when there are unread messages which otherwise would be lost, if `jabber-activity-query-unread' is t" (if (and jabber-activity-jids jabber-activity-query-unread) (or jabber-silent-mode (yes-or-no-p "You have unread Jabber messages, are you sure you want to quit?")) t)) ;;; 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 :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-hook '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 '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) ;;; jabber-activity.el ends here emacs-jabber/lisp/jabber-ahc-presence.el000066400000000000000000000106551476345337400204710ustar00rootroot00000000000000;;; jabber-ahc-presence.el --- provide remote control of presence -*- lexical-binding: t; -*- ;; 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-ahc) (defvar *jabber-current-show*) (defvar *jabber-current-status*) (defvar *jabber-current-priority*) (defconst jabber-ahc-presence-node "http://jabber.org/protocol/rc#set-status" "Node used by function `jabber-ahc-presence'.") (jabber-ahc-add jabber-ahc-presence-node "Set presence" 'jabber-ahc-presence 'jabber-my-jid-p) (defun jabber-ahc-presence (jc xml-data) "Process presence change command. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((query (jabber-iq-query xml-data)) (sessionid (jabber-xml-get-attribute query 'sessionid)) (action (jabber-xml-get-attribute query 'action))) ;; No session state is kept; instead, lack of session-id is used ;; as indication of first command. (cond ;; command cancelled ((string= action "cancel") `(command ((xmlns . "http://jabber.org/protocol/commands") (sessionid . ,sessionid) (node . ,jabber-ahc-presence-node) (status . "canceled")))) ;; return form ((null sessionid) `(command ((xmlns . "http://jabber.org/protocol/commands") (sessionid . "jabber-ahc-presence") (node . ,jabber-ahc-presence-node) (status . "executing")) (x ((xmlns . "jabber:x:data") (type . "form")) (title nil ,(format "Set presence of %s" (jabber-connection-jid jc))) (instructions nil "Select new presence status.") (field ((var . "FORM_TYPE") (type . "hidden")) (value nil "http://jabber.org/protocol/rc")) (field ((var . "status") (label . "Status") (type . "list-single")) (value nil ,(if (string= *jabber-current-show* "") "online" *jabber-current-show*)) (option ((label . "Online")) (value nil "online")) (option ((label . "Chatty")) (value nil "chat")) (option ((label . "Away")) (value nil "away")) (option ((label . "Extended away")) (value nil "xa")) (option ((label . "Do not disturb")) (value nil "dnd"))) (field ((var . "status-message") (label . "Message") (type . "text-single")) (value nil ,*jabber-current-status*)) (field ((var . "status-priority") (label . "Priority") (type . "text-single")) (value nil ,(int-to-string *jabber-current-priority*)))))) ;; process form (t (let* ((x (car (jabber-xml-get-children query 'x))) ;; we assume that the first is the jabber:x:data one (fields (jabber-xml-get-children x 'field)) (new-show *jabber-current-show*) (new-status *jabber-current-status*) (new-priority *jabber-current-priority*)) (dolist (field fields) (let ((var (jabber-xml-get-attribute field 'var)) ;; notice that multi-value fields won't be handled properly ;; by this (value (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value)))))) (cond ((string= var "status") (setq new-show (if (string= value "online") "" value))) ((string= var "status-message") (setq new-status value)) ((string= var "status-priority") (setq new-priority (string-to-number value)))))) (jabber-send-presence new-show new-status new-priority)) `(command ((xmlns . "http://jabber.org/protocol/commands") (sessionid . ,sessionid) (node . ,jabber-ahc-presence-node) (status . "completed")) (note ((type . "info")) "Presence has been changed.")))))) (provide 'jabber-ahc-presence) ;;; jabber-ahc-presence.el ends hereemacs-jabber/lisp/jabber-ahc.el000066400000000000000000000213021476345337400166560ustar00rootroot00000000000000;; jabber-ahc.el - Ad-Hoc Commands by JEP-0050 -*- lexical-binding: t; -*- ;; 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 "Alist of ad-hoc commands provided. The keys are node names as strings (which means that they must not conflict). The values are plists having the following properties - acl - function taking connection object and JID of requester, returning non-nil for access allowed. No function means open for everyone. name - name of command func - function taking connection object and entire IQ stanza as arguments and returning a node Use the function `jabber-ahc-add' to add a command to this list.") ;; Global reference declarations (defvar jabber-jid-info-menu) ; jabber-menu.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el ;; ;;; 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 node. ACL is a function taking JID as single argument, returning non-nil for access allowed. nil means open for everyone." (add-to-list 'jabber-ahc-commands (cons node (list 'name name 'func func 'acl acl))) (add-to-list 'jabber-disco-info-nodes (list node `((identity ((category . "automation") (type . "command-node") (name . ,name))) (feature ((var . "http://jabber.org/protocol/commands"))) (feature ((var . "http://jabber.org/protocol/disco#info"))) (feature ((var . "jabber:x:data"))))))) (jabber-disco-advertise-feature "http://jabber.org/protocol/commands") (add-to-list 'jabber-disco-items-nodes (list "http://jabber.org/protocol/commands" #'jabber-ahc-disco-items nil)) (defun jabber-ahc-disco-items (jc xml-data) "Return commands in response to disco#items request. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((jid (jabber-xml-get-attribute xml-data 'from))) (mapcar (function (lambda (command) (let ((node (car command)) (plist (cdr command))) (let ((acl (plist-get plist 'acl)) (name (plist-get plist 'name))) (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. See XEP-0050. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Request command list from: " nil nil nil nil nil))) (jabber-get-disco-items jc to "http://jabber.org/protocol/commands")) (add-to-list 'jabber-jid-service-menu (cons "Execute command" 'jabber-ahc-execute-command)) (defun jabber-ahc-execute-command (jc to node) "Execute ad-hoc command. See XEP-0050. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Execute command of: " nil nil nil nil nil) (jabber-read-node "Node of command: "))) (jabber-send-iq jc to "set" `(command ((xmlns . "http://jabber.org/protocol/commands") (node . ,node) (action . "execute"))) #'jabber-process-data #'jabber-ahc-display #'jabber-process-data "Command execution failed")) (defun jabber-ahc-display (jc xml-data) (let* ((from (jabber-xml-get-attribute xml-data 'from)) (query (jabber-iq-query xml-data)) (node (jabber-xml-get-attribute query 'node)) (notes (jabber-xml-get-children query 'note)) (sessionid (jabber-xml-get-attribute query 'sessionid)) (status (jabber-xml-get-attribute query 'status)) (actions (car (jabber-xml-get-children query 'actions))) xdata (inhibit-read-only t)) (make-local-variable 'jabber-ahc-sessionid) (setq jabber-ahc-sessionid sessionid) (make-local-variable 'jabber-ahc-node) (setq jabber-ahc-node node) (make-local-variable 'jabber-buffer-connection) (setq jabber-buffer-connection jc) (dolist (x (jabber-xml-get-children query 'x)) (when (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data") (setq xdata x))) (cond ((string= status "executing") (insert "Executing command\n\n")) ((string= status "completed") (insert "Command completed\n\n")) ((string= status "canceled") (insert "Command canceled\n\n"))) (dolist (note notes) (let ((note-type (jabber-xml-get-attribute note 'type))) (cond ((string= note-type "warn") (insert "Warning: ")) ((string= note-type "error") (insert "Error: "))) (insert (car (jabber-xml-node-children note)) "\n"))) (insert "\n") (when xdata (jabber-init-widget-buffer from) (let ((formtype (jabber-xml-get-attribute xdata 'type))) (if (string= formtype "result") (jabber-render-xdata-search-results xdata) (jabber-render-xdata-form xdata) (when (string= status "executing") (let ((button-titles (cond ((null actions) '(complete cancel)) (t (let ((children (mapcar #'jabber-xml-node-name (jabber-xml-node-children actions))) (default-action (jabber-xml-get-attribute actions 'execute))) (if (or (null default-action) (memq (intern default-action) children)) children (cons (intern default-action) children))))))) (dolist (button-title button-titles) (widget-create 'push-button :notify (lambda (&rest _ignore) (jabber-ahc-submit 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) ;;; jabber-ahc.el ends here. emacs-jabber/lisp/jabber-alert.el000066400000000000000000000475061476345337400172500ustar00rootroot00000000000000;;; jabber-alert.el --- alert hooks -*- lexical-binding: t; -*- ;; 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 'cl-lib) (require 'jabber-util) (require 'jabber-xml) (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)) (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) (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)) (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) (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)) (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) (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)) (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) (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))) (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) (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)) (defcustom jabber-alert-muc-wave "" "A sound file to play when a MUC message arrived." :type 'file) (defcustom jabber-alert-presence-wave "" "A sound file to play when a presence arrived." :type 'file) (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)) (defcustom jabber-alert-info-wave "" "A sound file to play when an info query result arrived." :type 'file) (defcustom jabber-play-sound-file 'play-sound-file "A function to call to play alert sound files." :type 'function) ;; Global reference declarations (declare-function jabber-chat-get-buffer "jabber-chat.el" (chat-with)) (declare-function jabber-chat-send "jabber-chat.el" (jc body)) (declare-function jabber-muc-sender-p "jabber-muc.el" (jid)) (defvar jabber-presence-strings) ; jabber.el (defvar jabber-xml-data) ; jabber.el (defvar *jabber-active-groupchats*) ; jabber-muc.el (defvar jabber-roster-buffer) ; jabber-core.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el ;; (defmacro define-jabber-alert (name docstring function) "Define a new family of external alert hooks. Use this macro when your hooks do nothing except displaying a string in some new innovative way. You write a string display function, and this macro does all the boring and repetitive work. NAME is the name of the alert family. The resulting hooks will be called jabber-{message,muc,presence,info}-NAME. DOCSTRING is the docstring to use for those hooks. FUNCTION is a function that takes one argument, a string, and displays it in some meaningful way. It can be either a lambda form or a quoted function name. The created functions are inserted as options in Customize. Examples: \(define-jabber-alert foo \"Send foo alert\" \\='foo-message) \(define-jabber-alert bar \"Send bar alert\" (lambda (msg) (bar msg 42)))" (let ((sn (symbol-name name))) (let ((msg (intern (format "jabber-message-%s" sn))) (muc (intern (format "jabber-muc-%s" sn))) (pres (intern (format "jabber-presence-%s" sn))) (info (intern (format "jabber-info-%s" sn)))) `(progn (defun ,msg (_from _buffer text title) ,docstring (when title (funcall ,function text title))) (cl-pushnew (quote ,msg) (get 'jabber-alert-message-hooks 'custom-options)) (defun ,muc (_nick _group _buffer text title) ,docstring (when title (funcall ,function text title))) (cl-pushnew (quote ,muc) (get 'jabber-alert-muc-hooks 'custom-options)) (defun ,pres (_who _oldstatus _newstatus statustext title) ,docstring (when title (funcall ,function statustext title))) (cl-pushnew (quote ,pres) (get 'jabber-alert-presence-hooks 'custom-options)) (defun ,info (_infotype _buffer text) ,docstring (when text (funcall ,function text))) (cl-pushnew (quote ,info) (get 'jabber-alert-info-message-hooks 'custom-options)))))) ;; Alert hooks (define-jabber-alert echo "Show a message in the echo area" (lambda (text &optional title) (message "%s" (or title text)))) (define-jabber-alert beep "Beep on event" (lambda (&rest _ignore) (beep))) ;; Message alert hooks (defcustom jabber-message-alert-same-buffer t "If nil, don't display message alerts for the current buffer." :type 'boolean) (defcustom jabber-muc-alert-self nil "If nil, don't display MUC alerts for your own messages." :type 'boolean) (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))))) (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 (cl-dolist (entry jabber-alert-message-wave-alist) (when (string-match (car entry) bare-jid) (cl-return (cdr entry)))) jabber-alert-message-wave))) (unless (equal sound-file "") (funcall jabber-play-sound-file sound-file))))) (defun jabber-message-display (_from buffer _text title) "Display the buffer where a new message has arrived." (when title (display-buffer buffer))) (defun jabber-message-switch (_from buffer _text title) "Switch to the buffer where a new message has arrived." (when title (switch-to-buffer buffer))) (defun jabber-message-scroll (_from buffer _text _title) "Scroll all nonselected windows where the chat buffer is displayed." ;; jabber-chat-buffer-display will DTRT with point in the buffer. ;; But this change will not take effect in nonselected windows. ;; Therefore we do that manually here. ;; ;; There are three cases: ;; 1. The user started typing a message in this window. Point is ;; greater than jabber-point-insert. In that case, we don't ;; want to move point. ;; 2. Point was at the end of the buffer, but no message was being ;; typed. After displaying the message, point is now close to ;; the end of the buffer. We advance it to the end. ;; 3. The user was perusing history in this window. There is no ;; simple way to distinguish this from 2, so the user loses. (let ((windows (get-buffer-window-list buffer nil t)) (new-point-max (with-current-buffer buffer (point-max)))) (dolist (w windows) (unless (eq w (selected-window)) (set-window-point w new-point-max))))) ;; MUC alert hooks (defun jabber-muc-default-message (nick group buffer _text) (when (or jabber-message-alert-same-buffer (not (memq (selected-window) (get-buffer-window-list buffer)))) (if nick (when (or jabber-muc-alert-self (not (string= nick (cdr (assoc group *jabber-active-groupchats*))))) (format "Message from %s in %s" nick (jabber-jid-displayname group))) (format "Message in %s" (jabber-jid-displayname group))))) (defun jabber-muc-wave (_nick _group _buffer _text title) "Play the wave file specified in `jabber-alert-muc-wave'." (when title (funcall jabber-play-sound-file jabber-alert-muc-wave))) (defun jabber-muc-display (_nick _group buffer _text title) "Display the buffer where a new message has arrived." (when title (display-buffer buffer))) (defun jabber-muc-switch (_nick _group buffer _text title) "Switch to the buffer where a new message has arrived." (when title (switch-to-buffer buffer))) (defun jabber-muc-scroll (_nick _group buffer _text _title) "Scroll buffer even if it is in an unselected window." (jabber-message-scroll nil buffer nil nil)) ;; Presence alert hooks (defun jabber-presence-default-message (who oldstatus newstatus _statustext) "Return a string with the status change if OLDSTATUS and NEWSTATUS differs. Return nil if OLDSTATUS and NEWSTATUS are equal, and in other cases a string of the form \"\\='name\\=' (jid) is now NEWSTATUS (STATUSTEXT)\". This function is not called directly, but is the default for `jabber-alert-presence-message-function'." (cond ((equal oldstatus newstatus) nil) (t (let ((formattedname (if (> (length (get who 'name)) 0) (get who 'name) (symbol-name who))) (formattedstatus (or (cdr (assoc newstatus '(("subscribe" . " requests subscription to your presence") ("subscribed" . " has granted presence subscription to you") ("unsubscribe" . " no longer subscribes to your presence") ("unsubscribed" . " cancels your presence subscription")))) (concat " is now " (or (cdr (assoc newstatus jabber-presence-strings)) newstatus))))) (concat formattedname formattedstatus))))) (defun jabber-presence-only-chat-open-message (who oldstatus newstatus statustext) "Same as `jabber-presence-default-message' but managing the presence messages. Return the same as `jabber-presence-default-message' but only if there is a chat buffer open for WHO, keeping the amount of presence messages at a more manageable level when there are lots of users. This function is not called directly, but can be used as the value for `jabber-alert-presence-message-function'." (when (get-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute jabber-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 (cl-dolist (entry jabber-alert-presence-wave-alist) (when (string-match (car entry) bare-jid) (cl-return (cdr entry)))) jabber-alert-presence-wave))) (unless (equal sound-file "") (funcall jabber-play-sound-file sound-file))))) ;; This is now defined in jabber-roster.el. ;; (defun jabber-presence-update-roster (who oldstatus newstatus statustext proposed-alert) ;; "Update the roster display by calling `jabber-display-roster'" ;; (jabber-display-roster)) (defun jabber-presence-display (_who _oldstatus _newstatus _statustext proposed-alert) "Display the roster buffer." (when proposed-alert (display-buffer jabber-roster-buffer))) (defun jabber-presence-switch (_who _oldstatus _newstatus _statustext proposed-alert) "Switch to the roster buffer." (when proposed-alert (switch-to-buffer jabber-roster-buffer))) ;;; 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. This makes sense only for MUC. NAME: the name of the sender." (let ((sn (symbol-name name))) (let ((func (intern (format "%s-personal" sn)))) `(progn (declare-function jabber-muc-looks-like-personal-p "jabber-muc-nick-completion.el" (message &optional group)) (defun ,func (nick group buffer text title) (if (jabber-muc-looks-like-personal-p text group) (,name nick group buffer text title))) (cl-pushnew (quote ,func) (get 'jabber-alert-muc-hooks 'custom-options)))))) (define-personal-jabber-alert jabber-muc-beep) (define-personal-jabber-alert jabber-muc-wave) (define-personal-jabber-alert jabber-muc-echo) (define-personal-jabber-alert jabber-muc-switch) (define-personal-jabber-alert jabber-muc-display) (defcustom jabber-autoanswer-alist nil "Specific phrases to autoanswer on specific message. The keys are regexps matching the incoming message text, and the values are autoanswer phrase." :type '(alist :key-type regexp :value-type string)) (defun jabber-autoanswer-answer (from buffer text proposed-alert) "Answer automaticaly when incoming text is in `jabber-autoanswer-alist'. Answer automaticaly when incoming text match the first element of `jabber-autoanswer-alist'" (when (and from buffer text proposed-alert jabber-autoanswer-alist) (let ((message (cl-dolist (entry jabber-autoanswer-alist) (when (string-match (car entry) text) (cl-return (cdr entry)))))) (if message (jabber-chat-send jabber-buffer-connection message))))) (cl-pushnew 'jabber-autoanswer-answer (get 'jabber-alert-message-hooks 'custom-options)) (defun jabber-autoanswer-answer-muc (nick group buffer text proposed-alert) "Answer automaticaly when incoming text is in `jabber-autoanswer-alist'. Answer automaticaly when incoming text match first element of `jabber-autoanswer-alist'." (when (and nick group buffer text proposed-alert jabber-autoanswer-alist) (let ((message (cl-dolist (entry jabber-autoanswer-alist) (when (string-match (car entry) text) (cl-return (cdr entry)))))) (if message (jabber-chat-send jabber-buffer-connection message))))) (cl-pushnew 'jabber-autoanswer-answer-muc (get 'jabber-alert-muc-hooks 'custom-options)) (provide 'jabber-alert) ;;; jabber-alert.el ends hereemacs-jabber/lisp/jabber-autoaway.el000066400000000000000000000200731476345337400177610ustar00rootroot00000000000000;;; jabber-autoaway.el --- change status to away after idleness -*- lexical-binding: t; -*- ;; 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 ;; 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: (eval-when-compile (require 'cl-lib)) (require 'time-date) (require 'jabber-util) (require 'jabber-presence) (defgroup jabber-autoaway nil "Change status to away after idleness." :group 'jabber) (defcustom jabber-autoaway-methods (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." :type 'hook :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." :type 'number) (defcustom jabber-autoaway-xa-timeout 10 "Minutes of inactivity before changing status to xa. Set to 0 to disable." :type 'number) (defcustom jabber-autoaway-status "Idle" "Status string for autoaway." :type 'string) (defcustom jabber-autoaway-xa-status "Extended away" "Status string for autoaway in xa state." :type 'string) (defcustom jabber-autoaway-priority nil "Priority for autoaway. If nil, don't change priority. See the manual for more information about priority." :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." :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." :type 'string) (defcustom jabber-autoaway-verbose nil "If nil, don't print autoaway status messages." :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.") ;; Global reference declarations (defvar *jabber-current-status*) ; jabber.el (defvar *jabber-current-show*) ; jabber.el (defvar *jabber-current-priority*) ; jabber.el (defvar jabber-default-show) ; jabber.el (defvar jabber-default-priority) ; jabber.el (defvar jabber-default-status) ; jabber.el ;; (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) ;;; jabber-autoaway.el ends hereemacs-jabber/lisp/jabber-autoloads.stub000066400000000000000000000003621476345337400204760ustar00rootroot00000000000000;;; jabber-autoloads.el --- automatically extracted autoloads ;; ;;; Code: (provide 'jabber-autoloads) ;; Local Variables: ;; version-control: never ;; no-byte-compile: t ;; no-update-autoloads: t ;; End: ;;; jabber-autoloads.el ends here emacs-jabber/lisp/jabber-avatar.el000066400000000000000000000205301476345337400174030ustar00rootroot00000000000000;;; jabber-avatar.el --- generic functions for avatars -*- lexical-binding: t; -*- ;; Copyright (C) 2006, 2007, 2008 Magnus Henoch ;; Author: Magnus Henoch ;; 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. [1][2][3] ;; ;; 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. ;; ;; [1] XEP-0008: IQ-Based Avatars ;; https://xmpp.org/extensions/xep-0008.html ;; [2] XEP-0084: User Avatar ;; https://xmpp.org/extensions/xep-0084.html ;; [3] XEP-0153: vCard-Based Avatars ;; https://xmpp.org/extensions/xep-0153.html ;;; Code: (require 'mailcap) (eval-when-compile (require 'cl-lib)) (require 'jabber-util) ;;;; 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." :type 'directory) (defcustom jabber-avatar-verbose nil "Display messages about irregularities with other people's avatars." :type 'boolean) (defcustom jabber-avatar-max-width 96 "Maximum width of avatars." :type 'integer) (defcustom jabber-avatar-max-height 96 "Maximum height of avatars." :type 'integer) ;;;; Avatar data handling (cl-defstruct avatar sha1-sum mime-type url base64-data height width bytes) (defun jabber-avatar-from-url (url) "Construct an avatar structure from the given URL. Retrieves the image to find info about it." (with-current-buffer (let ((coding-system-for-read 'binary)) (url-retrieve-synchronously url)) (let* ((case-fold-search t) (mime-type (ignore-errors (search-forward-regexp "^content-type:[ \t]*\\(.*\\)$") (match-string 1))) (data (progn (search-forward "\n\n") (buffer-substring (point) (point-max))))) (prog1 (jabber-avatar-from-data data nil mime-type) (kill-buffer nil))))) (defun jabber-avatar-from-file (filename) "Construct an avatar structure from FILENAME." (require 'mailcap) (let ((data (with-temp-buffer (insert-file-contents-literally filename) (buffer-string))) (mime-type (when (string-match "\\.[^.]+$" filename) (mailcap-extension-to-mime (match-string 0 filename))))) (jabber-avatar-from-data data nil mime-type))) (defun jabber-avatar-from-base64-string (base64-string &optional mime-type) "Construct an avatar stucture from BASE64-STRING. If MIME-TYPE is not specified, try to find it from the image data." (jabber-avatar-from-data nil base64-string mime-type)) (defun jabber-avatar-from-data (raw-data base64-string &optional mime-type) "Construct an avatar structure from RAW-DATA and/or BASE64-STRING. If either is not provided, it is computed. If MIME-TYPE is not specified, try to find it from the image data." (let* ((data (or raw-data (base64-decode-string base64-string))) (bytes (length data)) (sha1-sum (sha1 data)) (base64-data (or base64-string (base64-encode-string raw-data))) (type (or mime-type (cdr (assq (get :type (cdr (condition-case nil (jabber-create-image data nil t) (error nil)))) '((png "image/png") (jpeg "image/jpeg") (gif "image/gif"))))))) (jabber-avatar-compute-size (make-avatar :mime-type type :sha1-sum sha1-sum :base64-data base64-data :bytes bytes)))) ;; XXX: This function is based on an outdated version of XEP-0084. ;; (defun jabber-avatar-from-data-node (data-node) ;; "Construct an avatar structure from the given node." ;; (jabber-xml-let-attributes ;; (content-type id bytes height width) data-node ;; (let ((base64-data (car (jabber-xml-node-children data-node)))) ;; (make-avatar :mime-type content-type :sha1-sum id :bytes bytes ;; :height height :width width :base64-data base64-data)))) (defun jabber-avatar-image (avatar) "Create an image from AVATAR. Return nil if images of this type are not supported." (condition-case nil (jabber-create-image (with-temp-buffer (set-buffer-multibyte nil) (insert (avatar-base64-data avatar)) (base64-decode-region (point-min) (point-max)) (buffer-string)) nil t) (error nil))) (defun jabber-avatar-compute-size (avatar) "Compute and set the width and height fields of AVATAR. Return AVATAR." ;; image-size only works when there is a window system. ;; But display-graphic-p doesn't exist on XEmacs... (let ((size (and (fboundp 'display-graphic-p) (display-graphic-p) (let ((image (jabber-avatar-image avatar))) (and image (image-size image t)))))) (when size (setf (avatar-width avatar) (car size)) (setf (avatar-height avatar) (cdr size))) avatar)) ;;;; 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)) (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)))) (defun jabber-create-image (file-or-data &optional type data-p) "Create an image from FILE-OR-DATA. If width/height exceeds jabber-avatar-max-width or jabber-avatar-max-height, and ImageMagick is available, the image is scaled down." (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) ;;; jabber-avatar.el ends hereemacs-jabber/lisp/jabber-awesome.el000066400000000000000000000031741476345337400175720ustar00rootroot00000000000000;;; jabber-awesome.el --- emacs-jabber interface to awesome and naughty -*- lexical-binding: t; -*- ;; Copyright (C) 2009 - Evgenii Terechkov - evg@altlinux.org ;; This file is a part of jabber.el. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA (eval-when-compile (require 'jabber-alert)) (defcustom jabber-awesome-args ", timeout=5" "Additional args to naughty." :type 'string :group 'jabber-alerts) (defun jabber-awesome-message (text &optional title) "Show MSG in Awesome" ;; Possible errors include not finding the awesome binary. (condition-case nil (let ((process-connection-type)) (shell-command-to-string (format "echo 'naughty.notify({text = \"%s\" %s})' | awesome-client -" (or title text) jabber-awesome-args))) (error nil))) (define-jabber-alert awesome "Show a message through the Awesome window manager" 'jabber-awesome-message) (define-personal-jabber-alert jabber-muc-awesome) (provide 'jabber-awesome) ;;; jabber-awesome.el ends hereemacs-jabber/lisp/jabber-bookmarks.el000066400000000000000000000220371476345337400201210ustar00rootroot00000000000000;;; jabber-bookmarks.el --- bookmarks according to XEP-0048 -*- lexical-binding: t; -*- ;; 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 ;;; Code: (require 'cl-lib) (require 'jabber-private) (require 'jabber-widget) ;; Global reference declarations (defvar jabber-muc-default-nicknames) ; jabber-muc.el (defvar jabber-muc-autojoin) ; jabber-muc.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el ;; (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 (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 (cl-dolist (node result) (when (and (eq (jabber-xml-node-name node) 'conference) (string= (jabber-xml-get-attribute node 'jid) conference-jid)) (cl-return (jabber-parse-conference-bookmark node)))))) (if key (plist-get entry key) entry))) ;;;###autoload (defun jabber-parse-conference-bookmark (node) "Convert a tag into a plist. The plist may contain the keys :jid, :name, :autojoin, :nick and :password." (when (eq (jabber-xml-node-name node) 'conference) (list :jid (jabber-xml-get-attribute node 'jid) :name (jabber-xml-get-attribute node 'name) :autojoin (member (jabber-xml-get-attribute node 'autojoin) '("true" "1")) :nick (car (jabber-xml-node-children (car (jabber-xml-get-children node 'nick)))) :password (car (jabber-xml-node-children (car (jabber-xml-get-children node 'password))))))) ;;;###autoload (defun jabber-get-bookmarks (jc cont &optional refresh) "Retrieve bookmarks (if needed) and call CONT. Arguments to CONT are JC and the bookmark list. CONT will be called as the result of a filter function or a timer. If REFRESH is non-nil, always fetch bookmarks." (let ((bookmarks (gethash (jabber-connection-bare-jid jc) jabber-bookmarks))) (if (and (not refresh) bookmarks) (run-with-timer 0 nil cont jc (when (listp bookmarks) bookmarks)) (let* ((callback (lambda (jc result) (jabber-get-bookmarks-1 jc result cont)))) (jabber-private-get jc 'storage "storage:bookmarks" callback callback))))) (defun jabber-get-bookmarks-1 (jc result cont) (let ((my-jid (jabber-connection-bare-jid jc)) (value (if (eq (jabber-xml-node-name result) 'storage) (or (jabber-xml-node-children result) t) t))) (puthash my-jid value jabber-bookmarks) (funcall cont jc (when (listp value) value)))) ;;;###autoload (defun jabber-get-bookmarks-from-cache (jc) "Return cached bookmarks for JC. If bookmarks have not yet been fetched by `jabber-get-bookmarks', return nil." (gethash (jabber-connection-bare-jid jc) jabber-bookmarks)) (defun jabber-set-bookmarks (jc bookmarks &optional callback) "Set bookmarks to BOOKMARKS, which is a list of XML elements. If CALLBACK is non-nil, call it with JC and t or nil as arguments on success or failure, respectively." (unless callback (setq callback #'ignore)) (jabber-private-set jc `(storage ((xmlns . "storage:bookmarks")) ,@bookmarks) callback t callback nil)) ;;;###autoload (defun jabber-edit-bookmarks (jc) "Create a buffer for editing bookmarks interactively. JC is the Jabber connection." (interactive (list (jabber-read-account))) (jabber-get-bookmarks jc 'jabber-edit-bookmarks-1 t)) (defun jabber-edit-bookmarks-1 (jc bookmarks) (setq bookmarks (mapcar (lambda (e) (pcase (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) (pcase (car entry) ('url (pcase-let ((`(,_symbol ,url ,name) entry)) `(url ((url . ,url) (name . ,name))))) ('conference (pcase-let ((`(,_symbol ,jid ,name ,autojoin ,nick ,password) entry)) `(conference ((jid . ,jid) (name . ,name) (autojoin . ,(if autojoin "1" "0"))) ,@(unless (zerop (length nick)) `((nick () ,nick))) ,@(unless (zerop (length password)) `((password () ,password)))))))) bookmarks)) (remhash (jabber-connection-bare-jid jabber-buffer-connection) jabber-bookmarks) (jabber-private-set jabber-buffer-connection `(storage ((xmlns . "storage:bookmarks")) ,@bookmarks) 'jabber-report-success "Storing bookmarks" 'jabber-report-success "Storing bookmarks"))) (defun jabber-bookmarks-import (&rest _ignore) (let* ((value (widget-value (cdr (assq 'bookmarks jabber-widget-alist)))) (conferences (mapcar #'cdr (cl-remove-if-not (lambda (entry) (eq (car entry) 'conference)) value)))) (dolist (default-nickname jabber-muc-default-nicknames) (pcase-let* ((`(,muc-jid . ,nick) default-nickname) (entry (assoc muc-jid conferences))) (if entry (setf (nth 3 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 (nth 2 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) ;;; jabber-bookmarks.el ends hereemacs-jabber/lisp/jabber-browse.el000066400000000000000000000076641476345337400174430ustar00rootroot00000000000000;;; jabber-browse.el --- jabber browsing by JEP-0011 -*- lexical-binding: t; -*- ;; 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) (require 'jabber-menu) ;; 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. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "browse: " nil nil nil nil t))) (jabber-send-iq jc to "get" '(query ((xmlns . "jabber:iq:browse"))) #'jabber-process-data #'jabber-process-browse #'jabber-process-data "Browse failed")) ;; called from jabber-process-data (defun jabber-process-browse (jc xml-data) "Handle results from jabber:iq:browse requests. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (dolist (item (jabber-xml-node-children xml-data)) (when (and (listp item) (not (eq (jabber-xml-node-name item) 'ns))) (let ((jid (jabber-xml-get-attribute item 'jid)) (beginning (point))) (cond ((or (eq (jabber-xml-node-name item) 'user) (string= (jabber-xml-get-attribute item 'category) "user")) (insert (jabber-propertize "$ USER" 'face 'jabber-title-medium) "\n\n")) ((or (eq (jabber-xml-node-name item) 'service) (string= (jabber-xml-get-attribute item 'category) "service")) (insert (jabber-propertize "* SERVICE" 'face 'jabber-title-medium) "\n\n")) ((or (eq (jabber-xml-node-name item) 'conference) (string= (jabber-xml-get-attribute item 'category) "conference")) (insert (jabber-propertize "@ CONFERENCE" 'face 'jabber-title-medium) "\n\n")) (t ;; So far I've seen "server" and "directory", both in the node-name. ;; Those are actually service disco categories, but jabberd 2 seems ;; to use them for browse results as well. It's not right (as in ;; XEP-0011), but it's reasonable. (let ((category (jabber-xml-get-attribute item 'category))) (if (= (length category) 0) (setq category (jabber-xml-node-name item))) (insert (jabber-propertize (format "! OTHER: %s" category) 'face 'jabber-title-medium) "\n\n")))) (dolist (attr '((type . "Type:\t\t") (jid . "JID:\t\t") (name . "Name:\t\t") (version . "Version:\t"))) (let ((data (jabber-xml-get-attribute item (car attr)))) (if (> (length data) 0) (insert (cdr attr) data "\n")))) (dolist (ns (jabber-xml-get-children item 'ns)) (if (stringp (car (jabber-xml-node-children ns))) (insert "Namespace:\t" (car (jabber-xml-node-children ns)) "\n"))) (insert "\n") (put-text-property beginning (point) 'jabber-jid jid) (put-text-property beginning (point) 'jabber-account jc) ;; XXX: Is this kind of recursion really needed? (if (listp (car (jabber-xml-node-children item))) (jabber-process-browse jc item)))))) (provide 'jabber-browse) ;;; jabber-browse.el ends here. emacs-jabber/lisp/jabber-carbons.el000066400000000000000000000023341476345337400175560ustar00rootroot00000000000000;;; jabber-carbons.el --- Support for XEP-0280: Message Carbons -*- lexical-binding: t; -*- ;;; Commentary: ;; ;;; Code: (require 'jabber-util) (require 'jabber-xml) (require 'jabber-menu) (require 'jabber-iq) (require 'jabber-disco) (defun jabber-carbon-success (jc xml-data _context) (when (equal "result" (jabber-xml-get-attribute xml-data 'type)) (message "Carbons feature successfully enabled for %s" (jabber-connection-jid jc)))) (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)) ;;;###autoload (defun jabber-enable-carbons (jc) "Send request to enable XEP-0280 Message Carbons. JC is the Jabber connection." (interactive (list (jabber-read-account))) (jabber-send-iq jc nil "set" `(enable ((xmlns . "urn:xmpp:carbons:2"))) #'jabber-carbon-success "Carbons feature enablement" #'jabber-carbon-failure "Carbons feature enablement")) (jabber-disco-advertise-feature "urn:xmpp:carbons:2") (provide 'jabber-carbons) ;;; jabber-carbons.el ends here emacs-jabber/lisp/jabber-chat.el000066400000000000000000000655571476345337400170660ustar00rootroot00000000000000;;; jabber-chat.el --- one-to-one chats -*- lexical-binding: t; -*- ;; 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 ;;; Code: (require 'jabber-core) (require 'jabber-alert) (require 'jabber-chatbuffer) (require 'jabber-history) (require 'jabber-menu) ;we need jabber-jid-chat-menu (require 'ewoc) (require 'goto-addr) (eval-when-compile (require 'cl-lib)) (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) (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) (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) (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) (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) (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) (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) (defface jabber-rare-time-face '((t (:foreground "darkgreen" :underline t))) "face for displaying the rare time info") (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) (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) (defface jabber-chat-prompt-local '((t (:foreground "blue" :weight bold))) "face for displaying the chat prompt for what you type in") (defface jabber-chat-prompt-foreign '((t (:foreground "red" :weight bold))) "face for displaying the chat prompt for what they send") (defface jabber-chat-prompt-system '((t (:foreground "green" :weight bold))) "face used for system and special messages") (defface jabber-chat-text-local '((t ())) "Face used for text you write") (defface jabber-chat-text-foreign '((t ())) "Face used for text others write") (defface jabber-chat-error '((t (:foreground "red" :weight bold))) "Face used for error messages") ;;;###autoload (defvar jabber-chatting-with nil "JID of the person you are chatting with.") (defvar jabber-chat-printers '(jabber-chat-print-subject jabber-chat-print-body jabber-chat-print-url jabber-chat-goto-address) "List of functions that may be able to print part of a message. Each function receives these arguments: XML-DATA The entire message stanza WHO :local or :foreign, for sent or received stanza, respectively MODE :insert or :printp. For :insert, insert text at point. For :printp, return non-nil if function would insert text.") (defvar jabber-body-printers '(jabber-chat-normal-body) "List of functions that may be able to print a body for a message. Each function receives these arguments: XML-DATA The entire message stanza WHO :local, :foreign or :error MODE :insert or :printp. For :insert, insert text at point. For :printp, return non-nil if function would insert text. These functions are called in order, until one of them returns non-nil. Add a function to the beginning of this list if the tag it handles replaces the contents of the tag.") (defvar jabber-chat-send-hooks nil "List of functions called when a chat message is sent. The arguments are the text to send, and the id attribute of the message. The functions should return a list of XML nodes they want to be added to the outgoing message.") ;; Global reference declarations (declare-function jabber-compose "jabber-compose.el" (jc &optional recipient)) (declare-function jabber-muc-private-create-buffer "jabber-muc.el" (jc group nickname)) (declare-function jabber-muc-print-prompt "jabber-muc.el" (xml-data &optional local dont-print-nick-p)) (declare-function jabber-muc-private-print-prompt "jabber-muc.el" (xml-data)) (declare-function jabber-muc-system-prompt "jabber-muc.el" (&rest _ignore)) (declare-function jabber-muc-message-p "jabber-muc.el"(message)) (declare-function jabber-muc-sender-p "jabber-muc.el" (jid)) (declare-function jabber-muc-private-message-p "jabber-muc.el" (message)) (defvar jabber-group) ; jabber-muc.el (defvar jabber-muc-printers) ; jabber-muc.el ;; (defvar jabber-chat-earliest-backlog nil "Float-time of earliest backlog entry inserted into buffer. nil if no backlog has been inserted.") ;;;###autoload (defun jabber-chat-get-buffer (chat-with) "Return the chat buffer for chatting with CHAT-WITH (bare or full JID). Either a string or a buffer is returned, so use `get-buffer' or `get-buffer-create'." (format-spec jabber-chat-buffer-format (list (cons ?n (jabber-jid-displayname chat-with)) (cons ?j (jabber-jid-user chat-with)) (cons ?r (or (jabber-jid-resource chat-with) ""))))) (defun jabber-chat-create-buffer (jc chat-with) "Prepare a buffer for chatting with CHAT-WITH. This function is idempotent. JC is the Jabber connection." (with-current-buffer (get-buffer-create (jabber-chat-get-buffer chat-with)) (unless (eq major-mode 'jabber-chat-mode) (jabber-chat-mode jc #'jabber-chat-pp) (make-local-variable 'jabber-chatting-with) (setq jabber-chatting-with chat-with) (setq jabber-send-function #'jabber-chat-send) (setq header-line-format jabber-chat-header-line-format) (make-local-variable 'jabber-chat-earliest-backlog) ;; insert backlog (when (null jabber-chat-earliest-backlog) (let ((backlog-entries (jabber-history-backlog chat-with))) (if (null backlog-entries) (setq jabber-chat-earliest-backlog (jabber-float-time)) (setq jabber-chat-earliest-backlog (jabber-float-time (jabber-parse-time (aref (car backlog-entries) 0)))) (mapc #'jabber-chat-insert-backlog-entry (nreverse backlog-entries)))))) ;; Make sure the connection variable is up to date. (setq jabber-buffer-connection jc) (current-buffer))) (defun jabber-chat-insert-backlog-entry (msg) "Insert backlog entry MSG at beginning of buffer." ;; Rare timestamps are especially important in backlog. We risk ;; having superfluous timestamps if we just add before each backlog ;; entry. (let* ((message-time (jabber-parse-time (aref msg 0))) (fake-stanza `(message ((from . ,(aref msg 2))) (body nil ,(aref msg 4)) (x ((xmlns . "jabber:x:delay") (stamp . ,(jabber-encode-legacy-time message-time)))))) (node-data (list (if (string= (aref msg 1) "in") :foreign :local) fake-stanza :delayed t))) ;; Insert after existing rare timestamp? (if (and jabber-print-rare-time (ewoc-nth jabber-chat-ewoc 0) (eq (car (ewoc-data (ewoc-nth jabber-chat-ewoc 0))) :rare-time) (not (jabber-rare-time-needed message-time (cadr (ewoc-data (ewoc-nth jabber-chat-ewoc 0)))))) (ewoc-enter-after jabber-chat-ewoc (ewoc-nth jabber-chat-ewoc 0) node-data) ;; Insert first. (ewoc-enter-first jabber-chat-ewoc node-data) (when jabber-print-rare-time (ewoc-enter-first jabber-chat-ewoc (list :rare-time message-time)))))) (add-to-list 'jabber-jid-chat-menu (cons "Display more context" 'jabber-chat-display-more-backlog)) (defun jabber-chat-display-more-backlog (how-many) "Display more context. The HOW-MANY argument is number of messages. Specify 0 to display all messages." (interactive "nHow many more messages (Specify 0 to display all)? ") (let* ((inhibit-read-only t) (jabber-backlog-days nil) (jabber-backlog-number (if (= how-many 0) t how-many)) (backlog-entries (jabber-history-backlog (or jabber-chatting-with jabber-group) jabber-chat-earliest-backlog))) (when backlog-entries (setq jabber-chat-earliest-backlog (jabber-float-time (jabber-parse-time (aref (car backlog-entries) 0)))) (save-excursion (goto-char (point-min)) (mapc #'jabber-chat-insert-backlog-entry (nreverse backlog-entries)))))) (add-to-list 'jabber-message-chain #'jabber-process-chat) (defun jabber-get-forwarded-message (xml-data) (let* ((sent (car (jabber-xml-get-children xml-data 'sent))) (forwarded (car (jabber-xml-get-children sent 'forwarded))) (forwarded-message (car (jabber-xml-get-children forwarded 'message)))) (when forwarded-message forwarded-message))) (defun jabber-process-chat (jc xml-data) "If XML-DATA is a one-to-one chat message, handle it as such. JC is the Jabber connection." ;; For now, everything that is not a public MUC message is ;; potentially a 1to1 chat message. (when (not (jabber-muc-message-p xml-data)) ;; Note that we handle private MUC messages here. (cl-destructuring-bind (xml-data chat-buffer) (if (car (jabber-xml-get-children xml-data 'sent)) (let* ((fwd-msg (jabber-get-forwarded-message xml-data)) (to (jabber-xml-get-attribute fwd-msg 'to))) (list fwd-msg (and to (jabber-chat-create-buffer jc to)))) (list xml-data nil)) (let ((from (jabber-xml-get-attribute xml-data 'from)) (error-p (jabber-xml-get-children xml-data 'error)) (body-text (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'body)))))) ;; First check if we would output anything for this stanza. (when (or error-p (run-hook-with-args-until-success 'jabber-chat-printers xml-data :foreign :printp)) ;; If so, create chat buffer, if necessary... (with-current-buffer (if (jabber-muc-sender-p from) (jabber-muc-private-create-buffer jc (jabber-jid-user from) (jabber-jid-resource from)) (or chat-buffer (jabber-chat-create-buffer jc from))) ;; ...add the message to the ewoc... (let ((node (ewoc-enter-last jabber-chat-ewoc (list (if error-p :error :foreign) xml-data :time (current-time))))) (jabber-maybe-print-rare-time node)) ;; ...and call alert hooks. (dolist (hook '(jabber-message-hooks jabber-alert-message-hooks)) (run-hook-with-args hook from (current-buffer) body-text (funcall jabber-alert-message-function from (current-buffer) body-text))))))))) (defun jabber-chat-send (jc body) "Send BODY through connection JC, and display it in chat buffer. JC is the Jabber connection." ;; Build the stanza... (let* ((id (apply #'format "emacs-msg-%d.%d.%d" (current-time))) (stanza-to-send `(message ((to . ,jabber-chatting-with) (type . "chat") (id . ,id)) (body () ,body)))) ;; ...add additional elements... ;; TODO: Once we require Emacs 24.1, use `run-hook-wrapped' instead. ;; That way we don't need to eliminate the "local hook" functionality ;; here. (dolist (hook jabber-chat-send-hooks) (if (eq hook t) ;; Local hook referring to global... (when (local-variable-p 'jabber-chat-send-hooks) (dolist (global-hook (default-value 'jabber-chat-send-hooks)) (nconc stanza-to-send (funcall global-hook body id)))) (nconc stanza-to-send (funcall hook body id)))) ;; ...display it, if it would be displayed. (when (run-hook-with-args-until-success 'jabber-chat-printers stanza-to-send :local :printp) (jabber-maybe-print-rare-time (ewoc-enter-last jabber-chat-ewoc (list :local stanza-to-send :time (current-time))))) ;; ...and send it... (jabber-send-sexp jc stanza-to-send))) (defun jabber-chat-pp (data) "Pretty-print a stanza. \(car data) is either :local, :foreign, :error or :notice. \(cadr data) is the stanza. This function is used as an ewoc prettyprinter." (let* ((beg (point)) (original-timestamp (when (listp (cadr data)) (jabber-message-timestamp (cadr data)))) (internal-time (plist-get (cddr data) :time)) (body (ignore-errors (car (jabber-xml-node-children (car (jabber-xml-get-children (cadr data) 'body)))))) (/me-p (and (> (length body) 4) (string= (substring body 0 4) "/me ")))) ;; Print prompt... (let ((delayed (or original-timestamp (plist-get (cddr data) :delayed))) (prompt-start (point))) (pcase (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))) ((or :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)) ((or :muc-notice :muc-error) (jabber-muc-system-prompt))) (put-text-property prompt-start (point) 'field 'jabber-prompt)) ;; ...and body (pcase (car data) ((or :local :foreign) (run-hook-with-args 'jabber-chat-printers (cadr data) (car data) :insert)) ((or :muc-local :muc-foreign) (let ((args (list (cadr data) (car data) :insert))) (mapc (lambda (f) (apply f args)) (append jabber-muc-printers jabber-chat-printers)))) ((or :error :muc-error) (if (stringp (cadr data)) (insert (jabber-propertize (cadr data) 'face 'jabber-chat-error)) (jabber-chat-print-error (cadr data)))) ((or :notice :muc-notice) (insert (cadr data))) (:rare-time (insert (jabber-propertize (format-time-string jabber-rare-time-format (cadr data)) 'face 'jabber-rare-time-face))) (:subscription-request (insert "This user requests subscription to your presence.\n") (when (and (stringp (cadr data)) (not (zerop (length (cadr data))))) (insert "Message: " (cadr data) "\n")) (insert "Accept?\n\n") (cl-flet ((button (text action) (if (fboundp 'insert-button) (insert-button text 'action action) ;; simple button replacement (let ((keymap (make-keymap))) (define-key keymap "\r" action) (insert (jabber-propertize text 'keymap keymap 'face 'highlight)))) (insert "\t"))) (button "Mutual" 'jabber-subscription-accept-mutual) (button "One-way" 'jabber-subscription-accept-one-way) (button "Decline" 'jabber-subscription-decline)))) (when jabber-chat-fill-long-lines (save-restriction (narrow-to-region beg (point)) (jabber-chat-buffer-fill-long-lines))) (put-text-property beg (point) 'read-only t) (put-text-property beg (point) 'front-sticky t) (put-text-property beg (point) 'rear-nonsticky t))) (defun jabber-rare-time-needed (time1 time2) "Return non-nil if a timestamp should be printed between TIME1 and TIME2." (not (string= (format-time-string jabber-rare-time-format time1) (format-time-string jabber-rare-time-format time2)))) (defun jabber-maybe-print-rare-time (node) "Print rare time before NODE, if appropriate." (let* ((prev (ewoc-prev jabber-chat-ewoc node)) (data (ewoc-data node)) (prev-data (when prev (ewoc-data prev)))) (cl-flet ((entry-time (entry) (or (when (listp (cadr entry)) (jabber-message-timestamp (cadr entry))) (plist-get (cddr entry) :time)))) (when (and jabber-print-rare-time (or (null prev) (jabber-rare-time-needed (entry-time prev-data) (entry-time data)))) (ewoc-enter-before jabber-chat-ewoc node (list :rare-time (entry-time data))))))) (defun jabber-chat-print-prompt (xml-data timestamp delayed dont-print-nick-p) "Print prompt for received message in XML-DATA. TIMESTAMP is the timestamp to print, or nil to get it from a jabber:x:delay element. If DELAYED is non-nil, print long timestamp \(`jabber-chat-delayed-time-format' as opposed to `jabber-chat-time-format'). If DONT-PRINT-NICK-P is non-nil, don't include nickname." (let ((from (jabber-xml-get-attribute xml-data 'from)) (timestamp (or timestamp (jabber-message-timestamp xml-data)))) (insert (jabber-propertize (format-spec jabber-chat-foreign-prompt-format (list (cons ?t (format-time-string (if delayed jabber-chat-delayed-time-format jabber-chat-time-format) timestamp)) (cons ?n (if dont-print-nick-p "" (jabber-jid-displayname from))) (cons ?u (or (jabber-jid-username from) from)) (cons ?r (jabber-jid-resource from)) (cons ?j (jabber-jid-user from)))) 'face 'jabber-chat-prompt-foreign 'help-echo (concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from " from))))) (defun jabber-chat-system-prompt (timestamp) (insert (jabber-propertize (format-spec jabber-chat-foreign-prompt-format (list (cons ?t (format-time-string jabber-chat-time-format timestamp)) (cons ?n "") (cons ?u "") (cons ?r "") (cons ?j ""))) 'face 'jabber-chat-prompt-system 'help-echo (concat (format-time-string "System message on %Y-%m-%d %H:%M:%S" timestamp))))) (defun jabber-chat-self-prompt (timestamp delayed dont-print-nick-p) "Print prompt for sent message. TIMESTAMP is the timestamp to print, or nil for now. If DELAYED is non-nil, print long timestamp \(`jabber-chat-delayed-time-format' as opposed to `jabber-chat-time-format'). If DONT-PRINT-NICK-P is non-nil, don't include nickname." (let* ((state-data (fsm-get-state-data jabber-buffer-connection)) (username (plist-get state-data :username)) (server (plist-get state-data :server)) (resource (plist-get state-data :resource)) (nickname username)) (insert (jabber-propertize (format-spec jabber-chat-local-prompt-format (list (cons ?t (format-time-string (if delayed jabber-chat-delayed-time-format jabber-chat-time-format) timestamp)) (cons ?n (if dont-print-nick-p "" nickname)) (cons ?u username) (cons ?r resource) (cons ?j (concat username "@" server)))) 'face 'jabber-chat-prompt-local 'help-echo (concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from you"))))) (defun jabber-chat-print-error (xml-data) "Print error in given in a readable way. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((the-error (car (jabber-xml-get-children xml-data 'error)))) (insert (jabber-propertize (concat "Error: " (jabber-parse-error the-error)) 'face 'jabber-chat-error)))) (defun jabber-chat-print-subject (xml-data _who mode) "Print subject of given , if any. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((subject (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'subject)))))) (when (not (zerop (length subject))) (pcase 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 (pcase who ((or :foreign :muc-foreign) 'jabber-chat-text-foreign) ((or :local :muc-local) 'jabber-chat-text-local)))))) t))) (defun jabber-chat-print-url (xml-data _who mode) "Print URLs provided in jabber:x:oob namespace. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((foundp nil)) (dolist (x (jabber-xml-node-children xml-data)) (when (and (listp x) (eq (jabber-xml-node-name x) 'x) (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:oob")) (setq foundp t) (when (eql mode :insert) (let ((url (car (jabber-xml-node-children (car (jabber-xml-get-children x 'url))))) (desc (car (jabber-xml-node-children (car (jabber-xml-get-children x 'desc)))))) (insert "\n" (jabber-propertize "URL: " 'face 'jabber-chat-prompt-system) (format "%s <%s>" desc url)))))) foundp)) (defun jabber-chat-goto-address (_xml-data _who mode) "Call `goto-address' on the newly written text. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (when (eq mode :insert) (ignore-errors (let ((end (point)) (limit (max (- (point) 1000) (1+ (point-min))))) ;; We only need to fontify the text written since the last ;; prompt. The prompt has a field property, so we can find it ;; using `field-beginning'. (goto-address-fontify (field-beginning nil nil limit) end))))) ;; 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. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "to: ") (jabber-read-with-input-method "subject: ") (jabber-read-with-input-method "body: ") (read-string "type: "))) (jabber-send-sexp jc `(message ((to . ,to) ,(if (> (length type) 0) `(type . ,type))) ,(if (> (length subject) 0) `(subject () ,subject)) ,(if (> (length body) 0) `(body () ,body)))) (if (and jabber-history-enabled (not (string= type "groupchat"))) (jabber-history-log-message "out" nil to body (current-time)))) (add-to-list 'jabber-jid-chat-menu (cons "Start chat" 'jabber-chat-with)) (defun jabber-chat-with (jc jid &optional other-window) "Open an empty chat window for chatting with JID. With a prefix argument, open buffer in other window. Returns the chat buffer. JC is the Jabber connection." (interactive (let* ((jid (jabber-read-jid-completing "chat with:")) (account (jabber-read-account nil jid))) (list account jid current-prefix-arg))) (let ((buffer (jabber-chat-create-buffer jc jid))) (if other-window (switch-to-buffer-other-window buffer) (switch-to-buffer buffer)))) (defun jabber-chat-with-jid-at-point (&optional other-window) "Start chat with JID at point. Signal an error if there is no JID at point. With a prefix argument, open buffer in other window." (interactive "P") (let ((jid-at-point (get-text-property (point) 'jabber-jid)) (account (get-text-property (point) 'jabber-account))) (if (and jid-at-point account) (jabber-chat-with account jid-at-point other-window) (error "No contact at point")))) (provide 'jabber-chat) ;;; jabber-chat.el ends here emacs-jabber/lisp/jabber-chatbuffer.el000066400000000000000000000134751476345337400202500ustar00rootroot00000000000000;;; jabber-chatbuffer.el --- functions common to all chat buffers -*- lexical-binding: t; -*- ;; 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-util) (require 'jabber-core) (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.") ;; Global reference declarations (declare-function jabber-muc-nick-completion-at-point "jabber-nick-completion.el" ()) ;; ;;;###autoload (defvar jabber-buffer-connection nil "The connection used by this buffer.") ;;;###autoload (make-variable-buffer-local 'jabber-buffer-connection) (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) (define-key map "\t" 'completion-at-point) map)) (defun jabber-chat-mode (jc ewoc-pp) "Jabber chat mode. \\{jabber-chat-mode-map} JC is the Jabber connection." (kill-all-local-variables) ;; Make sure to set this variable somewhere (make-local-variable 'jabber-send-function) (make-local-variable 'scroll-conservatively) (make-local-variable 'jabber-point-insert) (make-local-variable 'jabber-chat-ewoc) (make-local-variable 'buffer-undo-list) (add-hook 'completion-at-point-functions #'jabber-muc-nick-completion-at-point nil t) (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) (defun jabber-chat-buffer-send () (interactive) ;; If user accidentally hits RET without writing anything, just ;; ignore it. (when (cl-plusp (- (point-max) jabber-point-insert)) ;; If connection was lost... (unless (memq jabber-buffer-connection jabber-connections) ;; ...maybe there is a new connection to the same account. (let ((new-jc (jabber-find-active-connection jabber-buffer-connection))) (if new-jc ;; If so, just use it. (setq jabber-buffer-connection new-jc) ;; Otherwise, ask for a new account. (setq jabber-buffer-connection (jabber-read-account t))))) (let ((body (delete-and-extract-region jabber-point-insert (point-max)))) (funcall jabber-send-function jabber-buffer-connection body)))) (defun jabber-chat-buffer-fill-long-lines () "Fill lines that are wider than the window width." ;; This was mostly stolen from article-fill-long-lines (interactive) (save-excursion (let ((inhibit-read-only t) (width (window-width (get-buffer-window (current-buffer))))) (goto-char (point-min)) (let ((adaptive-fill-mode nil)) ;Why? -sm (while (not (eobp)) (end-of-line) (when (>= (current-column) (min fill-column width)) (save-restriction (narrow-to-region (min (1+ (point)) (point-max)) (line-beginning-position)) (let ((goback (point-marker))) (fill-paragraph nil) (goto-char (marker-position goback))))) (forward-line 1)))))) (defun jabber-chat-buffer-switch () "Switch to a specified jabber chat buffer." (interactive) (let* ((jabber-buffers (cl-loop for buffer in (buffer-list) when (with-current-buffer buffer (eq major-mode 'jabber-chat-mode)) collect (buffer-name buffer))) (jabber-buffer (and jabber-buffers (completing-read "Switch to jabber buffer: " jabber-buffers)))) (if jabber-buffer (switch-to-buffer jabber-buffer) (error "No jabber buffer found")))) (provide 'jabber-chatbuffer) ;;; jabber-chatbuffer.el ends here emacs-jabber/lisp/jabber-chatstates.el000066400000000000000000000154351476345337400203000ustar00rootroot00000000000000;;; jabber-chatstate.el --- Chat state notification (XEP-0085) implementation -*- lexical-binding: t; -*- ;; Author: Ami Fischman ;; (based entirely on jabber-events.el by Magnus Henoch ) ;; 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. ;;; Code: (require 'cl-lib) (require 'jabber-core) (require 'jabber-chat) (require 'jabber-chatbuffer) (require 'jabber-disco) (require 'jabber-xml) (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?" :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) (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) ;;; 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-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 a `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 (cl-find jabber-chatstates-xmlns (jabber-xml-node-children xml-data) :key #'(lambda (x) (jabber-xml-get-attribute x 'xmlns)) :test #'string=))) (jabber-xml-node-name node)) (let ((node ;; XXX: this is how we interoperate with ;; Google Talk. We should really use a ;; namespace-aware XML parser. (cl-find jabber-chatstates-xmlns (jabber-xml-node-children xml-data) :key #'(lambda (x) (jabber-xml-get-attribute x 'xmlns:cha)) :test #'string=))) (when node ;; Strip the "cha:" prefix (let ((name (symbol-name (jabber-xml-node-name node)))) (when (> (length name) 4) (intern (substring name 4))))))))) ;; Set up hooks for composition notification (when (and jabber-chatstates-confirm state) (setq jabber-chatstates-requested t) (add-hook 'post-command-hook #'jabber-chatstates-after-change nil t)) (setq jabber-chatstates-last-state state) (jabber-chatstates-update-message))))))) ;; Add function last in chain, so a chat buffer is already created. (add-to-list 'jabber-message-chain #'jabber-handle-incoming-message-chatstates t) (jabber-disco-advertise-feature "http://jabber.org/protocol/chatstates") (provide 'jabber-chatstates) ;;; jabber-chatstates.el ends hereemacs-jabber/lisp/jabber-compose.el000066400000000000000000000056461476345337400176050ustar00rootroot00000000000000;;; jabber-compose.el --- compose a Jabber message in a buffer -*- lexical-binding: t; -*- ;; Copyright (C) 2006, 2007 Magnus Henoch ;; Author: Magnus Henoch ;; 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: (require 'jabber-core) (require 'jabber-util) (require 'jabber-widget) (require 'jabber-chat) ;; Global reference declarations (defvar jabber-buffer-connection) ; jabber-chatbuffer.el ;; ;;;###autoload (defun jabber-compose (jc &optional recipient) "Create a buffer for composing a Jabber message. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "To whom? "))) (with-current-buffer (get-buffer-create (generate-new-buffer-name (concat "Jabber-Compose" (when recipient (format "-%s" (jabber-jid-displayname recipient)))))) (set (make-local-variable 'jabber-widget-alist) nil) (setq jabber-buffer-connection jc) (use-local-map widget-keymap) (insert (jabber-propertize "Compose Jabber message\n" 'face 'jabber-title-large)) (insert (substitute-command-keys "\\Completion available with \\[widget-complete].\n")) (push (cons :recipients (widget-create '(repeat :tag "Recipients" jid) :value (when recipient (list recipient)))) jabber-widget-alist) (insert "\nSubject: ") (push (cons :subject (widget-create 'editable-field :value "")) jabber-widget-alist) (insert "\nText:\n") (push (cons :text (widget-create 'text :value "")) jabber-widget-alist) (insert "\n") (widget-create 'push-button :notify #'jabber-compose-send "Send") (widget-setup) (switch-to-buffer (current-buffer)) (goto-char (point-min)))) (defun jabber-compose-send (&rest _ignore) (let ((recipients (widget-value (cdr (assq :recipients jabber-widget-alist)))) (subject (widget-value (cdr (assq :subject jabber-widget-alist)))) (text (widget-value (cdr (assq :text jabber-widget-alist))))) (when (null recipients) (error "No recipients specified")) (dolist (to recipients) (jabber-send-message jabber-buffer-connection to subject text nil)) (bury-buffer) (message "Message sent"))) (provide 'jabber-compose) ;;; jabber-compose.el ends hereemacs-jabber/lisp/jabber-conn.el000066400000000000000000000347151476345337400170740ustar00rootroot00000000000000;;; jabber-conn.el --- Network transport functions -*- lexical-binding: t; -*- ;; 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 from a Jabber Server. Mostly inspired by Gnus. (eval-when-compile (require 'cl-lib)) (require 'jabber-core) (require 'fsm) ;; Emacs 24 can be linked with GnuTLS (require 'gnutls nil t) (require 'starttls nil t) (require 'srv) (defgroup jabber-conn nil "Jabber Connection Settings." :group 'jabber) (defun jabber-have-starttls () "Return non-nil if we can use STARTTLS." (or (and (fboundp 'gnutls-available-p) (gnutls-available-p)) (and (featurep 'starttls) (or (and (bound-and-true-p starttls-gnutls-program) (executable-find starttls-gnutls-program)) (and (bound-and-true-p starttls-program) (executable-find starttls-program)))))) (defconst jabber-default-connection-type (cond ;; Use STARTTLS if we can... ((jabber-have-starttls) 'starttls) ;; ...else default to unencrypted connection. (t 'network)) "Default connection type. See `jabber-connect-methods'.") (defcustom jabber-connection-ssl-program nil "Program used for SSL/TLS connections. nil means prefer gnutls but fall back to openssl. \='gnutls\=' means use gnutls (through `open-tls-stream'). \='openssl means use openssl (through `open-ssl-stream')." :type '(choice (const :tag "Prefer gnutls, fall back to openssl" nil) (const :tag "Use gnutls" gnutls) (const :tag "Use openssl" openssl))) (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)) (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.") ;; Global reference declarations (declare-function starttls-negotiate "starttls.el" (process)) (declare-function starttls-open-stream "starttls.el" (name buffer host port)) (declare-function gnutls-negotiate "gnutls.el" (&rest spec &key process type hostname priority-string trustfiles crlfiles keylist min-prime-bits verify-flags verify-error verify-hostname-error &allow-other-keys)) (defvar jabber-process-buffer) ; jabber.el (defvar jabber-debug-keep-process-buffers) ; jabber.el ;; (defun jabber-get-connect-function (type) "Get the connect function associated with TYPE. TYPE is a symbol; see `jabber-connection-type'." (let ((entry (assq type jabber-connect-methods))) (nth 1 entry))) (defun jabber-get-send-function (type) "Get the send function associated with TYPE. TYPE is a symbol; see `jabber-connection-type'." (let ((entry (assq type jabber-connect-methods))) (nth 2 entry))) (defun jabber-srv-targets (server network-server port) "Find host and port to connect to. If NETWORK-SERVER and/or PORT are specified, use them. If we can't find SRV records, use standard defaults." ;; If the user has specified a host or a port, obey that. (if (or network-server port) (list (cons (or network-server server) (or port 5222))) (or (condition-case nil (srv-lookup (concat "_xmpp-client._tcp." server)) (error nil)) (list (cons server 5222))))) ;; Plain TCP/IP connection (defun jabber-network-connect (fsm server network-server port) "Connect to a Jabber server with a plain network connection. Send a message of the form (:connected CONNECTION) to FSM if connection succeeds. Send a message (:connection-failed ERRORS) if connection fails." (cond ((featurep 'make-network-process '(:nowait t)) ;; We can connect asynchronously! (jabber-network-connect-async fsm server network-server port)) (t ;; Connecting to the server will block Emacs. (jabber-network-connect-sync fsm server network-server port)))) (defun jabber-network-connect-async (fsm server network-server port) ;; Get all potential targets... (let ((targets (jabber-srv-targets server network-server port)) errors) ;; ...and connect to them one after another, asynchronously, until ;; connection succeeds. (cl-labels ((connect (target remaining-targets) (cl-labels ((connection-successful (c) ;; This mustn't be `fsm-send-sync', because the FSM ;; needs to change the sentinel, which cannot be done ;; from inside the sentinel. (fsm-send fsm (list :connected c))) (connection-failed (c status) (when (and (> (length status) 0) (eq (aref status (1- (length status))) ?\n)) (setq status (substring status 0 -1))) (let ((err (format "Couldn't connect to %s:%s: %s" (car target) (cdr target) status))) (message "%s" err) (push err errors)) (when c (delete-process c)) (if remaining-targets (progn (message "Connecting to %s:%s..." (caar remaining-targets) (cdar remaining-targets)) (connect (car remaining-targets) (cdr remaining-targets))) (fsm-send fsm (list :connection-failed (nreverse errors)))))) (condition-case e (make-network-process :name "jabber" :buffer (generate-new-buffer jabber-process-buffer) :host (car target) :service (cdr target) :coding 'utf-8 :nowait t :sentinel (lambda (connection status) (cond ((string-match "^open" status) (connection-successful connection)) ((string-match "^failed" status) (connection-failed connection status)) ((string-match "^deleted" status) ;; This happens when we delete a process in the ;; "failed" case above. nil) (t (message "Unknown sentinel status `%s'" status))))) (file-error ;; A file-error has the error message in the third list ;; element. (connection-failed nil (car (cddr e)))) (error ;; Not sure if we ever get anything but file-errors, ;; but let's make sure we report them: (connection-failed nil (error-message-string e))))))) (message "Connecting to %s:%s..." (caar targets) (cdar targets)) (connect (car targets) (cdr targets))))) (defun jabber-network-connect-sync (fsm server network-server port) ;; This code will AFAIK only be used on Windows. Apologies in ;; advance for any bit rot... (let ((coding-system-for-read 'utf-8) (coding-system-for-write 'utf-8) (targets (jabber-srv-targets server network-server port)) errors) (catch 'connected (dolist (target targets) (condition-case e (let ((process-buffer (generate-new-buffer jabber-process-buffer)) connection) (unwind-protect (setq connection (open-network-stream "jabber" process-buffer (car target) (cdr target))) (unless (or connection jabber-debug-keep-process-buffers) (kill-buffer process-buffer))) (when connection (fsm-send fsm (list :connected connection)) (throw 'connected connection))) (file-error ;; A file-error has the error message in the third list ;; element. (let ((err (format "Couldn't connect to %s:%s: %s" (car target) (cdr target) (car (cddr e))))) (message "%s" err) (push err errors))) (error ;; Not sure if we ever get anything but file-errors, ;; but let's make sure we report them: (let ((err (format "Couldn't connect to %s:%s: %s" (car target) (cdr target) (error-message-string e)))) (message "%s" err) (push err errors))))) (fsm-send fsm (list :connection-failed (nreverse errors)))))) (defun jabber-network-send (connection string) "Send a string via a plain TCP/IP connection to the Jabber Server." (process-send-string connection string)) ;; SSL connection, we use openssl's s_client function for encryption ;; of the link ;; TODO: make this configurable (defun jabber-ssl-connect (fsm server network-server port) "Connect via OpenSSL or GnuTLS to a Jabber Server. Send a message of the form (:connected CONNECTION) to FSM if connection succeeds. Send a message (:connection-failed ERRORS) if connection fails." (let ((coding-system-for-read 'utf-8) (coding-system-for-write 'utf-8) (connect-function (cond ((and (memq jabber-connection-ssl-program '(nil gnutls)) (fboundp 'open-tls-stream)) 'open-tls-stream) ((and (memq jabber-connection-ssl-program '(nil openssl)) (fboundp 'open-ssl-stream)) 'open-ssl-stream) (t (error "Neither TLS nor SSL connect functions available")))) error-msg) (let ((process-buffer (generate-new-buffer jabber-process-buffer)) connection) (setq network-server (or network-server server)) (setq port (or port 5223)) (condition-case e (setq connection (funcall connect-function "jabber" process-buffer network-server port)) (error (setq error-msg (format "Couldn't connect to %s:%d: %s" network-server port (error-message-string e))) (message "%s" error-msg))) (unless (or connection jabber-debug-keep-process-buffers) (kill-buffer process-buffer)) (if connection (fsm-send fsm (list :connected connection)) (fsm-send fsm (list :connection-failed (when error-msg (list error-msg)))))))) (defun jabber-ssl-send (connection string) "Send a string via an SSL-encrypted connection to the Jabber Server." ;; It seems we need to send a linefeed afterwards. (process-send-string connection string) (process-send-string connection "\n")) (defun jabber-starttls-connect (fsm server network-server port) "Connect via an external GnuTLS process to a Jabber Server. Send a message of the form (:connected CONNECTION) to FSM if connection succeeds. Send a message (:connection-failed ERRORS) if connection fails." (let ((coding-system-for-read 'utf-8) (coding-system-for-write 'utf-8) (targets (jabber-srv-targets server network-server port)) errors) (unless (fboundp 'starttls-open-stream) (error "The starttls.el library is not available")) (catch 'connected (dolist (target targets) (condition-case e (let ((process-buffer (generate-new-buffer jabber-process-buffer)) connection) (unwind-protect (setq connection (starttls-open-stream "jabber" process-buffer (car target) (cdr target))) (unless (or connection jabber-debug-keep-process-buffers) (kill-buffer process-buffer))) (if (null connection) ;; It seems we don't actually get an error if we ;; can't connect. Let's try to convey some useful ;; information to the user at least. (let ((err (format "Couldn't connect to %s:%s" (car target) (cdr target)))) (message "%s" err) (push err errors)) (fsm-send fsm (list :connected connection)) (throw 'connected connection))) (error (let ((err (format "Couldn't connect to %s: %s" target (error-message-string e)))) (message "%s" err) (push err errors))))) (fsm-send fsm (list :connection-failed (nreverse errors)))))) (defun jabber-starttls-initiate (fsm) "Initiate a STARTTLS connection." (jabber-send-sexp fsm '(starttls ((xmlns . "urn:ietf:params:xml:ns:xmpp-tls"))))) (defun jabber-starttls-process-input (fsm xml-data) "Process result of starttls request. On failure, signal error. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (cond ((eq (car xml-data) 'proceed) (let* ((state-data (fsm-get-state-data fsm)) (connection (plist-get state-data :connection))) ;; Did we use open-network-stream or starttls-open-stream? We ;; can tell by process-type. (pcase (process-type connection) ('network (let* ((hostname (plist-get state-data :server)) (verifyp (not (member hostname jabber-invalid-certificate-servers)))) ;; gnutls-negotiate might signal an error, which is caught ;; by our caller (gnutls-negotiate :process connection ;; This is the hostname that the certificate should be valid for: :hostname hostname :verify-hostname-error verifyp :verify-error verifyp))) ('real (or (starttls-negotiate connection) (error "Negotiation failure")))))) ((eq (car xml-data) 'failure) (error "Command rejected by server")))) (defvar *jabber-virtual-server-function* nil "Function to use for sending stanzas on a virtual connection. The function should accept two arguments, the connection object and a string that the connection wants to send.") (defun jabber-virtual-connect (fsm _server _network-server _port) "Connect to a virtual \"server\". Use `*jabber-virtual-server-function*' as send function. FSM is the finite state machine created in jabber.el library." (unless (functionp *jabber-virtual-server-function*) (error "No virtual server function specified")) ;; We pass the fsm itself as "connection object", as that is what a ;; virtual server needs to send stanzas. (fsm-send fsm (list :connected fsm))) (defun jabber-virtual-send (connection string) (funcall *jabber-virtual-server-function* connection string)) (provide 'jabber-conn) ;;; jabber-conn.el ends here emacs-jabber/lisp/jabber-console.el000066400000000000000000000132561476345337400175760ustar00rootroot00000000000000;;; jabber-console.el --- XML Console mode -*- lexical-binding: t; -*- ;; Copyright (C) 2009, 2010 - Demyan Rogozhin ;; 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 'jabber-truncate) (require 'xml) (require 'ewoc) (require 'sgml-mode) ;we base on this mode to hightlight XML (defcustom jabber-debug-log-xml nil "Set to non-nil to log all XML i/o in *-jabber-console-JID-* buffer. Set to string to also dump XML i/o in specified file." :type '(choice (const :tag "Do not dump XML i/o" nil) (const :tag "Dump XML i/o in console" t) (string :tag "Dump XML i/o in console and this file")) :group 'jabber-debug) (defcustom jabber-console-name-format "*-jabber-console-%s-*" "Format for console buffer name. %s mean connection jid." :type 'string :group 'jabber-debug) (defcustom jabber-console-truncate-lines 3000 "Maximum number of lines in console buffer. Not truncate if set to 0." :type 'integer :group 'jabber-debug) (defvar jabber-point-insert nil "Position where the message being composed starts.") (defvar jabber-send-function nil "Function for sending a message from a chat buffer.") (defvar jabber-console-mode-hook nil "Hook called at the end of `jabber-console-mode'. Note that functions in this hook have no way of knowing what kind of chat buffer is being created.") (defvar jabber-console-ewoc nil "The ewoc showing the XML elements of this stream buffer.") (defvar jabber-console-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map jabber-common-keymap) (define-key map "\r" #'jabber-chat-buffer-send) map)) ;; Global reference declarations (declare-function jabber-send-string "jabber-core.el" (jc string)) (declare-function jabber-chat-buffer-send "jabber-chatbuffer.el" ()) (defvar jabber-buffer-connection) ; jabber-chatbuffer.el ;; (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 emacs-jabber/lisp/jabber-core.el000066400000000000000000001076601476345337400170670ustar00rootroot00000000000000;;; jabber-core.el --- core functions -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; SSL-Connection Parts: ;; Copyright (C) 2005 - Georg Lehner - jorge@magma.com.ni ;; This file is a part of jabber.el. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; Commentary: ;; ;; Standards (probably) involved - ;; 1. [RFC 6120] Extensible Messaging and Presence Protocol (XMPP): Core ;; https://datatracker.ietf.org/doc/rfc6120/ ;; ;; 2. [RFC 7950] Use of Transport Layer Security (TLS) in the Extensible Messaging and Presence Protocol (XMPP) ;; https://datatracker.ietf.org/doc/rfc7590/ ;; ;; 3. [RFC 6121] Extensible Messaging and Presence Protocol (XMPP): Instant Messaging and Presence ;; https://datatracker.ietf.org/doc/rfc6121/ ;; ;; 4. [RFC 7622] Extensible Messaging and Presence Protocol (XMPP): Address Format ;; https://datatracker.ietf.org/doc/rfc7622/ ;;; Code: (require 'cl-lib) (require 'jabber-sasl) (require 'jabber-xml) (require 'jabber-console) (require 'jabber-keepalive) (require 'fsm) (defvar jabber-connections nil "List of jabber-connection FSMs.") (defvar *jabber-roster* nil "The roster list.") (defvar jabber-jid-obarray (make-vector 127 0) "Obarray for keeping JIDs.") (defvar *jabber-disconnecting* nil "Non-nil if are we in the process of voluntary disconnection.") (defvar jabber-message-chain nil "Incoming messages are sent to these functions, in order.") (defvar jabber-iq-chain nil "Incoming infoqueries are sent to these functions, in order.") (defvar jabber-presence-chain nil "Incoming presence notifications are sent to these functions, in order.") (defvar jabber-namespace-prefixes nil "XML namespace prefixes used for the current connection.") (make-variable-buffer-local 'jabber-namespace-prefixes) (defgroup jabber-core nil "customize core functionality." :group 'jabber) (defcustom jabber-post-connect-hooks '(jabber-send-current-presence jabber-muc-autojoin jabber-whitespace-ping-start jabber-vcard-avatars-find-current jabber-enable-carbons) "*Hooks run after successful connection and authentication. The functions should accept one argument, the connection object." :type 'hook :options '(jabber-send-current-presence jabber-muc-autojoin jabber-whitespace-ping-start jabber-keepalive-start jabber-vcard-avatars-find-current jabber-autoaway-start)) (defcustom jabber-pre-disconnect-hook nil "*Hooks run just before voluntary disconnection. This might be due to failed authentication." :type 'hook) (defcustom jabber-lost-connection-hooks nil "*Hooks run after involuntary disconnection. The functions are called with one argument: the connection object." :type 'hook) (defcustom jabber-post-disconnect-hook nil "*Hooks run after disconnection." :type 'hook) (defcustom jabber-auto-reconnect nil "Reconnect automatically after losing connection? This will be of limited use unless you have the password library installed, and have configured it to cache your password indefinitely. See `password-cache' and `password-cache-expiry'." :type 'boolean) (defcustom jabber-reconnect-delay 5 "Seconds to wait before reconnecting." :type 'integer) (defcustom jabber-roster-buffer "*-jabber-roster-*" "The name of the roster buffer." :type 'string) (defcustom jabber-use-sasl t "If non-nil, use SASL if possible. SASL will still not be used if the library for it is missing or if the server doesn't support it. Disabling this shouldn't be necessary, but it may solve certain problems." :type 'boolean) (defsubst jabber-have-sasl-p () "Return non-nil if SASL functions are available." (featurep 'sasl)) (defvar jabber-account-history () "Keeps track of previously used jabber accounts.") (defvar jabber-connection-type-history () "Keeps track of previously used connection types.") ;; jabber-connect and jabber-connect-all should load jabber.el, not ;; just jabber-core.el, when autoloaded. ;; Global reference declarations (declare-function jabber-send-iq "jabber-iq.el" (jc to type query success-callback success-closure-data error-callback error-closure-data &optional result-id)) (declare-function jabber-muc-connection-closed "jabber-muc.el" (bare-jid)) (declare-function jabber-roster-update "jabber-roster.el" (jc new-items changed-items deleted-items)) (declare-function jabber-display-roster "jabber-roster.el" ()) (declare-function jabber-process-roster "jabber-presence.el" (jc xml-data closure-data)) (declare-function jabber-initial-roster-failure "jabber-presence.el" (jc xml-data _closure-data)) (declare-function jabber-get-auth "jabber-logon.el" (jc to session-id)) (declare-function jabber-get-register "jabber-register.el" (jc to)) (declare-function jabber-get-connect-function "jabber-conn.el" (type)) (declare-function jabber-get-send-function "jabber-conn.el" (type)) (declare-function jabber-starttls-process-input "jabber-conn.el" (fsm xml-data)) (declare-function jabber-starttls-initiate "jabber-conn.el" (fsm)) (declare-function jabber-mode-line-presence-update "jabber-modeline.el" ()) (defvar jabber-debug-keep-process-buffers) ; jabber.el (defvar jabber-silent-mode) ; jabber.el (defvar jabber-account-list) ; jabber.el (defvar jabber-xml-data) ; jabber.el (defvar jabber-default-connection-type) ; jabber-conn.el (defvar jabber-connect-methods) ; jabber-conn.el (defvar jabber-mode-line-mode) ; jabber-modeline.el ;; ;;;###autoload (autoload 'jabber-connect-all "jabber" "Connect to all configured Jabber accounts.\nSee `jabber-account-list'.\nIf no accounts are configured (or ARG supplied), call `jabber-connect' interactively." t) (defun jabber-connect-all (&optional arg) "Connect to all configured Jabber accounts. See `jabber-account-list'. If no accounts are configured (or with prefix argument), call `jabber-connect' interactively. With many prefix arguments, one less is passed to `jabber-connect'." (interactive "P") (let ((accounts (cl-remove-if (lambda (account) (cdr (assq :disabled (cdr account)))) jabber-account-list))) (if (or (null accounts) arg) (let ((current-prefix-arg (cond ;; A number of C-u's; remove one, so to speak. ((consp arg) (if (> (car arg) 4) (list (/ (car arg) 4)) nil)) ;; Otherwise, we just don't care. (t arg)))) (call-interactively 'jabber-connect)) ;; Only connect those accounts that are not yet connected. (let ((already-connected (mapcar #'jabber-connection-original-jid jabber-connections)) (connected-one nil)) (dolist (account accounts) (unless (member (jabber-jid-user (car account)) already-connected) (let* ((jid (car account)) (alist (cdr account)) (password (cdr (assq :password alist))) (network-server (cdr (assq :network-server alist))) (port (cdr (assq :port alist))) (connection-type (cdr (assq :connection-type alist)))) (jabber-connect (jabber-jid-username jid) (jabber-jid-server jid) (jabber-jid-resource jid) nil password network-server port connection-type) (setq connected-one t)))) (unless connected-one (message "All configured Jabber accounts are already connected")))))) ;;;###autoload (autoload 'jabber-connect "jabber" "Connect to the Jabber server and start a Jabber XML stream.\nWith prefix argument, register a new account.\nWith double prefix argument, specify more connection details." t) (defun jabber-connect (username server resource &optional registerp password network-server port connection-type) "Connect to the Jabber server and start a Jabber XML stream. With prefix argument, register a new account. With double prefix argument, specify more connection details." (interactive (let* ((jid (completing-read "Enter your JID: " jabber-account-list nil nil nil 'jabber-account-history)) (entry (assoc jid jabber-account-list)) (alist (cdr entry)) password network-server port connection-type registerp) (when (zerop (length jid)) (error "No JID specified")) (unless (jabber-jid-username jid) (error "Missing username part in JID")) (when entry ;; If the user entered the JID of one of the preconfigured ;; accounts, use that data. (setq password (cdr (assq :password alist))) (setq network-server (cdr (assq :network-server alist))) (setq port (cdr (assq :port alist))) (setq connection-type (cdr (assq :connection-type alist)))) (when (equal current-prefix-arg '(16)) ;; Double prefix arg: ask about everything. ;; (except password, which is asked about later anyway) (setq password nil) (setq network-server (read-string (format "Network server: (default `%s') " network-server) nil nil network-server)) (when (zerop (length network-server)) (setq network-server nil)) (setq port (car (read-from-string (read-string (format "Port: (default `%s') " port) nil nil (if port (number-to-string port) "nil"))))) (setq connection-type (car (read-from-string (let ((default (symbol-name (or connection-type jabber-default-connection-type)))) (completing-read (format "Connection type: (default `%s') " default) (mapcar (lambda (type) (cons (symbol-name (car type)) nil)) jabber-connect-methods) nil t nil 'jabber-connection-type-history default))))) (setq registerp (or jabber-silent-mode (yes-or-no-p "Register new account? ")))) (when (equal current-prefix-arg '(4)) (setq registerp t)) (list (jabber-jid-username jid) (jabber-jid-server jid) (jabber-jid-resource jid) registerp password network-server port connection-type))) (require 'jabber) (if (member (list username server) (mapcar (lambda (c) (let ((data (fsm-get-state-data c))) (list (plist-get data :username) (plist-get data :server)))) jabber-connections)) (message "Already connected to %s@%s" username server) ;;(jabber-clear-roster) (push (start-jabber-connection username server resource registerp password network-server port connection-type) jabber-connections))) (define-state-machine jabber-connection :start ((username server resource registerp password network-server port connection-type) "Start a Jabber connection." (let* ((connection-type (or connection-type jabber-default-connection-type)) (send-function (jabber-get-send-function connection-type))) (list :connecting (list :send-function send-function ;; Save the JID we originally connected with. :original-jid (concat username "@" server) :username username :server server :resource resource :password password :registerp registerp :connection-type connection-type :encrypted (eq connection-type 'ssl) :network-server network-server :port port))))) (define-enter-state jabber-connection nil (fsm state-data) ;; `nil' is the error state. ;; Close the network connection. (let ((connection (plist-get state-data :connection))) (when (processp connection) (let ((process-buffer (process-buffer connection))) (delete-process connection) (when (and (bufferp process-buffer) (not jabber-debug-keep-process-buffers)) (kill-buffer process-buffer))))) (setq state-data (plist-put state-data :connection nil)) ;; Clear MUC data (jabber-muc-connection-closed (jabber-connection-bare-jid fsm)) ;; Remove lost connections from the roster buffer. (jabber-display-roster) (let ((expected (plist-get state-data :disconnection-expected)) (reason (plist-get state-data :disconnection-reason)) (ever-session-established (plist-get state-data :ever-session-established))) (unless expected (run-hook-with-args 'jabber-lost-connection-hooks fsm) (message "%s@%s%s: connection lost: `%s'" (plist-get state-data :username) (plist-get state-data :server) (if (plist-get state-data :resource) (concat "/" (plist-get state-data :resource)) "") reason)) (if (and jabber-auto-reconnect (not expected) ever-session-established) ;; Reconnect after a short delay? (list state-data jabber-reconnect-delay) ;; Else the connection is really dead. Remove it from the list ;; of connections. (setq jabber-connections (delq fsm jabber-connections)) (when jabber-mode-line-mode (jabber-mode-line-presence-update)) (jabber-display-roster) ;; And let the FSM sleep... (list state-data nil)))) (define-state jabber-connection nil (fsm state-data event _callback) ;; In the `nil' state, the connection is dead. We wait for a ;; :timeout message, meaning to reconnect, or :do-disconnect, ;; meaning to cancel reconnection. (pcase event (:timeout (list :connecting state-data)) (:do-disconnect (setq jabber-connections (delq fsm jabber-connections)) (list nil state-data nil)))) (define-enter-state jabber-connection :connecting (fsm state-data) (let* ((connection-type (plist-get state-data :connection-type)) (connect-function (jabber-get-connect-function connection-type)) (server (plist-get state-data :server)) (network-server (plist-get state-data :network-server)) (port (plist-get state-data :port))) (funcall connect-function fsm server network-server port)) (list state-data nil)) (define-state jabber-connection :connecting (fsm state-data event _callback) (pcase (or (car-safe event) event) (:connected (let ((connection (cadr event)) ) ;; (registerp (plist-get state-data :registerp)) (setq state-data (plist-put state-data :connection connection)) (when (processp connection) ;; TLS connections leave data in the process buffer, which ;; the XML parser will choke on. (with-current-buffer (process-buffer connection) (erase-buffer)) (set-process-filter connection (fsm-make-filter fsm)) (set-process-sentinel connection (fsm-make-sentinel fsm))) (list :connected state-data))) (:connection-failed (message "Jabber connection failed") (plist-put state-data :disconnection-reason (mapconcat #'identity (cadr event) "; ")) (list nil state-data)) (:do-disconnect ;; We don't have the connection object, so defer the disconnection. :defer))) (defsubst jabber-fsm-handle-sentinel (state-data event) "Handle sentinel event for jabber fsm." ;; We do the same thing for every state, so avoid code duplication. (let* ((string (car (cddr event))) ;; The event string sometimes (always?) has a trailing ;; newline, that we don't care for. (trimmed-string (if (eq ?\n (aref string (1- (length string)))) (substring string 0 -1) string)) (new-state-data ;; If we already know the reason (e.g. a stream error), don't ;; overwrite it. (if (plist-get state-data :disconnection-reason) state-data (plist-put state-data :disconnection-reason trimmed-string)))) (list nil new-state-data))) (define-enter-state jabber-connection :connected (fsm state-data) (jabber-send-stream-header fsm) ;; Next thing happening is the server sending its own start tag. (list state-data nil)) (define-state jabber-connection :connected (fsm state-data event _callback) (pcase (or (car-safe event) event) (:filter (let ((process (cadr event)) (string (car (cddr event)))) (jabber-pre-filter process string fsm) (list :connected state-data))) (:sentinel (jabber-fsm-handle-sentinel state-data event)) (:stream-start (let ((session-id (cadr event)) (stream-version (car (cddr event)))) (setq state-data (plist-put state-data :session-id session-id)) ;; the stream feature is only sent if the initiating entity has ;; sent 1.0 in the stream header. if sasl is not supported then ;; we don't send 1.0 in the header and therefore we shouldn't wait ;; even if 1.0 is present in the receiving stream. (cond ;; Wait for stream features? ((and stream-version (>= (string-to-number stream-version) 1.0) jabber-use-sasl (jabber-have-sasl-p)) ;; Stay in same state... (list :connected state-data)) ;; Register account? ((plist-get state-data :registerp) ;; XXX: require encryption for registration? (list :register-account state-data)) ;; Legacy authentication? (t (list :legacy-auth state-data))))) (:stanza (let ((stanza (cadr event))) (cond ;; At this stage, we only expect a stream:features stanza. ((not (eq (jabber-xml-node-name stanza) 'features)) (list nil (plist-put state-data :disconnection-reason (format "Unexpected stanza %s" stanza)))) ((and (jabber-xml-get-children stanza 'starttls) (eq (plist-get state-data :connection-type) 'starttls)) (list :starttls state-data)) ;; XXX: require encryption for registration? ((plist-get state-data :registerp) ;; We could check for the element in stream ;; features, but as a client we would only lose by doing ;; that. (list :register-account state-data)) (t (list :sasl-auth (plist-put state-data :stream-features stanza)))))) (:do-disconnect (jabber-send-string fsm "") (list nil (plist-put state-data :disconnection-expected t))))) (define-enter-state jabber-connection :starttls (fsm state-data) (jabber-starttls-initiate fsm) (list state-data nil)) (define-state jabber-connection :starttls (fsm state-data event _callback) (pcase (or (car-safe event) event) (:filter (let ((process (cadr event)) (string (car (cddr event)))) (jabber-pre-filter process string fsm) (list :starttls state-data))) (:sentinel (jabber-fsm-handle-sentinel state-data event)) (:stanza (condition-case e (progn (jabber-starttls-process-input fsm (cadr event)) ;; Connection is encrypted. Send a stream tag again. (list :connected (plist-put state-data :encrypted t))) (error (let* ((msg (concat "STARTTLS negotiation failed: " (error-message-string e))) (new-state-data (plist-put state-data :disconnection-reason msg))) (list nil new-state-data))))) (:do-disconnect (jabber-send-string fsm "") (list nil (plist-put state-data :disconnection-expected t))))) (define-enter-state jabber-connection :register-account (fsm state-data) (jabber-get-register fsm nil) (list state-data nil)) (define-state jabber-connection :register-account (fsm state-data event _callback) ;; The connection will be closed in jabber-register (pcase (or (car-safe event) event) (:filter (let ((process (cadr event)) (string (car (cddr event)))) (jabber-pre-filter process string fsm) (list :register-account state-data))) (:sentinel (jabber-fsm-handle-sentinel state-data event)) (:stanza (or (jabber-process-stream-error (cadr event) state-data) (progn (jabber-process-input fsm (cadr event)) (list :register-account state-data)))) (:do-disconnect (jabber-send-string fsm "") (list nil (plist-put state-data :disconnection-expected t))))) (define-enter-state jabber-connection :legacy-auth (fsm state-data) (jabber-get-auth fsm (plist-get state-data :server) (plist-get state-data :session-id)) (list state-data nil)) (define-state jabber-connection :legacy-auth (fsm state-data event _callback) (pcase (or (car-safe event) event) (:filter (let ((process (cadr event)) (string (car (cddr event)))) (jabber-pre-filter process string fsm) (list :legacy-auth state-data))) (:sentinel (jabber-fsm-handle-sentinel state-data event)) (:stanza (or (jabber-process-stream-error (cadr event) state-data) (progn (jabber-process-input fsm (cadr event)) (list :legacy-auth state-data)))) (:authentication-success (jabber-cache-password (jabber-connection-bare-jid fsm) (cdr event)) (list :session-established state-data)) (:authentication-failure (jabber-uncache-password (jabber-connection-bare-jid fsm)) ;; jabber-logon has already displayed a message (list nil (plist-put state-data :disconnection-expected t))) (:do-disconnect (jabber-send-string fsm "") (list nil (plist-put state-data :disconnection-expected t))))) (define-enter-state jabber-connection :sasl-auth (fsm state-data) (let ((new-state-data (plist-put state-data :sasl-data (jabber-sasl-start-auth fsm (plist-get state-data :stream-features))))) (list new-state-data nil))) (define-state jabber-connection :sasl-auth (fsm state-data event _callback) (pcase (or (car-safe event) event) (:filter (let ((process (cadr event)) (string (car (cddr event)))) (jabber-pre-filter process string fsm) (list :sasl-auth state-data))) (:sentinel (jabber-fsm-handle-sentinel state-data event)) (:stanza (let ((new-sasl-data (jabber-sasl-process-input fsm (cadr event) (plist-get state-data :sasl-data)))) (list :sasl-auth (plist-put state-data :sasl-data new-sasl-data)))) (:use-legacy-auth-instead (list :legacy-auth (plist-put state-data :sasl-data nil))) (:authentication-success (jabber-cache-password (jabber-connection-bare-jid fsm) (cdr event)) (list :bind (plist-put state-data :sasl-data nil))) (:authentication-failure (jabber-uncache-password (jabber-connection-bare-jid fsm)) ;; jabber-sasl has already displayed a message (list nil (plist-put state-data :disconnection-expected t))) (:do-disconnect (jabber-send-string fsm "") (list nil (plist-put state-data :disconnection-expected t))))) (define-enter-state jabber-connection :bind (fsm state-data) (jabber-send-stream-header fsm) (list state-data nil)) (define-state jabber-connection :bind (fsm state-data event _callback) (pcase (or (car-safe event) event) (:filter (let ((process (cadr event)) (string (car (cddr event)))) (jabber-pre-filter process string fsm) (list :bind state-data))) (:sentinel (jabber-fsm-handle-sentinel state-data event)) (:stream-start ;; we wait for stream features... (list :bind state-data)) (:stanza (let ((stanza (cadr event))) (cond ((eq (jabber-xml-node-name stanza) 'features) ;; Record stream features, discarding earlier data: (setq state-data (plist-put state-data :stream-features stanza)) (if (jabber-xml-get-children stanza 'bind) (let ((handle-bind (lambda (jc xml-data success) (fsm-send jc (list (if success :bind-success :bind-failure) xml-data)))) ;; So let's bind a resource. We can either pick a resource ourselves, ;; or have the server pick one for us. (resource (plist-get state-data :resource))) (jabber-send-iq fsm nil "set" `(bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind")) ,@(when resource `((resource () ,resource)))) handle-bind t handle-bind nil) (list :bind state-data)) (message "Server doesn't permit resource binding") (list nil state-data))) (t (or (jabber-process-stream-error (cadr event) state-data) (progn (jabber-process-input fsm (cadr event)) (list :bind state-data))))))) (:bind-success (let ((jid (jabber-xml-path (cadr event) '(bind jid "")))) ;; Maybe this isn't the JID we asked for. (plist-put state-data :username (jabber-jid-username jid)) (plist-put state-data :server (jabber-jid-server jid)) (plist-put state-data :resource (jabber-jid-resource jid))) ;; If the server follows the older RFCs 3920 and 3921, it may ;; offer session initiation here. If it follows RFCs 6120 and ;; 6121, it might not offer it, and we should just skip it. (if (jabber-xml-get-children (plist-get state-data :stream-features) 'session) (let ((handle-session (lambda (jc xml-data success) (fsm-send jc (list (if success :session-success :session-failure) xml-data))))) (jabber-send-iq fsm nil "set" '(session ((xmlns . "urn:ietf:params:xml:ns:xmpp-session"))) handle-session t handle-session nil) (list :bind state-data)) ;; Session establishment not offered - assume not necessary. (list :session-established state-data))) (:session-success ;; We have a session (list :session-established state-data)) (:bind-failure (message "Resource binding failed: %s" (jabber-parse-error (jabber-iq-error (cadr event)))) (list nil state-data)) (:session-failure (message "Session establishing failed: %s" (jabber-parse-error (jabber-iq-error (cadr event)))) (list nil state-data)) (:do-disconnect (jabber-send-string fsm "") (list nil (plist-put state-data :disconnection-expected t))))) (defvar jabber-pending-presence-timeout 0.5 "Wait this long before doing presence packet batch processing.") (define-enter-state jabber-connection :session-established (fsm state-data) (jabber-send-iq fsm nil "get" '(query ((xmlns . "jabber:iq:roster"))) #'jabber-process-roster 'initial #'jabber-initial-roster-failure nil) (list (plist-put state-data :ever-session-established t) nil)) (define-state jabber-connection :session-established (fsm state-data event _callback) (pcase (or (car-safe event) event) (:filter (let ((process (cadr event)) (string (car (cddr event)))) (jabber-pre-filter process string fsm) (list :session-established state-data :keep))) (:sentinel (jabber-fsm-handle-sentinel state-data event)) (:stanza (or (jabber-process-stream-error (cadr event) state-data) (progn (jabber-process-input fsm (cadr event)) (list :session-established state-data :keep)))) (:roster-update ;; Batch up roster updates (let* ((jid-symbol-to-update (cdr event)) (pending-updates (plist-get state-data :roster-pending-updates))) ;; If there are pending updates, there is a timer running ;; already; just add the new symbol and wait. (if pending-updates (progn (unless (memq jid-symbol-to-update pending-updates) (nconc pending-updates (list jid-symbol-to-update))) (list :session-established state-data :keep)) ;; Otherwise, we need to create the list and start the timer. (setq state-data (plist-put state-data :roster-pending-updates (list jid-symbol-to-update))) (list :session-established state-data jabber-pending-presence-timeout)))) (:timeout ;; Update roster (let ((pending-updates (plist-get state-data :roster-pending-updates))) (setq state-data (plist-put state-data :roster-pending-updates nil)) (jabber-roster-update fsm nil pending-updates nil) (list :session-established state-data))) (:send-if-connected ;; This is the only state in which we respond to such messages. ;; This is to make sure we don't send anything inappropriate ;; during authentication etc. (jabber-send-sexp fsm (cdr event)) (list :session-established state-data :keep)) (:do-disconnect (jabber-send-string fsm "") (list nil (plist-put state-data :disconnection-expected t))))) (defun jabber-disconnect (&optional arg interactivep) "Disconnect from all Jabber servers. If ARG supplied, disconnect one account." (interactive "P\np") (if arg (jabber-disconnect-one (jabber-read-account)) (unless *jabber-disconnecting* ; avoid reentry (let ((*jabber-disconnecting* t)) (if (null jabber-connections) (message "Already disconnected") (run-hooks 'jabber-pre-disconnect-hook) (dolist (c jabber-connections) (jabber-disconnect-one c t)) (setq jabber-connections nil) (jabber-disconnected) (when interactivep (message "Disconnected from Jabber server(s)"))))))) (defun jabber-disconnect-one (jc &optional dont-redisplay interactivep) "Disconnect from one Jabber server. If DONT-REDISPLAY is non-nil, don't update roster buffer. JC is the Jabber connection." (interactive (list (jabber-read-account) nil 'interactive)) (fsm-send-sync jc :do-disconnect) (when interactivep (message "Disconnected from %s" (jabber-connection-jid jc))) (unless dont-redisplay (jabber-display-roster))) (defun jabber-disconnected () "Re-initialise jabber package variables. Call this function after disconnection." (when (get-buffer jabber-roster-buffer) (with-current-buffer (get-buffer jabber-roster-buffer) (let ((inhibit-read-only t)) (erase-buffer)))) (jabber-clear-roster) (run-hooks 'jabber-post-disconnect-hook)) (defun jabber-log-xml (fsm direction data) "Print DATA to XML console (and, optionally, in file). If `jabber-debug-log-xml' is nil, do nothing. FSM is the connection that is sending/receiving. DIRECTION is a string, either \"sending\" or \"receive\". DATA is any sexp." (when jabber-debug-log-xml (jabber-process-console fsm direction data))) (defun jabber-pre-filter (process string fsm) (with-current-buffer (process-buffer process) ;; Append new data (goto-char (point-max)) (insert string) (defvar jabber-filtering) (unless (boundp 'jabber-filtering) (let (jabber-filtering) (jabber-filter process fsm))))) (defun jabber-filter (process fsm) "The filter function for the Jabber process." (with-current-buffer (process-buffer process) ;; Start from the beginning (goto-char (point-min)) (let (xml-data) (cl-loop do ;; Skip whitespace (unless (zerop (skip-chars-forward " \t\r\n")) (delete-region (point-min) (point))) ;; Skip processing directive (when (looking-at "<\\?xml[^?]*\\?>") (delete-region (match-beginning 0) (match-end 0))) ;; Stream end? (when (looking-at "") (cl-return (fsm-send fsm :stream-end))) ;; Stream header? (when (looking-at "]*\\(>\\)") ;; Let's pretend that the stream header is a closed tag, ;; and parse it as such. (replace-match "/>" t t nil 1) (let* ((ending-at (point)) (stream-header (car (xml-parse-region (point-min) ending-at))) (session-id (jabber-xml-get-attribute stream-header 'id)) (stream-version (jabber-xml-get-attribute stream-header 'version))) ;; Need to keep any namespace attributes on the stream ;; header, as they can affect any stanza in the ;; stream... (setq jabber-namespace-prefixes (jabber-xml-merge-namespace-declarations (jabber-xml-node-attributes stream-header) nil)) (jabber-log-xml fsm "receive" stream-header) (fsm-send fsm (list :stream-start session-id stream-version)) (delete-region (point-min) ending-at))) ;; Normal tag ;; XXX: do these checks make sense? If so, reinstate them. ;;(if (active-minibuffer-window) ;; (run-with-idle-timer 0.01 nil #'jabber-filter process string) ;; This check is needed for xml.el of Emacs 21, as it chokes on ;; empty attribute values. (save-excursion (while (search-forward-regexp " \\w+=''" nil t) (replace-match ""))) (setq xml-data (jabber-xml-parse-next-stanza)) while xml-data do ;; If there's a problem with writing the XML log, ;; make sure the stanza is delivered, at least. (condition-case e (jabber-log-xml fsm "receive" (car xml-data)) (error (ding) (message "Couldn't write XML log: %s" (error-message-string e)) (sit-for 2))) (delete-region (point-min) (point)) (fsm-send fsm (list :stanza (jabber-xml-resolve-namespace-prefixes (car xml-data) nil jabber-namespace-prefixes))) ;; XXX: move this logic elsewhere ;; We explicitly don't catch errors in jabber-process-input, ;; to facilitate debugging. ;; (jabber-process-input (car xml-data)) )))) (defun jabber-process-input (jc xml-data) "Process an incoming parsed tag. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((jabber-xml-data xml-data) (tag (jabber-xml-node-name xml-data)) (functions (eval (cdr (assq tag '((iq . jabber-iq-chain) (presence . jabber-presence-chain) (message . jabber-message-chain))))))) (dolist (f functions) (condition-case e (funcall f jc xml-data) ((debug error) (fsm-debug-output "Error %S while processing %S with function %s" e xml-data f)))))) (defun jabber-process-stream-error (xml-data state-data) "Process an incoming stream error. Return nil if XML-DATA is not a stream:error stanza. Return an fsm result list if it is." (when (and (eq (jabber-xml-node-name xml-data) 'error) (equal (jabber-xml-get-xmlns xml-data) "http://etherx.jabber.org/streams")) (let ((condition (jabber-stream-error-condition xml-data)) (text (jabber-parse-stream-error xml-data))) (setq state-data (plist-put state-data :disconnection-reason (format "Stream error: %s" text))) ;; Special case: when the error is `conflict', we have been ;; forcibly disconnected by the same user. Don't reconnect ;; automatically. (when (eq condition 'conflict) (setq state-data (plist-put state-data :disconnection-expected t))) (list nil state-data)))) ;; XXX: This function should probably die. The roster is stored ;; inside the connection plists, and the obarray shouldn't be so big ;; that we need to clean it. (defun jabber-clear-roster () "Clean up the roster." ;; This is made complicated by the fact that the JIDs are symbols with properties. (mapatoms #'(lambda (x) (unintern x jabber-jid-obarray)) jabber-jid-obarray) (setq *jabber-roster* nil)) (defun jabber-send-sexp (jc sexp) "Send the xml corresponding to SEXP to connection JC." (condition-case e (jabber-log-xml jc "sending" sexp) (error (ding) (message "Couldn't write XML log: %s" (error-message-string e)) (sit-for 2))) (jabber-send-string jc (jabber-sexp2xml sexp))) (defun jabber-send-sexp-if-connected (jc sexp) "Send the stanza SEXP only if JC has established a session." (fsm-send-sync jc (cons :send-if-connected sexp))) (defun jabber-send-stream-header (jc) "Send stream header to connection JC." (let ((stream-header (concat " "))) (jabber-log-xml jc "sending" stream-header) (jabber-send-string jc stream-header))) (defun jabber-send-string (jc string) "Send STRING through the connection JC." (let* ((state-data (fsm-get-state-data jc)) (connection (plist-get state-data :connection)) (send-function (plist-get state-data :send-function))) (unless connection (error "%s has no connection" (jabber-connection-jid jc))) (funcall send-function connection string))) (provide 'jabber-core) ;;; jabber-core.el ends here emacs-jabber/lisp/jabber-disco.el000066400000000000000000000727661476345337400172500ustar00rootroot00000000000000;;; jabber-disco.el --- service discovery functions -*- lexical-binding: t; -*- ;; 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 ;;; Commentary: ;; Jabber discovery module, handles service discovery functions. ;;; Code: (require 'jabber-iq) (require 'jabber-xml) (require 'jabber-menu) ;; Global reference declarations (defvar jabber-presence-chain) ; jabber-core.el (defvar jabber-connections) ; jabber-core.el ;; ;;; Respond to disco requests (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.") ;; 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)) (defvar jabber-advertised-features (list "http://jabber.org/protocol/disco#info") "Features advertised on service discovery requests. Don't add your feature to this list directly. Instead, call `jabber-disco-advertise-feature'.") (defvar jabber-disco-items-nodes (list (list "" nil nil)) "Alist of node names and information about returning disco item data. Key is node name as a string, or \"\" for no node specified. Value is a list of two items. First item is data to return. If it is a function, that function is called and its return value is used; if it is a list, that list is used. The list should be the XML data to be returned inside the element, like this: \((item ((name . \"Name of first item\") (jid . \"first.item\") (node . \"node\")))) Second item is access control function. That function is passed the JID, and returns non-nil if access is granted. If the second item is nil, access is always granted.") (defvar jabber-disco-info-nodes (list (list "" #'jabber-disco-return-client-info nil)) "Alist of node names and information returning disco info data. Key is node name as a string, or \"\" for no node specified. Value is a list of two items. First item is data to return. If it is a function, that function is called and its return value is used; if it is a list, that list is used. The list should be the XML data to be returned inside the element, like this: \((identity ((category . \"client\") (type . \"pc\") (name . \"Jabber client\"))) (feature ((var . \"some-feature\")))) Second item is access control function. That function is passed the JID, and returns non-nil if access is granted. If the second item is nil, access is always granted.") ;; Global reference declarations (declare-function jabber-send-current-presence "jabber-presence.el" (&optional _ignore)) (declare-function jabber-xdata-formtype "jabber-widget.el" (x)) (defvar jabber-presence-element-functions) ; jabber-presence.el ;; (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-caps-get-cached (jid) "Get disco info from Entity Capabilities cache. JID should be a string containing a full JID. Return (IDENTITIES FEATURES), or nil if not in cache." (let* ((symbol (jabber-jid-symbol jid)) (resource (or (jabber-jid-resource jid) "")) (resource-plist (cdr (assoc resource (get symbol 'resources)))) (key (plist-get resource-plist 'caps))) (when key (let ((cache-entry (gethash key jabber-caps-cache))) (when (and (consp cache-entry) (not (floatp (car cache-entry)))) cache-entry))))) ;;;###autoload (defun jabber-process-caps (jc xml-data) "Look for entity capabilities in presence stanzas. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((from (jabber-xml-get-attribute xml-data 'from)) (type (jabber-xml-get-attribute xml-data 'type)) (c (jabber-xml-path xml-data '(("http://jabber.org/protocol/caps" . "c"))))) (when (and (null type) c) (jabber-xml-let-attributes (_ext hash node ver) c (cond (hash ;; If the element has a hash attribute, it follows the ;; "modern" version of XEP-0115. (jabber-process-caps-modern jc from hash node ver)) (t ;; No hash attribute. Use legacy version of XEP-0115. ;; TODO: do something clever here. )))))) (defun jabber-process-caps-modern (jc jid hash node ver) "Processes the capabilities of a contact which supports XEP-0115 v1.5 or later. JC is the jabber connection of the sender, JID is the Jabber ID of the entity sending the capabilities information. HASH is the generated hash representing the sender's capabilities. NODE is the namespace of the format. and VER is the entity's version number." (when (assoc hash jabber-caps-hash-names) ;; We support the hash function used. (let* ((key (cons hash ver)) (cache-entry (gethash key jabber-caps-cache))) ;; Remember the hash in the JID symbol. (let* ((symbol (jabber-jid-symbol jid)) (resource (or (jabber-jid-resource jid) "")) (resource-entry (assoc resource (get symbol 'resources))) (new-resource-plist (plist-put (cdr resource-entry) 'caps key))) (if resource-entry (setf (cdr resource-entry) new-resource-plist) (push (cons resource new-resource-plist) (get symbol 'resources)))) (cl-flet ((request-disco-info () (jabber-send-iq jc jid "get" `(query ((xmlns . "http://jabber.org/protocol/disco#info") (node . ,(concat node "#" ver)))) #'jabber-process-caps-info-result (list hash node ver) #'jabber-process-caps-info-error (list hash node ver)))) (cond ((and (consp cache-entry) (floatp (car cache-entry))) ;; We have a record of asking someone about this hash. (if (< (- (float-time) (car cache-entry)) 10.0) ;; We asked someone about this hash less than 10 seconds ago. ;; Let's add the new JID to the entry, just in case that ;; doesn't work out. (cl-pushnew jid (cdr cache-entry) :test #'string=) ;; We asked someone about it more than 10 seconds ago. ;; They're probably not going to answer. Let's ask ;; this contact about it instead. (setf (car cache-entry) (float-time)) (request-disco-info))) ((null cache-entry) ;; We know nothing about this hash. Let's note the ;; fact that we tried to get information about it. (puthash key (list (float-time)) jabber-caps-cache) (request-disco-info)) (t ;; We already know what this hash represents, so we ;; can cache info for this contact. (puthash (cons jid nil) cache-entry jabber-disco-info-cache))))))) (defun jabber-process-caps-info-result (jc xml-data closure-data) "Process the result of a jabber server's caps info request. JC is the jabber connection. XML-DATA is the XML data received from the server. CLOSURE-DATA is in the format of (HASH NODE VER), where HASH is the verification hash received from the server. NODE represents the software identification, and VER is the software version. If the verification string matches with VER, the software's discovery /disco/ information will be stored in the jabber-caps-cache, otherwise, it will try the next available option." (pcase-let* ((`(,hash ,node ,ver) closure-data) (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) "Process error in caps info for Jabber. JC is the Jabber connection. CLOSURE-DATA is a list of three parameters: hash, node, and version. This function makes another attempt to process the caps info when an error occurs." (pcase-let ((`(,hash ,node ,ver) closure-data)) (jabber-caps-try-next jc hash node ver))) (defun jabber-caps-try-next (jc hash node ver) "Try the next JID for a cached entry in Jabber CAPS Cache. JC is the Jabber connection. HASH is the hash value of the CAPS. NODE is the node identifier in the XEP-0115 specification. VER is the version string of the CAPS." (let* ((key (cons hash ver)) (cache-entry (gethash key jabber-caps-cache))) (when (floatp (car-safe cache-entry)) (let ((next-jid (pop (cdr cache-entry)))) ;; Do we know someone else we could ask about this hash? (if next-jid (progn (setf (car cache-entry) (float-time)) (jabber-send-iq jc next-jid "get" `(query ((xmlns . "http://jabber.org/protocol/disco#info") (node . ,(concat node "#" ver)))) #'jabber-process-caps-info-result (list hash node ver) #'jabber-process-caps-info-error (list hash node ver))) ;; No, forget about it for now. (remhash key jabber-caps-cache)))))) (defun jabber-caps-ver-string (query hash) "Create an XEP-0115 version string for a QUERY node with a specified HASH." ;; XEP-0115, section 5.1 ;; 1. Initialize an empty string S. (with-temp-buffer (let* ((identities (jabber-xml-get-children query 'identity)) (disco-features (mapcar (lambda (f) (jabber-xml-get-attribute f 'var)) (jabber-xml-get-children query 'feature))) (maybe-forms (jabber-xml-get-children query 'x)) (forms (cl-remove-if-not (lambda (x) ;; Keep elements that are forms and have a FORM_TYPE, ;; according to XEP-0128. (and (string= (jabber-xml-get-xmlns x) "jabber:x:data") (jabber-xdata-formtype x))) maybe-forms))) ;; 2. Sort the service discovery identities [15] by category ;; and then by type and then by xml:lang (if it exists), ;; formatted as CATEGORY '/' [TYPE] '/' [LANG] '/' ;; [NAME]. [16] Note that each slash is included even if the ;; LANG or NAME is not included (in accordance with XEP-0030, ;; the category and type MUST be included. (setq identities (sort identities #'jabber-caps-identity-<)) ;; 3. For each identity, append the 'category/type/lang/name' to ;; S, followed by the '<' character. (dolist (identity identities) (jabber-xml-let-attributes (category type xml:lang name) identity ;; Use `concat' here instead of passing everything to ;; `insert', since `concat' tolerates nil values. (insert (concat category "/" type "/" xml:lang "/" name "<")))) ;; 4. Sort the supported service discovery features. [17] (setq disco-features (sort disco-features #'string<)) ;; 5. For each feature, append the feature to S, followed by the ;; '<' character. (dolist (f disco-features) (insert f "<")) ;; 6. If the service discovery information response includes ;; XEP-0128 data forms, sort the forms by the FORM_TYPE (i.e., ;; by the XML character data of the element). (setq forms (sort forms (lambda (a b) (string< (jabber-xdata-formtype a) (jabber-xdata-formtype b))))) ;; 7. For each extended service discovery information form: (dolist (form forms) ;; Append the XML character data of the FORM_TYPE field's ;; element, followed by the '<' character. (insert (jabber-xdata-formtype form) "<") ;; Sort the fields by the value of the "var" attribute. (let ((fields (sort (jabber-xml-get-children form 'field) (lambda (a b) (string< (jabber-xml-get-attribute a 'var) (jabber-xml-get-attribute b 'var)))))) (dolist (field fields) ;; For each field other than FORM_TYPE: (unless (string= (jabber-xml-get-attribute field 'var) "FORM_TYPE") ;; Append the value of the "var" attribute, followed by the '<' character. (insert (jabber-xml-get-attribute field 'var) "<") ;; Sort values by the XML character data of the element. (let ((values (sort (mapcar (lambda (value) (car (jabber-xml-node-children value))) (jabber-xml-get-children field 'value)) #'string<))) ;; For each element, append the XML character ;; data, followed by the '<' character. (dolist (value values) (insert (or 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) "Compute and return a secure hash from STRING using ALGORITHM." (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) "Compare two Jabber identity XML elements A and B, return t if A < B." (let ((a-category (jabber-xml-get-attribute a 'category)) (b-category (jabber-xml-get-attribute b 'category))) (or (string< a-category b-category) (and (string= a-category b-category) (let ((a-type (jabber-xml-get-attribute a 'type)) (b-type (jabber-xml-get-attribute b 'type))) (or (string< a-type b-type) (and (string= a-type b-type) (let ((a-xml:lang (jabber-xml-get-attribute a 'xml:lang)) (b-xml:lang (jabber-xml-get-attribute b 'xml:lang))) (string< a-xml:lang b-xml:lang))))))))) (defvar jabber-caps-default-hash-function "sha-1" "Hash function to use when sending caps in presence stanzas. The value should be a key in `jabber-caps-hash-names'.") (defvar jabber-caps-current-hash nil "The current disco hash we're sending out in presence stanzas.") (defconst jabber-caps-node "http://emacs-jabber.sourceforge.net") ;;;###autoload (defun jabber-disco-advertise-feature (feature) "Add a new FEATURE to `jabber-advertised-features', if not already present." (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) "Generate XML presence element using `jabber-caps-current-hash' and _JC param." (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)) (defun jabber-return-disco-info (jc xml-data) "Respond to a service discovery request. See XEP-0030. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((to (jabber-xml-get-attribute xml-data 'from)) (id (jabber-xml-get-attribute xml-data 'id)) (xmlns (jabber-iq-xmlns xml-data)) (which-alist (eval (cdr (assoc xmlns (list (cons "http://jabber.org/protocol/disco#info" 'jabber-disco-info-nodes) (cons "http://jabber.org/protocol/disco#items" 'jabber-disco-items-nodes)))))) (node (or (jabber-xml-get-attribute (jabber-iq-query xml-data) 'node) "")) (return-list (cdr (assoc node which-alist))) (func (nth 0 return-list)) (access-control (nth 1 return-list))) (if return-list (if (and (functionp access-control) (not (funcall access-control jc to))) (jabber-signal-error "Cancel" 'not-allowed) ;; Access control passed (let ((result (if (functionp func) (funcall func jc xml-data) func))) (jabber-send-iq jc to "result" `(query ((xmlns . ,xmlns) ,@(when node (list (cons 'node node)))) ,@result) nil nil nil nil id))) ;; No such node (jabber-signal-error "Cancel" 'item-not-found)))) (defun jabber-disco-return-client-info (&optional _jc _xml-data) "Return a Jabber Disco information according to the client env. Generate a list which represents the identity and features supported by the Emacs Jabber client. The type of the client is decided based on the window system. If Emacs is running under a window system (x, w32, mac, ns), the type is classified as pc, otherwise console." `( ;; If running under a window system, this is ;; a GUI client. If not, it is a console client. (identity ((category . "client") (name . "Emacs Jabber client") (type . ,(if (memq window-system '(x w32 mac ns)) "pc" "console")))) ,@(mapcar #'(lambda (featurename) `(feature ((var . ,featurename)))) jabber-advertised-features))) (add-to-list 'jabber-jid-info-menu (cons "Send items disco query" 'jabber-get-disco-items)) (defun jabber-get-disco-items (jc to &optional node) "Send a service discovery request for items. JC, the Jabber connection, is typically required to be active. TO is the JID (Jabber ID) of the entity to request items from. NODE is an optional parameter specifying a particular node to request items for." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Send items disco request to: " nil nil nil 'full t) (jabber-read-node "Node (or leave empty): "))) (jabber-send-iq jc to "get" (list 'query (append (list (cons 'xmlns "http://jabber.org/protocol/disco#items")) (if (> (length node) 0) (list (cons 'node node))))) #'jabber-process-data #'jabber-process-disco-items #'jabber-process-data "Item discovery failed")) (add-to-list 'jabber-jid-info-menu (cons "Send info disco query" 'jabber-get-disco-info)) (defun jabber-get-disco-info (jc to &optional node) "Send a service discovery request for info. JC is the Jabber connection. TO is the JID (Jabber ID) of the entity to request items from. NODE is an optional parameter specifying a particular node to request items for." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Send info disco request to: " nil nil nil 'full t) (jabber-read-node "Node (or leave empty): "))) (jabber-send-iq jc to "get" (list 'query (append (list (cons 'xmlns "http://jabber.org/protocol/disco#info")) (if (> (length node) 0) (list (cons 'node node))))) #'jabber-process-data #'jabber-process-disco-info #'jabber-process-data "Info discovery failed")) (defun jabber-process-disco-info (jc xml-data) "Handle results from info disco requests. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((beginning (point))) (dolist (x (jabber-xml-node-children (jabber-iq-query xml-data))) (cond ((eq (jabber-xml-node-name x) 'identity) (let ((name (jabber-xml-get-attribute x 'name)) (category (jabber-xml-get-attribute x 'category)) (type (jabber-xml-get-attribute x 'type))) (insert (jabber-propertize (if name name "Unnamed") 'face 'jabber-title-medium) "\n\nCategory:\t" category "\n") (if type (insert "Type:\t\t" type "\n")) (insert "\n"))) ((eq (jabber-xml-node-name x) 'feature) (let ((var (jabber-xml-get-attribute x 'var))) (insert "Feature:\t" var "\n"))))) (put-text-property beginning (point) 'jabber-jid (jabber-xml-get-attribute xml-data 'from)) (put-text-property beginning (point) 'jabber-account jc))) (defun jabber-process-disco-items (jc xml-data) "Handle results from items disco requests. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((items (jabber-xml-get-children (jabber-iq-query xml-data) 'item))) (if items (dolist (item items) (let ((jid (jabber-xml-get-attribute item 'jid)) (name (jabber-xml-get-attribute item 'name)) (node (jabber-xml-get-attribute item 'node))) (insert (jabber-propertize (concat (jabber-propertize (concat jid "\n" (if node (format "Node: %s\n" node))) 'face 'jabber-title-medium) name "\n\n") 'jabber-jid jid 'jabber-account jc 'jabber-node node)))) (insert "No items found.\n")))) (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) "Process the received jabber-disco info query response. Parse received disco-info from XML-DATA and caches it. If a CALLBACK-DATA function is provided, it's called with the JC, CALLBACK-DATA and RESULT. JC: The jabber connection. XML-DATA: The XML data containing the info query response. CALLBACK-DATA: Optional function to be triggered after processing info query response." (let ((jid (jabber-xml-get-attribute xml-data 'from)) (node (jabber-xml-get-attribute (jabber-iq-query xml-data) 'node)) (result (jabber-disco-parse-info xml-data))) (puthash (cons jid node) result jabber-disco-info-cache) (when (car callback-data) (funcall (car callback-data) jc (cdr callback-data) result)))) (defun jabber-disco-parse-info (xml-data) "Extract data from an stanza containing a disco#info result. See `jabber-disco-get-info' for a description of the return value. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (list (mapcar #'(lambda (id) (vector (jabber-xml-get-attribute id 'name) (jabber-xml-get-attribute id 'category) (jabber-xml-get-attribute id 'type))) (jabber-xml-get-children (jabber-iq-query xml-data) 'identity)) (mapcar #'(lambda (feature) (jabber-xml-get-attribute feature 'var)) (jabber-xml-get-children (jabber-iq-query xml-data) 'feature)))) (defun jabber-disco-get-info-immediately (jid node) "Get cached disco info for JID and NODE. Return nil if no info available. Fill the cache with `jabber-disco-get-info'." (or ;; Check "normal" cache... (gethash (cons jid node) jabber-disco-info-cache) ;; And then check Entity Capabilities. (and (null node) (jabber-caps-get-cached jid)))) (defun jabber-disco-get-items (jc jid node callback closure-data &optional force) "Get disco items for JID and NODE, using connection JC. Call CALLBACK with JC and CLOSURE-DATA as first and second arguments and items result as third argument when result is available. On success, result is a list of items, where each item is [\"name\" \"jid\" \"node\"] (some values may be nil). On error, result is the error node, recognizable by (eq (car result) \='error). If CALLBACK is nil, just fetch data. If FORCE is non-nil, invalidate cache and get fresh data." (when force (remhash (cons jid node) jabber-disco-items-cache)) (let ((result (gethash (cons jid node) jabber-disco-items-cache))) (if result (and callback (run-with-timer 0 nil callback jc closure-data result)) (jabber-send-iq jc jid "get" `(query ((xmlns . "http://jabber.org/protocol/disco#items") ,@(when node `((node . ,node))))) #'jabber-disco-got-items (cons callback closure-data) (lambda (jc xml-data callback-data) (when (car callback-data) (funcall (car callback-data) jc (cdr callback-data) (jabber-iq-error xml-data)))) (cons callback closure-data))))) (defun jabber-disco-got-items (jc xml-data callback-data) "Process received Jabber disco items. Processes the received disco items XML-DATA from the Jabber connection JC & updates the disco items cache. If a callback function is provided in CALLBACK-DATA, it will then be called with JC, the remaining CALLBACK-DATA, and the obtained RESULT." (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) "Retrieve items from `jabber-disco-items-cache' using JID & NODE as key." (gethash (cons jid node) jabber-disco-items-cache)) (defun jabber-disco-publish (jc node item-name item-jid item-node) "Publish the given item under disco node NODE. JC is the Jabber connection." (jabber-send-iq jc nil "set" `(query ((xmlns . "http://jabber.org/protocol/disco#items") ,@(when node `((node . ,node)))) (item ((action . "update") (jid . ,item-jid) ,@(when item-name `((name . ,item-name))) ,@(when item-node `((node . ,item-node)))))) 'jabber-report-success "Disco publish" 'jabber-report-success "Disco publish")) (defun jabber-disco-publish-remove (jc node item-jid item-node) "Remove the given item from published disco items. JC: Jabber Client connection. NODE: Disco node to remove item from. Can be nil. ITEM-JID: JID (Jabber ID) of the disco item to be removed. ITEM-NODE: Specific node of the disco item to be removed. Can be nil." (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")) (provide 'jabber-disco) ;;; jabber-disco.el ends here. emacs-jabber/lisp/jabber-events.el000066400000000000000000000220241476345337400174310ustar00rootroot00000000000000;;; jabber-events.el --- Message events (JEP-0022) implementation -*- lexical-binding: t; -*- ;; Copyright (C) 2005, 2008 Magnus Henoch ;; Author: Magnus Henoch ;; 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. ;;; Code: (require 'cl-lib) (require 'jabber-core) (require 'jabber-chat) (require 'jabber-chatbuffer) (require 'jabber-xml) (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))) (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) ;; Global reference declarations (declare-function jabber-muc-message-p "jabber-muc.el" (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?" :type 'boolean) (defcustom jabber-events-confirm-displayed t "Send display confirmation if requested?" :type 'boolean) (defcustom jabber-events-confirm-composing t "Send notifications about typing a reply?" :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 ;; FIXME: Make it buffer-local? #'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 (cl-find "jabber:x:event" (jabber-xml-get-children xml-data 'x) :key #'(lambda (x) (jabber-xml-get-attribute x 'xmlns)) :test #'string=))) (cond ;; If we get an error message, we shouldn't report any ;; events, as the requests are mirrored from us. ((string= (jabber-xml-get-attribute xml-data 'type) "error") (remove-hook 'post-command-hook #'jabber-events-after-change t) (setq jabber-events-requested nil)) ;; If there's a body, it's not an incoming message event. ((jabber-xml-get-children xml-data 'body) ;; User is done composing, obviously. (setq jabber-events-composing-p nil) (jabber-events-update-message) ;; Reset variables (setq jabber-events-display-confirmed nil) (setq jabber-events-delivery-confirmed nil) ;; User requests message events (setq jabber-events-requested ;; There might be empty strings in the XML data, ;; which car chokes on. Having nil values in ;; the list won't hurt, therefore car-safe. (mapcar #'car-safe (jabber-xml-node-children x))) (setq jabber-events-last-id (jabber-xml-get-attribute xml-data 'id)) ;; Send notifications we already know about (cl-flet ((send-notification (type) (jabber-send-sexp jc `(message ((to . ,(jabber-xml-get-attribute xml-data 'from))) (x ((xmlns . "jabber:x:event")) (,type) (id () ,jabber-events-last-id)))))) ;; Send delivery confirmation if appropriate (when (and jabber-events-confirm-delivered (memq 'delivered jabber-events-requested)) (send-notification 'delivered) (setq jabber-events-delivery-confirmed t)) ;; Send display confirmation if appropriate (when (and jabber-events-confirm-displayed (get-buffer-window (current-buffer) 'visible) (memq 'displayed jabber-events-requested)) (send-notification 'displayed) (setq jabber-events-display-confirmed t)) ;; Set up hooks for composition notification (when (and jabber-events-confirm-composing (memq 'composing jabber-events-requested)) (add-hook 'post-command-hook #'jabber-events-after-change nil t)))) (t ;; So it has no body. If it's a message event, ;; the node should be the only child of the ;; message, and it should contain an node. ;; We check the latter. (when (and x (jabber-xml-get-children x 'id)) ;; Currently we don't care about the node. ;; There's only one node except for the id. (unless (cl-dolist (possible-node '(offline delivered displayed)) (when (jabber-xml-get-children x possible-node) (setq jabber-events-arrived possible-node) (jabber-events-update-message) (cl-return t))) ;; Or maybe even zero, which is a negative composing node. (setq jabber-events-composing-p (not (null (jabber-xml-get-children x 'composing)))) (jabber-events-update-message))))))))) (provide 'jabber-events) ;;; jabber-events.el ends hereemacs-jabber/lisp/jabber-export.el000066400000000000000000000211601476345337400174460ustar00rootroot00000000000000;;; jabber-export.el --- export Jabber roster to file -*- lexical-binding: t; -*- ;; Copyright (C) 2005, 2007 Magnus Henoch ;; Author: Magnus Henoch ;; 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. ;;; Code: (require 'cl-lib) (require 'jabber-core) (require 'jabber-xml) (require 'jabber-widget) (require 'fsm) (require 'widget) (defvar jabber-export-roster-widget nil) (defvar jabber-import-subscription-p-widget nil) ;; Global reference declarations (defvar jabber-buffer-connection) ; jabber-chatbuffer.el ;; ;;;###autoload (defun jabber-export-roster (jc) "Export roster for connection JC." (interactive (list (jabber-read-account))) (let ((state-data (fsm-get-state-data jc))) (jabber-export-roster-do-it (jabber-roster-to-sexp (plist-get state-data :roster))))) (defun jabber-export-roster-do-it (roster) "Create buffer from which ROSTER can be exported to a file." (interactive) (with-current-buffer (get-buffer-create "Export roster") (jabber-init-widget-buffer nil) (widget-insert (jabber-propertize "Export roster\n" 'face 'jabber-title-large)) (widget-insert "You are about to save your roster to a file. Here you can edit it before saving. Changes done here will not affect your actual roster. ") (widget-create 'push-button :notify #'jabber-export-save "Save to file") (widget-insert " ") (widget-create 'push-button :notify #'jabber-export-remove-regexp "Remove by regexp") (widget-insert "\n\n") (make-local-variable 'jabber-export-roster-widget) (jabber-export-display roster) (widget-setup) (widget-minor-mode 1) (goto-char (point-min)) (switch-to-buffer (current-buffer)))) ;;;###autoload (defun jabber-import-roster (jc file) "Create buffer for roster import for connection JC from FILE." (interactive (list (jabber-read-account) (read-file-name "Import roster from file: "))) (let ((roster (with-temp-buffer (let ((coding-system-for-read 'utf-8)) (jabber-roster-xml-to-sexp (car (xml-parse-file file))))))) (with-current-buffer (get-buffer-create "Import roster") (setq jabber-buffer-connection jc) (jabber-init-widget-buffer nil) (widget-insert (jabber-propertize "Import roster\n" 'face 'jabber-title-large)) (widget-insert "You are about to import the contacts below to your roster. ") (make-local-variable 'jabber-import-subscription-p-widget) (setq jabber-import-subscription-p-widget (widget-create 'checkbox)) (widget-insert " Adjust subscriptions\n") (widget-create 'push-button :notify #'jabber-import-doit "Import to roster") (widget-insert " ") (widget-create 'push-button :notify #'jabber-export-remove-regexp "Remove by regexp") (widget-insert "\n\n") (make-local-variable 'jabber-export-roster-widget) (jabber-export-display roster) (widget-setup) (widget-minor-mode 1) (goto-char (point-min)) (switch-to-buffer (current-buffer))))) (defun jabber-export-remove-regexp (&rest _ignore) (let* ((value (widget-value jabber-export-roster-widget)) (length-before (length value)) (regexp (read-string "Remove JIDs matching regexp: "))) (setq value (cl-delete-if #'(lambda (a) (string-match regexp (nth 0 a))) value)) (widget-value-set jabber-export-roster-widget value) (widget-setup) (message "%d items removed" (- length-before (length value))))) (defun jabber-export-save (&rest _ignore) "Export roster to file." (let ((items (mapcar #'jabber-roster-sexp-to-xml (widget-value jabber-export-roster-widget))) (coding-system-for-write 'utf-8)) (with-temp-file (read-file-name "Export roster to file: ") (insert "\n") (dolist (item items) (insert (jabber-sexp2xml item) "\n")) (insert "\n")) (message "Roster saved"))) (defun jabber-import-doit (&rest _ignore) "Import roster being edited in widget." (let* ((state-data (fsm-get-state-data jabber-buffer-connection)) (jabber-roster (plist-get state-data :roster)) roster-delta) (dolist (n (widget-value jabber-export-roster-widget)) (let* ((jid (nth 0 n)) (name (and (not (zerop (length (nth 1 n)))) (nth 1 n))) (subscription (nth 2 n)) (groups (nth 3 n)) (jid-symbol (jabber-jid-symbol jid)) (in-roster-p (memq jid-symbol jabber-roster)) (jid-name (and in-roster-p (get jid-symbol 'name))) (jid-subscription (and in-roster-p (get jid-symbol 'subscription))) (jid-groups (and in-roster-p (get jid-symbol 'groups)))) ;; Do we need to change the roster? (when (or ;; If the contact is not in the roster already, (not in-roster-p) ;; or if the import introduces a name, (and name (not jid-name)) ;; or changes a name, (and name jid-name (not (string= name jid-name))) ;; or introduces new groups. (cl-set-difference groups jid-groups :test #'string=)) (push (jabber-roster-sexp-to-xml (list jid (or name jid-name) nil (cl-union groups jid-groups :test #'string=)) t) roster-delta)) ;; And adujst subscription. (when (widget-value jabber-import-subscription-p-widget) (let ((want-to (member subscription '("to" "both"))) (want-from (member subscription '("from" "both"))) (have-to (member jid-subscription '("to" "both"))) (have-from (member jid-subscription '("from" "both")))) (cl-flet ((request-subscription (type) (jabber-send-sexp jabber-buffer-connection `(presence ((to . ,jid) (type . ,type)))))) (cond ((and want-to (not have-to)) (request-subscription "subscribe")) ((and have-to (not want-to)) (request-subscription "unsubscribe"))) (cond ((and want-from (not have-from)) ;; not much to do here ) ((and have-from (not want-from)) (request-subscription "unsubscribed")))))))) (when roster-delta (jabber-send-iq jabber-buffer-connection nil "set" `(query ((xmlns . "jabber:iq:roster")) ,@roster-delta) #'jabber-report-success "Roster import" #'jabber-report-success "Roster import")))) (defun jabber-roster-to-sexp (roster) "Convert ROSTER to simpler sexp format. Return a list, where each item is a vector: \[jid name subscription groups] where groups is a list of strings." (mapcar #'(lambda (n) (list (symbol-name n) (or (get n 'name) "") (get n 'subscription) (get n 'groups))) roster)) (defun jabber-roster-sexp-to-xml (sexp &optional omit-subscription) "Convert SEXP to XML format. Return an XML node." `(item ((jid . ,(nth 0 sexp)) ,@(let ((name (nth 1 sexp))) (unless (zerop (length name)) `((name . ,name)))) ,@(unless omit-subscription `((subscription . ,(nth 2 sexp))))) ,@(mapcar #'(lambda (g) (list 'group nil g)) (nth 3 sexp)))) (defun jabber-roster-xml-to-sexp (xml-data) "Convert XML-DATA to simpler sexp format. XML-DATA is an node with a child. See `jabber-roster-to-sexp' for description of output format." (cl-assert (eq (jabber-xml-node-name xml-data) 'iq)) (let ((query (car (jabber-xml-get-children xml-data 'query)))) (cl-assert query) (mapcar #'(lambda (n) (list (jabber-xml-get-attribute n 'jid) (or (jabber-xml-get-attribute n 'name) "") (jabber-xml-get-attribute n 'subscription) (mapcar #'(lambda (g) (car (jabber-xml-node-children g))) (jabber-xml-get-children n 'group)))) (jabber-xml-get-children query 'item)))) (defun jabber-export-display (roster) (setq jabber-export-roster-widget (widget-create '(repeat :tag "Roster" (list :format "%v" (string :tag "JID") (string :tag "Name") (choice :tag "Subscription" (const "none") (const "both") (const "to") (const "from")) (repeat :tag "Groups" (string :tag "Group")))) :value roster))) (provide 'jabber-export) ;;; jabber-export.el ends hereemacs-jabber/lisp/jabber-fallback-lib/000077500000000000000000000000001476345337400201065ustar00rootroot00000000000000emacs-jabber/lisp/jabber-fallback-lib/.nosearch000066400000000000000000000000001476345337400216770ustar00rootroot00000000000000emacs-jabber/lisp/jabber-fallback-lib/fsm.el000066400000000000000000000405571476345337400212300ustar00rootroot00000000000000;;; fsm.el --- state machine library -*- lexical-binding: t; -*- ;; Copyright (C) 2006, 2007, 2008, 2015 Free Software Foundation, Inc. ;; Author: Magnus Henoch ;; Maintainer: Thomas Fitzsimmons ;; Version: 0.2.1 ;; Package-Requires: ((emacs "24.1") (cl-lib "0.5")) ;; Keywords: extensions ;; This file is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This file is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; fsm.el is an exercise in metaprogramming inspired by gen_fsm of ;; Erlang/OTP. It aims to make asynchronous programming in Emacs Lisp ;; easy and fun. By "asynchronous" I mean that long-lasting tasks ;; don't interfere with normal editing. ;; Some people say that it would be nice if Emacs Lisp had threads ;; and/or continuations. They are probably right, but there are few ;; things that can't be made to run in the background using facilities ;; already available: timers, filters and sentinels. As the code can ;; become a bit messy when using such means, with callbacks everywhere ;; and such things, it can be useful to structure the program as a ;; state machine. ;; In this model, a state machine passes between different "states", ;; which are actually only different event handler functions. The ;; state machine receives "events" (from timers, filters, user ;; requests, etc) and reacts to them, possibly entering another state, ;; possibly returning a value. ;; The essential macros/functions are: ;; ;; define-state-machine - create start-FOO function ;; define-state - event handler for each state (required) ;; define-enter-state - called when entering a state (optional) ;; define-fsm - encapsulates the above three (more sugar!) ;; fsm-send - send an event to a state machine ;; fsm-call - send an event and wait for reply ;; fsm.el is similar to but different from Distel: ;; ;; Emacs' tq library is a similar idea. ;; Here is a simple (not using all the features of fsm.el) example: ;; ;; ;; -*- lexical-binding: t; -*- ;; (require 'fsm) ;; (cl-labels ((hey (n ev) ;; (message "%d (%s)\tp%sn%s!" n ev ;; (if (zerop (% n 4)) "o" "i") ;; (make-string (max 1 (abs n)) ?g)))) ;; (cl-macrolet ((zow (next timeout) ;; `(progn (hey (cl-incf count) event) ;; (list ,next count ,timeout)))) ;; (define-fsm pingpong ;; :start ((init) "Start a pingpong fsm." ;; (interactive "nInit (number, negative to auto-terminate): ") ;; (list :ping (ash (ash init -2) 2) ; 4 is death ;; (when (called-interactively-p 'interactive) 0))) ;; :state-data-name count ;; :states ;; ((:ping ;; (:event (zow :pingg 0.1))) ;; (:pingg ;; (:event (zow :pinggg 0.1))) ;; (:pinggg ;; (:event (zow :pong 1))) ;; (:pong ;; (:event (zow :ping (if (= 0 count) ;; (fsm-goodbye-cruel-world 'pingpong) ;; 3)))))))) ;; (fsm-send (start-pingpong -16) t) ;; ;; Copy into a buffer, uncomment, and type M-x eval-buffer RET. ;; Alternatively, you can replace the `fsm-goodbye-cruel-world' ;; form with `nil', eval just the `cl-labels' form and then type ;; M-x start-pingpong RET -16 RET. ;;; News: ;; Version 0.2: ;; -- Delete trailing whitespace. ;; -- Fix formatting. ;; -- Use lexical binding. ;; -- Port to cl-lib. ;; -- Remove unnecessary fsm-debug-output message. ;; -- Add FSM name to fsm-debug-output messages that were not including it. ;; -- Fix checkdoc errors. ;; -- Change FSMs from plists to uninterned symbols. ;; NOTE: This is version 0.1ttn4 of fsm.el, with the following ;; mods (an exercise in meta-meta-programming ;-) by ttn: ;; -- Refill for easy (traditional 80-column) perusal. ;; -- New var `fsm-debug-timestamp-format'. ;; -- Make variables satisfy `user-variable-p'. ;; -- Use `format' instead of `concat'. ;; -- New func `fsm-goodbye-cruel-world'. ;; -- Make start-function respect `interactive' spec. ;; -- Make enter-/event-functions anonymous. ;; -- New macro `define-fsm'. ;; -- Example usage in Commentary. ;;; Code: ;; We require cl-lib at runtime, since we insert `cl-destructuring-bind' into ;; modules that use fsm.el. (require 'cl-lib) (defvar fsm-debug "*fsm-debug*" "*Name of buffer for fsm debug messages. If nil, don't output debug messages.") (defvar fsm-debug-timestamp-format nil "*Timestamp format (a string) for `fsm-debug-output'. Default format is whatever `current-time-string' returns followed by a colon and a space.") (defun fsm-debug-output (format &rest args) "Append debug output to buffer named by the variable `fsm-debug'. FORMAT and ARGS are passed to `format'." (when fsm-debug (with-current-buffer (get-buffer-create fsm-debug) (save-excursion (goto-char (point-max)) (insert (if fsm-debug-timestamp-format (format-time-string fsm-debug-timestamp-format) (concat (current-time-string) ": ")) (apply #'format format args) "\n"))))) (cl-defmacro define-state-machine (name &key start sleep) "Define a state machine class called NAME. A function called start-NAME is created, which uses the argument list and body specified in the :start argument. BODY should return a list of the form (STATE STATE-DATA [TIMEOUT]), where STATE is the initial state (defined by `define-state'), STATE-DATA is any object, and TIMEOUT is the number of seconds before a :timeout event will be sent to the state machine. BODY may refer to the instance being created through the dynamically bound variable `fsm'. SLEEP-FUNCTION, if provided, takes one argument, the number of seconds to sleep while allowing events concerning this state machine to happen. There is probably no reason to change the default, which is `accept-process-output' with rearranged arguments. \(fn NAME :start ((ARG ...) DOCSTRING BODY) [:sleep SLEEP-FUNCTION])" (declare (debug (&define name :name start &rest &or [":start" (lambda-list [&optional ("interactive" interactive)] stringp def-body)] [":sleep" function-form]))) (let ((start-name (intern (format "start-%s" name))) interactive-spec) (cl-destructuring-bind (arglist docstring &body body) start (when (and (consp (car body)) (eq 'interactive (caar body))) (setq interactive-spec (list (pop body)))) (unless (stringp docstring) (error "Docstring is not a string")) `(progn (put ',name :fsm-enter (make-hash-table :size 11 :test 'eq)) (put ',name :fsm-event (make-hash-table :size 11 :test 'eq)) (defun ,start-name ,arglist ,docstring ,@interactive-spec (fsm-debug-output "Starting %s" ',name) (let ((fsm (cl-gensym (concat "fsm-" ,(symbol-name name) "-")))) (cl-destructuring-bind (state state-data &optional timeout) (progn ,@body) (put fsm :name ',name) (put fsm :state nil) (put fsm :state-data nil) (put fsm :sleep ,(or sleep '(lambda (secs) (accept-process-output nil secs)))) (put fsm :deferred nil) (fsm-update fsm state state-data timeout) fsm))))))) (cl-defmacro define-state (fsm-name state-name arglist &body body) "Define a state called STATE-NAME in the state machine FSM-NAME. ARGLIST and BODY make a function that gets called when the state machine receives an event in this state. The arguments are: FSM the state machine instance (treat it as opaque) STATE-DATA An object EVENT The occurred event, an object. CALLBACK A function of one argument that expects the response to this event, if any (often `ignore' is used) If the event should return a response, the state machine should arrange to call CALLBACK at some point in the future (not necessarily in this handler). The function should return a list of the form (NEW-STATE NEW-STATE-DATA TIMEOUT): NEW-STATE The next state, a symbol NEW-STATE-DATA An object TIMEOUT A number: send timeout event after this many seconds nil: cancel existing timer :keep: let existing timer continue Alternatively, the function may return the keyword :defer, in which case the event will be resent when the state machine enters another state." (declare (debug (&define name name :name handler lambda-list def-body))) `(setf (gethash ',state-name (get ',fsm-name :fsm-event)) (lambda ,arglist ,@body))) (cl-defmacro define-enter-state (fsm-name state-name arglist &body body) "Define a function to call when FSM-NAME enters the state STATE-NAME. ARGLIST and BODY make a function that gets called when the state machine enters this state. The arguments are: FSM the state machine instance (treat it as opaque) STATE-DATA An object The function should return a list of the form (NEW-STATE-DATA TIMEOUT): NEW-STATE-DATA An object TIMEOUT A number: send timeout event after this many seconds nil: cancel existing timer :keep: let existing timer continue" (declare (debug (&define name name :name enter lambda-list def-body))) `(setf (gethash ',state-name (get ',fsm-name :fsm-enter)) (lambda ,arglist ,@body))) (cl-defmacro define-fsm (name &key start sleep states (fsm-name 'fsm) (state-data-name 'state-data) (callback-name 'callback) (event-name 'event)) "Define a state machine class called NAME, along with its STATES. This macro is (further) syntactic sugar for `define-state-machine', `define-state' and `define-enter-state' macros, q.v. NAME is a symbol. Everything else is specified with a keyword arg. START and SLEEP are the same as for `define-state-machine'. STATES is a list, each element having the form (STATE-NAME . STATE-SPEC). STATE-NAME is a symbol. STATE-SPEC is an alist with keys `:event' or `:enter', and values a series of expressions representing the BODY of a `define-state' or `define-enter-state' call, respectively. FSM-NAME, STATE-DATA-NAME, CALLBACK-NAME, and EVENT-NAME are symbols, used to construct the state functions' arglists." `(progn (define-state-machine ,name :start ,start :sleep ,sleep) ,@(cl-loop for (state-name . spec) in states if (assq :enter spec) collect `(define-enter-state ,name ,state-name (,fsm-name ,state-data-name) ,@(cdr it)) end if (assq :event spec) collect `(define-state ,name ,state-name (,fsm-name ,state-data-name ,event-name ,callback-name) ,@(cdr it)) end))) (defun fsm-goodbye-cruel-world (name) "Unbind functions related to fsm NAME (a symbol). Includes start-NAME, and each fsm-NAME-STATE and fsm-NAME-enter-STATE. Functions are `fmakunbound', which will probably give (fatal) pause to any state machines using them. Return nil." (interactive "SUnbind function definitions for fsm named: ") (fmakunbound (intern (format "start-%s" name))) (let (ht) (when (hash-table-p (setq ht (get name :fsm-event))) (clrhash ht) (cl-remprop name :fsm-event)) (when (hash-table-p (setq ht (get name :fsm-enter))) (clrhash ht) (cl-remprop name :fsm-enter))) nil) (defun fsm-start-timer (fsm secs) "Send a timeout event to FSM after SECS seconds. The timer is canceled if another event occurs before, unless the event handler explicitly asks to keep the timer." (fsm-stop-timer fsm) (put fsm :timeout (run-with-timer secs nil #'fsm-send-sync fsm :timeout))) (defun fsm-stop-timer (fsm) "Stop the timeout timer of FSM." (let ((timer (get fsm :timeout))) (when (timerp timer) (cancel-timer timer) (put fsm :timeout nil)))) (defun fsm-maybe-change-timer (fsm timeout) "Change the timer of FSM according to TIMEOUT." (cond ((numberp timeout) (fsm-start-timer fsm timeout)) ((null timeout) (fsm-stop-timer fsm)) ;; :keep needs no timer change )) (defun fsm-send (fsm event &optional callback) "Send EVENT to FSM asynchronously. If the state machine generates a response, eventually call CALLBACK with the response as only argument." (run-with-timer 0 nil #'fsm-send-sync fsm event callback)) (defun fsm-update (fsm new-state new-state-data timeout) "Update FSM with NEW-STATE, NEW-STATE-DATA and TIMEOUT." (let ((fsm-name (get fsm :name)) (old-state (get fsm :state))) (put fsm :state new-state) (put fsm :state-data new-state-data) (fsm-maybe-change-timer fsm timeout) ;; On state change, call enter function and send deferred events ;; again. (unless (eq old-state new-state) (fsm-debug-output "%s enters %s" fsm-name new-state) (let ((enter-fn (gethash new-state (get fsm-name :fsm-enter)))) (when (functionp enter-fn) (fsm-debug-output "Found enter function for %s/%s" fsm-name new-state) (condition-case e (cl-destructuring-bind (newer-state-data newer-timeout) (funcall enter-fn fsm new-state-data) (put fsm :state-data newer-state-data) (fsm-maybe-change-timer fsm newer-timeout)) ((debug error) (fsm-debug-output "%s/%s update didn't work: %S" fsm-name new-state e))))) (let ((deferred (nreverse (get fsm :deferred)))) (put fsm :deferred nil) (dolist (event deferred) (apply #'fsm-send-sync fsm event)))))) (defun fsm-send-sync (fsm event &optional callback) "Send EVENT to FSM synchronously. If the state machine generates a response, eventually call CALLBACK with the response as only argument." (save-match-data (let* ((fsm-name (get fsm :name)) (state (get fsm :state)) (state-data (get fsm :state-data)) (state-fn (gethash state (get fsm-name :fsm-event)))) ;; If the event is a list, output only the car, to avoid an ;; overflowing debug buffer. (fsm-debug-output "Sent %S to %s in state %s" (or (car-safe event) event) fsm-name state) (let ((result (condition-case e (funcall state-fn fsm state-data event (or callback 'ignore)) ((debug error) (cons :error-signaled e))))) ;; Special case for deferring an event until next state change. (cond ((eq result :defer) (let ((deferred (get fsm :deferred))) (put fsm :deferred (cons (list event callback) deferred)))) ((null result) (fsm-debug-output "Warning: event %S ignored in state %s/%s" event fsm-name state)) ((eq (car-safe result) :error-signaled) (fsm-debug-output "Error in %s/%s: %s" fsm-name state (error-message-string (cdr result)))) ((and (listp result) (<= 2 (length result)) (<= (length result) 3)) (cl-destructuring-bind (new-state new-state-data &optional timeout) result (fsm-update fsm new-state new-state-data timeout))) (t (fsm-debug-output "Incorrect return value in %s/%s: %S" fsm-name state result))))))) (defun fsm-call (fsm event) "Send EVENT to FSM synchronously, and wait for a reply. Return the reply. `with-timeout' might be useful." (let (reply) (fsm-send-sync fsm event (lambda (r) (setq reply (list r)))) (while (null reply) (fsm-sleep fsm 1)) (car reply))) (defun fsm-make-filter (fsm) "Return a filter function that sends events to FSM. Events sent are of the form (:filter PROCESS STRING)." (let ((fsm fsm)) (lambda (process string) (fsm-send-sync fsm (list :filter process string))))) (defun fsm-make-sentinel (fsm) "Return a sentinel function that sends events to FSM. Events sent are of the form (:sentinel PROCESS STRING)." (let ((fsm fsm)) (lambda (process string) (fsm-send-sync fsm (list :sentinel process string))))) (defun fsm-sleep (fsm secs) "Sleep up to SECS seconds in a way that lets FSM receive events." (funcall (get fsm :sleep) secs)) (defun fsm-get-state-data (fsm) "Return the state data of FSM. Note the absence of a set function. The fsm should manage its state data itself; other code should just send messages to it." (get fsm :state-data)) (provide 'fsm) ;;; fsm.el ends here emacs-jabber/lisp/jabber-fallback-lib/srv.el000066400000000000000000000130011476345337400212350ustar00rootroot00000000000000;;; srv.el --- perform SRV DNS requests -*- lexical-binding: t; -*- ;; Copyright (C) 2005, 2007, 2018 Magnus Henoch ;; Author: Magnus Henoch ;; Keywords: comm ;; Version: 0.2 ;; Package-Requires: ((emacs "24.3")) ;; URL: https://github.com/legoscia/srv.el ;; This file is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This file is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Commentary: ;; This code implements RFC 2782 (SRV records). It was originally ;; written for jabber.el , but is now a ;; separate package. ;; ;; It is used to look up hostname and port for a service at a specific ;; domain. There might be multiple results, and the caller is supposed ;; to attempt to connect to each hostname+port in turn. For example, ;; to find the XMPP client service for the domain gmail.com: ;; ;; (srv-lookup "_xmpp-client._tcp.gmail.com") ;; -> (("xmpp.l.google.com" . 5222) ;; ("alt3.xmpp.l.google.com" . 5222) ;; ("alt4.xmpp.l.google.com" . 5222) ;; ("alt1.xmpp.l.google.com" . 5222) ;; ("alt2.xmpp.l.google.com" . 5222)) ;;; Code: (require 'dns nil t) (eval-when-compile (require 'cl-lib)) ;;;###autoload (defun srv-lookup (target) "Perform SRV lookup of TARGET and return list of connection candidiates. TARGET is a string of the form \"_Service._Proto.Name\". Returns a list with elements of the form (HOST . PORT), where HOST is a hostname and PORT is a numeric port. The caller is supposed to make connection attempts in the order given, starting from the beginning of the list. The list is empty if no SRV records were found." (if (not (boundp 'dns-query-types)) (error "No dns.el available") (unless (assq 'SRV dns-query-types) (error "dns.el doesn't support SRV lookups")) (let* ((result (srv--dns-query target)) (answers (mapcar #'(lambda (a) (cadr (assq 'data a))) (cadr (assq 'answers result)))) answers-by-priority weighted-result) (if (or (null answers) ;; Special case for "service decidedly not available" (and (eq (length answers) 1) (string= (cadr (assq 'target (car answers))) "."))) nil ;; Sort answers into groups of same priority. (dolist (a answers) (let* ((priority (cadr (assq 'priority a))) (entry (assq priority answers-by-priority))) (if entry (push a (cdr entry)) (push (cons priority (list a)) answers-by-priority)))) ;; Sort by priority. (setq answers-by-priority (sort answers-by-priority #'(lambda (a b) (< (car a) (car b))))) ;; Randomize by weight within priority groups. See ;; algorithm in RFC 2782. (dolist (p answers-by-priority) (let ((weight-acc 0) weight-order) ;; Assign running sum of weight to each entry. (dolist (a (cdr p)) (cl-incf weight-acc (cadr (assq 'weight a))) (push (cons weight-acc a) weight-order)) (setq weight-order (nreverse weight-order)) ;; While elements remain, pick a random number between 0 and ;; weight-acc inclusive, and select the first entry whose ;; running sum is greater than or equal to this number. (while weight-order (let* ((r (random (1+ weight-acc))) (next-entry (cl-dolist (a weight-order) (if (>= (car a) r) (cl-return a))))) (push (cdr next-entry) weighted-result) (setq weight-order (delq next-entry weight-order)))))) ;; Extract hostnames and ports (mapcar #'(lambda (a) (cons (cadr (assq 'target a)) (cadr (assq 'port a)))) (nreverse weighted-result)))))) (defun srv--dns-query (target) "Perform DNS query for TARGET. On Windows, call `srv--nslookup'; on all other systems, call `dns-query'." ;; dns-query uses UDP, but that is not supported on Windows... (if (featurep 'make-network-process '(:type datagram)) (dns-query target 'SRV t) ;; ...so let's call nslookup instead. (srv--nslookup target))) (defun srv--nslookup (target) "Call the `nslookup' program to make an SRV query for TARGET." (with-temp-buffer (call-process "nslookup" nil t nil "-type=srv" target) (goto-char (point-min)) (let (results) ;; This matches what nslookup prints on Windows. It's unlikely ;; to work for other systems, but on those systems we use DNS ;; directly. (while (search-forward-regexp (concat "[\s\t]*priority += \\(.*\\)\r?\n" "[\s\t]*weight += \\(.*\\)\r?\n" "[\s\t]*port += \\(.*\\)\r?\n" "[\s\t]*svr hostname += \\(.*\\)\r?\n") nil t) (push (list (list 'data (list (list 'priority (string-to-number (match-string 1))) (list 'weight (string-to-number (match-string 2))) (list 'port (string-to-number (match-string 3))) (list 'target (match-string 4))))) results)) (list (list 'answers results))))) (provide 'srv) ;;; srv.el ends here emacs-jabber/lisp/jabber-feature-neg.el000066400000000000000000000106721476345337400203350ustar00rootroot00000000000000;;; jabber-feature-neg.el --- Feature Negotiation by JEP-0020 -*- lexical-binding: t; -*- ;; 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-lib) (jabber-disco-advertise-feature "http://jabber.org/protocol/feature-neg") (defun jabber-fn-parse (xml-data type) "Parse a Feature Negotiation request, return alist representation. XML-DATA should have one child element, , in the jabber:x:data namespace. TYPE is either `request' or `response'. Returned alist has field name as key, and value is a list of offered alternatives." (let ((x (car (jabber-xml-get-children xml-data 'x)))) (unless (and x (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data")) (jabber-signal-error "Modify" 'bad-request "Malformed Feature Negotiation")) (let (alist (fields (jabber-xml-get-children x 'field))) (dolist (field fields) (let ((var (jabber-xml-get-attribute field 'var)) (value (car (jabber-xml-get-children field 'value))) (options (jabber-xml-get-children field 'option))) (setq alist (cons (cons var (cond ((eq type 'request) (mapcar #'(lambda (option) (car (jabber-xml-node-children (car (jabber-xml-get-children option 'value))))) options)) ((eq type 'response) (jabber-xml-node-children value)) (t (error "Incorrect Feature Negotiation type: %s" type)))) alist)))) ;; return alist alist))) (defun jabber-fn-encode (alist type) "Transform a feature alist into an node int the jabber:x:data namespace. Note that this is not the reverse of `jabber-fn-parse'. TYPE is either `request' or `response'." (let ((requestp (eq type 'request))) `(x ((xmlns . "jabber:x:data") (type . ,(if requestp "form" "submit"))) ,@(mapcar #'(lambda (field) `(field ((type . "list-single") (var . ,(car field))) ,@(if requestp (mapcar #'(lambda (option) `(option nil (value nil ,option))) (cdr field)) (list `(value nil ,(cadr field)))))) alist)))) (defun jabber-fn-intersection (mine theirs) "Find values acceptable to both parties. MINE and THEIRS are alists, as returned by `jabber-fn-parse'. An alist is returned, where the keys are the negotiated variables, and the values are lists containing the preferred option. If negotiation is impossible, an error is signalled. The errors are as specified in XEP-0020, and not necessarily the ones of higher-level protocols." (let ((vars (mapcar #'car mine)) (their-vars (mapcar #'car theirs))) ;; are the same variables being negotiated? (sort vars #'string-lessp) (sort their-vars #'string-lessp) (let ((mine-but-not-theirs (cl-set-difference vars their-vars :test #'string=)) (theirs-but-not-mine (cl-set-difference their-vars vars :test #'string=))) (when mine-but-not-theirs (jabber-signal-error "Modify" 'not-acceptable (car mine-but-not-theirs))) (when theirs-but-not-mine (jabber-signal-error "Cancel" 'feature-not-implemented (car theirs-but-not-mine)))) (let (alist) (dolist (var vars) (let ((my-options (cdr (assoc var mine))) (their-options (cdr (assoc var theirs)))) (let ((common-options (cl-intersection my-options their-options :test #'string=))) (if common-options ;; we have a match; but which one to use? ;; the first one will probably work (setq alist (cons (list var (car common-options)) alist)) ;; no match (jabber-signal-error "Modify" 'not-acceptable var))))) alist))) (provide 'jabber-feature-neg) ;;; jabber-feature-neg.el ends hereemacs-jabber/lisp/jabber-festival.el000066400000000000000000000046511476345337400177500ustar00rootroot00000000000000;;; jabber-festival.el --- Festival alert hooks -*- lexical-binding: t; -*- ;; Copyright (C) 2005 Magnus Henoch ;; This file is a part of jabber.el. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. (eval-when-compile (require 'jabber-alert)) (require 'festival nil t) ;; Oddly enough, there are two different implementations of ;; festival.el. One is distributed with the festival package ;; (http://festvox.org/festival), which provides the speech-to-text ;; executable. The other was written by Dave Pearson ;; (https://github.com/davep/festival.el). ;; ;; EmacsWiki points to Pearson’s version. And that is the version ;; which straight.el's loads by default. Neither version is provided ;; by either GNU ELPA, or MELPA. ;; ;; The version bundled with the binary package supplies ;; ‘festival-say-string’, Pearson's version supplies ‘festival-say’ ;; instead. We support both, suppressing ‘check-declare’ warnings by ;; prefixing the filename with "ext:". ;; Global reference declarations (declare-function festival-say-string "ext:festival.el" (say)) (declare-function festival-say "ext:festival.el" (format &rest args)) ;; (when (featurep 'festival) (cond ((fboundp 'festival-say-string) (define-jabber-alert festival "Voice messages through Festival" (lambda (text &optional title) (festival-say-string (or title text))))) ((fboundp 'festival-say) (define-jabber-alert festival "Voice messages through Festival" (lambda (text &optional title) (festival-say (or title text))))) (t (define-jabber-alert festival "Voice messages through Festival" (lambda (_text &optional _title) (error "Unsupported festival.el implementation.")))))) (provide 'jabber-festival) ;;; jabber-festival.el ends hereemacs-jabber/lisp/jabber-history.el000066400000000000000000000314421476345337400176320ustar00rootroot00000000000000;;; jabber-history.el --- recording message history -*- lexical-binding: t; -*- ;; 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 ;; XEP-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) (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) (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) (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) (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) (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 -, where is 1 or the smallest number after the last rotation." :type 'boolean) (defcustom jabber-history-size-limit 1024 "Maximum history file size in kilobytes. When history file reaches this limit, it is renamed to -, where is 1 or the smallest number after the last rotation." :type 'integer) ;; Global reference declarations (declare-function jabber-muc-message-p "jabber-muc.el"(message)) (defvar jabber-chatting-with) ; jabber-chatbuffer.el (defvar jabber-buffer-connection) ; jabber-buffer-connection.el ;; (defvar jabber-history-inhibit-received-message-functions nil "Functions determining whether to log an incoming message stanza. The functions in this list are called with two arguments, the connection and the full message stanza. If any of the functions returns non-nil, the stanza is not logged in the message history.") (defun jabber-rotate-history-p (history-file) "Return non-nil if HISTORY-FILE should be rotated." (when (and jabber-history-enable-rotation (file-exists-p history-file)) (> (/ (nth 7 (file-attributes history-file)) 1024) jabber-history-size-limit))) (defun jabber-history-rotate (history-file &optional try) "Rename HISTORY-FILE to HISTORY-FILE-TRY." (let ((suffix (number-to-string (or try 1)))) (if (file-exists-p (concat history-file "-" suffix)) (jabber-history-rotate history-file (if try (1+ try) 1)) (rename-file history-file (concat history-file "-" suffix))))) (add-to-list 'jabber-message-chain #'jabber-message-history) (defun jabber-message-history (jc xml-data) "Log message to log file. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (when (and (not jabber-use-global-history) (not (file-directory-p jabber-history-dir))) (make-directory jabber-history-dir)) (let ((is-muc (jabber-muc-message-p xml-data))) (when (and jabber-history-enabled (or (not is-muc) ;chat message or private MUC message (and jabber-history-muc-enabled is-muc))) ;muc message and muc logging active (unless (run-hook-with-args-until-success 'jabber-history-inhibit-received-message-functions jc xml-data) (let ((from (jabber-xml-get-attribute xml-data 'from)) (text (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'body))))) (timestamp (jabber-message-timestamp xml-data))) (when (and from text) (jabber-history-log-message "in" from nil text timestamp))))))) (add-hook 'jabber-chat-send-hooks #'jabber-history-send-hook) (defun jabber-history-send-hook (body _id) "Log outgoing message to log file." (when (and (not jabber-use-global-history) (not (file-directory-p jabber-history-dir))) (make-directory jabber-history-dir)) ;; This function is called from a chat buffer, so jabber-chatting-with ;; contains the desired value. (if jabber-history-enabled (jabber-history-log-message "out" nil jabber-chatting-with body (current-time)))) (defun jabber-history-filename (contact) "Return a history filename for CONTACT. Return the global history filename, or (if the per-user file logging strategy is used) a history filename for CONTACT." (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) ;;; jabber-history.el ends hereemacs-jabber/lisp/jabber-httpupload.el000066400000000000000000000631421476345337400203170ustar00rootroot00000000000000;;; jabber-httpupload.el --- Emacs Jabber HTTP Upload Implementation -*- lexical-binding: t; -*- ;; Copyright 2021 cnngimenez ;; ;; Author: cnngimenez ;; Maintainer: cnngimenez ;; Version: 0.1.0 ;; Keywords: comm ;; URL: https://github.com/cnngimenez/emacs-jabber ;; Package-Requires: ((emacs "26.1") (jabber "0.8.92")) ;; 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 . ;;; Commentary: ;; This file implements XEP-0363: HTTP Upload ;; (https://xmpp.org/extensions/xep-0363.html), providing a way to ;; send files (images, audio, etc) through XMPP clients by using ;; server space, and the HTTP protocol to upload and download from it. ;; The advantage is that the sender user does not need to be connected ;; after sharing the file, and the receiver may be disconnected while ;; the sender is uploading. ;; The procedure to send a file is as follows - ;; 1. Use Disco queries to discover if the server supports the HTTP Upload (~urn:xmpp:http:upload~ namespace). ;; 2. Request a slot to the upload Disco item. The server will answer with a GET and PUT URL. ;; 3. Upload the file to the HTTP server by using the PUT URL. ;; 4. Usually, send the GET URL to the other XMPP clients to allow them to access the uploaded file. ;; ;; TODO - ;; 1. Use wget to send the file ;; 2. Recording audio and sending ;;; Code: (require 'seq) (require 'fsm) (require 'mailcap) (require 'jabber) ;; * Configuration variables * (defgroup jabber-httpupload nil "Jabber HTTP Upload Settings." :group 'jabber) (defcustom jabber-httpupload-upload-function #'jabber-httpupload-put-file-curl "The function used to upload the file. Some functions calls external programs such as Curl and wget, please check their documentation for more information." :group 'jabber-httpupload :type 'function) ;; TODO Recording and sending audio ;; (defcustom jabber-httpupload-record-command "sox -d -t ogg $(filename).ogg" ;; "What is the command used to record audio? ;; Use $(filename) where the temporal filename should be." ;; :group 'jabber-httpupload ;; :type 'function) ;; Disco is used to discover if HTTP Upload is supported on the server ;; side. Two queries are used: ;; 1. An IQ Disco items request to get all items supported by the ;; server. ;; 2. For each item, an IQ Disco info request to test if the item is ;; the Upload service. ;; The namespace of the HTTP Upload feature is ;; "urn:xmpp:http:upload:0". This will be used on the second query to ;; detect which item is the upload service. ;; For more information, see XML examples at the ;; [[https://xmpp.org/extensions/xep-0363.html#disco][Discovering ;; Support section of XEP-0363]]. ;; This implementation requires an initialization step to fill the ;; `jabber-httpupload-support' variable. This variable registers all ;; connections with their HTTP Upload item. If one of the server ;; associated to a connection does not support HTTP Upload, then it ;; will be registered with a `nil' item. ;; * Discovering support * (defvar jabber-httpupload-support nil "Alist of Jabber connections and the node with HTTP Upload support. This is filled by the `jabber-httpupload-test-all-connections-suport'. Each element are of the form (jabber-connection . string/nil). If the value is a string, it is the upload item IRI, if nil means no support.") (defun jabber-httpupload-test-all-connections-support () "Test all connections in `jabber-connections' for HTTP Upload support. Store the results at `jabber-httpupload-support'. If the connection is already tested, ignore it." (let ((connections (seq-difference jabber-connections (mapcar #'car jabber-httpupload-support)))) (dolist (jc connections) (jabber-httpupload-test-connection-support jc)))) (defun jabber-httpupload-test-connection-support (jc) "Test if HTTP Upload is supported on the JC connection's server. If it is supported, store the item IRI at `jabber-httpupload-support'. This function is asynchronous, thus it won't return any results." (jabber-httpupload-apply-to-items jc (lambda (jc result) (jabber-httpupload-test-item-support jc (elt result 1))))) ;; CALLBACK receives three arguments: the jabber connection, extra ;; data and the query result. The result is a list of features ;; supported by the server. For example, if the client receives the ;; following IQ answer: ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; urn:xmpp:http:upload:0 ;; ;; ;; 500000 ;; ;; ;; ;; ;; urn:xmpp:http:upload ;; ;; ;; 500000 ;; ;; ;; ;; ;; ;; The result would be: ;; ;; ((["HTTP File Upload" "store" "file"]) ;; ("http://jabber.org/protocol/disco#info" ;; "http://jabber.org/protocol/disco#items" ;; "urn:xmpp:http:upload:0" ;; "urn:xmpp:http:upload")) ;; ;; This Disco item supports HTTP Upload because the ;; "urn:xmpp:http:upload" namespace is in the second list. (defun jabber-httpupload-test-item-support (jc iri) "Test if the IRI Disco item supports HTTP Upload. Get the Disco Info from the provided IRI at the current JC jabber connection, if the HTTP Upload namespace feature is in the answer, store the IRI in `jabber-httpupload-support'." (jabber-disco-get-info jc iri nil (lambda (jc _data result) (when (member "urn:xmpp:http:upload" (nth 1 result)) ;; This item supports HTTP Upload... register it! (push (cons jc iri) jabber-httpupload-support))) nil)) ;; CALLBACK receives three arguments: the jabber connection, extra ;; data and the query result. The result is a list of vector with the ;; node name, its IRI and any other properties. ;; ;; For example, if the client receives the following XML: ;; ;; ;; ;; ;; ;; ;; ;; ;; The result would be: ;; (["MUC chats!" "conference.server.org" nil] [nil "upload.server.org" nil]) (defun jabber-httpupload-apply-to-items (jc callback) "Retrieve al Disco IRIs from the server connected in JC. Return a list of IRI strings. JC is a jabber connection. CALLBACK is a function that receives two arguments: Jabber connection and the item vector." (let ((node (plist-get (fsm-get-state-data jc) :server))) (jabber-disco-get-items jc node nil (lambda (jc _data result) (dolist (item result) (message "item: %S" item) (funcall callback jc item))) nil))) (defun jabber-httpupload-server-has-support (jc) "Check if the server has HTTP Upload support. Return the tuple (jabber-connection . upload-url) when there is support from the server. Return nil when the server does not support HTTP Upload. If the server is not in `jabber-httpupload-support', then it is considered as it is not supported. It SHOULD be tested on-line with `jabber-httpupload-test-connection-support' as soon as the connection and authentication is established. JC is the Jabber Connection to use." (seq-find (lambda (tuple) (and (equal jc (car tuple)) (cdr tuple))) jabber-httpupload-support)) ;; * Requesting a slot * ;; The XEP specifies that the client must ask for a "slot" before ;; uploading the file to the server. The slot is a fresh URL that will ;; be enabled for the client to upload the file. The server may give ;; two URLs in one slot query: the uploading URL and the GET URL to ;; share. ;; The server may limit the file size to upload. ;; ;; ;; ;;
Basic Base64String==
;;
foo=bar; user=romeo
;; ;; ;; ;; (defun jabber-httpupload-parse-slot-answer (xml-data) "Retrieve the slot data from the XML-DATA information. The XML-DATA is the stanza receive from the Jabber Connection after requesting the slot for a file. The returned list has the PUT URL and the GET URL." (list (jabber-xml-get-attribute (jabber-xml-path xml-data '(slot put)) 'url) (jabber-xml-get-attribute (jabber-xml-path xml-data '(slot get)) 'url))) (defun jabber-httpupload--request-slot-successful (jc xml-data data) "Callback function used when the slot request succeeded. XML-DATA is the received XML from the server. DATA is a triple (filedata success-callback success-args) where: FILEDATA is a triple (filename size content-type) SUCCESS-CALLBACK is a function to call after parsing and requesting the upload. It should accept following arguments: JC XML-DATA FILEDATA PUT-GET-URLS and SUCCESS-ARGS. SUCCESS-ARGS is a list to pass to the SUCCESS-CALLBACK." (let ((urls (jabber-httpupload-parse-slot-answer xml-data)) (filedata (car data)) (success-callback (nth 1 data)) (success-args (nth 2 data))) (funcall success-callback jc xml-data filedata urls success-args))) ;; Maybe this function should be added as lambda inside the jabber-httpupload-request-slot... (defun jabber-httpupload--request-slot-failed (jc xml-data data) "Callback function used when the slot request failed. DATA is a list (filedata error-callback error-args) where: FILEDATA is a triple (filename size content-type) ERROR-CALLBACK is a function to call. If no error-callback is provided, then `error' is used. Its arguments are JC XML-DATA FILEDATA ERROR-ARGS. ERROR-ARGS is list passed to the ERROR-CALLBACK." (let ((filedata (car data)) (error-callback (nth 1 data)) (error-args (nth 2 data))) (if error-callback (funcall error-callback jc xml-data filedata error-args) (error (format "The file %s cannot be uploaded: SLOT rejected. %S" (car data) xml-data))))) ;; The XML used to request a slot is similar to the following - ;; ;; ;; (defun jabber-httpupload-request-slot (jc filedata success-callback success-args &optional error-callback error-args) "Request a slot for HTTP Upload to the server's connection. JC is an active Jabber Connection. FILEDATA is a list with (filename size content-type). SUCCESS-CALLBACK is a function name to call when the slot is received. Its arguments should be: jc xml-data data and put-get-URLs. SUCCESS-ARGS is a list of arguments used by the SUCCESS-CALLBACK ERROR-CALLBACK is a function to call on failure. Its arguments should be: jc xml-data. ERROR-ARGS is a list with arguments for ERROR-CALLBACK." (let ((filename (file-name-nondirectory (car filedata))) (size (nth 1 filedata)) (content-type (nth 2 filedata))) (jabber-send-iq jc (cdr (jabber-httpupload-server-has-support jc)) "get" `(request ((xmlns . "urn:xmpp:http:upload:0") (filename . ,filename) (size . ,size) (content-type . ,content-type))) #'jabber-httpupload--request-slot-successful (list filedata success-callback success-args) #'jabber-httpupload--request-slot-failed (list filedata error-callback error-args)))) ;; * Uploading the file * ;; Use the HTTP protocol to upload the file to the PUT URL provided by ;; the slot. ;; The following functions call the upload programs asynchronously. ;; When the program ends, a callback function is called with one ;; argument provided by the caller function. ;; The uploading process supports multiple calls. For example, the ;; user may call `jabber-httpupload-send-file' again while the upload process of a ;; previous `jabber-httpupload-send-file' call is still running. ;; Also, a callback can be provided in order to send the URL to the ;; receiving Jabber client or to perform any other action after ;; uploading the file. (defun jabber-httpupload-ignore-certificate (jc) "Should the SSL/TLS certificates be ignore from JC connection? Check if JC URL is in the variable `jabber-invalid-certificate-servers', if it is the XMPP and HTTPs connection should be established regarding their certificate validation status." (member (plist-get (fsm-get-state-data jc) :server) jabber-invalid-certificate-servers)) (defun jabber-httpupload-upload-file (filepath content-type put-url callback callback-arg &optional ignore-cert-problems) "Update the given file at FILEPATH to the provided PUT-URL. The CONTENT-TYPE (MIME type) of the file must match the one provided to the Jabber Connection with `jabber-httpupload-request-slot'. IGNORE-CERT-PROBLEMS allows to connect with HTTPS servers with invalid or non-trusted SSL/TLS certificates. When the process ends, a callback function is called using the following code: (funcall CALLBACK CALLBACK-ARG)" (unless (funcall jabber-httpupload-upload-function filepath content-type put-url callback callback-arg ignore-cert-problems) (error (concat "The upload function failed to PUT the file to the server. " "Try other function or install the required program")))) ;; Multiple files can be uploaded in parallel, and thus multiple ;; subprocess could be working at the same time. This happens when the ;; user calls interactively `jabber-httpupload-send-file' twice or while a file is ;; still uploading. ;; This variable keeps track of the subprocesses and their callback ;; along with any data required by these functions. (defvar jabber-httpupload-upload-processes nil "Alist of running processes uploading the file to the server. List of running processes uploading the file to the server associated with their callback and arguments. Each element has the following format: (process . (callback arg))") ;; When the file has been uploaded, the process is still registered ;; with its callback function. This callback should be called and the ;; process deleted from the system. (defun jabber-httpupload-process-ended (process) "What to do when an upload process ends. PROCESS is the process that ended. First remove the process from `jabber-httpupload-upload-processes', then call its callback with the provided argument." (let* ((data (assq process jabber-httpupload-upload-processes)) (callback (cadr data)) (callback-arg (caddr data))) (setq jabber-httpupload-upload-processes (assq-delete-all process jabber-httpupload-upload-processes)) (funcall callback callback-arg))) ;; Using CURL to send the file ;; These functions call curl to send the file to the server. A ;; sentinel is required to check when the subprocess finishes to call ;; the next function (usually, send the URL to the other jabber ;; client). (defun jabber-httpupload-curl-sentinel (process event) "Detect when Curl ends and act accordingly. PROCESS is the asynchronous Curl call. EVENT is a string describing the reason the sentinel were called. When EVENT is \"finished\n\", then the function `jabber-httpupload-process-ended' is called." (with-current-buffer (process-buffer process) (let ((inhibit-read-only t)) (goto-char (point-max)) (insert (format "Sentinel: %S event received." event)))) (when (string= event "finished\n") (jabber-httpupload-process-ended process))) ;; This is the function used to send a file to the server by running a curl subprocess. (defun jabber-httpupload-put-file-curl (filepath content-type put-url callback callback-arg &optional ignore-cert-problems) "Use the curl command to put the file at FILEPATH into the PUT-URL. Send the SIZE and CONTENT-TYPE MIME as headers. IGNORE-CERT-PROBLEMS enable the use of HTTPS connections with invalid or non-trusted SSL/TLS certificates. If nil, curl will validate the certificate provided by the HTTP/S Web server. When the process ends, the function CALLBACK is called like the following call: (funcall CALLBACK CALLBACK-ARG). The process is registered at `jabber-httpupload-upload-processes' AList with the provided CALLBACK and CALLBACK-ARG." (let* ((exec-path (executable-find "curl")) (cmd (format "%s %s --upload-file '%s' -H \"content-type: %s\" '%s'" exec-path (if ignore-cert-problems "--insecure" "") filepath content-type put-url))) (when exec-path (with-current-buffer (get-buffer-create "*jabber-httpupload-put-file-curl*") (let ((inhibit-read-only t)) (goto-char (point-max)) (insert (format "%s Uploading to %s with curl:\n$ %s" (current-time-string) put-url cmd)) (let ((process (start-process-shell-command "jabber-httpupload-put-file-curl" (current-buffer) cmd))) (push (cons process (list callback callback-arg)) jabber-httpupload-upload-processes) (set-process-sentinel process #'jabber-httpupload-curl-sentinel)) (insert "-- done --") t))))) ;; * Send the file URL to the client * ;; The following message is similar to one sent by Conversations - ;; ;; ;; https://fromserver.org:5281/upload/kFTT5ET9JeF_CC6s/_IJNy8ZUSRGiKyVxjf5FkA.jpg ;; ;; ;; ;; ;; https://fromserver.org:5281/upload/kFTT5ET9JeF_CC6s/_IJNy8ZUSRGiKyVxjf5FkA.jpg ;; ;; ;; ;; The message should add the "body" and "x" tags. (defun jabber-httpupload-send-file-url (jc jid get-url) "Send the GET URL address to the JID user. The message requiers the GET-URL of the slot file, the receiver's JID and the JC Jabber Connection." ;; This could be a possibliity, but... cannot send the x tag. ;; (jabber-send-message jc jid nil get-url nil) (let* ((id (apply #'format "emacs-msg-%d.%d.%d" (current-time))) (fromjid (jabber-connection-original-jid jc)) (type (if (assoc jid *jabber-active-groupchats*) "groupchat" "chat")) (body get-url) (stanza-to-send `(message ((to . ,jid) (from . ,fromjid) (type . ,type) (id . ,id)) (body () ,body) (x ((xmlns . "jabber:x:oob")) (url () ,body))))) (unless (equal type "groupchat") (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)))) (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))) ;; * Chat buffer * ;; ** Send file (complete process) ** ;; The following functions add interactive commands to the chat buffer ;; to send the GET URL to the current (or selected) client. (defun jabber-httpupload-send-file (jc jid filepath) "Send the file at FILEPATH to the user JID. JC is the Jabber Connection to send the file URL." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Send file to: " nil nil nil 'full t) (read-file-name "File to send:"))) (unless (jabber-httpupload-server-has-support jc) (error "The Jabber Connection provided has no HTTP Upload support")) (let* ((size (file-attribute-size (file-attributes filepath))) (content-type (mailcap-extension-to-mime (file-name-extension filepath))) (filedata (list filepath size content-type))) (jabber-httpupload-request-slot jc filedata #'jabber-httpupload--slot-reserved (list jid)))) ;; The following functions are callbacks used in the following order: ;; 1. `jabber-httpupload-request-slot' calls `jabber-httpupload--slot-reserved'. ;; 2. `jabber-httpupload--slot-reserved' calls `jabber-httpupload--upload-done'. ;; 3. `jabber-httpupload--upload-done' calls `jabber-httpupload-send-file-url'. ;; This form of calling is required because of the asynchronous ;; behaviour of the upload file function. (defun jabber-httpupload--upload-done (data) "Callback function used when the upload is done. When the upload process finished, a callback function is called with an argument. This function is expected to be used as the CALLBACK argument for the function `jabber-httpupload-upload-file', DATA is its CALLBACK-ARG argument. Also, see `jabber-httpupload-process-ended' for more information. DATA is expected to have the following foramt: (jc jid get-url). After the upload is done, send the get-url to the destined Jabber user JID." (let ((jc (car data)) (jid (nth 1 data)) (get-url (nth 2 data))) (condition-case err (jabber-httpupload-send-file-url jc jid get-url) (error "Cannot send message. Error: %S" err)))) ;; When the slot is reserved, the HTTP upload should be started. (defun jabber-httpupload--slot-reserved (jc _xml-data filedata urls extra-data) "Callback function used when the slot request succeeded. JC is the current Jabber Connection. XML-DATA is the received XML from the server. FILEDATA is a triple `(filepath size content-type). URLS is a tuple `(put-url get-url). EXTRA-DATA is a list `(jid)" (let ((filepath (car filedata)) (content-type (nth 2 filedata)) (jid (car extra-data)) (get-url (cadr urls)) (put-url (car urls))) (message "jabber-httpupload: slot PUT and GET URLs: %S" urls) (condition-case err (jabber-httpupload-upload-file (expand-file-name filepath) content-type put-url #'jabber-httpupload--upload-done (list jc jid get-url) (jabber-httpupload-ignore-certificate jc)) (error "Cannot upload the file. Error: %S" err)))) ;; TODO Recording and sending audio ** ;; (defun jabber-httpupload--record-audio () ;; "Create a new audio record and save the file into a temporal directory." ;; (let ((process (start-process-shell-command ;; "jabber-httpupload-record-audio" ;; (current-buffer) ;; (replace-string "$(filename" ;; "/tmp/jabber-httpupload-record" ;; jabber-httpupload-record-command)))) ;; (set-process-sentinel process #'jabber-httpupload-record-sentinel))) ;; * Add hooks * ;; Some function should start automatically. ;; ** Test connection support after session is established ** ;; Call `jabber-httpupload-test-connection-support' as soon as ;; * Adding functions to hooks * ;; ** Test HTTP Upload support after connecting ** (add-hook 'jabber-post-connect-hooks #'jabber-httpupload-test-connection-support) (provide 'jabber-httpupload) ;;; jabber-httpupload.el ends here emacs-jabber/lisp/jabber-iq.el000066400000000000000000000210641476345337400165410ustar00rootroot00000000000000;;; jabber-iq.el --- infoquery functions -*- lexical-binding: t; -*- ;; 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-util) (require 'jabber-alert) (require 'jabber-keymap) (require 'jabber-menu) (defvar *jabber-open-info-queries* nil "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) ;; Global reference declarations (declare-function jabber-send-sexp "jabber-core.el" (jc sexp)) (defvar jabber-iq-chain) ; jabber-core.el ;; (define-derived-mode jabber-browse-mode special-mode "jabber-browse" "Special mode." ;; FIXME: Improve! (setq buffer-read-only t)) (eval-after-load "jabber-core" '(add-to-list 'jabber-iq-chain 'jabber-process-iq)) (defun jabber-process-iq (jc xml-data) "Process an incoming iq stanza. JC is the Jabber Connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((id (jabber-xml-get-attribute xml-data 'id)) (type (jabber-xml-get-attribute xml-data 'type)) (from (jabber-xml-get-attribute xml-data 'from)) (query (jabber-iq-query xml-data)) (callback (assoc id *jabber-open-info-queries*))) (cond ;; if type is "result" or "error", this is a response to a query we sent. ((or (string= type "result") (string= type "error")) (let ((callback-cons (nth (cdr (assoc type '(("result" . 0) ("error" . 1)))) (cdr callback)))) (if (consp callback-cons) (funcall (car callback-cons) jc xml-data (cdr callback-cons)))) (setq *jabber-open-info-queries* (delq callback *jabber-open-info-queries*))) ;; if type is "get" or "set", correct action depends on namespace of request. ((and (listp query) (or (string= type "get") (string= type "set"))) (let* ((which-alist (eval (cdr (assoc type (list (cons "get" 'jabber-iq-get-xmlns-alist) (cons "set" 'jabber-iq-set-xmlns-alist)))))) (handler (cdr (assoc (jabber-xml-get-attribute query 'xmlns) which-alist)))) (if handler (condition-case error-var (funcall handler jc xml-data) (jabber-error (apply #'jabber-send-iq-error jc from id query (cdr error-var))) (error (jabber-send-iq-error jc from id query "wait" 'internal-server-error (error-message-string error-var)))) (jabber-send-iq-error jc from id query "cancel" 'feature-not-implemented))))))) (defun jabber-send-iq (jc to type query success-callback success-closure-data error-callback error-closure-data &optional result-id) "Send an iq stanza to the specified entity, and optionally set up a callback. JC is the Jabber connection. TO is the addressee. TYPE is one of \"get\", \"set\", \"result\" or \"error\". QUERY is a list containing the child of the iq node in the format `jabber-sexp2xml' accepts. SUCCESS-CALLBACK is the function to be called when a successful result arrives. SUCCESS-CLOSURE-DATA is an extra argument to SUCCESS-CALLBACK. ERROR-CALLBACK is the function to be called when an error arrives. ERROR-CLOSURE-DATA is an extra argument to ERROR-CALLBACK. RESULT-ID is the id to be used for a response to a received iq message. `jabber-report-success' and `jabber-process-data' are common callbacks. The callback functions are called like this: \(funcall CALLBACK JC XML-DATA CLOSURE-DATA) with XML-DATA being the IQ stanza received in response. " (let ((id (or result-id (apply #'format "emacs-iq-%d.%d.%d" (current-time))))) (if (or success-callback error-callback) (setq *jabber-open-info-queries* (cons (list id (cons success-callback success-closure-data) (cons error-callback error-closure-data)) *jabber-open-info-queries*))) (jabber-send-sexp jc (list 'iq (append (if to (list (cons 'to to))) (list (cons 'type type)) (list (cons 'id id))) query)))) (defun jabber-send-iq-error (jc to id original-query error-type condition &optional text app-specific) "Send an error iq stanza in response to a previously sent iq stanza. Send an error iq stanza to the specified entity in response to a previously sent iq stanza. TO is the addressee. ID is the id of the iq stanza that caused the error. ORIGINAL-QUERY is the original query, which should be included in the error, or nil. ERROR-TYPE is one of \"cancel\", \"continue\", \"modify\", \"auth\" and \"wait\". CONDITION is a symbol denoting a defined XMPP condition. TEXT is a string to be sent in the error message, or nil for no text. APP-SPECIFIC is a list of extra XML tags. JC is the Jabber connection. See section 9.3 of XMPP Core." (jabber-send-sexp jc `(iq (,@(when to `((to . ,to))) (type . "error") (id . ,(or id ""))) ,original-query (error ((type . ,error-type)) (,condition ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))) ,(if text `(text ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")) ,text)) ,@app-specific)))) (defun jabber-process-data (jc xml-data closure-data) "Process random results from various requests. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((from (or (jabber-xml-get-attribute xml-data 'from) (plist-get (fsm-get-state-data jc) :server)))) (with-current-buffer (get-buffer-create (format-spec jabber-browse-buffer-format (list (cons ?n from)))) (if (not (eq major-mode 'jabber-browse-mode)) (jabber-browse-mode)) (setq buffer-read-only nil) (goto-char (point-max)) (insert (jabber-propertize from 'face 'jabber-title-large) "\n\n") ;; Put point at beginning of data (save-excursion ;; If closure-data is a function, call it. If it is a string, ;; output it along with a description of the error. For other ;; values (e.g. nil), just dump the XML. (cond ((functionp closure-data) (funcall closure-data jc xml-data)) ((stringp closure-data) (insert closure-data ": " (jabber-parse-error (jabber-iq-error xml-data)) "\n\n")) (t (insert (format "%S\n\n" xml-data)))) (dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks)) (run-hook-with-args hook 'browse (current-buffer) (funcall jabber-alert-info-message-function 'browse (current-buffer)))))))) (defun jabber-silent-process-data (jc xml-data closure-data) "Process random results from various requests to only alert hooks. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((text (cond ((functionp closure-data) (funcall closure-data jc xml-data)) ((stringp closure-data) (concat closure-data ": " (jabber-parse-error (jabber-iq-error xml-data)))) (t (format "%S" xml-data))))) (dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks)) (run-hook-with-args hook 'browse (current-buffer) text)))) (provide 'jabber-iq) ;;; jabber-iq.el ends here. emacs-jabber/lisp/jabber-keepalive.el000066400000000000000000000141101476345337400200670ustar00rootroot00000000000000;; jabber-keepalive.el - try to detect lost connection -*- lexical-binding: t; -*- ;; 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) (defcustom jabber-keepalive-timeout 20 "Seconds to wait for response from server." :type 'integer) (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.") ;; Global reference declarations (declare-function jabber-send-string "jabber-core.el" (jc string)) (declare-function jabber-disconnect-one "jabber-core.el" (jc &optional dont-redisplay)) (defvar jabber-connections) ; jabber-core.el ;; ;;;###autoload (defun jabber-keepalive-start (&optional _jc) "Activate keepalive. That is, regularly send a ping request to the server, and disconnect it if it doesn't answer. See variable `jabber-keepalive-interval' and variable `jabber-keepalive-timeout'. The JC argument makes it possible to add this function to `jabber-post-connect-hooks'; it is ignored. Keepalive is activated for all accounts regardless of the argument." (interactive) (when jabber-keepalive-timer (jabber-keepalive-stop)) (setq jabber-keepalive-timer (run-with-timer 5 jabber-keepalive-interval #'jabber-keepalive-do)) (add-hook 'jabber-post-disconnect-hook #'jabber-keepalive-stop)) (defun jabber-keepalive-stop () "Deactivate keepalive." (interactive) (when jabber-keepalive-timer (jabber-cancel-timer jabber-keepalive-timer) (setq jabber-keepalive-timer nil))) (defun jabber-keepalive-do () (when jabber-keepalive-debug (message "%s: sending keepalive packet(s)" (current-time-string))) (setq jabber-keepalive-timeout-timer (run-with-timer jabber-keepalive-timeout nil #'jabber-keepalive-timeout)) (setq jabber-keepalive-pending jabber-connections) (dolist (c jabber-connections) ;; Whether we get an error or not is not interesting. ;; Getting a response at all is. (jabber-ping-send c nil 'jabber-keepalive-got-response nil nil))) (defun jabber-keepalive-got-response (jc &rest _args) (when jabber-keepalive-debug (message "%s: got keepalive response from %s" (current-time-string) (plist-get (fsm-get-state-data jc) :server))) (setq jabber-keepalive-pending (remq jc jabber-keepalive-pending)) (when (and (null jabber-keepalive-pending) (timerp jabber-keepalive-timeout-timer)) (jabber-cancel-timer jabber-keepalive-timeout-timer) (setq jabber-keepalive-timeout-timer nil))) (defun jabber-keepalive-timeout () (jabber-cancel-timer jabber-keepalive-timer) (setq jabber-keepalive-timer nil) (dolist (c jabber-keepalive-pending) (message "%s: keepalive timeout, connection to %s considered lost" (current-time-string) (plist-get (fsm-get-state-data c) :server)) (run-hook-with-args 'jabber-lost-connection-hooks c) (jabber-disconnect-one c nil))) ;;;; 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) ;;; jabber-keepalive.el ends hereemacs-jabber/lisp/jabber-keymap.el000066400000000000000000000063411476345337400174170ustar00rootroot00000000000000;;; jabber-keymap.el --- common keymap for many modes -*- lexical-binding: t; -*- ;; 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 ;;; Code: (require 'jabber-menu) (require 'button t nil) ;; Global reference declarations (declare-function jabber-send-presence "jabber-presence.el" (show status priority)) (declare-function jabber-send-xa-presence "jabber-presence.el" (&optional status)) (declare-function jabber-send-default-presence "jabber-presence.el" (&optional _ignore)) (declare-function jabber-send-away-presence "jabber-presence.el" (&optional status)) (declare-function jabber-activity-switch-to "lisp/jabber-activity.el" (&optional jid-param)) (declare-function jabber-chat-with "jabber-chat.el" (jc jid &optional other-window)) (declare-function jabber-switch-to-roster-buffer "jabber-roster.el" (&optional _jc)) (declare-function jabber-disconnect "jabber-core.el" (&optional arg interactivep)) (declare-function jabber-connect-all "jabber-core.el" (&optional arg)) (declare-function jabber-chat-buffer-switch "jabber-chat.el") ;; (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) (define-key map "\C-b" #'jabber-chat-buffer-switch) map) "Global Jabber keymap (usually under C-x C-j).") ;;;###autoload (define-key ctl-x-map "\C-j" jabber-global-keymap) (provide 'jabber-keymap) ;;; jabber-keymap.el ends here emacs-jabber/lisp/jabber-libnotify.el000066400000000000000000000100371476345337400201250ustar00rootroot00000000000000;;; jabber-libnotify.el --- emacs-jabber interface to libnotify -*- lexical-binding: t; -*- ;; Copyright (C) 2010 - Kirill A. Korinskiy - catap@catap.ru ;; Copyright (C) 2007 - Rodrigo Lazo - rlazo.paz@gmail.com ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA (require 'dbus nil t) (eval-when-compile (require 'jabber-alert)) (defcustom jabber-libnotify-icon "" "Icon to be used on the notification pop-up. Default is empty" :type '(file :must-match t) :group 'jabber-alerts) (defcustom jabber-libnotify-timeout 2500 "Specifies the timeout of the pop up window in millisecond" :type 'integer :group 'jabber-alerts) (defcustom jabber-libnotify-message-header "Jabber message" "Defines the header of the pop up." :type 'string :group 'jabber-alerts) (defcustom jabber-libnotify-app "Emacs Jabber" "Defines the app of the pop up." :type 'string :group 'jabber-alerts) (defcustom jabber-libnotify-urgency "low" "Urgency of libnotify message" :type '(choice (const :tag "Low" "low") (const :tag "Normal" "normal") (const :tag "Critical" "critical")) :group 'jabber-alerts) (defcustom jabber-libnotify-method (if (featurep 'dbus) 'dbus 'shell) "Specifies the method for libnotify call. Dbus is faster but require emacs23+, use shell as a fallback." ;; TODO: why the distinction now that jabber.el requires Emacs version 27.1? :type '(choice (const :tag "Shell" shell) (const :tag "D-Bus" dbus)) :group 'jabber-alerts) (defvar jabber-libnotify-id 0) ;; Global reference declarations (declare-function jabber-escape-xml "jabber-xml.el" (string)) ;; (defun jabber-libnotify-next-id () "Return the next notification id." (setq jabber-libnotify-id (+ jabber-libnotify-id 1))) (defun jabber-libnotify-message (text &optional title) "Show MSG using libnotify" (let ((body (or (jabber-escape-xml text) " ")) (head (jabber-escape-xml (or title (or jabber-libnotify-message-header " ") text)))) ;; Possible errors include not finding the notify-send binary. (condition-case nil (cond ((eq jabber-libnotify-method 'shell) (let ((process-connection-type nil)) (start-process "notification" nil "notify-send" "-t" (format "%s" jabber-libnotify-timeout) "-i" (or jabber-libnotify-icon "\"\"") "-u" jabber-libnotify-urgency head body))) ((eq jabber-libnotify-method 'dbus) (dbus-call-method :session ; use the session (not system) bus "org.freedesktop.Notifications" ; service name "/org/freedesktop/Notifications" ; path name "org.freedesktop.Notifications" "Notify" ; Method jabber-libnotify-app (jabber-libnotify-next-id) jabber-libnotify-icon ':string (encode-coding-string head 'utf-8) ':string (encode-coding-string body 'utf-8) '(:array) '(:array :signature "{sv}") ':int32 jabber-libnotify-timeout))) (error nil)))) (define-jabber-alert libnotify "Show a message through the libnotify interface" 'jabber-libnotify-message) (define-personal-jabber-alert jabber-muc-libnotify) (provide 'jabber-libnotify) ;;; jabber-libnotify.el ends hereemacs-jabber/lisp/jabber-logon.el000066400000000000000000000074621476345337400172540ustar00rootroot00000000000000;;; jabber-logon.el --- logon functions -*- lexical-binding: t; -*- ;; 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) (require 'fsm) ;; Global reference declarations (declare-function jabber-send-iq "jabber-iq.el" (jc to type query success-callback success-closure-data error-callback error-closure-data &optional result-id)) ;; ;; 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\". JC is the Jabber connection." (jabber-send-iq jc to "get" `(query ((xmlns . "jabber:iq:auth")) (username () ,(plist-get (fsm-get-state-data jc) :username))) #'jabber-do-logon session-id #'jabber-report-success "Impossible error - auth field request")) (defun jabber-do-logon (jc xml-data session-id) "Send username and password in logon attempt. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((digest-allowed (jabber-xml-get-children (jabber-iq-query xml-data) 'digest)) (passwd (when (or digest-allowed (plist-get (fsm-get-state-data jc) :encrypted) (yes-or-no-p "Jabber server only allows cleartext password transmission! Continue? ")) (or (plist-get (fsm-get-state-data jc) :password) (jabber-read-password (jabber-connection-bare-jid jc))))) auth) (if (null passwd) (fsm-send jc :authentication-failure) (if digest-allowed (setq auth `(digest () ,(sha1 (concat session-id passwd)))) (setq auth `(password () ,passwd))) ;; For legacy authentication we must specify a resource. (unless (plist-get (fsm-get-state-data jc) :resource) ;; Yes, this is ugly. Where is my encapsulation? (plist-put (fsm-get-state-data jc) :resource "emacs-jabber")) (jabber-send-iq jc (plist-get (fsm-get-state-data jc) :server) "set" `(query ((xmlns . "jabber:iq:auth")) (username () ,(plist-get (fsm-get-state-data jc) :username)) ,auth (resource () ,(plist-get (fsm-get-state-data jc) :resource))) #'jabber-process-logon passwd #'jabber-process-logon nil)))) (defun jabber-process-logon (jc xml-data closure-data) "Receive login success or failure, and request roster. CLOSURE-DATA should be the password on success and nil on failure. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (if closure-data ;; Logon success (fsm-send jc (cons :authentication-success closure-data)) ;; Logon failure (jabber-report-success jc xml-data "Logon") (fsm-send jc :authentication-failure))) (provide 'jabber-logon) ;;; jabber-logon.el ends hereemacs-jabber/lisp/jabber-menu.el000066400000000000000000000150111476345337400170670ustar00rootroot00000000000000;;; jabber-menu.el --- menu definitions -*- lexical-binding: t; -*- ;; 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 (eval-when-compile (require 'cl-lib)) (require 'jabber-util) (require 'wid-edit) ;;;###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." "2008") ;;;###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) ;;; jabber-menu.el ends here emacs-jabber/lisp/jabber-modeline.el000066400000000000000000000073511476345337400177270ustar00rootroot00000000000000;;; jabber-modeline.el --- display jabber status in modeline -*- lexical-binding: t; -*- ;; 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 ;;; Code: (require 'jabber-presence) (require 'jabber-alert) (eval-when-compile (require 'cl-lib)) (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." :type 'boolean) (defvar jabber-mode-line-string nil) (defvar jabber-mode-line-presence nil) (defvar jabber-mode-line-contacts nil) ;; Global reference declarations (defvar *jabber-current-show*) ; jabber.el (defvar jabber-presence-strings) ; jabber.el ;; (defun jabber-mode-line-presence-update (&rest _) (setq jabber-mode-line-presence (if (and jabber-connections (not *jabber-disconnecting*)) (cdr (assoc *jabber-current-show* jabber-presence-strings)) "Offline"))) (defun jabber-mode-line-count-contacts (&rest _ignore) (let ((count (list (cons "chat" 0) (cons "" 0) (cons "away" 0) (cons "xa" 0) (cons "dnd" 0) (cons nil 0)))) (dolist (jc jabber-connections) (dolist (buddy (plist-get (fsm-get-state-data jc) :roster)) (when (assoc (get buddy 'show) count) (cl-incf (cdr (assoc (get buddy 'show) count)))))) (setq jabber-mode-line-contacts (if jabber-mode-line-compact (format "(%d/%d/%d)" (+ (cdr (assoc "chat" count)) (cdr (assoc "" count))) (+ (cdr (assoc "away" count)) (cdr (assoc "xa" count)) (cdr (assoc "dnd" count))) (cdr (assoc nil count))) (apply #'format "(%d/%d/%d/%d/%d/%d)" (mapcar #'cdr count)))))) (define-minor-mode jabber-mode-line-mode "Toggle display of Jabber status in mode lines. Display consists of your own status, and six numbers meaning the number of chatty, online, away, xa, dnd and offline contacts, respectively." :global t (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) (add-hook 'jabber-send-presence #'jabber-mode-line-presence-update) (add-hook 'jabber-post-disconnect-hook #'jabber-mode-line-presence-update) (add-hook 'jabber-presence-hooks #'jabber-mode-line-count-contacts)) (remove-hook 'jabber-post-disconnect-hook #'jabber-mode-line-presence-update) (remove-hook 'jabber-send-presence #'jabber-mode-line-presence-update) (remove-hook 'jabber-presence-hooks #'jabber-mode-line-count-contacts))) (provide 'jabber-modeline) ;;; jabber-modeline.el ends hereemacs-jabber/lisp/jabber-muc-nick-coloring.el000066400000000000000000000061751476345337400214560ustar00rootroot00000000000000;;; jabber-muc-nick-coloring.el --- Add nick coloring abilyty to emacs-jabber -*- lexical-binding: t; -*- ;; 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: (require 'color) ;;;;########################################################################## ;;;; 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-hsv-to-hsl (h s v) "Convert color consisting of H, S and V to list of HSL values." ;; https://en.wikipedia.org/wiki/HSL_and_HSV#HSV_to_HSL (let* ((hue h) (luminance (* v (- 1 (/ s 2.0)))) (saturation (if (or (= luminance 0) (= luminance 1)) 0 (/ (- v luminance) (min luminance (- 1 luminance)))))) (list hue saturation luminance))) (defun jabber-muc-nick-gen-color (nick) "Return a good enough color from the available pool." (let* ((pool-index (mod (string-to-number (substring (md5 nick) 0 6) 16) 360)) (hue (/ pool-index 360.0)) (saturation jabber-muc-nick-saturation) (value jabber-muc-nick-value) (hsl (jabber-muc-nick-hsv-to-hsl hue saturation value))) (apply #'color-rgb-to-hex (apply #'color-hsl-to-rgb hsl)))) (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 emacs-jabber/lisp/jabber-muc-nick-completion.el000066400000000000000000000161651476345337400220130ustar00rootroot00000000000000;;; jabber-muc-nick-completion.el --- Add nick completion abilyty to emacs-jabber -*- lexical-binding: t; -*- ;; 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 ;;; Commentary: ;; ;;; History: ;; ;;; Code: (require 'cl-lib) (require 'jabber-chatbuffer) ;;; 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) (defvar *jabber-muc-participant-last-speaking* nil "Global alist in form (group . ((member . time-of-last-speaking) ...) ...).") ;; Global reference declarations (defvar jabber-group) ; jabber-muc.el (defvar *jabber-active-groupchats*) ; jabber-muc.el (defvar jabber-muc-default-nicknames) ; jabber-muc.el (defvar jabber-muc-participants) ; jabber-muc.el (defvar jabber-chatting-with) ; jabber-chat.el ;; (defun jabber-my-nick (&optional group) "Return my jabber nick in GROUP." (let ((room (or group jabber-group))) (cdr (or (assoc room *jabber-active-groupchats*) (assoc room jabber-muc-default-nicknames))))) ;;;###autoload (defun jabber-muc-looks-like-personal-p (message &optional group) "Return non-nil if jabber MESSAGE is addresed to me. Optional argument GROUP to look." (if message (string-match (concat "^" (jabber-my-nick group) (regexp-opt jabber-muc-looks-personaling-symbols)) message) nil)) (defun jabber-muc-nicknames () "List of conference participants, excluding self, or nil if we not in conference." (cl-delete-if (lambda (nick) (string= nick (jabber-my-nick))) (append (mapcar #'car (cdr (assoc jabber-group jabber-muc-participants))) (list jabber-muc-all-string)))) (defun jabber-muc-participant-update-activity (group nick time) "Update NICK's time of last speaking in GROUP to TIME." (let* ((room (assoc group *jabber-muc-participant-last-speaking*)) (room-activity (cdr room)) (entry (assoc nick room-activity)) (old-time (or (cdr entry) 0))) (when (> time old-time) ;; don't use put-alist for speed (progn (if entry (setcdr entry time) (setq room-activity (cons (cons nick time) room-activity))) (if room (setcdr room room-activity) (setq *jabber-muc-participant-last-speaking* (cons (cons group room-activity) *jabber-muc-participant-last-speaking*))))))) (defun jabber-muc-track-message-time (nick group _buffer text &optional _title) "Tracks time of NICK's last speaking in GROUP." (when nick (let ((time (float-time))) (jabber-muc-participant-update-activity group nick (if (jabber-muc-looks-like-personal-p text group) (+ time jabber-muc-personal-message-bonus) time))))) (defun jabber-sort-nicks (nicks group) "Return list of NICKS in GROUP, sorted." ;; when completing word at beginning of line each nick, each element of NICKS ;; has a trailing completion-delimiter (usually ": "). (let ((times (cdr (assoc group *jabber-muc-participant-last-speaking*)))) (cl-flet ((fetch-time (nick) (let ((time-entry (assoc (if (string-suffix-p jabber-muc-completion-delimiter nick) (substring nick 0 (- (length nick) 2)) nick) times))) (cons nick (if time-entry (cdr time-entry) 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 (line-beginning-position)) (backward-char (+ (length jabber-muc-completion-delimiter) 1))) (skip-syntax-backward "^-") (point))) (defun jabber-muc-active-participants (group) "Return nicks for speaking participants." (let ((times (cdr (assoc group *jabber-muc-participant-last-speaking*)))) (cl-remove-if-not (lambda (nick) (assoc nick times)) (jabber-muc-nicknames)))) (defun jabber-muc-nick-completion-at-point () "Nick completion function for `completion-at-point'." ;; largely cribbed from rcirc.el (let* ((line-begin (line-beginning-position)) (group jabber-group) (beg (save-excursion ;; On some networks it is common to message or ;; mention someone using @nick instead of just ;; nick. (if (re-search-backward "[[:space:]@]" line-begin t) (1+ (point)) line-begin))) (table (mapcar (lambda (str) (if (= beg line-begin) (concat str jabber-muc-completion-delimiter) str)) (jabber-muc-active-participants group)))) (list beg (point) (lambda (str pred action) (if (eq action 'metadata) `(metadata (display-sort-function . ,(lambda (nicks) (jabber-sort-nicks nicks group))) (cycle-sort-function . identity)) (complete-with-action action table str pred)))))) (add-hook 'jabber-muc-hooks #'jabber-muc-track-message-time) (provide 'jabber-muc-nick-completion) ;;; jabber-muc-nick-completion.el ends here emacs-jabber/lisp/jabber-muc.el000066400000000000000000001401141476345337400167120ustar00rootroot00000000000000;;; jabber-muc.el --- advanced MUC functions -*- lexical-binding: t; -*- ;; Copyright (C) 2010 - Kirill A. Korinskiy - catap@catap.ru ;; Copyright (C) 2003, 2004, 2007, 2008, 2009, 2010 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; This file is a part of jabber.el. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; Code: (require 'cl-lib) (require 'jabber-widget) (require 'jabber-disco) (require 'jabber-muc-nick-coloring) ;; we need jabber-bookmarks for jabber-muc-autojoin (via ;; jabber-get-bookmarks and jabber-parse-conference-bookmark): (require 'jabber-bookmarks) (require 'ewoc) ;;;###autoload (defvar *jabber-active-groupchats* nil "Alist of groupchats and nicknames. Keys are strings, the bare JID of the room. Values are strings.") (defvar jabber-pending-groupchats (make-hash-table) "Hash table of groupchats and nicknames. Keys are JID symbols; values are strings. This table records the last nickname used to join the particular chat room. Items are thus never removed.") (defvar jabber-muc-participants nil "Alist of groupchats and participants. Keys are strings, the bare JID of the room. Values are lists of nickname strings.") (defvar jabber-group nil "The groupchat you are participating in.") (defvar jabber-muc-topic "" "The topic of the current MUC room.") (defvar jabber-role-history () "Keeps track of previously used roles.") (defvar jabber-affiliation-history () "Keeps track of previously used affiliations.") (defvar jabber-muc-nickname-history () "Keeps track of previously referred-to nicknames.") (defcustom jabber-muc-default-nicknames nil "Default nickname for specific MUC rooms." :group 'jabber-chat :type '(repeat (cons :format "%v" (string :tag "JID of room") (string :tag "Nickname")))) (defcustom jabber-muc-autojoin nil "List of MUC rooms to automatically join on connection. This list is saved in your Emacs customizations. You can also store such a list on the Jabber server, where it is available to every client; see `jabber-edit-bookmarks'." :group 'jabber-chat :type '(repeat (string :tag "JID of room"))) (defcustom jabber-muc-disable-disco-check nil "If non-nil, disable checking disco#info of rooms before joining them. Disco information can tell whether the room exists and whether it is password protected, but some servers do not support it. If you want to join chat rooms on such servers, set this variable to t." :group 'jabber-chat :type 'boolean) (defcustom jabber-groupchat-buffer-format "*-jabber-groupchat-%n-*" "The format specification for the name of groupchat buffers. These fields are available (all are about the group you are chatting in): %n Roster name of group, or JID if no nickname set %b Name of group from bookmarks or roster name or JID if none set %j Bare JID (without resource)" :type 'string :group 'jabber-chat) (defcustom jabber-groupchat-prompt-format "[%t] %n> " "The format specification for lines in groupchat. These fields are available: %t Time, formatted according to `jabber-chat-time-format' %n, %u, %r Nickname in groupchat %j Full JID (room@server/nick)" :type 'string :group 'jabber-chat) (defcustom jabber-muc-header-line-format '(" " (:eval (jabber-jid-displayname jabber-group)) "\t" jabber-muc-topic) "The specification for the header line of MUC buffers. The format is that of `mode-line-format' and `header-line-format'." :type 'sexp :group 'jabber-chat) (defcustom jabber-muc-private-buffer-format "*-jabber-muc-priv-%g-%n-*" "The format specification for the buffer name for private MUC messages. These fields are available: %g Roster name of group, or JID if no nickname set %n Nickname of the group member you're chatting with" :type 'string :group 'jabber-chat) (defcustom jabber-muc-private-foreign-prompt-format "[%t] %g/%n> " "The format specification for lines others type in a private MUC buffer. These fields are available: %t Time, formatted according to `jabber-chat-time-format' %n Nickname in room %g Short room name (either roster name or username part of JID)" :type 'string :group 'jabber-chat) (defcustom jabber-muc-print-names-format " %n %a %j\n" "The format specification for MUC list lines. Fields available: %n Nickname in room %a Affiliation status %j Full JID (room@server/nick)" :type 'string :group 'jabber-chat) (defcustom jabber-muc-private-header-line-format '(" " (:eval (jabber-jid-resource jabber-chatting-with)) " in " (:eval (jabber-jid-displayname (jabber-jid-user jabber-chatting-with))) "\t" jabber-events-message "\t" jabber-chatstates-message) "The specification for the header line of private MUC chat buffers. The format is that of `mode-line-format' and `header-line-format'." :type 'sexp :group 'jabber-chat) ;; Global reference declarations (declare-function jabber-presence-children "jabber-presence.el" (jc)) (declare-function jabber-vcard-get "jabber-vcard.el" (jc jid)) (declare-function jabber-parse-conference-bookmark "jabber-bookmarks.el" (node)) (declare-function jabber-send-sexp "jabber-core.el" (jc sexp)) (declare-function jabber-chat-send "jabber-chat.el" (jc sexp)) (declare-function jabber-send-message "jabber-chat.el" (jc to subject body type)) (declare-function jabber-maybe-print-rare-time "jabber-chat.el" (node)) (declare-function jabber-chat-pp "jabber-chat.el" (data)) (declare-function jabber-chat-mode "jabber-chatbuffer.el" (jc ewoc-pp)) (defvar jabber-silent-mode) ; jabber.el (defvar jabber-message-chain) ; jabber-core.el (defvar jabber-alert-muc-function) ; jabber-alert.el (defvar jabber-body-printers) ; jabber-chat.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-chat-delayed-time-format) ; jabber-chat.el (defvar jabber-chat-delayed-time-format) ; jabber-chat.el (defvar jabber-chat-ewoc) ; jabber-chatbuffer.el (defvar jabber-chat-printers) ; jabber-chat.el (defvar jabber-chat-time-format) ; jabber-chat.el (defvar jabber-send-function) ; jabber-console.el ;; ;;;###autoload (defvar jabber-muc-printers '() "List of functions that may be able to print part of a MUC message. This gets prepended to `jabber-chat-printers', which see.") ;;;###autoload (defun jabber-muc-get-buffer (group) "Return the chat buffer for chatroom GROUP. Either a string or a buffer is returned, so use `get-buffer' or `get-buffer-create'." (format-spec jabber-groupchat-buffer-format (list (cons ?n (jabber-jid-displayname group)) (cons ?b (jabber-jid-bookmarkname group)) (cons ?j (jabber-jid-user group))))) (defun jabber-muc-create-buffer (jc group) "Prepare a buffer for chatroom GROUP. This function is idempotent. JC is the Jabber connection." (with-current-buffer (get-buffer-create (jabber-muc-get-buffer group)) (unless (eq major-mode 'jabber-chat-mode) (jabber-chat-mode jc #'jabber-chat-pp)) ;; Make sure the connection variable is up to date. (setq jabber-buffer-connection jc) (set (make-local-variable 'jabber-group) group) (make-local-variable 'jabber-muc-topic) (setq jabber-send-function #'jabber-muc-send) (setq header-line-format jabber-muc-header-line-format) (current-buffer))) ;;;###autoload (defun jabber-muc-private-get-buffer (group nickname) "Return the chat buffer for private chat with NICKNAME in GROUP. Either a string or a buffer is returned, so use `get-buffer' or `get-buffer-create'." (format-spec jabber-muc-private-buffer-format (list (cons ?g (jabber-jid-displayname group)) (cons ?n nickname)))) (defun jabber-muc-private-create-buffer (jc group nickname) "Prepare a buffer for chatting with NICKNAME in GROUP. This function is idempotent. JC is the Jabber connection." (with-current-buffer (get-buffer-create (jabber-muc-private-get-buffer group nickname)) (unless (eq major-mode 'jabber-chat-mode) (jabber-chat-mode jc #'jabber-chat-pp)) (set (make-local-variable 'jabber-chatting-with) (concat group "/" nickname)) (setq jabber-send-function #'jabber-chat-send) (setq header-line-format jabber-muc-private-header-line-format) (current-buffer))) (defun jabber-muc-send (jc body) "Send BODY to MUC room in current buffer. JC is the Jabber connection." ;; There is no need to display the sent message in the buffer, as ;; we will get it back from the MUC server. (jabber-send-sexp jc `(message ((to . ,jabber-group) (type . "groupchat")) (body () ,body)))) (defun jabber-muc-add-groupchat (group nickname) "Remember participating in GROUP under NICKNAME." (let ((whichgroup (assoc group *jabber-active-groupchats*))) (if whichgroup (setcdr whichgroup nickname) (add-to-list '*jabber-active-groupchats* (cons group nickname))))) (defun jabber-muc-remove-groupchat (group) "Remove GROUP from internal bookkeeping." (let ((whichgroup (assoc group *jabber-active-groupchats*)) (whichparticipants (assoc group jabber-muc-participants))) (setq *jabber-active-groupchats* (delq whichgroup *jabber-active-groupchats*)) (setq jabber-muc-participants (delq whichparticipants jabber-muc-participants)))) (defun jabber-muc-connection-closed (bare-jid) "Remove MUC data for BARE-JID. Forget all information about rooms that had been entered with this JID. Suitable to call when the connection is closed." (dolist (room-entry jabber-muc-participants) (let* ((room (car room-entry)) (buffer (get-buffer (jabber-muc-get-buffer room)))) (when (bufferp buffer) (with-current-buffer buffer (when (string= bare-jid (jabber-connection-bare-jid jabber-buffer-connection)) (setq *jabber-active-groupchats* (cl-delete room *jabber-active-groupchats* :key #'car :test #'string=)) (setq jabber-muc-participants (delq room-entry jabber-muc-participants)))))))) (defun jabber-muc-participant-plist (group nickname) "Return plist associated with NICKNAME in GROUP. Return nil if nothing known about that combination." (let ((whichparticipants (assoc group jabber-muc-participants))) (when whichparticipants (cdr (assoc nickname whichparticipants))))) (defun jabber-muc-modify-participant (group nickname new-plist) "Assign properties in NEW-PLIST to NICKNAME in GROUP." (let ((participants (assoc group jabber-muc-participants))) ;; either we have a list of participants already... (if participants (let ((participant (assoc nickname participants))) ;; and maybe this participant is already in the list (if participant ;; if so, just update role, affiliation, etc. (setf (cdr participant) new-plist) (push (cons nickname new-plist) (cdr participants)))) ;; or we don't (push (cons group (list (cons nickname new-plist))) jabber-muc-participants)))) (defun jabber-muc-report-delta (nickname old-plist new-plist reason actor) "Compare OLD-PLIST and NEW-PLIST, and return a string explaining the change. Return nil if nothing noteworthy has happened. NICKNAME is the user experiencing the change. REASON and ACTOR, if non-nil, are the corresponding presence fields. This function is only concerned with presence stanzas resulting in the user entering/staying in the room." ;; The keys in the plist are affiliation, role and jid. (when (plist-get new-plist 'jid) ;; nickname is only used for displaying, so we can modify it if we ;; want to. (setq nickname (concat nickname " <" (jabber-jid-user (plist-get new-plist 'jid)) ">"))) (cond ((null old-plist) ;; User enters the room (concat nickname " enters the room (" (plist-get new-plist 'role) (unless (string= (plist-get new-plist 'affiliation) "none") (concat ", " (plist-get new-plist 'affiliation))) ")")) ;; If affiliation changes, the role change is usually the logical ;; one, so don't report it separately. ((not (string= (plist-get old-plist 'affiliation) (plist-get new-plist 'affiliation))) (let ((actor-reason (concat (when actor (concat " by " actor)) (when reason (concat ": " reason)))) (from (plist-get old-plist 'affiliation)) (to (plist-get new-plist 'affiliation))) ;; There are many ways to express these transitions in English. ;; This one favors eloquence over regularity and consistency. (cond ;; Higher affiliation ((or (and (member from '("outcast" "none" "member")) (member to '("admin" "owner"))) (and (string= from "admin") (string= to "owner"))) (concat nickname " has been promoted to " to actor-reason)) ;; Lower affiliation ((or (and (member from '("owner" "admin")) (string= to "member")) (and (string= from "owner") (string= to "admin"))) (concat nickname " has been demoted to " to actor-reason)) ;; Become member ((string= to "member") (concat nickname " has been granted membership" actor-reason)) ;; Lose membership ((string= to "none") (concat nickname " has been deprived of membership" actor-reason))))) ;; Role changes ((not (string= (plist-get old-plist 'role) (plist-get new-plist 'role))) (let ((actor-reason (concat (when actor (concat " by " actor)) (when reason (concat ": " reason)))) (from (plist-get old-plist 'role)) (to (plist-get new-plist 'role))) ;; Possible roles are "none" (not in room, hence not of interest ;; in this function), "visitor" (no voice), "participant" (has ;; voice), and "moderator". (cond ((string= to "moderator") (concat nickname " has been granted moderator privileges" actor-reason)) ((and (string= from "moderator") (string= to "participant")) (concat nickname " had moderator privileges revoked" actor-reason)) ((string= to "participant") (concat nickname " has been granted voice" actor-reason)) ((string= to "visitor") (concat nickname " has been denied voice" actor-reason))))))) (defun jabber-muc-remove-participant (group nickname) "Forget everything about NICKNAME in GROUP." (let ((participants (assoc group jabber-muc-participants))) (when participants (let ((participant (assoc nickname (cdr participants)))) (setf (cdr participants) (delq participant (cdr participants))))))) (defmacro jabber-muc-argument-list (&optional args) "Prepend connection and group name to ARGS. If the current buffer is not an MUC buffer, signal an error. This macro is meant for use as an argument to `interactive'." `(if (null jabber-group) (error "Not in MUC buffer") (nconc (list jabber-buffer-connection jabber-group) ,args))) (defun jabber-muc-read-completing (prompt &optional allow-not-joined) "Read the name of a joined chatroom, or use chatroom of current buffer if any. If ALLOW-NOT-JOINED is provided and non-nil, permit choosing any JID; only provide completion as a guide." (or jabber-group (jabber-read-jid-completing prompt (if (null *jabber-active-groupchats*) (error "You haven't joined any group") (mapcar (lambda (x) (jabber-jid-symbol (car x))) *jabber-active-groupchats*)) (not allow-not-joined) jabber-group))) (defun jabber-muc-read-nickname (group prompt) "Read the nickname of a participant in GROUP." (let ((nicknames (cdr (assoc group jabber-muc-participants)))) (unless nicknames (error "Unknown group: %s" group)) (completing-read prompt nicknames nil t nil 'jabber-muc-nickname-history))) (add-to-list 'jabber-jid-muc-menu (cons "Request vcard" 'jabber-muc-vcard-get)) ;;;###autoload (defun jabber-muc-vcard-get (jc group nickname) "Request vcard from chat with NICKNAME in GROUP. JC is the Jabber connection." (interactive (jabber-muc-argument-list (list (jabber-muc-read-nickname jabber-group "Nickname: ")))) (let ((muc-name (format "%s/%s" group nickname))) (jabber-vcard-get jc muc-name))) (defun jabber-muc-instant-config (jc group) "Accept default configuration for GROUP. This can be used for a newly created room, as an alternative to filling out the configuration form with `jabber-muc-get-config'. Both of these methods unlock the room, so that other users can enter it. JC is the Jabber connection." (interactive (jabber-muc-argument-list)) (jabber-send-iq jc group "set" '(query ((xmlns . "http://jabber.org/protocol/muc#owner")) (x ((xmlns . "jabber:x:data") (type . "submit")))) #'jabber-report-success "MUC instant configuration" #'jabber-report-success "MUC instant configuration")) (add-to-list 'jabber-jid-muc-menu (cons "Configure groupchat" 'jabber-muc-get-config)) (defun jabber-muc-get-config (jc group) "Ask for MUC configuration form. JC is the Jabber connection." (interactive (jabber-muc-argument-list)) (jabber-send-iq jc group "get" '(query ((xmlns . "http://jabber.org/protocol/muc#owner"))) #'jabber-process-data #'jabber-muc-render-config #'jabber-process-data "MUC configuration request failed")) (defalias 'jabber-groupchat-get-config #'jabber-muc-get-config "Deprecated. See `jabber-muc-get-config' instead.") (defun jabber-muc-render-config (jc xml-data) "Render MUC configuration form. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((query (jabber-iq-query xml-data)) xdata) (dolist (x (jabber-xml-get-children query 'x)) (if (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data") (setq xdata x))) (if (not xdata) (insert "No configuration possible.\n") (jabber-init-widget-buffer (jabber-xml-get-attribute xml-data 'from)) (setq jabber-buffer-connection jc) (jabber-render-xdata-form xdata) (widget-create 'push-button :notify #'jabber-muc-submit-config "Submit") (widget-insert "\t") (widget-create 'push-button :notify #'jabber-muc-cancel-config "Cancel") (widget-insert "\n") (widget-setup) (widget-minor-mode 1)))) (defalias 'jabber-groupchat-render-config #'jabber-muc-render-config "Deprecated. See `jabber-muc-render-config' instead.") (defun jabber-muc-submit-config (&rest _ignore) "Submit MUC configuration form." (jabber-send-iq jabber-buffer-connection jabber-submit-to "set" `(query ((xmlns . "http://jabber.org/protocol/muc#owner")) ,(jabber-parse-xdata-form)) #'jabber-report-success "MUC configuration" #'jabber-report-success "MUC configuration")) (defalias 'jabber-groupchat-submit-config #'jabber-muc-submit-config "Deprecated. See `jabber-muc-submit-config' instead.") (defun jabber-muc-cancel-config (&rest _ignore) "Cancel MUC configuration form." (jabber-send-iq jabber-buffer-connection jabber-submit-to "set" '(query ((xmlns . "http://jabber.org/protocol/muc#owner")) (x ((xmlns . "jabber:x:data") (type . "cancel")))) nil nil nil nil)) (defalias 'jabber-groupchat-cancel-config #'jabber-muc-cancel-config "Deprecated. See `jabber-muc-cancel-config' instead.") (add-to-list 'jabber-jid-muc-menu (cons "Join groupchat" 'jabber-muc-join)) (defun jabber-muc-join (jc group nickname &optional popup) "Join a groupchat, or change nick. In interactive calls, or if POPUP is non-nil, switch to the groupchat buffer. JC is the Jabber connection." (interactive (let ((account (jabber-read-account)) (group (jabber-read-jid-completing "group: "))) (list account group (jabber-muc-read-my-nickname account group) t))) ;; If the user is already in the room, we don't need as many checks. (if (or (assoc group *jabber-active-groupchats*) ;; Or if the users asked us not to check disco info. jabber-muc-disable-disco-check) (jabber-muc-join-3 jc group nickname nil popup) ;; Else, send a disco request to find out what we are connecting ;; to. (jabber-disco-get-info jc group nil #'jabber-muc-join-2 (list group nickname popup)))) (defalias 'jabber-groupchat-join #'jabber-muc-join "Deprecated. Use `jabber-muc-join' instead.") (defun jabber-muc-join-2 (jc closure result) (pcase-let ((`(,group ,nickname ,popup) closure)) (let* ( ;; Either success... (identities (car result)) (features (cadr result)) ;; ...or error (condition (when (eq identities 'error) (jabber-error-condition result)))) (cond ;; Maybe the room doesn't exist yet. ((eq condition 'item-not-found) (unless (or jabber-silent-mode (y-or-n-p (format "%s doesn't exist. Create it? " (jabber-jid-displayname group)))) (error "Non-existent groupchat"))) ;; Maybe the room doesn't support disco. ((eq condition 'feature-not-implemented) t ;whatever... we will ignore it later ) ;; Maybe another error occurred. Report it to user (condition (message "Couldn't query groupchat: %s" (jabber-parse-error result))) ;; Bad stanza? Without NS, for example ((and (eq identities 'error) (not condition)) (message "Bad error stanza received"))) ;; Continue only if it is really chat room. If there was an ;; error, give the chat room the benefit of the doubt. (Needed ;; for ejabberd's mod_irc, for example) (when (or condition (cl-find "conference" (if (sequencep identities) identities nil) :key (lambda (i) (aref i 1)) :test #'string=)) (let ((password ;; Is the room password-protected? (when (member "muc_passwordprotected" features) (or (jabber-get-conference-data jc group nil :password) (read-passwd (format "Password for %s: " (jabber-jid-displayname group))))))) (jabber-muc-join-3 jc group nickname password popup)))))) (defalias 'jabber-groupchat-join-2 #'jabber-muc-join-2 "Deprecated. See `jabber-muc-join-2' instead.") (defun jabber-muc-join-3 (jc group nickname password popup) ;; Remember that this is a groupchat _before_ sending the stanza. ;; The response might come quicker than you think. (puthash (jabber-jid-symbol group) nickname jabber-pending-groupchats) (jabber-send-sexp jc `(presence ((to . ,(format "%s/%s" group nickname))) (x ((xmlns . "http://jabber.org/protocol/muc")) ,@(when password `((password () ,password)))) ,@(jabber-presence-children jc))) ;; There, stanza sent. Now we just wait for the MUC service to ;; mirror the stanza. This is handled in ;; `jabber-muc-process-presence', where a buffer will be created for ;; the room. ;; But if the user interactively asked to join, he/she probably ;; wants the buffer to pop up right now. (when popup (let ((buffer (jabber-muc-create-buffer jc group))) (switch-to-buffer buffer)))) (defalias 'jabber-groupchat-join-3 #'jabber-muc-join-3 "Deprecated. See `jabber-muc-join-3' instead.") (defun jabber-muc-read-my-nickname (jc group &optional default) "Read nickname for joining GROUP. If DEFAULT is non-nil, return default nick without prompting. JC is the Jabber connection." (let ((default-nickname (or (jabber-get-conference-data jc group nil :nick) (cdr (assoc group jabber-muc-default-nicknames)) (plist-get (fsm-get-state-data jc) :username)))) (if default default-nickname (jabber-read-with-input-method (format "Nickname: (default %s) " default-nickname) nil nil default-nickname)))) (add-to-list 'jabber-jid-muc-menu (cons "Change nickname" 'jabber-muc-nick)) (defalias 'jabber-muc-nick #'jabber-muc-join) (add-to-list 'jabber-jid-muc-menu (cons "Leave groupchat" 'jabber-muc-leave)) (defun jabber-muc-leave (jc group) "Leave a groupchat. JC is the Jabber connection." (interactive (jabber-muc-argument-list)) (let ((whichgroup (assoc group *jabber-active-groupchats*))) ;; send unavailable presence to our own nick in room (jabber-send-sexp jc `(presence ((to . ,(format "%s/%s" group (cdr whichgroup))) (type . "unavailable")))))) (defalias 'jabber-groupchat-leave #'jabber-muc-leave "Deprecated. Use `jabber-muc-leave' instead.") (add-to-list 'jabber-jid-muc-menu (cons "List participants" 'jabber-muc-names)) (defun jabber-muc-names () "Print names, affiliations, and roles of participants in current buffer." (interactive) (ewoc-enter-last jabber-chat-ewoc (list :notice (jabber-muc-print-names (cdr (assoc jabber-group jabber-muc-participants))) :time (current-time)))) (defun jabber-muc-format-names (participant) "Format one participant name." (format-spec jabber-muc-print-names-format (list (cons ?n (car participant)) (cons ?a (plist-get (cdr participant) 'affiliation)) (cons ?j (or (plist-get (cdr participant) 'jid) ""))))) (defun jabber-muc-print-names (participants) "Format and return data in PARTICIPANTS." (let ((mlist) (plist) (vlist) (nlist) dummy) (mapc (lambda (x) (let ((role (plist-get (cdr x) 'role))) (cl-pushnew x (pcase role ("moderator" mlist) ("participant" plist) ("visitor" vlist) ("none" nlist) (_ dummy)) :test #'equal))) participants) (concat (apply #'concat "\nModerators:\n" (mapcar #'jabber-muc-format-names mlist)) (apply #'concat "\nParticipants:\n" (mapcar #'jabber-muc-format-names plist)) (apply #'concat "\nVisitors:\n" (mapcar #'jabber-muc-format-names vlist)) (apply #'concat "\nNones:\n" (mapcar #'jabber-muc-format-names nlist))))) (add-to-list 'jabber-jid-muc-menu (cons "Set topic" 'jabber-muc-set-topic)) (defun jabber-muc-set-topic (jc group topic) "Set topic of GROUP to TOPIC. JC is the Jabber connection." (interactive (jabber-muc-argument-list (list (jabber-read-with-input-method "New topic: " jabber-muc-topic)))) (jabber-send-message jc group topic nil "groupchat")) (defun jabber-muc-snarf-topic (xml-data) "Record subject (topic) of the given , if any. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((new-topic (jabber-xml-path xml-data '(subject "")))) (when new-topic (setq jabber-muc-topic new-topic)))) (add-to-list 'jabber-jid-muc-menu (cons "Set role (kick, voice, op)" 'jabber-muc-set-role)) (defun jabber-muc-set-role (jc group nickname role reason) "Set role of NICKNAME in GROUP to ROLE, specifying REASON. JC is the Jabber connection." (interactive (jabber-muc-argument-list (let ((nickname (jabber-muc-read-nickname jabber-group "Nickname: "))) (list nickname (completing-read "New role: " '(("none") ("visitor") ("participant") ("moderator")) nil t nil 'jabber-role-history) (read-string "Reason: "))))) (unless (or (zerop (length nickname)) (zerop (length role))) (jabber-send-iq jc group "set" `(query ((xmlns . "http://jabber.org/protocol/muc#admin")) (item ((nick . ,nickname) (role . ,role)) ,(unless (zerop (length reason)) `(reason () ,reason)))) 'jabber-report-success "Role change" 'jabber-report-success "Role change"))) (add-to-list 'jabber-jid-muc-menu (cons "Set affiliation (ban, member, admin)" 'jabber-muc-set-affiliation)) (defun jabber-muc-set-affiliation (jc group nickname-or-jid nickname-p affiliation reason) "Set affiliation of NICKNAME-OR-JID in GROUP to AFFILIATION. If NICKNAME-P is non-nil, NICKNAME-OR-JID is a nickname in the group, else it is a JID. JC is the Jabber connection." (interactive (jabber-muc-argument-list (let ((nickname-p (y-or-n-p "Specify user by room nickname? "))) (list (if nickname-p (jabber-muc-read-nickname jabber-group "Nickname: ") (jabber-read-jid-completing "User: ")) nickname-p (completing-read "New affiliation: " '(("none") ("outcast") ("member") ("admin") ("owner")) nil t nil 'jabber-affiliation-history) (read-string "Reason: "))))) (let ((jid (if nickname-p (let ((participants (cdr (assoc group jabber-muc-participants)))) (unless participants (error "Couldn't find group %s" group)) (let ((participant (cdr (assoc nickname-or-jid participants)))) (unless participant (error "Couldn't find %s in group %s" nickname-or-jid group)) (or (plist-get participant 'jid) (error "JID of %s in group %s is unknown" nickname-or-jid group)))) nickname-or-jid))) (jabber-send-iq jc group "set" `(query ((xmlns . "http://jabber.org/protocol/muc#admin")) (item ((jid . ,jid) (affiliation . ,affiliation)) ,(unless (zerop (length reason)) `(reason () ,reason)))) 'jabber-report-success "Affiliation change" 'jabber-report-success "Affiliation change"))) (add-to-list 'jabber-jid-muc-menu (cons "Invite someone to chatroom" 'jabber-muc-invite)) (defun jabber-muc-invite (jc jid group reason) "Invite JID to GROUP, stating REASON. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Invite whom: " ;; The current room is _not_ a good default for whom to invite. (remq (jabber-jid-symbol jabber-group) (jabber-concat-rosters))) (jabber-muc-read-completing "To group: ") (jabber-read-with-input-method "Reason: "))) (jabber-send-sexp jc `(message ((to . ,group)) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (invite ((to . ,jid)) ,(unless (zerop (length reason)) `(reason nil ,reason))))))) (add-to-list 'jabber-body-printers 'jabber-muc-print-invite) (defun jabber-muc-print-invite (xml-data _who mode) "Print MUC invitation. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (cl-dolist (x (jabber-xml-get-children xml-data 'x)) (when (string= (jabber-xml-get-attribute x 'xmlns) "http://jabber.org/protocol/muc#user") (let ((invitation (car (jabber-xml-get-children x 'invite)))) (when invitation (when (eql mode :insert) (let ((group (jabber-xml-get-attribute xml-data 'from)) (inviter (jabber-xml-get-attribute invitation 'from)) (reason (car (jabber-xml-node-children (car (jabber-xml-get-children invitation 'reason)))))) ;; XXX: password (insert "You have been invited to MUC room " (jabber-jid-displayname group)) (when inviter (insert " by " (jabber-jid-displayname inviter))) (insert ".") (when reason (insert " Reason: " reason)) (insert "\n\n") (let ((action (lambda (&rest _ignore) (interactive) (jabber-muc-join jabber-buffer-connection group (jabber-muc-read-my-nickname jabber-buffer-connection group))))) (if (fboundp 'insert-button) (insert-button "Accept" 'action action) ;; Simple button replacement (let ((keymap (make-keymap))) (define-key keymap "\r" action) (insert (jabber-propertize "Accept" 'keymap keymap 'face 'highlight)))) (insert "\t") (let ((action (lambda (&rest _ignore) (interactive) (let ((reason (jabber-read-with-input-method "Reason: "))) (jabber-send-sexp jabber-buffer-connection `(message ((to . ,group)) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (decline ((to . ,inviter)) ,(unless (zerop (length reason)) `(reason nil ,reason)))))))))) (if (fboundp 'insert-button) (insert-button "Decline" 'action action) ;; Simple button replacement (let ((keymap (make-keymap))) (define-key keymap "\r" action) (insert (jabber-propertize "Decline" 'keymap keymap 'face 'highlight)))))))) (cl-return t)))))) (defun jabber-muc-autojoin (jc) "Join rooms specified in account bookmarks and global `jabber-muc-autojoin'. JC is the Jabber connection." (interactive (list (jabber-read-account))) (when (bound-and-true-p jabber-muc-autojoin) (dolist (group jabber-muc-autojoin) (jabber-muc-join jc group (or (cdr (assoc group jabber-muc-default-nicknames)) (plist-get (fsm-get-state-data jc) :username))))) (jabber-get-bookmarks jc (lambda (jc bookmarks) (dolist (bookmark bookmarks) (setq bookmark (jabber-parse-conference-bookmark bookmark)) (when (and bookmark (plist-get bookmark :autojoin)) (jabber-muc-join jc (plist-get bookmark :jid) (or (plist-get bookmark :nick) (plist-get (fsm-get-state-data jc) :username)))))))) ;;;###autoload (defun jabber-muc-message-p (message) "Return non-nil if MESSAGE is a groupchat message. That does not include private messages in a groupchat, but does include groupchat invites." ;; Public groupchat messages have type "groupchat" and are from ;; room@server/nick. Public groupchat errors have type "error" and ;; are from room@server. (let ((from (jabber-xml-get-attribute message 'from)) (type (jabber-xml-get-attribute message 'type))) (or (string= type "groupchat") (and (string= type "error") (gethash (jabber-jid-symbol from) jabber-pending-groupchats)) (jabber-xml-path message '(("http://jabber.org/protocol/muc#user" . "x") invite))))) ;;;###autoload (defun jabber-muc-sender-p (jid) "Return non-nil if JID is a full JID of an MUC participant." (and (assoc (jabber-jid-user jid) *jabber-active-groupchats*) (jabber-jid-resource jid))) ;;;###autoload (defun jabber-muc-private-message-p (message) "Return non-nil if MESSAGE is a private message in a groupchat." (let ((from (jabber-xml-get-attribute message 'from)) (type (jabber-xml-get-attribute message 'type))) (and (not (string= type "groupchat")) (jabber-muc-sender-p from)))) (add-to-list 'jabber-jid-muc-menu (cons "Open private chat" 'jabber-muc-private)) (defun jabber-muc-private (_jc group nickname) "Open private chat with NICKNAME in GROUP. JC is the Jabber connection." (interactive (jabber-muc-argument-list (list (jabber-muc-read-nickname jabber-group "Nickname: ")))) (switch-to-buffer (jabber-muc-private-create-buffer jabber-buffer-connection group nickname))) (defun jabber-muc-presence-p (presence) "Return non-nil if PRESENCE is presence from groupchat." (let ((from (jabber-xml-get-attribute presence 'from)) (type (jabber-xml-get-attribute presence 'type)) (muc-marker (cl-find-if (lambda (x) (equal (jabber-xml-get-attribute x 'xmlns) "http://jabber.org/protocol/muc#user")) (jabber-xml-get-children presence 'x)))) ;; This is MUC presence if it has an MUC-namespaced tag... (or muc-marker ;; ...or if it is error presence from a room we tried to join. (and (string= type "error") (gethash (jabber-jid-symbol from) jabber-pending-groupchats))))) (defun jabber-muc-parse-affiliation (x-muc) "Parse X-MUC in the muc#user namespace and return a plist. Return nil if X-MUC is nil." ;; XXX: parse and tags? or maybe elsewhere? (apply #'nconc (mapcar (lambda (prop) (list (car prop) (cdr prop))) (jabber-xml-node-attributes (car (jabber-xml-get-children x-muc 'item)))))) (defun jabber-muc-print-prompt (xml-data &optional local dont-print-nick-p) "Print MUC prompt for message in XML-DATA." (let ((nick (jabber-jid-resource (jabber-xml-get-attribute xml-data 'from))) (timestamp (jabber-message-timestamp xml-data))) (if (stringp nick) (insert (jabber-propertize (format-spec jabber-groupchat-prompt-format (list (cons ?t (format-time-string (if timestamp jabber-chat-delayed-time-format jabber-chat-time-format) timestamp)) (cons ?n (if dont-print-nick-p "" nick)) (cons ?u nick) (cons ?r nick) (cons ?j (concat jabber-group "/" nick)))) 'face (if local ;Message from you. (if jabber-muc-colorize-local ;; If colorization enable... ;; ...colorize nick (list ':foreground (jabber-muc-nick-get-color nick)) ;; otherwise, use default face. 'jabber-chat-prompt-local) ;; Message from other participant. (if jabber-muc-colorize-foreign ;If colorization enable... ;; ... colorize nick (list ':foreground (jabber-muc-nick-get-color nick)) ;; otherwise, use default face. 'jabber-chat-prompt-foreign)) 'help-echo (concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from " nick " in " jabber-group))) (jabber-muc-system-prompt)))) (defun jabber-muc-private-print-prompt (xml-data) "Print prompt for private MUC message in XML-DATA." (let ((nick (jabber-jid-resource (jabber-xml-get-attribute xml-data 'from))) (group (jabber-jid-user (jabber-xml-get-attribute xml-data 'from))) (timestamp (jabber-message-timestamp xml-data))) (insert (jabber-propertize (format-spec jabber-muc-private-foreign-prompt-format (list (cons ?t (format-time-string (if timestamp jabber-chat-delayed-time-format jabber-chat-time-format) timestamp)) (cons ?n nick) (cons ?g (or (jabber-jid-rostername group) (jabber-jid-username group))))) 'face 'jabber-chat-prompt-foreign 'help-echo (concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from " nick " in " jabber-group))))) (defun jabber-muc-system-prompt (&rest _ignore) "Print system prompt for MUC." (insert (jabber-propertize (format-spec jabber-groupchat-prompt-format (list (cons ?t (format-time-string jabber-chat-time-format)) (cons ?n "") (cons ?u "") (cons ?r "") (cons ?j jabber-group))) 'face 'jabber-chat-prompt-system 'help-echo (format-time-string "System message on %Y-%m-%d %H:%M:%S")))) (add-to-list 'jabber-message-chain #'jabber-muc-process-message) (defun jabber-muc-process-message (jc xml-data) "If XML-DATA is a groupchat message, handle it as such. JC is the Jabber connection." (when (jabber-muc-message-p xml-data) (let* ((from (jabber-xml-get-attribute xml-data 'from)) (group (jabber-jid-user from)) (nick (jabber-jid-resource from)) (error-p (jabber-xml-get-children xml-data 'error)) (type (cond (error-p :muc-error) ((string= nick (cdr (assoc group *jabber-active-groupchats*))) :muc-local) (t :muc-foreign))) (body-text (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'body))))) (printers (append jabber-muc-printers jabber-chat-printers))) (with-current-buffer (jabber-muc-create-buffer jc group) (jabber-muc-snarf-topic xml-data) ;; Call alert hooks only when something is output (when (or error-p (let ((res nil)) (while (and printers (not res)) (setq res (funcall (pop printers) xml-data type :printp))) res)) (jabber-maybe-print-rare-time (ewoc-enter-last jabber-chat-ewoc (list type xml-data :time (current-time)))) ;; ...except if the message is part of history, in which ;; case we don't want an alert. (let ((children-namespaces (mapcar (lambda (x) (when (listp x) (jabber-xml-get-attribute x 'xmlns))) (jabber-xml-node-children xml-data)))) (unless (or (member "urn:xmpp:delay" children-namespaces) (member "jabber:x:delay" children-namespaces)) (dolist (hook '(jabber-muc-hooks jabber-alert-muc-hooks)) (run-hook-with-args hook nick group (current-buffer) body-text (funcall jabber-alert-muc-function nick group (current-buffer) body-text)))))))))) (defface jabber-muc-presence-dim '((t (:foreground "dark grey" :weight light :slant italic))) "face for diminished presence notifications." :group 'jabber-alerts) (defcustom jabber-muc-decorate-presence-patterns nil "List of regular expressions and face pairs. When a presence notification matches a pattern, display it with associated face. Ignore notification if face is ‘nil’." :type '(repeat :tag "Patterns" (cons :format "%v" (regexp :tag "Regexp") (choice (const :tag "Ignore" nil) (face :tag "Face" :value jabber-muc-presence-dim)))) :group 'jabber-alerts) (defun jabber-muc-maybe-decorate-presence (node) "Filter presence notifications." (cl-destructuring-bind (key msg &key time) node (let* ((match (cl-find-if (lambda (pair) (string-match (car pair) msg)) jabber-muc-decorate-presence-patterns)) (face (cdr-safe match))) (if match (when face (jabber-maybe-print-rare-time (ewoc-enter-last jabber-chat-ewoc (list key (propertize msg 'face face) :time time)))) (jabber-maybe-print-rare-time (ewoc-enter-last jabber-chat-ewoc node)))))) (defun jabber-muc-process-presence (jc presence) (let* ((from (jabber-xml-get-attribute presence 'from)) (type (jabber-xml-get-attribute presence 'type)) (x-muc (cl-find-if (lambda (x) (equal (jabber-xml-get-attribute x 'xmlns) "http://jabber.org/protocol/muc#user")) (jabber-xml-get-children presence 'x))) (group (jabber-jid-user from)) (nickname (jabber-jid-resource from)) (symbol (jabber-jid-symbol from)) (our-nickname (gethash symbol jabber-pending-groupchats)) (item (car (jabber-xml-get-children x-muc 'item))) (actor (jabber-xml-get-attribute (car (jabber-xml-get-children item 'actor)) 'jid)) (reason (car (jabber-xml-node-children (car (jabber-xml-get-children item 'reason))))) (error-node (car (jabber-xml-get-children presence 'error))) (status-codes (if error-node (list (jabber-xml-get-attribute error-node 'code)) (mapcar (lambda (status-element) (jabber-xml-get-attribute status-element 'code)) (jabber-xml-get-children x-muc 'status))))) ;; handle leaving a room (cond ((or (string= type "unavailable") (string= type "error")) ;; error from room itself? or are we leaving? (if (or (null nickname) (member "110" status-codes) (string= nickname our-nickname)) ;; Assume that an error means that we were thrown out of the ;; room... (let* ((leavingp t) (message (cond ((string= type "error") (cond ;; ...except for certain cases. ((or (member "406" status-codes) (member "409" status-codes)) (setq leavingp nil) (concat "Nickname change not allowed" (when error-node (concat ": " (jabber-parse-error error-node))))) (t (concat "Error entering room" (when error-node (concat ": " (jabber-parse-error error-node))))))) ((member "301" status-codes) (concat "You have been banned" (when actor (concat " by " actor)) (when reason (concat " - '" reason "'")))) ((member "307" status-codes) (concat "You have been kicked" (when actor (concat " by " actor)) (when reason (concat " - '" reason "'")))) (t "You have left the chatroom")))) (when leavingp (jabber-muc-remove-groupchat group)) ;; If there is no buffer for this groupchat, don't bother ;; creating one just to tell that user left the room. (let ((buffer (get-buffer (jabber-muc-get-buffer group)))) (if buffer (with-current-buffer buffer (jabber-muc-maybe-decorate-presence (list (if (string= type "error") :muc-error :muc-notice) message :time (current-time)))) (message "%s: %s" (jabber-jid-displayname group) message)))) ;; or someone else? (let* ((plist (jabber-muc-participant-plist group nickname)) (jid (plist-get plist 'jid)) (name (concat nickname (when jid (concat " <" (jabber-jid-user jid) ">"))))) (jabber-muc-remove-participant group nickname) (with-current-buffer (jabber-muc-create-buffer jc group) (jabber-muc-maybe-decorate-presence (list :muc-notice (cond ((member "301" status-codes) (concat name " has been banned" (when actor (concat " by " actor)) (when reason (concat " - '" reason "'")))) ((member "307" status-codes) (concat name " has been kicked" (when actor (concat " by " actor)) (when reason (concat " - '" reason "'")))) ((member "303" status-codes) (concat name " changes nickname to " (jabber-xml-get-attribute item 'nick))) (t (concat name " has left the chatroom"))) :time (current-time))))))) (t ;; someone is entering (when (or (member "110" status-codes) (string= nickname our-nickname)) ;; This is us. We just succeeded in entering the room. ;; ;; The MUC server is supposed to send a 110 code whenever this ;; is our presence ("self-presence"), but at least one ;; (ejabberd's mod_irc) doesn't, so check the nickname as well. ;; ;; This check might give incorrect results if the server ;; changed our nickname to avoid collision with an existing ;; participant, but even in this case the window where we have ;; incorrect information should be very small, as we should be ;; getting our own 110+210 presence shortly. (let ((whichgroup (assoc group *jabber-active-groupchats*))) (if whichgroup (setcdr whichgroup nickname) (add-to-list '*jabber-active-groupchats* (cons group nickname)))) ;; The server may have changed our nick. Record the new one. (puthash symbol nickname jabber-pending-groupchats)) ;; Whoever enters, we create a buffer (if it didn't already ;; exist), and print a notice. This is where autojoined MUC ;; rooms have buffers created for them. We also remember some ;; metadata. (let ((old-plist (jabber-muc-participant-plist group nickname)) (new-plist (jabber-muc-parse-affiliation x-muc))) (jabber-muc-modify-participant group nickname new-plist) (let ((report (jabber-muc-report-delta nickname old-plist new-plist reason actor))) (when report (with-current-buffer (jabber-muc-create-buffer jc group) (jabber-muc-maybe-decorate-presence (list :muc-notice report :time (current-time))) ;; Did the server change our nick? (when (member "210" status-codes) (ewoc-enter-last jabber-chat-ewoc (list :muc-notice (concat "Your nick was changed to " nickname " by the server") :time (current-time)))) ;; Was this room just created? If so, it's a locked ;; room. Notify the user. (when (member "201" status-codes) (ewoc-enter-last jabber-chat-ewoc (list :muc-notice (with-temp-buffer (insert "This room was just created, and is locked to other participants.\n" "To unlock it, ") (insert-text-button "configure the room" 'action (apply-partially 'call-interactively 'jabber-muc-get-config)) (insert " or ") (insert-text-button "accept the default configuration" 'action (apply-partially 'call-interactively 'jabber-muc-instant-config)) (insert ".") (buffer-string)) :time (current-time)))))))))))) (provide 'jabber-muc) ;;; jabber-muc.el ends here. emacs-jabber/lisp/jabber-notifications.el000066400000000000000000000073451476345337400210070ustar00rootroot00000000000000;;; jabber-notifications.el --- emacs-jabber interface to notifications.el -*- lexical-binding: t; -*- ;; Copyright (C) 2014 - Adam Sjøgren - asjo@koldfront.dk ;; Copyright (C) 2010 - Kirill A. Korinskiy - catap@catap.ru ;; Copyright (C) 2007 - Rodrigo Lazo - rlazo.paz@gmail.com ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;; Built on jabber-libnotify.el. (eval-when-compile (require 'jabber-alert)) (require 'notifications) (defcustom jabber-notifications-icon "" "Icon to be used on the notification pop-up. Default is empty" :type '(file :must-match t) :group 'jabber-alerts) (defcustom jabber-notifications-timeout nil "Specifies the timeout of the pop up window in millisecond" :type 'integer :group 'jabber-alerts) (defcustom jabber-notifications-message-header "Jabber message" "Defines the header of the pop up." :type 'string :group 'jabber-alerts) (defcustom jabber-notifications-app "Emacs Jabber" "Defines the app of the pop up." :type 'string :group 'jabber-alerts) (defcustom jabber-notifications-urgency "low" "Urgency of message" :type '(choice (const :tag "Low" "low") (const :tag "Normal" "normal") (const :tag "Critical" "critical")) :group 'jabber-alerts) ;; Global reference declarations (declare-function jabber-muc-looks-like-personal-p "jabber-muc-nick-completion.el" (message &optional group)) (declare-function jabber-avatar-find-cached "jabber-avatar.el" (sha1-sum)) (declare-function jabber-jid-symbol "jabber-util.el" (jid)) (declare-function jabber-escape-xml "jabber-xml.el" (string)) ;; (defun jabber-message-notifications (from _buffer text title) "Show a message through the notifications.el interface" (let ((body (or (jabber-escape-xml text) " ")) (avatar-hash (get (jabber-jid-symbol from) 'avatar-hash))) (notifications-notify :title title :body body :app-icon (or (and avatar-hash (jabber-avatar-find-cached avatar-hash)) jabber-notifications-icon) :app-name jabber-notifications-app :category "jabber.message" :timeout jabber-notifications-timeout))) (defun jabber-muc-notifications (nick group buffer text title) "Show MUC message through the notifications.el interface" (jabber-message-notifications group buffer (if nick (format "%s: %s" nick text) text) title) ) (defun jabber-muc-notifications-personal (nick group buffer text title) "Show personal MUC message through the notifications.el interface" (if (jabber-muc-looks-like-personal-p text group) (jabber-muc-notifications nick group buffer text title)) ) ;; jabber-*-notifications* requires "from" argument, so we cant use ;; define-jabber-alert/define-personal-jabber-alert here and do the ;; work by hand: (cl-pushnew 'jabber-message-notifications (get 'jabber-alert-message-hooks 'custom-options)) (cl-pushnew 'jabber-muc-notifications (get 'jabber-alert-muc-hooks 'custom-options)) (cl-pushnew 'jabber-muc-notifications-personal (get 'jabber-alert-muc-hooks 'custom-options)) (provide 'jabber-notifications) ;;; jabber-notifications.el ends hereemacs-jabber/lisp/jabber-ping.el000066400000000000000000000054211476345337400170640ustar00rootroot00000000000000;;; jabber-ping.el --- XMPP "Ping" by XEP-0199 -*- lexical-binding: t; -*- ;; 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) ;; Global reference declarations (defvar jabber-connections) ; jabber-core.el ;; (add-to-list 'jabber-jid-info-menu (cons "Ping" 'jabber-ping)) (defun jabber-ping-send (jc to process-func on-success on-error) "Send XEP-0199 ping IQ stanza. JC is connection to use, TO is full JID, PROCESS-FUNC is fucntion to call to process result, ON-SUCCESS and ON-ERROR is arg for this function depending on result." (jabber-send-iq jc to "get" '(ping ((xmlns . "urn:xmpp:ping"))) process-func on-success process-func on-error)) (defun jabber-ping (to) "Ping XMPP entity. TO is full JID. All connected JIDs is used." (interactive (list (jabber-read-jid-completing "Send ping to: " nil nil nil 'full))) (dolist (jc jabber-connections) (jabber-ping-send jc to 'jabber-silent-process-data 'jabber-process-ping "Ping is unsupported"))) ;; called by jabber-process-data (defun jabber-process-ping (_jc xml-data) "Handle results from ping requests. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((to (jabber-xml-get-attribute xml-data 'from))) (format "%s is alive" to))) (add-to-list 'jabber-iq-get-xmlns-alist (cons "urn:xmpp:ping" 'jabber-pong)) (jabber-disco-advertise-feature "urn:xmpp:ping") (defun jabber-pong (jc xml-data) "Return pong as defined in XEP-0199. Sender and Id are determined from the incoming packet passed in XML-DATA. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((to (jabber-xml-get-attribute xml-data 'from)) (id (jabber-xml-get-attribute xml-data 'id))) (jabber-send-iq jc to "result" nil nil nil nil nil id))) (provide 'jabber-ping) ;;; jabber-ping.el ends here emacs-jabber/lisp/jabber-presence.el000066400000000000000000000572061476345337400177430ustar00rootroot00000000000000;; jabber-presence.el - roster and presence bookkeeping -*- lexical-binding: t; -*- ;; 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 'ewoc) (defvar jabber-presence-element-functions nil "List of functions returning extra elements for stanzas. Each function takes one argument, the connection, and returns a possibly empty list of extra child element of the stanza.") (defvar jabber-presence-history () "Keeps track of previously used presence status types.") (defvar jabber-presence-sent-hooks nil "List of functions called after presence messages are sent.") ;; Global reference declarations (declare-function jabber-display-roster "jabber-roster.el" ()) (declare-function jabber-roster-update "jabber-roster.el" (jc new-items changed-items deleted-items)) (declare-function jabber-chat-create-buffer "jabber-chat.el" (jc chat-with)) (declare-function jabber-muc-get-buffer "jabber-muc.el" (group)) (declare-function jabber-muc-process-presence "jabber-muc.el" (jc presence)) (declare-function jabber-muc-presence-p "jabber-muc.el" (presence)) (defvar jabber-chatting-with) ; jabber-chat.el (defvar *jabber-active-groupchats*) ; jabber-muc.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-chat-ewoc) ; jabber-chatbuffer.el (defvar *jabber-current-priority*) ; jabber.el (defvar jabber-default-priority) ; jabber.el (defvar *jabber-current-show*) ; jabber.el (defvar *jabber-current-status*) ; jabber.el (defvar *jabber-current-priority*) ; jabber.el (defvar *jabber-current-status*) ; jabber.el (defvar *jabber-current-show*) ; jabber.el (defvar *jabber-current-priority*) ; jabber.el (defvar *jabber-current-show*) ; jabber.el (defvar *jabber-current-status*) ; jabber.el (defvar *jabber-current-status*) ; jabber.el (defvar *jabber-current-priority*) ; jabber.el (defvar *jabber-current-status*) ; jabber.el (defvar *jabber-current-priority*) ; jabber.el (defvar jabber-default-show) ; jabber.el (defvar jabber-default-status) ; jabber.el (defvar jabber-default-priority) ; jabber.el (defvar *jabber-current-show*) ; jabber.el (defvar *jabber-current-status*) ; jabber.el (defvar *jabber-current-priority*) ; jabber.el (defvar jabber-silent-mode) ; jabber.el ;; (add-to-list 'jabber-iq-set-xmlns-alist (cons "jabber:iq:roster" (function (lambda (jc x) (jabber-process-roster jc x nil))))) (defun jabber-process-roster (jc xml-data closure-data) "Process an incoming roster infoquery result. CLOSURE-DATA should be `initial' if initial roster push, nil otherwise. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((roster (plist-get (fsm-get-state-data jc) :roster)) (from (jabber-xml-get-attribute xml-data 'from)) (type (jabber-xml-get-attribute xml-data 'type)) (id (jabber-xml-get-attribute xml-data 'id)) (username (plist-get (fsm-get-state-data jc) :username)) (server (plist-get (fsm-get-state-data jc) :server)) (resource (plist-get (fsm-get-state-data jc) :resource)) new-items changed-items deleted-items) ;; Perform sanity check on "from" attribute: it should be either absent ;; match our own JID, or match the server's JID (the latter is what ;; Facebook does). (if (not (or (null from) (string= from server) (string= from (concat username "@" server)) (string= from (concat username "@" server "/" resource)))) (message "Roster push with invalid \"from\": \"%s\" (expected \"%s\", \"%s@%s\" or \"%s@%s/%s\")" from server username server username server resource) (dolist (item (jabber-xml-get-children (car (jabber-xml-get-children xml-data 'query)) 'item)) (let (roster-item (jid (jabber-jid-symbol (jabber-xml-get-attribute item 'jid)))) ;; If subscripton="remove", contact is to be removed from roster (if (string= (jabber-xml-get-attribute item 'subscription) "remove") (progn (if (jabber-jid-rostername jid) (message "%s (%s) removed from roster" (jabber-jid-rostername jid) jid) (message "%s removed from roster" jid)) (push jid deleted-items)) ;; Find contact if already in roster (setq roster-item (car (memq jid roster))) (if roster-item (push roster-item changed-items) ;; If not found, create a new roster item. (unless (eq closure-data 'initial) (if (jabber-xml-get-attribute item 'name) (message "%s (%s) added to roster" (jabber-xml-get-attribute item 'name) jid) (message "%s added to roster" jid))) (setq roster-item jid) (push roster-item new-items)) ;; If this is an initial push, we want to forget ;; everything we knew about this contact before - e.g. if ;; the contact was online when we disconnected and offline ;; when we reconnect, we don't want to see stale presence ;; information. This assumes that no contacts are shared ;; between accounts. (when (eq closure-data 'initial) (setplist roster-item nil)) ;; Now, get all data associated with the contact. (put roster-item 'name (jabber-xml-get-attribute item 'name)) (put roster-item 'subscription (jabber-xml-get-attribute item 'subscription)) (put roster-item 'ask (jabber-xml-get-attribute item 'ask)) ;; Since roster items can't be changed incrementally, we ;; save the original XML to be able to modify it, instead of ;; having to reproduce it. This is for forwards ;; compatibility. (put roster-item 'xml item) (put roster-item 'groups (mapcar (lambda (foo) (nth 2 foo)) (jabber-xml-get-children item 'group))))))) ;; This is the function that does the actual updating and ;; redrawing of the roster. (jabber-roster-update jc new-items changed-items deleted-items) (if (and id (string= type "set")) (jabber-send-iq jc nil "result" nil nil nil nil nil id))) ;; After initial roster push, run jabber-post-connect-hooks. We do ;; it here and not before since we want to have the entire roster ;; before we receive any presence stanzas. (when (eq closure-data 'initial) (run-hook-with-args 'jabber-post-connect-hooks jc))) (defun jabber-initial-roster-failure (jc xml-data _closure-data) "Report the initial roster failure. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." ;; 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. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." ;; XXX: use JC argument (let ((roster (plist-get (fsm-get-state-data jc) :roster)) (from (jabber-xml-get-attribute xml-data 'from)) (type (jabber-xml-get-attribute xml-data 'type)) (presence-show (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'show))))) (presence-status (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'status))))) (error (car (jabber-xml-get-children xml-data 'error))) (priority (string-to-number (or (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'priority)))) "0")))) (cond ((string= type "subscribe") (run-with-idle-timer 0.01 nil #'jabber-process-subscription-request jc from presence-status)) ((jabber-muc-presence-p xml-data) (jabber-muc-process-presence jc xml-data)) (t ;; XXX: Think about what to do about out-of-roster presences. (let ((buddy (jabber-jid-symbol from))) (if (memq buddy roster) (let* ((oldstatus (get buddy 'show)) (resource (or (jabber-jid-resource from) "")) (resource-plist (cdr (assoc resource (get buddy 'resources)))) newstatus) (cond ((and (string= resource "") (member type '("unavailable" "error"))) ;; 'unavailable' or 'error' from bare JID means that all resources ;; are offline. (setq resource-plist nil) (setq newstatus (if (string= type "error") "error" nil)) (let ((new-message (if error (jabber-parse-error error) presence-status))) ;; erase any previous information (put buddy 'resources nil) (put buddy 'connected nil) (put buddy 'show newstatus) (put buddy 'status new-message))) ((string= type "unavailable") (setq resource-plist (plist-put resource-plist 'connected nil)) (setq resource-plist (plist-put resource-plist 'show nil)) (setq resource-plist (plist-put resource-plist 'status presence-status))) ((string= type "error") (setq newstatus "error") (setq resource-plist (plist-put resource-plist 'connected nil)) (setq resource-plist (plist-put resource-plist 'show "error")) (setq resource-plist (plist-put resource-plist 'status (if error (jabber-parse-error error) presence-status)))) ((or (string= type "unsubscribe") (string= type "subscribed") (string= type "unsubscribed")) ;; Do nothing, except letting the user know. The Jabber protocol ;; places all this complexity on the server. (setq newstatus type)) (t (setq resource-plist (plist-put resource-plist 'connected t)) (setq resource-plist (plist-put resource-plist 'show (or presence-show ""))) (setq resource-plist (plist-put resource-plist 'status presence-status)) (setq resource-plist (plist-put resource-plist 'priority priority)) (setq newstatus (or presence-show "")))) (when resource-plist ;; this is for `assoc-set!' in guile (if (assoc resource (get buddy 'resources)) (setcdr (assoc resource (get buddy 'resources)) resource-plist) (put buddy 'resources (cons (cons resource resource-plist) (get buddy 'resources)))) (jabber-prioritize-resources buddy)) (fsm-send jc (cons :roster-update buddy)) (dolist (hook '(jabber-presence-hooks jabber-alert-presence-hooks)) (run-hook-with-args hook buddy oldstatus newstatus (plist-get resource-plist 'status) (funcall jabber-alert-presence-message-function buddy oldstatus newstatus (plist-get resource-plist 'status))))))))))) (defun jabber-process-subscription-request (jc from presence-status) "Process an incoming subscription request. JC is the Jabber connection." (with-current-buffer (jabber-chat-create-buffer jc from) (ewoc-enter-last jabber-chat-ewoc (list :subscription-request presence-status :time (current-time))) (dolist (hook '(jabber-presence-hooks jabber-alert-presence-hooks)) (run-hook-with-args hook (jabber-jid-symbol from) nil "subscribe" presence-status (funcall jabber-alert-presence-message-function (jabber-jid-symbol from) nil "subscribe" presence-status))))) (defun jabber-subscription-accept-mutual (&rest _ignored) (message "Subscription accepted; reciprocal subscription request sent") (jabber-subscription-reply "subscribed" "subscribe")) (defun jabber-subscription-accept-one-way (&rest _ignored) (message "Subscription accepted") (jabber-subscription-reply "subscribed")) (defun jabber-subscription-decline (&rest _ignored) (message "Subscription declined") (jabber-subscription-reply "unsubscribed")) (defun jabber-subscription-reply (&rest types) (let ((to (jabber-jid-user jabber-chatting-with))) (dolist (type types) (jabber-send-sexp jabber-buffer-connection `(presence ((to . ,to) (type . ,type))))))) (defun jabber-prioritize-resources (buddy) "Set connected, show and status properties for BUDDY. Show status properties from highest-priority resource." (let ((resource-alist (get buddy 'resources)) (highest-priority nil)) ;; Reset to nil at first, for cases (a) resource-alist is nil ;; and (b) all resources are disconnected. (put buddy 'connected nil) (put buddy 'show nil) (put buddy 'status nil) (mapc #'(lambda (resource) (let* ((resource-plist (cdr resource)) (priority (plist-get resource-plist 'priority))) (if (plist-get resource-plist 'connected) (when (or (null highest-priority) (and priority (> priority highest-priority))) ;; if no priority specified, interpret as zero (setq highest-priority (or priority 0)) (put buddy 'connected (plist-get resource-plist 'connected)) (put buddy 'show (plist-get resource-plist 'show)) (put buddy 'status (plist-get resource-plist 'status)) (put buddy 'resource (car resource))) ;; if we have not found a connected resource yet, but this ;; disconnected resource has a status message, display it. (when (not (get buddy 'connected)) (if (plist-get resource-plist 'status) (put buddy 'status (plist-get resource-plist 'status))) (if (plist-get resource-plist 'show) (put buddy 'show (plist-get resource-plist 'show))))))) resource-alist))) (defun jabber-count-connected-resources (buddy) "Return the number of connected resources for BUDDY." (let ((resource-alist (get buddy 'resources)) (count 0)) (dolist (resource resource-alist) (if (plist-get (cdr resource) 'connected) (setq count (1+ count)))) count)) ;;;###autoload (defun jabber-send-presence (show status priority) "Set presence for all accounts." (interactive (list (completing-read "show: " '("" "away" "xa" "dnd" "chat") nil t nil 'jabber-presence-history) (jabber-read-with-input-method "status message: " *jabber-current-status* '*jabber-status-history*) (read-string "priority: " (int-to-string (if *jabber-current-priority* *jabber-current-priority* jabber-default-priority))))) (setq *jabber-current-show* show *jabber-current-status* status) (setq *jabber-current-priority* (if (numberp priority) priority (string-to-number priority))) (let (subelements-map) ;; For each connection, we use a different set of subelements. We ;; cache them, to only generate them once. ;; Ordinary presence, with no specified recipient (dolist (jc jabber-connections) (let ((subelements (jabber-presence-children jc))) (push (cons jc subelements) subelements-map) (jabber-send-sexp-if-connected jc `(presence () ,@subelements)))) ;; Then send presence to groupchats (dolist (gc *jabber-active-groupchats*) (let* ((buffer (get-buffer (jabber-muc-get-buffer (car gc)))) (jc (when buffer (buffer-local-value 'jabber-buffer-connection buffer))) (subelements (cdr (assq jc subelements-map)))) (when jc (jabber-send-sexp-if-connected jc `(presence ((to . ,(concat (car gc) "/" (cdr gc)))) ,@subelements)))))) (jabber-display-roster) (run-hooks 'jabber-presence-sent-hooks)) (defun jabber-presence-children (jc) "Return the children for a stanza. JC is the Jabber connection." `(,(when (> (length *jabber-current-status*) 0) `(status () ,*jabber-current-status*)) ,(when (> (length *jabber-current-show*) 0) `(show () ,*jabber-current-show*)) ,(when *jabber-current-priority* `(priority () ,(number-to-string *jabber-current-priority*))) ,@(apply #'append (mapcar (lambda (f) (funcall f jc)) jabber-presence-element-functions)))) (defun jabber-send-directed-presence (jc jid type) "Send a directed presence stanza to JID. TYPE is one of: \"online\", \"away\", \"xa\", \"dnd\", \"chatty\": Appear as present with the given status. \"unavailable\": Appear as offline. \"probe\": Ask the contact's server for updated presence. \"subscribe\": Ask for subscription to contact's presence. (see also `jabber-send-subscription-request') \"unsubscribe\": Cancel your subscription to contact's presence. \"subscribed\": Accept contact's request for presence subscription. (this is usually done within a chat buffer) \"unsubscribed\": Cancel contact's subscription to your presence. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Send directed presence to: ") (completing-read "Type (default is online): " '(("online") ("away") ("xa") ("dnd") ("chatty") ("probe") ("unavailable") ("subscribe") ("unsubscribe") ("subscribed") ("unsubscribed")) nil t nil 'jabber-presence-history "online"))) (cond ((member type '("probe" "unavailable" "subscribe" "unsubscribe" "subscribed" "unsubscribed")) (jabber-send-sexp jc `(presence ((to . ,jid) (type . ,type))))) (t (let ((*jabber-current-show* (if (string= type "online") "" type)) (*jabber-current-status* nil)) (jabber-send-sexp jc `(presence ((to . ,jid)) ,@(jabber-presence-children jc))))))) (defun jabber-send-away-presence (&optional status) "Set status to away. With prefix argument, ask for status message." (interactive (list (when current-prefix-arg (jabber-read-with-input-method "status message: " *jabber-current-status* '*jabber-status-history*)))) (jabber-send-presence "away" (if status status *jabber-current-status*) *jabber-current-priority*)) ;; XXX code duplication! (defun jabber-send-xa-presence (&optional status) "Send extended away presence. With prefix argument, ask for status message." (interactive (list (when current-prefix-arg (jabber-read-with-input-method "status message: " *jabber-current-status* '*jabber-status-history*)))) (jabber-send-presence "xa" (if status status *jabber-current-status*) *jabber-current-priority*)) ;;;###autoload (defun jabber-send-default-presence (&optional _ignore) "Send default presence. Default presence is specified by `jabber-default-show', `jabber-default-status', and `jabber-default-priority'." (interactive) (jabber-send-presence jabber-default-show jabber-default-status jabber-default-priority)) (defun jabber-send-current-presence (&optional _ignore) "(Re-)send current presence. That is, if presence has already been sent, use current settings, otherwise send defaults (see `jabber-send-default-presence')." (interactive) (if *jabber-current-show* (jabber-send-presence *jabber-current-show* *jabber-current-status* *jabber-current-priority*) (jabber-send-default-presence))) (add-to-list 'jabber-jid-roster-menu (cons "Send subscription request" 'jabber-send-subscription-request)) (defun jabber-send-subscription-request (jc to &optional request) "Send a subscription request to jid. Show him your request text, if specified. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "to: ") (jabber-read-with-input-method "request: "))) (jabber-send-sexp jc `(presence ((to . ,to) (type . "subscribe")) ,@(when (and request (> (length request) 0)) (list `(status () ,request)))))) (defvar jabber-roster-group-history nil "History of entered roster groups.") (add-to-list 'jabber-jid-roster-menu (cons "Add/modify roster entry" 'jabber-roster-change)) (defun jabber-roster-change (jc jid name groups) "Add or change a roster item. JC is the Jabber connection." (interactive (let* ((jid (jabber-jid-symbol (jabber-read-jid-completing "Add/change JID: "))) (account (jabber-read-account)) (name (get jid 'name)) (groups (get jid 'groups)) (all-groups (apply #'append (mapcar (lambda (j) (get j 'groups)) (plist-get (fsm-get-state-data account) :roster))))) (when (string< emacs-version "22") ;; Older emacsen want the completion table to be an alist... (setq all-groups (mapcar #'list all-groups))) (list account jid (jabber-read-with-input-method (format "Name: (default `%s') " name) nil nil name) (delete "" (completing-read-multiple (format "Groups, comma-separated: (default %s) " (if groups (mapconcat #'identity groups ",") "none")) all-groups nil nil nil 'jabber-roster-group-history (mapconcat #'identity groups ",") t))))) ;; If new fields are added to the roster XML structure in a future standard, ;; they will be clobbered by this function. ;; XXX: specify account (jabber-send-iq jc nil "set" (list 'query (list (cons 'xmlns "jabber:iq:roster")) (append (list 'item (append (list (cons 'jid (symbol-name jid))) (if (and name (> (length name) 0)) (list (cons 'name name))))) (mapcar #'(lambda (x) `(group () ,x)) groups))) #'jabber-report-success "Roster item change" #'jabber-report-success "Roster item change")) (add-to-list 'jabber-jid-roster-menu (cons "Delete roster entry" 'jabber-roster-delete)) (defun jabber-roster-delete (jc jid) (interactive (list (jabber-read-account) (jabber-read-jid-completing "Delete from roster: "))) (jabber-send-iq jc nil "set" `(query ((xmlns . "jabber:iq:roster")) (item ((jid . ,jid) (subscription . "remove")))) #'jabber-report-success "Roster item removal" #'jabber-report-success "Roster item removal")) (defun jabber-roster-delete-jid-at-point () "Delete JID at point from roster. Signal an error if there is no JID at point." (interactive) (let ((jid-at-point (get-text-property (point) 'jabber-jid)) (account (get-text-property (point) 'jabber-account))) (if (and jid-at-point account (or jabber-silent-mode (yes-or-no-p (format "Really delete %s from roster? " jid-at-point)))) (jabber-roster-delete account jid-at-point) (error "No contact at point")))) (defun jabber-roster-delete-group-from-jids (jc jids group) "Delete group `group' from all JIDs. JC is the Jabber connection." (interactive) (dolist (jid jids) (jabber-roster-change jc jid (get jid 'name) (cl-remove-if-not (lambda (g) (not (string= g group))) (get jid 'groups))))) (defun jabber-roster-edit-group-from-jids (jc jids group) "Edit group `group' from all JIDs. JC is the Jabber connection." (interactive) (let ((new-group (jabber-read-with-input-method (format "New group: (default `%s') " group) nil nil group))) (dolist (jid jids) (jabber-roster-change jc jid (get jid 'name) (cl-remove-duplicates (mapcar (lambda (g) (if (string= g group) new-group g)) (get jid 'groups)) :test #'string=))))) (provide 'jabber-presence) ;;; jabber-presence.el ends hereemacs-jabber/lisp/jabber-private.el000066400000000000000000000044541476345337400176060ustar00rootroot00000000000000;;; jabber-private.el --- jabber:iq:private API by JEP-0049 -*- lexical-binding: t; -*- ;; Copyright (C) 2005 Magnus Henoch ;; Author: Magnus Henoch ;; 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. ;;; Code: (require 'jabber-util) (require 'jabber-xml) (require 'jabber-iq) ;;;###autoload (defun jabber-private-get (jc node-name namespace success-callback error-callback) "Retrieve an item from private XML storage. The item to retrieve is identified by NODE-NAME (a symbol) and NAMESPACE (a string). On success, SUCCESS-CALLBACK is called with JC and the retrieved XML fragment. On error, ERROR-CALLBACK is called with JC and the entire IQ result." (jabber-send-iq jc nil "get" `(query ((xmlns . "jabber:iq:private")) (,node-name ((xmlns . ,namespace)))) #'jabber-private-get-1 success-callback #'(lambda (jc xml-data error-callback) (funcall error-callback jc xml-data)) error-callback)) (defun jabber-private-get-1 (jc xml-data success-callback) (funcall success-callback jc (car (jabber-xml-node-children (jabber-iq-query xml-data))))) ;;;###autoload (defun jabber-private-set (jc fragment &optional success-callback success-closure-data error-callback error-closure-data) "Store FRAGMENT in private XML storage. SUCCESS-CALLBACK, SUCCESS-CLOSURE-DATA, ERROR-CALLBACK and ERROR-CLOSURE-DATA are used as in `jabber-send-iq'. JC is the Jabber connection." (jabber-send-iq jc nil "set" `(query ((xmlns . "jabber:iq:private")) ,fragment) success-callback success-closure-data error-callback error-closure-data)) (provide 'jabber-private) ;;; jabber-private.el ends here emacs-jabber/lisp/jabber-ratpoison.el000066400000000000000000000026261476345337400201510ustar00rootroot00000000000000;;; jabber-ratpoison.el --- emacs-jabber interface to ratpoison -*- lexical-binding: t; -*- ;; Copyright (C) 2005, 2008 - Magnus Henoch - mange@freemail.hu ;; This file is a part of jabber.el. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA (eval-when-compile (require 'jabber-alert)) (defun jabber-ratpoison-message (text &optional title) "Show MSG in Ratpoison" ;; Possible errors include not finding the ratpoison binary. (condition-case nil (let ((process-connection-type)) (call-process "ratpoison" nil 0 nil "-c" (concat "echo " (or title text)))) (error nil))) (define-jabber-alert ratpoison "Show a message through the Ratpoison window manager" 'jabber-ratpoison-message) (provide 'jabber-ratpoison) ;;; jabber-ratpoison.el ends hereemacs-jabber/lisp/jabber-register.el000066400000000000000000000136301476345337400177540ustar00rootroot00000000000000;;; jabber-register.el --- registration according to JEP-0077 -*- lexical-binding: t; -*- ;; 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 ;;; Code: (require 'jabber-iq) (require 'jabber-widget) ;; Global reference declarations (declare-function jabber-disconnect-one "jabber-core.el" (jc &optional dont-redisplay)) (declare-function jabber-submit-search "jabber-search.el" (&rest _ignore)) (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-silent-mode) ; jabber.el ;; (add-to-list 'jabber-jid-service-menu (cons "Register with service" 'jabber-get-register)) (defun jabber-get-register (jc to) "Send IQ get request in namespace \"jabber:iq:register\". JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Register with: "))) (jabber-send-iq jc to "get" '(query ((xmlns . "jabber:iq:register"))) #'jabber-process-data #'jabber-process-register-or-search #'jabber-report-success "Registration")) (defun jabber-process-register-or-search (jc xml-data) "Display results from jabber:iq:{register,search} query as a form. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((query (jabber-iq-query xml-data)) (have-xdata nil) (type (cond ((string= (jabber-iq-xmlns xml-data) "jabber:iq:register") 'register) ((string= (jabber-iq-xmlns xml-data) "jabber:iq:search") 'search) (t (error "Namespace %s not handled by jabber-process-register-or-search" (jabber-iq-xmlns xml-data))))) (register-account (plist-get (fsm-get-state-data jc) :registerp)) (username (plist-get (fsm-get-state-data jc) :username)) (server (plist-get (fsm-get-state-data jc) :server))) (cond ((eq type 'register) ;; If there is no `from' attribute, we are registering with the server (jabber-init-widget-buffer (or (jabber-xml-get-attribute xml-data 'from) server))) ((eq type 'search) ;; no such thing here (jabber-init-widget-buffer (jabber-xml-get-attribute xml-data 'from)))) (setq jabber-buffer-connection jc) (widget-insert (if (eq type 'register) "Register with " "Search ") jabber-submit-to "\n\n") (dolist (x (jabber-xml-get-children query 'x)) (when (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data") (setq have-xdata t) ;; If the registration form obeys XEP-0068, we know ;; for sure how to put a default username in it. (jabber-render-xdata-form x (if (and register-account (string= (jabber-xdata-formtype x) "jabber:iq:register")) (list (cons "username" username)) nil)))) (if (not have-xdata) (jabber-render-register-form query (when register-account username))) (widget-create 'push-button :notify (if (eq type 'register) #'jabber-submit-register #'jabber-submit-search) "Submit") (when (eq type 'register) (widget-insert "\t") (widget-create 'push-button :notify #'jabber-remove-register "Cancel registration")) (widget-insert "\n") (widget-setup) (widget-minor-mode 1))) (defun jabber-submit-register (&rest _ignore) "Submit registration input. See `jabber-process-register-or-search'." (let* ((registerp (plist-get (fsm-get-state-data jabber-buffer-connection) :registerp)) (handler (if registerp #'jabber-process-register-secondtime #'jabber-report-success)) (text (concat "Registration with " jabber-submit-to))) (jabber-send-iq jabber-buffer-connection jabber-submit-to "set" (cond ((eq jabber-form-type 'register) `(query ((xmlns . "jabber:iq:register")) ,@(jabber-parse-register-form))) ((eq jabber-form-type 'xdata) `(query ((xmlns . "jabber:iq:register")) ,(jabber-parse-xdata-form))) (t (error "Unknown form type: %s" jabber-form-type))) handler (if registerp 'success text) handler (if registerp 'failure text))) (message "Registration sent")) (defun jabber-process-register-secondtime (jc xml-data closure-data) "Receive registration success or failure. CLOSURE-DATA is either `success' or `error'. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (cond ((eq closure-data 'success) (message "Registration successful. You may now connect to the server.")) (t (jabber-report-success jc xml-data "Account registration"))) (sit-for 3) (jabber-disconnect-one jc)) (defun jabber-remove-register (&rest _ignore) "Cancel registration. See `jabber-process-register-or-search'." (if (or jabber-silent-mode (yes-or-no-p (concat "Are you sure that you want to cancel your registration to " jabber-submit-to "? "))) (jabber-send-iq jabber-buffer-connection jabber-submit-to "set" '(query ((xmlns . "jabber:iq:register")) (remove)) #'jabber-report-success "Unregistration" #'jabber-report-success "Unregistration"))) (provide 'jabber-register) ;;; jabber-register.el ends hereemacs-jabber/lisp/jabber-roster.el000066400000000000000000000762761476345337400174650ustar00rootroot00000000000000;;; jabber-roster.el --- displaying the roster -*- coding: utf-8; lexical-binding: t; -*- ;; 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 'cl-lib) (require 'jabber-util) (require 'jabber-alert) (require 'jabber-keymap) (require 'jabber-private) (require 'jabber-presence) (require 'jabber-carbons) (require 'format-spec) (require 'ewoc) (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) (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")))) (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) (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)) (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)))) (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))) (defcustom jabber-show-offline-contacts t "Show offline contacts in roster when non-nil." :type 'boolean) (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) (defcustom jabber-roster-show-bindings t "Show keybindings in roster buffer?." :type 'boolean) (defcustom jabber-roster-show-title t "Show title in roster buffer?." :type 'boolean) (defcustom jabber-roster-mode-hook nil "Hook run when entering Roster mode." :type 'hook) (defcustom jabber-roster-default-group-name "other" "Default group name for buddies without groups." :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?" :type 'boolean) (defface jabber-roster-user-online '((t (:foreground "blue" :weight bold :slant normal))) "Face for displaying online users.") (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.") (defface jabber-roster-user-dnd '((t (:foreground "red" :weight normal :slant italic))) "Face for displaying do not disturb users.") (defface jabber-roster-user-away '((t (:foreground "dark green" :weight normal :slant italic))) "Face for displaying away users.") (defface jabber-roster-user-chatty '((t (:foreground "dark orange" :weight bold :slant normal))) "Face for displaying chatty users.") (defface jabber-roster-user-error '((t (:foreground "red" :weight light :slant italic))) "Face for displaying users sending presence errors.") (defface jabber-roster-user-offline '((t (:foreground "dark grey" :weight light :slant italic))) "Face for displaying offline users.") (defvar jabber-roster-debug nil "Debug roster draw.") (defvar jabber-roster-mode-map (let ((map (make-sparse-keymap))) (suppress-keymap map) (set-keymap-parent map jabber-common-keymap) (define-key map [mouse-2] #'jabber-roster-mouse-2-action-at-point) (define-key map (kbd "TAB") #'jabber-go-to-next-roster-item) (define-key map (kbd "S-TAB") #'jabber-go-to-previous-roster-item) (define-key map (kbd "M-TAB") #'jabber-go-to-previous-roster-item) (define-key map (kbd "") #'jabber-go-to-previous-roster-item) (define-key map (kbd "RET") #'jabber-roster-ret-action-at-point) (define-key map (kbd "C-k") #'jabber-roster-delete-at-point) (define-key map "e" #'jabber-roster-edit-action-at-point) (define-key map "s" #'jabber-send-subscription-request) (define-key map "q" #'bury-buffer) (define-key map "i" #'jabber-get-disco-items) (define-key map "j" #'jabber-muc-join) (define-key map "I" #'jabber-get-disco-info) (define-key map "b" #'jabber-get-browse) (define-key map "v" #'jabber-get-version) (define-key map "a" #'jabber-send-presence) (define-key map "g" #'jabber-display-roster) (define-key map "o" #'jabber-roster-toggle-offline-display) (define-key map "H" #'jabber-roster-toggle-binding-display) ;;(define-key map "D" #'jabber-disconnect) map)) ;; Global reference declarations (declare-function jabber-muc-read-my-nickname "jabber-muc.el" (jc group &optional default)) (declare-function jabber-muc-join "jabber-muc.el" (jc group nickname &optional popup)) (declare-function jabber-chat-with "jabber-chat.el" (jc jid &optional other-window)) (declare-function jabber-disco-get-info "jabber-disco.el" (jc jid node callback closure-data &optional force)) (declare-function jabber-get-version "jabber-version.el" (jc to)) (declare-function jabber-get-browse "jabber-browse.el" (jc to)) (defvar *jabber-current-show*) ; jabber.el (defvar jabber-presence-strings) ; jabber.el (defvar *jabber-current-status*) ; jabber.el (defvar jabber-presence-faces) ; jabber.el ;; (defun jabber-roster-ret-action-at-point () "Action for RET. Before try to roll up/down group. Eval `chat-with-jid-at-point' is no group at point." (interactive) (let ((group-at-point (get-text-property (point) 'jabber-group)) (account-at-point (get-text-property (point) 'jabber-account)) (jid-at-point (get-text-property (point) 'jabber-jid))) (if (and group-at-point account-at-point) (jabber-roster-roll-group account-at-point group-at-point) ;; Is this a normal contact, or a groupchat? Let's ask it. (jabber-disco-get-info account-at-point (jabber-jid-user jid-at-point) nil #'jabber-roster-ret-action-at-point-1 jid-at-point)))) (defun jabber-roster-ret-action-at-point-1 (jc jid result) ;; If we get an error, assume it's a normal contact. (if (eq (car result) 'error) (jabber-chat-with jc jid) ;; Otherwise, let's check whether it has a groupchat identity. (let ((identities (car result))) (if (cl-find "conference" (if (sequencep identities) identities nil) :key (lambda (i) (aref i 1)) :test #'string=) ;; Yes! Let's join it. (jabber-muc-join jc jid (jabber-muc-read-my-nickname jc jid t) t) ;; No. Let's open a normal chat buffer. (jabber-chat-with jc jid))))) (defun jabber-roster-mouse-2-action-at-point (e) "Action for mouse 2. Before try to roll up/down group. Eval `chat-with-jid-at-point' is no group at point." (interactive "e") (mouse-set-point e) (let ((group-at-point (get-text-property (point) 'jabber-group)) (account-at-point (get-text-property (point) 'jabber-account))) (if (and group-at-point account-at-point) (jabber-roster-roll-group account-at-point group-at-point) (jabber-popup-combined-menu)))) (defun jabber-roster-delete-at-point () "Delete at point from roster. Try to delete the group from all contaacs. Delete a jid if there is no group at point." (interactive) (let ((group-at-point (get-text-property (point) 'jabber-group)) (account-at-point (get-text-property (point) 'jabber-account))) (if (and group-at-point account-at-point) (let ((jids-with-group (gethash group-at-point (plist-get (fsm-get-state-data account-at-point) :roster-hash)))) (jabber-roster-delete-group-from-jids account-at-point jids-with-group group-at-point)) (jabber-roster-delete-jid-at-point)))) (defun jabber-roster-edit-action-at-point () "Action for e. Before try to edit group name. Eval `jabber-roster-change' is no group at point." (interactive) (let ((group-at-point (get-text-property (point) 'jabber-group)) (account-at-point (get-text-property (point) 'jabber-account))) (if (and group-at-point account-at-point) (let ((jids-with-group (gethash group-at-point (plist-get (fsm-get-state-data account-at-point) :roster-hash)))) (jabber-roster-edit-group-from-jids account-at-point jids-with-group group-at-point)) (call-interactively 'jabber-roster-change)))) (defun jabber-roster-roll-group (jc group-name &optional set) "Roll up/down group in roster. If optional SET is t, roll up group. If SET is nor t or nil, roll down group." (let* ((state-data (fsm-get-state-data jc)) (roll-groups (plist-get state-data :roster-roll-groups)) (new-roll-groups (if (cl-find group-name roll-groups :test #'string=) ;; group is rolled up, roll it down if needed (if (or (not set) (and set (not (eq set t)))) (cl-remove-if-not (lambda (group-name-in-list) (not (string= group-name group-name-in-list))) roll-groups) roll-groups) ;; group is rolled down, roll it up if needed (if (or (not set) (and set (eq set t))) (append roll-groups (list group-name)) roll-groups)))) (unless (equal roll-groups new-roll-groups) (plist-put state-data :roster-roll-groups new-roll-groups) (jabber-display-roster)))) (defun jabber-roster-mode () "Major mode for Jabber roster display. Use the keybindings (mnemonic as Chat, Roster, Info, MUC, Service) to bring up menus of actions. \\{jabber-roster-mode-map}" (kill-all-local-variables) (setq major-mode 'jabber-roster-mode mode-name "jabber-roster") (use-local-map jabber-roster-mode-map) (setq buffer-read-only t) (if (fboundp 'run-mode-hooks) (run-mode-hooks 'jabber-roster-mode-hook) (run-hooks 'jabber-roster-mode-hook))) (put 'jabber-roster-mode 'mode-class 'special) ;;;###autoload (defun jabber-switch-to-roster-buffer (&optional _jc) "Switch to roster buffer. Optional JC argument is ignored; it's there so this function can be used in `jabber-post-connection-hooks'." (interactive) (if (not (get-buffer jabber-roster-buffer)) (jabber-display-roster) (switch-to-buffer jabber-roster-buffer))) (defun jabber-sort-roster (jc) "Sort roster according to online status. JC is the Jabber connection." (let ((state-data (fsm-get-state-data jc))) (dolist (group (plist-get state-data :roster-groups)) (let ((group-name (car group))) (puthash group-name (sort (gethash group-name (plist-get state-data :roster-hash)) #'jabber-roster-sort-items) (plist-get state-data :roster-hash)))))) (defun jabber-roster-prepare-roster (jc) "Make a hash based roster. JC is the Jabber connection." (let* ((state-data (fsm-get-state-data jc)) (hash (make-hash-table :test 'equal)) (buddies (plist-get state-data :roster)) (all-groups '())) (dolist (buddy buddies) (let ((groups (get buddy 'groups))) (if groups (progn (dolist (group groups) (progn (setq all-groups (append all-groups (list group))) (puthash group (append (gethash group hash) (list buddy)) hash)))) (progn (setq all-groups (append all-groups (list jabber-roster-default-group-name))) (puthash jabber-roster-default-group-name (append (gethash jabber-roster-default-group-name hash) (list buddy)) hash))))) ;; remove duplicates name of group (setq all-groups (sort (cl-remove-duplicates all-groups :test #'string=) #'string<)) ;; put to state-data all-groups as list of list (plist-put state-data :roster-groups (mapcar #'list all-groups)) ;; put to state-data hash-roster (plist-put state-data :roster-hash hash))) (defun jabber-roster-sort-items (a b) "Sort roster items A and B according to `jabber-roster-sort-functions'. Return t if A is less than B." (cl-dolist (fn jabber-roster-sort-functions) (let ((comparison (funcall fn a b))) (cond ((< comparison 0) (cl-return t)) ((> comparison 0) (cl-return nil)))))) (defun jabber-roster-sort-by-status (a b) "Sort roster items by online status. See `jabber-sort-order' for order used." (cl-flet ((order (item) (length (member (get item 'show) jabber-sort-order)))) (let ((a-order (order a)) (b-order (order b))) ;; Note reversed test. Items with longer X-order go first. (cond ((< a-order b-order) 1) ((> a-order b-order) -1) (t 0))))) (defun jabber-roster-sort-by-displayname (a b) "Sort roster items by displayed name." (let ((a-name (jabber-jid-displayname a)) (b-name (jabber-jid-displayname b))) (cond ((string-lessp a-name b-name) -1) ((string= a-name b-name) 0) (t 1)))) (defun jabber-roster-sort-by-group (a b) "Sort roster items by group membership." (cl-flet ((first-group (item) (or (car (get item 'groups)) ""))) (let ((a-group (first-group a)) (b-group (first-group b))) (cond ((string-lessp a-group b-group) -1) ((string= a-group b-group) 0) (t 1))))) (defun jabber-fix-status (status) "Make status strings more readable." (when status (when (string-match "\n+$" status) (setq status (replace-match "" t t status))) (when jabber-remove-newlines (while (string-match "\n" status) (setq status (replace-match " " t t status)))) status)) (defvar jabber-roster-ewoc nil "Ewoc displaying the roster. There is only one; we don't rely on buffer-local variables or such.") (defun jabber-roster-filter-display (buddies) "Filter BUDDIES for items to be displayed in the roster." (cl-remove-if-not (lambda (buddy) (or jabber-show-offline-contacts (get buddy 'connected))) buddies)) (defun jabber-roster-toggle-offline-display () "Toggle display of offline contacts. To change this permanently, customize the `jabber-show-offline-contacts'." (interactive) (setq jabber-show-offline-contacts (not jabber-show-offline-contacts)) (jabber-display-roster)) (defun jabber-roster-toggle-binding-display () "Toggle display of the roster binding text." (interactive) (setq jabber-roster-show-bindings (not jabber-roster-show-bindings)) (jabber-display-roster)) (defun jabber-display-roster (&optional interactivep) "Switch to the main jabber buffer and refresh it. Switch to the roster display and refresh it to reflect the current information." (interactive (list 'interactive)) (with-current-buffer (get-buffer-create jabber-roster-buffer) (if (not (eq major-mode 'jabber-roster-mode)) (jabber-roster-mode)) (setq buffer-read-only nil) ;; line-number-at-pos is in Emacs >= 21.4. Only used to avoid ;; excessive scrolling when updating roster, so not absolutely ;; necessary. (let ((current-line (and (fboundp 'line-number-at-pos) (line-number-at-pos))) (current-column (current-column))) (erase-buffer) (setq jabber-roster-ewoc nil) (when jabber-roster-show-title (insert (jabber-propertize "Jabber roster" 'face 'jabber-title-large) "\n")) (when jabber-roster-show-bindings (insert "RET Open chat buffer C-k Delete roster item e Edit item s Send subscription request q Bury buffer i Get disco items I Get disco info b Browse j Join groupchat (MUC) v Get client version a Send presence o Show offline contacts on/off C-c C-c Chat menu C-c C-m Multi-User Chat menu C-c C-i Info menu C-c C-r Roster menu C-c C-s Service menu H Toggle displaying this text ")) (insert "__________________________________\n\n") (if (null jabber-connections) (insert "Not connected\n") (let ((map (make-sparse-keymap))) (define-key map [mouse-2] #'jabber-send-presence) (insert (jabber-propertize (concat (format " - %s" (cdr (assoc *jabber-current-show* jabber-presence-strings))) (if (not (zerop (length *jabber-current-status*))) (format " (%s)" (jabber-fix-status *jabber-current-status*))) " -") 'face (or (cdr (assoc *jabber-current-show* jabber-presence-faces)) 'jabber-roster-user-online) ;;'mouse-face (cons 'background-color "light grey") 'keymap map) "\n"))) (dolist (jc jabber-connections) ;; use a hash-based roster (when (not (plist-get (fsm-get-state-data jc) :roster-hash)) (jabber-roster-prepare-roster jc)) ;; We sort everything before putting it in the ewoc (jabber-sort-roster jc) (let ((before-ewoc (point)) (ewoc (ewoc-create (let ((jc jc)) (lambda (data) (let* ((group (car data)) (group-name (car group)) (buddy (car (cdr data)))) (jabber-display-roster-entry jc group-name buddy)))) (concat (jabber-propertize (concat (plist-get (fsm-get-state-data jc) :username) "@" (plist-get (fsm-get-state-data jc) :server)) 'face 'jabber-title-medium) "\n__________________________________\n") "__________________________________"))) (plist-put(fsm-get-state-data jc) :roster-ewoc ewoc) (dolist (group (plist-get (fsm-get-state-data jc) :roster-groups)) (let* ((group-name (car group)) (buddies (jabber-roster-filter-display (gethash group-name (plist-get (fsm-get-state-data jc) :roster-hash))))) (when (or jabber-roster-show-empty-group (> (length buddies) 0)) (let ((group-node (ewoc-enter-last ewoc (list group nil)))) (if (not (cl-find group-name (plist-get (fsm-get-state-data jc) :roster-roll-groups) :test #'string=)) (dolist (buddy (reverse buddies)) (ewoc-enter-after ewoc group-node (list group buddy)))))))) (goto-char (point-max)) (insert "\n") (put-text-property before-ewoc (point) 'jabber-account jc))) (goto-char (point-min)) (setq buffer-read-only t) (if interactivep (dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks)) (run-hook-with-args hook 'roster (current-buffer) (funcall jabber-alert-info-message-function 'roster (current-buffer))))) (when current-line ;; Go back to previous line - don't use goto-line, since it ;; sets the mark. (goto-char (point-min)) (forward-line (1- current-line)) ;; ...and go back to previous column (move-to-column current-column))))) (defun jabber-display-roster-entry (jc group-name buddy) "Format and insert a roster entry for BUDDY at point. BUDDY is a JID symbol. JC is the Jabber connection." (if buddy (let ((buddy-str (format-spec jabber-roster-line-format (list (cons ?a (jabber-propertize " " 'display (get buddy 'avatar))) (cons ?c (if (get buddy 'connected) "*" " ")) (cons ?u (cdr (assoc (or (get buddy 'subscription) "none") jabber-roster-subscription-display))) (cons ?n (if (> (length (get buddy 'name)) 0) (get buddy 'name) (symbol-name buddy))) (cons ?j (symbol-name buddy)) (cons ?r (or (get buddy 'resource) "")) (cons ?s (or (cdr (assoc (get buddy 'show) jabber-presence-strings)) (get buddy 'show))) (cons ?S (if (get buddy 'status) (jabber-fix-status (get buddy 'status)) "")))))) (add-text-properties 0 (length buddy-str) (list 'face (or (cdr (assoc (get buddy 'show) jabber-presence-faces)) 'jabber-roster-user-online) ;;'mouse-face ;;(cons 'background-color "light grey") 'help-echo (symbol-name buddy) 'jabber-jid (symbol-name buddy) 'jabber-account jc) buddy-str) (insert buddy-str) (when (or (eq jabber-show-resources 'always) (and (eq jabber-show-resources 'sometimes) (> (jabber-count-connected-resources buddy) 1))) (dolist (resource (get buddy 'resources)) (when (plist-get (cdr resource) 'connected) (let ((resource-str (format-spec jabber-resource-line-format (list (cons ?c "*") (cons ?n (if (> (length (get buddy 'name)) 0) (get buddy 'name) (symbol-name buddy))) (cons ?j (symbol-name buddy)) (cons ?r (if (> (length (car resource)) 0) (car resource) "empty")) (cons ?s (or (cdr (assoc (plist-get (cdr resource) 'show) jabber-presence-strings)) (plist-get (cdr resource) 'show))) (cons ?S (if (plist-get (cdr resource) 'status) (jabber-fix-status (plist-get (cdr resource) 'status)) "")) (cons ?p (number-to-string (plist-get (cdr resource) 'priority))))))) (add-text-properties 0 (length resource-str) (list 'face (or (cdr (assoc (plist-get (cdr resource) 'show) jabber-presence-faces)) 'jabber-roster-user-online) 'jabber-jid (format "%s/%s" (symbol-name buddy) (car resource)) 'jabber-account jc) resource-str) (insert "\n" resource-str)))))) (let ((group-name (or group-name jabber-roster-default-group-name))) (add-text-properties 0 (length group-name) (list 'face 'jabber-title-small 'jabber-group group-name 'jabber-account jc) group-name) (insert group-name)))) ;;;###autoload (defun jabber-roster-update (jc new-items changed-items deleted-items) "Update roster, in memory and on display. Add NEW-ITEMS, update CHANGED-ITEMS and remove DELETED-ITEMS, all three being lists of JID symbols. JC is the Jabber connection." (let* ((roster (plist-get (fsm-get-state-data jc) :roster)) (hash (plist-get (fsm-get-state-data jc) :roster-hash)) (all-groups (plist-get (fsm-get-state-data jc) :roster-groups))) ;; fix a old-roster (dolist (delete-this deleted-items) (setq roster (delq delete-this roster))) (setq roster (append new-items roster)) (plist-put (fsm-get-state-data jc) :roster roster) ;; update a hash-roster (if (not hash) (jabber-roster-prepare-roster jc) (when jabber-roster-debug (message "update hash-based roster")) ;; delete items (dolist (delete-this (append deleted-items changed-items)) (let ((jid (symbol-name delete-this))) (when jabber-roster-debug (message (concat "delete jid: " jid))) (dolist (group (mapcar (lambda (g) (car g)) all-groups)) (when jabber-roster-debug (message (concat "try to delete jid: " jid " from group " group))) (puthash group (delq delete-this (gethash group hash)) hash)))) ;; insert changed-items (dolist (insert-this (append changed-items new-items)) (let ((jid (symbol-name insert-this))) (when jabber-roster-debug (message (concat "insert jid: " jid))) (dolist (group (or (get insert-this 'groups) (list jabber-roster-default-group-name))) (when jabber-roster-debug (message (concat "insert jid: " jid " to group " group))) (puthash group (append (gethash group hash) (list insert-this)) hash) (setq all-groups (append all-groups (list (list group))))))) (when jabber-roster-debug (message "remove duplicates from new group")) (setq all-groups (sort (cl-remove-duplicates all-groups :test (lambda (g1 g2) (let ((g1-name (car g1)) (g2-name (car g2))) (string= g1-name g2-name)))) (lambda (g1 g2) (let ((g1-name (car g1)) (g2-name (car g2))) (string< g1-name g2-name))))) (plist-put (fsm-get-state-data jc) :roster-groups all-groups)) (when jabber-roster-debug (message "re display roster")) ;; recreate roster buffer (jabber-display-roster))) (defalias 'jabber-presence-update-roster #'ignore) ;;jabber-presence-update-roster is not needed anymore. ;;Its work is done in `jabber-process-presence'." (make-obsolete 'jabber-presence-update-roster 'ignore "2007") (defun jabber-next-property (&optional prev) "Return position of next property appearence or nil if there is none. If optional PREV is non-nil, return position of previous property appearence." (let ((pos (point)) (found nil) (nextprev (if prev 'previous-single-property-change 'next-single-property-change))) (while (not found) (setq pos (let ((jid (funcall nextprev pos 'jabber-jid)) (group (funcall nextprev pos 'jabber-group))) (cond ((not jid) group) ((not group) jid) (t (funcall (if prev 'max 'min) jid group))))) (if (not pos) (setq found t) (setq found (or (get-text-property pos 'jabber-jid) (get-text-property pos 'jabber-group))))) pos)) (defun jabber-go-to-next-roster-item () "Move the cursor to the next jid/group in the buffer." (interactive) (let* ((next (jabber-next-property)) (next (if (not next) (progn (goto-char (point-min)) (jabber-next-property)) next))) (if next (goto-char next) (goto-char (point-min))))) (defun jabber-go-to-previous-roster-item () "Move the cursor to the previous jid/group in the buffer." (interactive) (let* ((previous (jabber-next-property 'prev)) (previous (if (not previous) (progn (goto-char (point-max)) (jabber-next-property 'prev)) previous))) (if previous (goto-char previous) (goto-char (point-max))))) (defun jabber-roster-restore-groups (jc) "Restore roster's groups rolling state from private storage. JC is the Jabber connection." (interactive (list (jabber-read-account))) (jabber-private-get jc 'roster "emacs-jabber" 'jabber-roster-restore-groups-1 'ignore)) (defun jabber-roster-restore-groups-1 (jc xml-data) "Parse roster groups and restore rolling state. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (when (string= (jabber-xml-get-xmlns xml-data) "emacs-jabber") (let* ((data (car (last xml-data))) (groups (if (stringp data) (split-string data "\n") nil))) (dolist (group groups) (jabber-roster-roll-group jc group t))))) (defun jabber-roster-save-groups () "Save roster's groups rolling state in private storage." (interactive) (dolist (jc jabber-connections) (let* ((groups (plist-get (fsm-get-state-data jc) :roster-roll-groups)) (roll-groups (if groups (mapconcat (lambda (a) (substring-no-properties a)) groups "\n") ""))) (jabber-private-set jc `(roster ((xmlns . "emacs-jabber")) ,roll-groups) 'jabber-report-success "Roster groups saved" 'jabber-report-success "Failed to save roster groups")))) (provide 'jabber-roster) ;;; jabber-roster.el ends hereemacs-jabber/lisp/jabber-rtt.el000066400000000000000000000274411476345337400167460ustar00rootroot00000000000000;;; jabber-rtt.el --- XEP-0301: In-Band Real Time Text -*- lexical-binding: t; -*- ;; Copyright (C) 2013 Magnus Henoch ;; Author: Magnus Henoch ;; 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 . ;;; Commentary: ;; ;;; Code: (eval-when-compile (require 'cl-lib)) (require 'jabber-disco) (require 'jabber-core) (require 'jabber-core) (require 'ewoc) ;; Global reference declarations (declare-function jabber-chat-get-buffer "jabber-chat.el" (chat-with)) (declare-function jabber-muc-message-p "jabber-muc.el"(message)) (defvar jabber-message-chain) ; jabber-core.el (defvar jabber-chat-ewoc) ; jabber-chatbuffer.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-chatting-with) ; jabber-chat.el (defvar jabber-point-insert) ; jabber-console.el ;;;; 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 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))) (pcase (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." :lighter " Real-Time" (if (null jabber-rtt-send-mode) (progn (remove-hook 'after-change-functions #'jabber-rtt--queue-update t) (remove-hook 'jabber-chat-send-hooks #'jabber-rtt--message-sent t) (jabber-rtt--cancel-send)) (unless (derived-mode-p 'jabber-chat-mode) (error "Real Time Text only makes sense in chat buffers")) (when (timerp jabber-rtt-send-timer) (cancel-timer jabber-rtt-send-timer)) (setq jabber-rtt-send-timer nil jabber-rtt-send-seq nil jabber-rtt-outgoing-events nil jabber-rtt-send-last-timestamp nil) (jabber-rtt--send-current-text nil) (add-hook 'after-change-functions #'jabber-rtt--queue-update nil t) (add-hook 'jabber-chat-send-hooks #'jabber-rtt--message-sent nil t))) (defun jabber-rtt--cancel-send () (when (timerp jabber-rtt-send-timer) (cancel-timer jabber-rtt-send-timer)) (setq jabber-rtt-send-seq (1+ jabber-rtt-send-seq)) (jabber-send-sexp jabber-buffer-connection `(message ((to . ,jabber-chatting-with) (type . "chat")) (rtt ((xmlns . "urn:xmpp:rtt:0") (seq . ,(number-to-string jabber-rtt-send-seq)) (event . "cancel")) nil))) (setq jabber-rtt-send-timer nil jabber-rtt-send-seq nil jabber-rtt-outgoing-events nil jabber-rtt-send-last-timestamp nil)) (defun jabber-rtt--send-current-text (resetp) (let ((text (buffer-substring-no-properties jabber-point-insert (point-max)))) ;; This should give us enough room to avoid wrap-arounds, even ;; with just 28 bits... (setq jabber-rtt-send-seq (random 100000)) (jabber-send-sexp jabber-buffer-connection `(message ((to . ,jabber-chatting-with) (type . "chat")) (rtt ((xmlns . "urn:xmpp:rtt:0") (seq . ,(number-to-string jabber-rtt-send-seq)) (event . ,(if resetp "reset" "new"))) (t () ,text)))))) (defun jabber-rtt--queue-update (beg end pre-change-length) (unless (or (< beg jabber-point-insert) (< end jabber-point-insert)) (let ((timestamp (current-time))) (when jabber-rtt-send-last-timestamp (let* ((time-difference (time-subtract timestamp jabber-rtt-send-last-timestamp)) (interval (truncate (* 1000 (float-time time-difference))))) (when (and (> interval 0) ;; Don't send too long intervals - this should have ;; been sent by our timer already. (< interval 1000)) (push `(w ((n . ,(number-to-string interval))) nil) jabber-rtt-outgoing-events)))) (setq jabber-rtt-send-last-timestamp timestamp)) (when (> pre-change-length 0) ;; Some text was deleted. Let's check if we can use a shorter ;; tag: (let ((at-end (= end (point-max))) (erase-one (= pre-change-length 1))) (push `(e ( ,@(unless at-end `((p . ,(number-to-string (+ beg (- jabber-point-insert) pre-change-length))))) ,@(unless erase-one `((n . ,(number-to-string pre-change-length)))))) jabber-rtt-outgoing-events))) (when (/= beg end) ;; Some text was inserted. (let ((text (buffer-substring-no-properties beg end)) (at-end (= end (point-max)))) (push `(t ( ,@(unless at-end `((p . ,(number-to-string (- beg jabber-point-insert)))))) ,text) jabber-rtt-outgoing-events))) (when (null jabber-rtt-send-timer) (setq jabber-rtt-send-timer (run-with-timer 0.7 nil #'jabber-rtt--send-queued-events (current-buffer)))))) (defun jabber-rtt--send-queued-events (buffer) (with-current-buffer buffer (setq jabber-rtt-send-timer nil) (when jabber-rtt-outgoing-events (let ((event (if jabber-rtt-send-seq "edit" "new"))) (setq jabber-rtt-send-seq (if jabber-rtt-send-seq (1+ jabber-rtt-send-seq) (random 100000))) (jabber-send-sexp jabber-buffer-connection `(message ((to . ,jabber-chatting-with) (type . "chat")) (rtt ((xmlns . "urn:xmpp:rtt:0") (seq . ,(number-to-string jabber-rtt-send-seq)) (event . ,event)) ,@(nreverse jabber-rtt-outgoing-events)))) (setq jabber-rtt-outgoing-events nil))))) (defun jabber-rtt--message-sent (_text _id) ;; We're sending a element; reset our state (when (timerp jabber-rtt-send-timer) (cancel-timer jabber-rtt-send-timer)) (setq jabber-rtt-send-timer nil jabber-rtt-send-seq nil jabber-rtt-outgoing-events nil jabber-rtt-send-last-timestamp nil)) (provide 'jabber-rtt) ;;; jabber-rtt.el ends here emacs-jabber/lisp/jabber-sasl.el000066400000000000000000000152471476345337400171000ustar00rootroot00000000000000;;; jabber-sasl.el --- SASL authentication -*- lexical-binding: t; -*- ;; 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 ;;; Code: (require 'cl-lib) (require 'fsm) (require 'jabber-util) ;; 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) ;; Global reference declarations (declare-function jabber-send-sexp "jabber-core.el" (jc sexp)) (defvar jabber-silent-mode) ; jabber.el ;; (defun jabber-sasl-start-auth (jc stream-features) "Start the SASL authentication mechanism. JC is The Jabber Connection. STREAM-FEATURES the XML parsed \"stream features\" answer (it is used with `jabber-xml-get-chidlren')." ;; Find a suitable common mechanism. (let* ((mechanism-elements (car (jabber-xml-get-children stream-features 'mechanisms))) (mechanisms (mapcar (lambda (tag) (car (jabber-xml-node-children tag))) (jabber-xml-get-children mechanism-elements 'mechanism))) (mechanism (if (and (member "ANONYMOUS" mechanisms) (or jabber-silent-mode (yes-or-no-p "Use anonymous authentication? "))) (sasl-find-mechanism '("ANONYMOUS")) (sasl-find-mechanism mechanisms)))) ;; No suitable mechanism? (if (null mechanism) ;; Maybe we can use legacy authentication (let ((iq-auth (cl-find "http://jabber.org/features/iq-auth" (jabber-xml-get-children stream-features 'auth) :key #'jabber-xml-get-xmlns :test #'string=)) ;; Or maybe we have to use STARTTLS, but can't (starttls (cl-find "urn:ietf:params:xml:ns:xmpp-tls" (jabber-xml-get-children stream-features 'starttls) :key #'jabber-xml-get-xmlns :test #'string=))) (cond (iq-auth (fsm-send jc :use-legacy-auth-instead)) (starttls (message "STARTTLS encryption required, but disabled/non-functional at our end") (fsm-send jc :authentication-failure)) (t (message "Authentication failure: no suitable SASL mechanism found") (fsm-send jc :authentication-failure)))) ;; Watch for plaintext logins over unencrypted connections (if (and (not (plist-get (fsm-get-state-data jc) :encrypted)) (member (sasl-mechanism-name mechanism) '("PLAIN" "LOGIN")) (not (yes-or-no-p "Jabber server only allows cleartext password transmission! Continue? "))) (fsm-send jc :authentication-failure) ;; Start authentication. (let* (passphrase (client (sasl-make-client mechanism (plist-get (fsm-get-state-data jc) :username) "xmpp" (plist-get (fsm-get-state-data jc) :server))) (sasl-read-passphrase (jabber-sasl-read-passphrase-closure jc (lambda (p) (setq passphrase (copy-sequence p)) p))) (step (sasl-next-step client nil))) (jabber-send-sexp jc `(auth ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl") (mechanism . ,(sasl-mechanism-name mechanism))) ,(when (sasl-step-data step) (base64-encode-string (sasl-step-data step) t)))) (list client step passphrase)))))) (defun jabber-sasl-read-passphrase-closure (jc remember) "Return a lambda function suitable for `sasl-read-passphrase' for JC. Call REMEMBER with the password. REMEMBER is expected to return it as well." (let ((password (plist-get (fsm-get-state-data jc) :password)) (bare-jid (jabber-connection-bare-jid jc))) (if password (lambda (_prompt) (funcall remember (copy-sequence password))) (lambda (_prompt) (funcall remember (jabber-read-password bare-jid)))))) (defun jabber-sasl-process-input (jc xml-data sasl-data) "SASL protocol input processing. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((client (car sasl-data)) (step (nth 1 sasl-data)) (passphrase (nth 2 sasl-data)) (sasl-read-passphrase (jabber-sasl-read-passphrase-closure jc (lambda (p) (setq passphrase (copy-sequence p)) p)))) (cond ((eq (car xml-data) 'challenge) (sasl-step-set-data step (base64-decode-string (car (jabber-xml-node-children xml-data)))) (setq step (sasl-next-step client step)) (jabber-send-sexp jc `(response ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl")) ,(when (sasl-step-data step) (base64-encode-string (sasl-step-data step) t))))) ((eq (car xml-data) 'failure) (message "%s: authentication failure: %s" (jabber-connection-bare-jid jc) (jabber-xml-node-name (car (jabber-xml-node-children xml-data)))) (fsm-send jc :authentication-failure)) ((eq (car xml-data) 'success) ;; The server might, depending on the mechanism, send ;; "additional data" (see RFC 4422) with the element. ;; Since some SASL mechanisms perform mutual authentication, we ;; need to pass this data to sasl.el - we're not necessarily ;; done just because the server says we're done. (let* ((data (car (jabber-xml-node-children xml-data))) (decoded (if data (base64-decode-string data) ""))) (sasl-step-set-data step decoded) (condition-case e (progn ;; Check that sasl-next-step doesn't signal an error. ;; TODO: once sasl.el allows it, check that all steps have ;; been completed. (sasl-next-step client step) (message "Authentication succeeded for %s" (jabber-connection-bare-jid jc)) (fsm-send jc (cons :authentication-success passphrase))) (sasl-error (message "%s: authentication failure: %s" (jabber-connection-bare-jid jc) (error-message-string e)) (fsm-send jc :authentication-failure)))))) (list client step passphrase))) (provide 'jabber-sasl) ;;; jabber-sasl.el ends hereemacs-jabber/lisp/jabber-sawfish.el000066400000000000000000000033301476345337400175700ustar00rootroot00000000000000;;; jabber-sawfish.el --- emacs-jabber interface to sawfish -*- lexical-binding: t; -*- ;; Copyright (C) 2005 - Mario Domenech Goulart ;; This file is a part of jabber.el. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA (eval-when-compile (require 'jabber-alert)) (defcustom jabber-sawfish-display-time 3 "Time in seconds for displaying a jabber message through the Sawfish window manager." :type 'integer :group 'jabber-alerts) (defun jabber-sawfish-display-message (text &optional title) "Displays MESSAGE through the Sawfish window manager." (let ((process-connection-type nil)) (start-process-shell-command "jabber-sawfish" nil (concat "echo '(progn (require (quote timers)) (display-message \"" (or title text) "\")(make-timer (lambda () (display-message nil)) " (number-to-string jabber-sawfish-display-time) "))' | sawfish-client - &> /dev/null")))) (define-jabber-alert sawfish "Display a message through the Sawfish window manager" 'jabber-sawfish-display-message) (provide 'jabber-sawfish) ;;; jabber-sawfish.el ends hereemacs-jabber/lisp/jabber-screen.el000066400000000000000000000023401476345337400174030ustar00rootroot00000000000000;;; jabber-screen.el --- emacs-jabber interface to screen -*- lexical-binding: t; -*- ;; Copyright (C) 2005 - Magnus Henoch - mange@freemail.hu ;; This file is a part of jabber.el. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA (eval-when-compile (require 'jabber-alert)) (defun jabber-screen-message (text &optional title) "Show MSG in screen" (call-process "screen" nil nil nil "-X" "echo" (or title text))) (define-jabber-alert screen "Show a message through the Screen terminal manager" 'jabber-screen-message) (provide 'jabber-screen) ;;; jabber-screen.el ends here. emacs-jabber/lisp/jabber-search.el000066400000000000000000000106221476345337400173730ustar00rootroot00000000000000;;; jabber-search.el --- searching by JEP-0055, with x:data support -*- lexical-binding: t; -*- ;; 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 ;;; Code: (require 'jabber-register) ;; Global reference declarations (defvar jabber-buffer-connection) ; jabber-chatbuffer.el ;; (add-to-list 'jabber-jid-service-menu (cons "Search directory" 'jabber-get-search)) (defun jabber-get-search (jc to) "Send IQ get request in namespace \"jabber:iq:search\". JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Search what database: "))) (jabber-send-iq jc to "get" '(query ((xmlns . "jabber:iq:search"))) #'jabber-process-data #'jabber-process-register-or-search #'jabber-report-success "Search field retrieval")) ;; `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. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." ;; This function assumes that all search results come in one packet, ;; which is not necessarily the case. (let ((query (jabber-iq-query xml-data)) (have-xdata nil) xdata fields) ;; 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)))) (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) ;;; jabber-search.el ends hereemacs-jabber/lisp/jabber-time.el000066400000000000000000000212251476345337400170650ustar00rootroot00000000000000;;; jabber-time.el --- time reporting by XEP-0012, XEP-0090, XEP-0202 -*- lexical-binding: t; -*- ;; 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. ;;; Code: (require 'jabber-disco) (require 'jabber-iq) (require 'jabber-util) (require 'jabber-autoaway) (require 'time-date) ;; Global reference declarations (defvar jabber-jid-info-menu) ; jabber-menu.el ;; (add-to-list 'jabber-jid-info-menu (cons "Request time" 'jabber-get-time)) (defun jabber-get-time (jc to) "Request time. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Request time of: " nil nil nil 'full t))) (jabber-send-iq jc to "get" '(time ((xmlns . "urn:xmpp:time"))) 'jabber-silent-process-data 'jabber-process-time 'jabber-silent-process-data (lambda (jc xml-data) (let ((from (jabber-xml-get-attribute xml-data 'from))) (jabber-get-legacy-time jc from))))) (defun jabber-get-legacy-time (jc to) "Request legacy time. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Request time of: " nil nil nil 'full t))) (jabber-send-iq jc to "get" '(query ((xmlns . "jabber:iq:time"))) 'jabber-silent-process-data 'jabber-process-legacy-time 'jabber-silent-process-data "Time request failed")) ;; called by jabber-process-data (defun jabber-process-time (_jc xml-data) "Handle results from urn:xmpp:time requests. JC is the Jabber Connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((from (jabber-xml-get-attribute xml-data 'from)) (time (or (car (jabber-xml-get-children xml-data 'time)) ;; adium response of qeury (car (jabber-xml-get-children xml-data 'query)))) (tzo (car (jabber-xml-node-children (car (jabber-xml-get-children time 'tzo))))) (utc (car (jabber-xml-node-children (car (jabber-xml-get-children time 'utc)))))) (when (and utc tzo) (format "%s has time: %s %s" from (format-time-string "%Y-%m-%d %T" (jabber-parse-time utc)) tzo)))) (defun jabber-process-legacy-time (_jc xml-data) "Handle results from jabber:iq:time requests. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((from (jabber-xml-get-attribute xml-data 'from)) (query (jabber-iq-query xml-data)) (display (car (jabber-xml-node-children (car (jabber-xml-get-children query 'display))))) (utc (car (jabber-xml-node-children (car (jabber-xml-get-children query 'utc))))) (tz (car (jabber-xml-node-children (car (jabber-xml-get-children query 'tz)))))) (format "%s has time: %s" from (cond (display display) (utc (concat (format-time-string "%Y-%m-%d %T" (jabber-parse-legacy-time utc)) (when tz (concat " " tz)))))))) ;; 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. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Get last online for: " nil nil nil 'bare-or-muc))) (jabber-send-iq jc to "get" '(query ((xmlns . "jabber:iq:last"))) #'jabber-silent-process-data #'jabber-process-last #'jabber-silent-process-data "Last online request failed")) (defun jabber-get-idle-time (jc to) "Request idle time of user. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Get idle time for: " nil nil nil 'full t))) (jabber-send-iq jc to "get" '(query ((xmlns . "jabber:iq:last"))) #'jabber-silent-process-data #'jabber-process-last #'jabber-silent-process-data "Idle time request failed")) (defun jabber-process-last (_jc xml-data) "Handle results from jabber:iq:last requests. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((from (jabber-xml-get-attribute xml-data 'from)) (query (jabber-iq-query xml-data)) (seconds (jabber-xml-get-attribute query 'seconds))) (cond ((jabber-jid-resource from) ;; Full JID: idle time (format "%s idle for %s seconds" from seconds)) ((jabber-jid-username from) ;; Bare JID with username: time since online (concat (format "%s last online %s seconds ago" from seconds) (let ((seconds (condition-case nil (string-to-number seconds) (error nil)))) (when (numberp seconds) (concat " - that is, at " (format-time-string "%Y-%m-%d %T" (time-subtract (current-time) (seconds-to-time seconds))) "\n"))))) (t ;; Only hostname: uptime (format "%s uptime: %s seconds" from seconds))))) (add-to-list 'jabber-iq-get-xmlns-alist (cons "jabber:iq:time" 'jabber-return-legacy-time)) (jabber-disco-advertise-feature "jabber:iq:time") (defun jabber-return-legacy-time (jc xml-data) "Return client time as defined in XEP-0090. Sender and ID are determined from the incoming packet passed in XML-DATA. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((to (jabber-xml-get-attribute xml-data 'from)) (id (jabber-xml-get-attribute xml-data 'id))) (jabber-send-iq jc to "result" `(query ((xmlns . "jabber:iq:time")) ;; what is ``human-readable'' format? ;; the same way as formating using by tkabber (display () ,(format-time-string "%a %b %d %H:%M:%S %Z %Y")) (tz () ,(format-time-string "%Z")) (utc () ,(jabber-encode-legacy-time nil))) nil nil nil nil id))) (add-to-list 'jabber-iq-get-xmlns-alist (cons "urn:xmpp:time" 'jabber-return-time)) (jabber-disco-advertise-feature "urn:xmpp:time") (defun jabber-return-time (jc xml-data) "Return client time as defined in XEP-0202. Sender and ID are determined from the incoming packet passed in XML-DATA. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((to (jabber-xml-get-attribute xml-data 'from)) (id (jabber-xml-get-attribute xml-data 'id))) (jabber-send-iq jc to "result" `(time ((xmlns . "urn:xmpp:time")) (utc () ,(jabber-encode-time nil)) (tzo () ,(jabber-encode-timezone))) nil nil nil nil id))) (add-to-list 'jabber-iq-get-xmlns-alist (cons "jabber:iq:last" 'jabber-return-last)) (jabber-disco-advertise-feature "jabber:iq:last") (defun jabber-return-last (jc xml-data) (let ((to (jabber-xml-get-attribute xml-data 'from)) (id (jabber-xml-get-attribute xml-data 'id))) (jabber-send-iq jc to "result" `(time ((xmlns . "jabber:iq:last") ;; XEP-0012 specifies that this is an integer. (seconds . ,(number-to-string (floor (jabber-autoaway-get-idle-time)))))) nil nil nil nil id))) (provide 'jabber-time) ;;; jabber-time.el ends hereemacs-jabber/lisp/jabber-tmux.el000066400000000000000000000024521476345337400171250ustar00rootroot00000000000000;;; jabber-tmux.el --- emacs-jabber interface to tmux -*- lexical-binding: t; -*- ;; Copyright (C) 2012 - Michael Cardell Widerkrantz ;; This file is a part of jabber.el. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA (eval-when-compile (require 'jabber-alert)) (defun jabber-tmux-message (text &optional title) "Show MSG in tmux" (call-process "tmux" nil nil nil "display-message" (or title text))) ; Automatically defines jabber-{message,muc,presence,info}-tmux ; functions. (define-jabber-alert tmux "Show a message through the tmux terminal multiplexer" 'jabber-tmux-message) (provide 'jabber-tmux) ;;; jabber-tmux.el ends hereemacs-jabber/lisp/jabber-truncate.el000066400000000000000000000054071476345337400177600ustar00rootroot00000000000000;;; jabber-truncate.el --- cleanup top lines in chatbuffers -*- lexical-binding: t; -*- ;; 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 ;;; Code: (require 'cl-lib) (require 'jabber-alert) (require 'ewoc) (defvar jabber-log-lines-to-keep 1000 "Maximum number of lines in chat buffer.") ;; Global reference declarations (defvar jabber-chat-ewoc) ; jabber-chatbuffer.el ;; (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 interfere 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 (with-current-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) ;;; jabber-truncate.el ends hereemacs-jabber/lisp/jabber-util.el000066400000000000000000000732641476345337400171160ustar00rootroot00000000000000;;; jabber-util.el --- various utility functions -*- coding: utf-8; lexical-binding: t; -*- ;; 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 ;;; Code: (require 'cl-lib) (require 'jabber-xml) (require 'fsm) (require 'password-cache) (condition-case nil (require 'auth-source) (error nil)) (defvar jabber-jid-history nil "History of entered JIDs.") ;; Global reference declarations (declare-function jabber-chat-with "jabber-chat.el" (jc jid &optional other-window)) (declare-function jabber-ahc-execute-command "jabber-ahc.el" (jc to node)) (declare-function jabber-get-register "jabber-register.el" (jc to)) (declare-function jabber-muc-read-my-nickname "jabber-muc.el" (jc group &optional default)) (declare-function jabber-muc-join "jabber-muc.el" (jc group nickname &optional popup)) ;; (defalias 'jabber-propertize 'propertize) (defsubst jabber-read-with-input-method (prompt &optional initial-contents history default-value) "Like `read-string', but always inheriting the current input method." ;; Preserve input method when entering a minibuffer. (read-string prompt initial-contents history default-value t)) (unless (fboundp 'delete-and-extract-region) (defsubst delete-and-extract-region (start end) (prog1 (buffer-substring start end) (delete-region start end)))) (unless (fboundp 'access-file) (defsubst access-file (filename error-message) (unless (file-readable-p filename) (error error-message)))) (defalias 'jabber-float-time 'float-time) (defalias 'jabber-cancel-timer 'cancel-timer) (defvar jabber-connections) (defun jabber-concat-rosters () "Concatenate the rosters of all connected accounts." (apply #'append (mapcar (lambda (jc) (plist-get (fsm-get-state-data jc) :roster)) jabber-connections))) (defun jabber-concat-rosters-full () "Concatenate the rosters of all connected accounts. Show full JIDs, with resources." (let ((jids (apply #'append (mapcar (lambda (jc) (plist-get (fsm-get-state-data jc) :roster)) jabber-connections)))) (apply #'append (mapcar (lambda (jid) (mapcar (lambda (res) (intern (format "%s/%s" jid (car res)))) (get (jabber-jid-symbol jid) 'resources))) jids)))) (defun jabber-connection-jid (jc) "Return the full JID of connection JC." (let ((sd (fsm-get-state-data jc))) (concat (plist-get sd :username) "@" (plist-get sd :server) "/" (plist-get sd :resource)))) (defun jabber-connection-bare-jid (jc) "Return the bare JID of connection JC." (let ((sd (fsm-get-state-data jc))) (concat (plist-get sd :username) "@" (plist-get sd :server)))) (defun jabber-connection-original-jid (jc) "Return the original JID of connection JC. The \"original JID\" is the JID we authenticated with. The server might subsequently assign us a different JID at resource binding." (plist-get (fsm-get-state-data jc) :original-jid)) (defun jabber-find-connection (bare-jid) "Find the connection to the account named by BARE-JID. Return nil if none found." (cl-dolist (jc jabber-connections) (when (string= bare-jid (jabber-connection-bare-jid jc)) (cl-return jc)))) (defun jabber-find-active-connection (dead-jc) "Find an active connection for dead connection DEAD-JC. Return nil if none found." (let ((jid (jabber-connection-bare-jid dead-jc))) (jabber-find-connection jid))) (defun jabber-jid-username (jid) "Return the username portion of JID, or nil if none found. JID must be a string." (when (string-match "\\(.*\\)@.*\\(/.*\\)?" jid) (match-string 1 jid))) (defun jabber-jid-user (jid) "Return the user portion (username@server) of JID. JID must be a string." ;;transports don't have @, so don't require it ;;(string-match ".*@[^/]*" jid) (string-match "[^/]*" jid) (match-string 0 jid)) (defun jabber-jid-server (jid) "Return the server portion of JID." (string-match "^\\(.*@\\)?\\([^@/]+\\)\\(/.*\\)?$" jid) (match-string 2 jid)) (defun jabber-jid-rostername (user) "Return the name of USER if present in roster, or nil." (let ((user (jabber-jid-symbol user))) (if (> (length (get user 'name)) 0) (get user 'name)))) (defun jabber-jid-displayname (string) "Return the name of the user from STRING as in roster, else username@server." (or (jabber-jid-rostername string) (jabber-jid-user (if (symbolp string) (symbol-name string) string)))) (defvar jabber-bookmarks) (defun jabber-jid-bookmarkname (string) "Return from STRING the conference name from boomarks or displayname. Use the name according to roster or else the JID if none set." (require 'jabber-bookmarks) (or (cl-loop for conference in (car (cl-loop for value being the hash-values of jabber-bookmarks collect value)) do (let ((ls (cadr conference))) (if (string= (cdr (assoc 'jid ls)) string) (cl-return (cdr (assoc 'name ls)))))) (jabber-jid-displayname string))) (defun jabber-jid-resource (jid) "Return the resource portion of a JID, or nil if there is none. JID must be a string." (when (string-match "^\\(\\([^/]*@\\)?[^/]*\\)/\\(.*\\)" jid) (match-string 3 jid))) (defvar jabber-jid-obarray) (defun jabber-jid-symbol (jid) "Return the symbol for JID, which must be a symbol or a string." ;; If it's already a symbol, just return it. (if (symbolp jid) jid ;; XXX: "downcase" is a poor man's nodeprep. See XMPP CORE. (intern (downcase (jabber-jid-user jid)) jabber-jid-obarray))) (defvar jabber-account-list) (defun jabber-my-jid-p (jc jid) "Return non-nil if the specified JID is in the `jabber-account-list'. Comment: (modulo resource). Also return non-nil if JID matches JC, modulo resource." (or (equal (jabber-jid-user jid) (jabber-connection-bare-jid jc)) (member (jabber-jid-user jid) (mapcar (lambda (x) (jabber-jid-user (car x))) jabber-account-list)))) (defvar *jabber-active-groupchats*) (defun jabber-read-jid-completing (prompt &optional subset require-match default resource fulljids) "Read a jid out of the current roster from the minibuffer. If SUBSET is non-nil, it should be a list of symbols from which the JID is to be selected, instead of using the entire roster. If REQUIRE-MATCH is non-nil, the JID must be in the list used. If DEFAULT is non-nil, it's used as the default value, otherwise the default is inferred from context. RESOURCE is one of the following: nil Accept full or bare JID, as entered full Turn bare JIDs to full ones with highest-priority resource bare-or-muc Turn full JIDs to bare ones, except for in MUC If FULLJIDS is non-nil, complete jids with resources." (let ((jid-at-point (or (and default ;; default can be either a symbol or a string (if (symbolp default) (symbol-name default) default)) (let* ((jid (get-text-property (point) 'jabber-jid)) (res (get (jabber-jid-symbol jid) 'resource))) (when jid (if (and fulljids res (not (jabber-jid-resource jid))) (format "%s/%s" jid res) jid))) (bound-and-true-p jabber-chatting-with) (bound-and-true-p jabber-group))) (completion-ignore-case t) (jid-completion-table (mapcar #'(lambda (item) (cons (symbol-name item) item)) (or subset (funcall (if fulljids 'jabber-concat-rosters-full 'jabber-concat-rosters))))) chosen) (dolist (item (or subset (jabber-concat-rosters))) (if (get item 'name) (push (cons (get item 'name) item) jid-completion-table))) ;; if the default is not in the allowed subset, it's not a good default (if (and subset (not (assoc jid-at-point jid-completion-table))) (setq jid-at-point nil)) (let ((input (completing-read (concat prompt (if jid-at-point (format "(default %s) " jid-at-point))) jid-completion-table nil require-match nil 'jabber-jid-history jid-at-point))) (setq chosen (if (and input (assoc-string input jid-completion-table t)) (symbol-name (cdr (assoc-string input jid-completion-table t))) (and (not (zerop (length input))) input)))) (when chosen (pcase 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)))) (_ chosen))))) (defun jabber-read-node (prompt) "Read node name, taking default from disco item at point." (let ((node-at-point (get-text-property (point) 'jabber-node))) (read-string (concat prompt (if node-at-point (format "(default %s) " node-at-point))) node-at-point))) (defun jabber-password-key (bare-jid) "Construct key for `password' library from BARE-JID." (concat "xmpp:" bare-jid)) (defun jabber-read-password (bare-jid) "Read Jabber password from minibuffer." (let ((found (and (fboundp 'auth-source-search) (nth 0 (auth-source-search :user (jabber-jid-username bare-jid) :host (jabber-jid-server bare-jid) :port "xmpp" :max 1 :require '(:secret)))))) (if found (let ((secret (plist-get found :secret))) (copy-sequence (if (functionp secret) (funcall secret) secret))) (let ((prompt (format "Jabber password for %s: " bare-jid))) ;; Need to copy the password, as sasl.el wants to erase it. (copy-sequence (password-read prompt (jabber-password-key bare-jid))))))) (defun jabber-cache-password (bare-jid password) "Cache PASSWORD for BARE-JID." (password-cache-add (jabber-password-key bare-jid) password)) (defun jabber-uncache-password (bare-jid) "Uncache cached password for BARE-JID. Useful if the password proved to be wrong." (interactive (list (jabber-jid-user (completing-read "Forget password of account: " jabber-account-list nil nil nil 'jabber-account-history)))) (password-cache-remove (jabber-password-key bare-jid))) (defvar jabber-buffer-connection) (defun jabber-read-account (&optional always-ask contact-hint) "Ask for which connected account to use. If ALWAYS-ASK is nil and there is only one account, return that account. If CONTACT-HINT is a string or a JID symbol, default to an account that has that contact in its roster." (let ((completions (mapcar (lambda (c) (cons (jabber-connection-bare-jid c) c)) jabber-connections))) (cond ((null jabber-connections) (error "Not connected to Jabber")) ((and (null (cdr jabber-connections)) (not always-ask)) ;; only one account (car jabber-connections)) (t (or ;; if there is a jabber-account property at point, ;; present it as default value (cdr (assoc (let ((at-point (get-text-property (point) 'jabber-account))) (when (and at-point (memq at-point jabber-connections)) (jabber-connection-bare-jid at-point))) completions)) (let* ((default (or (and contact-hint (setq contact-hint (jabber-jid-symbol contact-hint)) (let ((matching (cl-find-if (lambda (jc) (memq contact-hint (plist-get (fsm-get-state-data jc) :roster))) jabber-connections))) (when matching (jabber-connection-bare-jid matching)))) ;; if the buffer is associated with a connection, use it (when (and jabber-buffer-connection (jabber-find-active-connection jabber-buffer-connection)) (jabber-connection-bare-jid jabber-buffer-connection)) ;; else, use the first connection in the list (caar completions))) (input (completing-read (concat "Select Jabber account (default " default "): ") completions nil t nil 'jabber-account-history default))) (cdr (assoc input completions)))))))) (defun jabber-iq-query (xml-data) "Return the query part of an IQ stanza. An IQ stanza may have zero or one query child, and zero or one child. The query child is often but not always . XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let (query) (dolist (x (jabber-xml-node-children xml-data)) (if (and (listp x) (not (eq (jabber-xml-node-name x) 'error))) (setq query x))) query)) (defun jabber-iq-error (xml-data) "Return the part of an IQ stanza, if any. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (car (jabber-xml-get-children xml-data 'error))) (defun jabber-iq-xmlns (xml-data) "Return the namespace of an IQ stanza, i.e. the namespace of its query part. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (jabber-xml-get-attribute (jabber-iq-query xml-data) 'xmlns)) (defun jabber-message-timestamp (xml-data) "Given a element, return its timestamp, or nil if none. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (jabber-x-delay (or (jabber-xml-path xml-data '(("urn:xmpp:delay" . "delay"))) (jabber-xml-path xml-data '(("jabber:x:delay" . "x")))))) (defun jabber-x-delay (xml-data) "Return timestamp given a delayed delivery element. This can be either a tag in namespace urn:xmpp:delay (XEP-0203), or a tag in namespace jabber:x:delay (XEP-0091). Return nil if no such data available. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (cond ((and (eq (jabber-xml-node-name xml-data) 'x) (string= (jabber-xml-get-attribute xml-data 'xmlns) "jabber:x:delay")) (let ((stamp (jabber-xml-get-attribute xml-data 'stamp))) (if (and (stringp stamp) (= (length stamp) 17)) (jabber-parse-legacy-time stamp)))) ((and (eq (jabber-xml-node-name xml-data) 'delay) (string= (jabber-xml-get-attribute xml-data 'xmlns) "urn:xmpp:delay")) (let ((stamp (jabber-xml-get-attribute xml-data 'stamp))) (when (stringp stamp) (jabber-parse-time stamp)))))) (defun jabber-parse-legacy-time (timestamp) "Parse timestamp in ccyymmddThh:mm:ss format (UTC) and return as internal time value." (let ((year (string-to-number (substring timestamp 0 4))) (month (string-to-number (substring timestamp 4 6))) (day (string-to-number (substring timestamp 6 8))) (hour (string-to-number (substring timestamp 9 11))) (minute (string-to-number (substring timestamp 12 14))) (second (string-to-number (substring timestamp 15 17)))) (encode-time second minute hour day month year 0))) (defun jabber-encode-legacy-time (timestamp) "Parse TIMESTAMP as internal time value and encode as ccyymmddThh:mm:ss (UTC)." (if (featurep 'xemacs) ;; XEmacs doesn't have `universal' argument to format-time-string, ;; so we have to do it ourselves. (format-time-string "%Y%m%dT%H:%M:%S" (time-subtract timestamp (list 0 (car (current-time-zone))))) (format-time-string "%Y%m%dT%H:%M:%S" timestamp t))) (defun jabber-encode-time (time) "Convert TIME to a string by XEP-0082. TIME is in a format accepted by `format-time-string'." (format-time-string "%Y-%m-%dT%H:%M:%SZ" time t)) (defun jabber-encode-timezone () (let ((time-zone-offset (nth 0 (current-time-zone)))) (if (null time-zone-offset) "Z" (let* ((positivep (>= time-zone-offset 0)) (hours (/ (abs time-zone-offset) 3600)) (minutes (/ (% (abs time-zone-offset) 3600) 60))) (format "%s%02d:%02d"(if positivep "+" "-") hours minutes))))) (defun jabber-parse-time (raw-time) "Parse the DateTime encoded in TIME according to XEP-0082." (let* ((time (if (string= (substring raw-time 4 5) "-") raw-time (concat (substring raw-time 0 4) "-" (substring raw-time 4 6) "-" (substring raw-time 6 (length raw-time))))) (year (string-to-number (substring time 0 4))) (month (string-to-number (substring time 5 7))) (day (string-to-number (substring time 8 10))) (hour (string-to-number (substring time 11 13))) (minute (string-to-number (substring time 14 16))) (second (string-to-number (substring time 17 19))) (timezone (if (eq (aref time 19) ?.) ;; fractions are optional (let ((timezone (cadr (split-string (substring time 20) "[-+Z]")))) (if (string= "" timezone) "Z" timezone)) (substring time 19)))) ;; timezone is either Z (UTC) or [+-]HH:MM (let ((timezone-seconds (if (string= timezone "Z") 0 (* (if (eq (aref timezone 0) ?+) 1 -1) (* 60 (+ (* 60 (string-to-number (substring timezone 1 3))) (string-to-number (substring timezone 4 6)))))))) (encode-time second minute hour day month year timezone-seconds)))) (defun jabber-report-success (_jc xml-data context) "IQ callback reporting success or failure of the operation. CONTEXT is a string describing the action. \"CONTEXT succeeded\" or \"CONTEXT failed: REASON\" is displayed in the echo area. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((type (jabber-xml-get-attribute xml-data 'type))) (message (concat context (if (string= type "result") " succeeded" (concat " failed: " (let ((the-error (jabber-iq-error xml-data))) (if the-error (jabber-parse-error the-error) "No error message given")))))))) (defconst jabber-error-messages (list (cons 'bad-request "Bad request") (cons 'conflict "Conflict") (cons 'feature-not-implemented "Feature not implemented") (cons 'forbidden "Forbidden") (cons 'gone "Gone") (cons 'internal-server-error "Internal server error") (cons 'item-not-found "Item not found") (cons 'jid-malformed "JID malformed") (cons 'not-acceptable "Not acceptable") (cons 'not-allowed "Not allowed") (cons 'not-authorized "Not authorized") (cons 'payment-required "Payment required") (cons 'recipient-unavailable "Recipient unavailable") (cons 'redirect "Redirect") (cons 'registration-required "Registration required") (cons 'remote-server-not-found "Remote server not found") (cons 'remote-server-timeout "Remote server timeout") (cons 'resource-constraint "Resource constraint") (cons 'service-unavailable "Service unavailable") (cons 'subscription-required "Subscription required") (cons 'undefined-condition "Undefined condition") (cons 'unexpected-request "Unexpected request")) "String descriptions of XMPP stanza errors.") (defconst jabber-legacy-error-messages (list (cons 302 "Redirect") (cons 400 "Bad request") (cons 401 "Unauthorized") (cons 402 "Payment required") (cons 403 "Forbidden") (cons 404 "Not found") (cons 405 "Not allowed") (cons 406 "Not acceptable") (cons 407 "Registration required") (cons 408 "Request timeout") (cons 409 "Conflict") (cons 500 "Internal server error") (cons 501 "Not implemented") (cons 502 "Remote server error") (cons 503 "Service unavailable") (cons 504 "Remote server timeout") (cons 510 "Disconnected")) "String descriptions of legacy errors (XEP-0086).") (defun jabber-parse-error (error-xml) "Parse the given tag and return a string fit for human consumption. See secton 9.3, Stanza Errors, of XMPP Core, and XEP-0086, Legacy Errors." (let ((error-type (jabber-xml-get-attribute error-xml 'type)) (error-code (jabber-xml-get-attribute error-xml 'code)) condition text) (if error-type ;; If the tag has a type element, it is new-school. (dolist (child (jabber-xml-node-children error-xml)) (when (string= (jabber-xml-get-attribute child 'xmlns) "urn:ietf:params:xml:ns:xmpp-stanzas") (if (eq (jabber-xml-node-name child) 'text) (setq text (car (jabber-xml-node-children child))) (setq condition (or (cdr (assq (jabber-xml-node-name child) jabber-error-messages)) (symbol-name (jabber-xml-node-name child))))))) (setq condition (or (cdr (assq (string-to-number error-code) jabber-legacy-error-messages)) error-code)) (setq text (car (jabber-xml-node-children error-xml)))) (concat condition (if text (format ": %s" text))))) (defun jabber-error-condition (error-xml) "Parse the given tag and return the condition symbol." (catch 'condition (dolist (child (jabber-xml-node-children error-xml)) (when (string= (jabber-xml-get-attribute child 'xmlns) "urn:ietf:params:xml:ns:xmpp-stanzas") (throw 'condition (jabber-xml-node-name child)))))) (defvar jabber-stream-error-messages (list (cons 'bad-format "Bad XML format") (cons 'bad-namespace-prefix "Bad namespace prefix") (cons 'conflict "Conflict") (cons 'connection-timeout "Connection timeout") (cons 'host-gone "Host gone") (cons 'host-unknown "Host unknown") (cons 'improper-addressing "Improper addressing") ; actually only s2s (cons 'internal-server-error "Internal server error") (cons 'invalid-from "Invalid from") (cons 'invalid-id "Invalid id") (cons 'invalid-namespace "Invalid namespace") (cons 'invalid-xml "Invalid XML") (cons 'not-authorized "Not authorized") (cons 'policy-violation "Policy violation") (cons 'remote-connection-failed "Remote connection failed") (cons 'resource-constraint "Resource constraint") (cons 'restricted-xml "Restricted XML") (cons 'see-other-host "See other host") (cons 'system-shutdown "System shutdown") (cons 'undefined-condition "Undefined condition") (cons 'unsupported-encoding "Unsupported encoding") (cons 'unsupported-stanza-type "Unsupported stanza type") (cons 'unsupported-version "Unsupported version") (cons 'xml-not-well-formed "XML not well formed")) "String descriptions of XMPP stream errors.") (defun jabber-stream-error-condition (error-xml) "Return the condition of a tag." ;; as we don't know the node name of the condition, we have to ;; search for it. (cl-dolist (node (jabber-xml-node-children error-xml)) (when (and (string= (jabber-xml-get-attribute node 'xmlns) "urn:ietf:params:xml:ns:xmpp-streams") (assq (jabber-xml-node-name node) jabber-stream-error-messages)) (cl-return (jabber-xml-node-name node))))) (defun jabber-parse-stream-error (error-xml) "Parse the given error tag and return a string fit for human consumption. ERROR-XML is a tag parsed with `xml-parse-region'." (let ((text-node (car (jabber-xml-get-children error-xml 'text))) (condition (jabber-stream-error-condition error-xml))) (concat (if condition (cdr (assq condition jabber-stream-error-messages)) "Unknown stream error") (if (and text-node (stringp (car (jabber-xml-node-children text-node)))) (concat ": " (car (jabber-xml-node-children text-node))))))) (put 'jabber-error 'error-conditions '(error jabber-error)) (put 'jabber-error 'error-message "Jabber error") ;; https://www.rfc-editor.org/rfc/rfc6120.html#section-8.3 explains ;; that there are stanza errors, which are recoverable and do not ;; terminate the stream. ;; Each stanza has a type which are the one explained at the ;; ERROR-TYPE parameter. checkdoc throws warnings stating that errors ;; messages should start with capital letters, thus the `downcase' ;; function is used as a workaround. (defun jabber-signal-error (error-type condition &optional text app-specific) "Signal an error to be sent by Jabber. ERROR-TYPE is one of \"Cancel\", \"Continue\", \"Mmodify\", \"Auth\" and \"Wait\" (lowercase versions make `checkdoc' to throw errors). CONDITION is a symbol denoting a defined XMPP condition. TEXT is a string to be sent in the error message, or nil for no text. APP-SPECIFIC is a list of extra XML tags. See section 9.3 of XMPP Core (RFC 3920). See section 8.3 of XMPP Core (RFC 6120)." (signal 'jabber-error (list (downcase error-type) condition text app-specific))) (defun jabber-unhex (string) "Convert a hex-encoded UTF-8 string to Emacs representation. For example, \"ji%C5%99i@%C4%8Dechy.example/v%20Praze\" becomes \"jiři@čechy.example/v Praze\"." (decode-coding-string (url-unhex-string string) 'utf-8)) (defun jabber-handle-uri (uri &rest _ignored-args) "Handle XMPP links according to draft-saintandre-xmpp-iri-04. See Info node `(jabber)XMPP URIs'. URI is a string with the \"xmpp://\" link to handle. IGNORED-ARGS are ignored arguments the handler may pass. " (interactive "sEnter XMPP URI: ") (when (string-match "//" uri) (error "URIs with authority part are not supported")) ;; This regexp handles three cases: ;; xmpp:romeo@montague.net ;; xmpp:romeo@montague.net?roster ;; xmpp:romeo@montague.net?roster;name=Romeo%20Montague;group=Lovers (unless (string-match "^xmpp:\\([^?]+\\)\\(\\?\\([a-z]+\\)\\(;\\(.*\\)\\)?\\)?" uri) (error "Invalid XMPP URI '%s'" uri)) ;; We start by raising the Emacs frame. (raise-frame) (let ((jid (jabber-unhex (match-string 1 uri))) (method (match-string 3 uri)) (args (let ((text (match-string 5 uri))) ;; If there are arguments... (when text ;; ...split the pairs by ';'... (let ((pairs (split-string text ";"))) (mapcar (lambda (pair) ;; ...and split keys from values by '='. (pcase-let ((`(,key ,value) (split-string pair "="))) ;; Values can be hex-coded. (cons key (jabber-unhex value)))) pairs)))))) ;; The full list of methods is at ;; . (cond ;; Join an MUC. ((string= method "join") (let ((account (jabber-read-account))) (jabber-muc-join account jid (jabber-muc-read-my-nickname account jid) t))) ;; Register with a service. ((string= method "register") (jabber-get-register (jabber-read-account) jid)) ;; Run an ad-hoc command ((string= method "command") ;; XXX: does the 'action' attribute make sense? (jabber-ahc-execute-command (jabber-read-account) jid (cdr (assoc "node" args)))) ;; Everything else: open a chat buffer. (t (jabber-chat-with (jabber-read-account) jid))))) (defun url-xmpp (url) "Handle XMPP URLs from internal Emacs functions." ;; XXX: This parsing roundtrip is redundant, and the parser of the ;; url package might lose information. (jabber-handle-uri (url-recreate-url url))) (defun string>-numerical (s1 s2) "Return t if first arg string is more than second in numerical order." (cond ((string= s1 s2) nil) ((> (length s1) (length s2)) t) ((< (length s1) (length s2)) nil) ((< (string-to-number (substring s1 0 1)) (string-to-number (substring s2 0 1))) nil) ((> (string-to-number (substring s1 0 1)) (string-to-number (substring s2 0 1))) t) (t (string>-numerical (substring s1 1) (substring s2 1))))) (defun jabber-append-string-to-file (string file &optional func &rest args) "Append STRING (may be nil) to FILE. Create FILE if needed. If FUNC is non-nil, then call FUNC with ARGS at beginning of temporaly buffer _before_ inserting STRING." (when (or (stringp string) (functionp func)) (with-temp-buffer (when (functionp func) (apply func args)) (when (stringp string) (insert string)) (write-region (point-min) (point-max) file t (list t))))) (defun jabber-tree-map (fn tree) "Apply FN to all nodes in the TREE starting with root. FN is applied to the node and not to the data itself." (let ((result (cons nil nil))) (cl-do ((tail tree (cdr tail)) (prev result end) (end result (let* ((x (car tail)) (val (if (atom x) (funcall fn x) (jabber-tree-map fn x)))) (setf (car end) val (cdr end) (cons nil nil))))) ((atom tail) (progn (setf (cdr prev) (if tail (funcall fn tail) nil)) result))))) (provide 'jabber-util) ;;; jabber-util.el ends hereemacs-jabber/lisp/jabber-vcard-avatars.el000066400000000000000000000122571476345337400206720ustar00rootroot00000000000000;;; jabber-vcard-avatars.el --- Avatars by JEP-0153 -*- lexical-binding: t; -*- ;; Copyright (C) 2006, 2007, 2008 Magnus Henoch ;; Author: Magnus Henoch ;; 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-util) (require 'jabber-xml) (require 'jabber-vcard) (require 'jabber-presence) (require 'jabber-iq) (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 stanza. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." ;; Only look at ordinary presence (when (and jabber-vcard-avatars-retrieve (null (jabber-xml-get-attribute xml-data 'type))) (let* ((from (jabber-jid-user (jabber-xml-get-attribute xml-data 'from))) (photo (jabber-xml-path xml-data '(("vcard-temp:x:update" . "x") photo))) (sha1-hash (car (jabber-xml-node-children photo)))) (cond ((null sha1-hash) ;; User has removed avatar (jabber-avatar-set from nil)) ((string= sha1-hash (get (jabber-jid-symbol from) 'avatar-hash)) ;; Same avatar as before; do nothing ) ((jabber-avatar-find-cached sha1-hash) ;; Avatar is cached (jabber-avatar-set from sha1-hash)) (t ;; Avatar is not cached; retrieve it (jabber-vcard-avatars-fetch jc from sha1-hash)))))) (defun jabber-vcard-avatars-fetch (jc jid sha1-hash) "Fetch vCard for JID and extract the avatar. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Fetch whose vCard avatar: ") nil)) (jabber-send-iq jc jid "get" '(vCard ((xmlns . "vcard-temp"))) #'jabber-vcard-avatars-vcard (cons jid sha1-hash) #'ignore nil)) (defun jabber-vcard-avatars-vcard (_jc iq closure) "Get the photo from the vCard, and set the avatar." (let ((from (car closure)) (sha1-hash (cdr closure)) (photo (assq 'PHOTO (jabber-vcard-parse (jabber-iq-query iq))))) (if photo (let ((avatar (jabber-avatar-from-base64-string (nth 2 photo) (nth 1 photo)))) (unless (or (null sha1-hash) (string= sha1-hash (avatar-sha1-sum avatar))) (when jabber-avatar-verbose (message "%s's avatar should have SHA1 sum %s, but has %s" (jabber-jid-displayname from) sha1-hash (avatar-sha1-sum avatar)))) (jabber-avatar-cache avatar) (jabber-avatar-set from avatar)) (jabber-avatar-set from nil)))) (defun jabber-vcard-avatars-find-current (jc) "Request our own vCard, to find hash of avatar. JC is the Jabber connection." (when jabber-vcard-avatars-publish (jabber-send-iq jc nil "get" '(vCard ((xmlns . "vcard-temp"))) #'jabber-vcard-avatars-find-current-1 t #'jabber-vcard-avatars-find-current-1 nil))) (defun jabber-vcard-avatars-find-current-1 (jc xml-data success) (jabber-vcard-avatars-update-current jc (and success (let ((photo (assq 'PHOTO (jabber-vcard-parse (jabber-iq-query xml-data))))) (when photo (let ((avatar (jabber-avatar-from-base64-string (nth 2 photo) (nth 1 photo)))) (avatar-sha1-sum avatar))))))) (defun jabber-vcard-avatars-update-current (jc new-hash) (let ((old-hash (gethash (jabber-connection-bare-jid jc) jabber-vcard-avatars-current-hash))) (when (not (string= old-hash new-hash)) (puthash (jabber-connection-bare-jid jc) new-hash jabber-vcard-avatars-current-hash) (jabber-send-current-presence jc)))) (add-to-list 'jabber-presence-element-functions 'jabber-vcard-avatars-presence-element) (defun jabber-vcard-avatars-presence-element (jc) (when jabber-vcard-avatars-publish (let ((hash (gethash (jabber-connection-bare-jid jc) jabber-vcard-avatars-current-hash))) (list `(x ((xmlns . "vcard-temp:x:update")) ;; if "not yet ready to advertise image", don't. ;; that is, we haven't yet checked what avatar we have. ,(when hash `(photo () ,hash))))))) (provide 'jabber-vcard-avatars) ;;; jabber-vcard-avatars.el ends hereemacs-jabber/lisp/jabber-vcard.el000066400000000000000000000444511476345337400172340ustar00rootroot00000000000000;;; jabber-vcard.el --- vcards according to JEP-0054 -*- lexical-binding: t; -*- ;; Copyright (C) 2005, 2007 Magnus Henoch ;; Author: Magnus Henoch ;; This file is a part of jabber.el. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; 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) ;; Global reference declarations (declare-function jabber-vcard-avatars-update-current "jabber-vcard-avatars.el" (jc new-hash)) (defvar jabber-vcard-fields) ; jabber-vcard.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el ;; (defun jabber-vcard-parse (vcard) "Parse the vCard XML structure given in VCARD. The top node should be the `vCard' node." ;; Hm... stpeter has a as top node... ;;(unless (eq (jabber-xml-node-name vcard) 'vCard) ;; (error "Invalid vCard")) (let (result) (dolist (verbatim-node '(FN NICKNAME BDAY JABBERID MAILER TZ TITLE ROLE NOTE PRODID REV SORT-STRING UID URL DESC)) ;; There should only be one of each of these. They are ;; used verbatim. (let ((node (car (jabber-xml-get-children vcard verbatim-node)))) ;; Some clients include the node, but without data (when (car (jabber-xml-node-children node)) (push (cons (jabber-xml-node-name node) (car (jabber-xml-node-children node))) result)))) ;; Name components (let ((node (car (jabber-xml-get-children vcard 'N)))) ;; Subnodes are FAMILY, GIVEN, MIDDLE, PREFIX, SUFFIX (push (cons 'N (let (name) (dolist (subnode (jabber-xml-node-children node)) (when (and (memq (jabber-xml-node-name subnode) '(FAMILY GIVEN MIDDLE PREFIX SUFFIX)) (not (zerop (length (car (jabber-xml-node-children subnode)))))) (push (cons (jabber-xml-node-name subnode) (car (jabber-xml-node-children subnode))) name))) name)) result)) ;; There can be several addresses (let (addresses) (dolist (adr (jabber-xml-get-children vcard 'ADR)) ;; Find address type(s) (let (types) (dolist (possible-type '(HOME WORK POSTAL PARCEL DOM INTL PREF)) (when (jabber-xml-get-children adr possible-type) (push possible-type types))) (let (components) (dolist (component (jabber-xml-node-children adr)) (when (and (memq (jabber-xml-node-name component) '(POBOX EXTADD STREET LOCALITY REGION PCODE CTRY)) (not (zerop (length (car (jabber-xml-node-children component)))))) (push (cons (jabber-xml-node-name component) (car (jabber-xml-node-children component))) components))) (push (cons types components) addresses)))) (when addresses (push (cons 'ADR addresses) result))) ;; Likewise for phone numbers (let (phone-numbers) (dolist (tel (jabber-xml-get-children vcard 'TEL)) ;; Find phone type(s) (let ((number (car (jabber-xml-node-children (car (jabber-xml-get-children tel 'NUMBER))))) types) ;; Some clients put no NUMBER node. Avoid that. (when number (dolist (possible-type '(HOME WORK VOICE FAX PAGER MSG CELL VIDEO BBS MODEM ISDN PCS PREF)) (when (jabber-xml-get-children tel possible-type) (push possible-type types))) (push (cons types number) phone-numbers)))) (when phone-numbers (push (cons 'TEL phone-numbers) result))) ;; And for e-mail addresses (let (e-mails) (dolist (email (jabber-xml-get-children vcard 'EMAIL)) (let ((userid (car (jabber-xml-node-children (car (jabber-xml-get-children email 'USERID))))) types) ;; Some clients put no USERID node. Avoid that. (when userid (dolist (possible-type '(HOME WORK INTERNET PREF X400)) (when (jabber-xml-get-children email possible-type) (push possible-type types))) (unless (or (memq 'INTERNET types) (memq 'X400 types)) (push 'INTERNET types)) (push (cons types userid) e-mails)))) (when e-mails (push (cons 'EMAIL e-mails) result))) ;; XEP-0153: vCard-based avatars (let ((photo-tag (car (jabber-xml-get-children vcard 'PHOTO)))) (when photo-tag (let ((type (jabber-xml-path photo-tag '(TYPE ""))) (binval (jabber-xml-path photo-tag '(BINVAL "")))) (when (and type binval) (push (list 'PHOTO type binval) result))))) result)) (defun jabber-vcard-reassemble (parsed) "Create a vCard XML structure from PARSED." ;; Save photo in jabber-vcard-photo, to avoid excessive processing. (let ((photo (cdr (assq 'PHOTO parsed)))) (cond ;; No photo ((null photo) (setq jabber-vcard-photo nil)) ;; Existing photo ((listp photo) (setq jabber-vcard-photo (jabber-avatar-from-base64-string (nth 1 photo) (nth 0 photo)))) ;; New photo from file (t (access-file photo "Avatar file not found") ;; Maximum allowed size is 8 kilobytes (when (> (nth 7 (file-attributes photo)) 8192) (error "Avatar bigger than 8 kilobytes")) (setq jabber-vcard-photo (jabber-avatar-from-file photo))))) `(vCard ((xmlns . "vcard-temp")) ;; Put in simple fields ,@(mapcar (lambda (field) (when (and (assq (car field) jabber-vcard-fields) (not (zerop (length (cdr field))))) (list (car field) nil (cdr field)))) parsed) ;; Put in decomposited name (N nil ,@(mapcar (lambda (name-part) (when (not (zerop (length (cdr name-part)))) (list (car name-part) nil (cdr name-part)))) (cdr (assq 'N parsed)))) ;; Put in addresses ,@(mapcar (lambda (address) (append '(ADR) '(()) (mapcar #'list (nth 0 address)) (mapcar (lambda (field) (list (car field) nil (cdr field))) (cdr address)))) (cdr (assq 'ADR parsed))) ;; Put in phone numbers ,@(mapcar (lambda (phone) (append '(TEL) '(()) (mapcar #'list (car phone)) (list (list 'NUMBER nil (cdr phone))))) (cdr (assq 'TEL parsed))) ;; Put in e-mail addresses ,@(mapcar (lambda (email) (append '(EMAIL) '(()) (mapcar #'list (car email)) (list (list 'USERID nil (cdr email))))) (cdr (assq 'EMAIL parsed))) ;; Put in photo ,@(when jabber-vcard-photo `((PHOTO () (TYPE () ,(avatar-mime-type jabber-vcard-photo)) (BINVAL () ,(avatar-base64-data jabber-vcard-photo))))))) (add-to-list 'jabber-jid-info-menu (cons "Request vcard" 'jabber-vcard-get)) (defun jabber-vcard-get (jc jid) "Request vcard from JID. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Request vcard from: " nil nil nil 'bare-or-muc))) (jabber-send-iq jc jid "get" '(vCard ((xmlns . "vcard-temp"))) #'jabber-process-data #'jabber-vcard-display #'jabber-process-data "Vcard request failed")) (defun jabber-vcard-edit (jc) "Edit your own vcard. JC is the Jabber connection." (interactive (list (jabber-read-account))) (jabber-send-iq jc nil "get" '(vCard ((xmlns . "vcard-temp"))) #'jabber-vcard-do-edit nil #'jabber-report-success "Vcard request failed")) (defconst jabber-vcard-fields '((FN . "Full name") (NICKNAME . "Nickname") (BDAY . "Birthday") (URL . "URL") (JABBERID . "JID") (MAILER . "User agent") (TZ . "Time zone") (TITLE . "Title") (ROLE . "Role") (REV . "Last changed") (DESC . "Description") (NOTE . "Note"))) (defconst jabber-vcard-name-fields '((PREFIX . "Prefix") (GIVEN . "Given name") (MIDDLE . "Middle name") (FAMILY . "Family name") (SUFFIX . "Suffix"))) (defconst jabber-vcard-phone-types '((HOME . "Home") (WORK . "Work") (VOICE . "Voice") (FAX . "Fax") (PAGER . "Pager") (MSG . "Message") (CELL . "Cell phone") (VIDEO . "Video") (BBS . "BBS") (MODEM . "Modem") (ISDN . "ISDN") (PCS . "PCS"))) (defconst jabber-vcard-email-types '((HOME . "Home") (WORK . "Work") (INTERNET . "Internet") (X400 . "X400") (PREF . "Preferred"))) (defconst jabber-vcard-address-types '((HOME . "Home") (WORK . "Work") (POSTAL . "Postal") (PARCEL . "Parcel") (DOM . "Domestic") (INTL . "International") (PREF . "Preferred"))) (defconst jabber-vcard-address-fields '((POBOX . "Post box") (EXTADD . "Ext. address") (STREET . "Street") (LOCALITY . "Locality") (REGION . "Region") (PCODE . "Post code") (CTRY . "Country"))) (defun jabber-vcard-display (_jc xml-data) "Display received vcard. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data)))) (dolist (simple-field jabber-vcard-fields) (let ((field (assq (car simple-field) parsed))) (when field (insert (cdr simple-field)) (indent-to 20) (insert (cdr field) "\n")))) (let ((names (cdr (assq 'N parsed)))) (when names (insert "\n") (dolist (name-field jabber-vcard-name-fields) (let ((field (assq (car name-field) names))) (when field (insert (cdr name-field)) (indent-to 20) (insert (cdr field) "\n")))))) (let ((email-addresses (cdr (assq 'EMAIL parsed)))) (when email-addresses (insert "\n") (insert (jabber-propertize "E-mail addresses:\n" 'face 'jabber-title-medium)) (dolist (email email-addresses) (insert (mapconcat (lambda (type) (cdr (assq type jabber-vcard-email-types))) (car email) " ")) (insert ": " (cdr email) "\n")))) (let ((phone-numbers (cdr (assq 'TEL parsed)))) (when phone-numbers (insert "\n") (insert (jabber-propertize "Phone numbers:\n" 'face 'jabber-title-medium)) (dolist (number phone-numbers) (insert (mapconcat (lambda (type) (cdr (assq type jabber-vcard-phone-types))) (car number) " ")) (insert ": " (cdr number) "\n")))) (let ((addresses (cdr (assq 'ADR parsed)))) (when addresses (insert "\n") (insert (jabber-propertize "Addresses:\n" 'face 'jabber-title-medium)) (dolist (address addresses) (insert (jabber-propertize (mapconcat (lambda (type) (cdr (assq type jabber-vcard-address-types))) (car address) " ") 'face 'jabber-title-small)) (insert "\n") (dolist (address-field jabber-vcard-address-fields) (let ((field (assq (car address-field) address))) (when field (insert (cdr address-field)) (indent-to 20) (insert (cdr field) "\n"))))))) ;; XEP-0153: vCard-based avatars (let ((photo-type (nth 1 (assq 'PHOTO parsed))) (photo-binval (nth 2 (assq 'PHOTO parsed)))) (when (and photo-type photo-binval) (condition-case nil ;; ignore the type, let create-image figure it out. (let ((image (jabber-create-image (base64-decode-string photo-binval) nil t))) (insert-image image "[Photo]") (insert "\n")) (error (insert "Couldn't display photo\n"))))))) (defun jabber-vcard-do-edit (jc xml-data _closure-data) (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data))) start-position) (with-current-buffer (get-buffer-create "Edit vcard") (jabber-init-widget-buffer nil) (setq jabber-buffer-connection jc) (setq start-position (point)) (dolist (simple-field jabber-vcard-fields) (widget-insert (cdr simple-field)) (indent-to 15) (let ((default-value (cdr (assq (car simple-field) parsed)))) (push (cons (car simple-field) (widget-create 'editable-field (or default-value ""))) jabber-widget-alist))) (widget-insert "\n") (push (cons 'N (widget-create '(set :tag "Decomposited name" (cons :tag "Prefix" :format "%t: %v" (const :format "" PREFIX) (string :format "%v")) (cons :tag "Given name" :format "%t: %v" (const :format "" GIVEN) (string :format "%v")) (cons :tag "Middle name" :format "%t: %v" (const :format "" MIDDLE) (string :format "%v")) (cons :tag "Family name" :format "%t: %v" (const :format "" FAMILY) (string :format "%v")) (cons :tag "Suffix" :format "%t: %v" (const :format "" SUFFIX) (string :format "%v"))) :value (cdr (assq 'N parsed)))) jabber-widget-alist) (widget-insert "\n") (push (cons 'ADR (widget-create '(repeat :tag "Postal addresses" (cons :tag "Address" (set :tag "Type" (const :tag "Home" HOME) (const :tag "Work" WORK) (const :tag "Postal" POSTAL) (const :tag "Parcel" PARCEL) (const :tag "Domestic" DOM) (const :tag "International" INTL) (const :tag "Preferred" PREF)) (set :tag "Address" (cons :tag "Post box" :format "%t: %v" (const :format "" POBOX) (string :format "%v")) (cons :tag "Ext. address" :format "%t: %v" (const :format "" EXTADD) (string :format "%v")) (cons :tag "Street" :format "%t: %v" (const :format "" STREET) (string :format "%v")) (cons :tag "Locality" :format "%t: %v" (const :format "" LOCALITY) (string :format "%v")) (cons :tag "Region" :format "%t: %v" (const :format "" REGION) (string :format "%v")) (cons :tag "Post code" :format "%t: %v" (const :format "" PCODE) (string :format "%v")) (cons :tag "Country" :format "%t: %v" (const :format "" CTRY) (string :format "%v"))))) :value (cdr (assq 'ADR parsed)))) jabber-widget-alist) (widget-insert "\n") (push (cons 'TEL (widget-create '(repeat :tag "Phone numbers" (cons :tag "Number" (set :tag "Type" (const :tag "Home" HOME) (const :tag "Work" WORK) (const :tag "Voice" VOICE) (const :tag "Fax" FAX) (const :tag "Pager" PAGER) (const :tag "Message" MSG) (const :tag "Cell phone" CELL) (const :tag "Video" VIDEO) (const :tag "BBS" BBS) (const :tag "Modem" MODEM) (const :tag "ISDN" ISDN) (const :tag "PCS" PCS)) (string :tag "Number"))) :value (cdr (assq 'TEL parsed)))) jabber-widget-alist) (widget-insert "\n") (push (cons 'EMAIL (widget-create '(repeat :tag "E-mail addresses" (cons :tag "Address" (set :tag "Type" (const :tag "Home" HOME) (const :tag "Work" WORK) (const :tag "Internet" INTERNET) (const :tag "X400" X400) (const :tag "Preferred" PREF)) (string :tag "Address"))) :value (cdr (assq 'EMAIL parsed)))) jabber-widget-alist) (widget-insert "\n") (widget-insert "Photo/avatar:\n") (let* ((photo (assq 'PHOTO parsed)) (avatar (when photo (jabber-avatar-from-base64-string (nth 2 photo) (nth 1 photo))))) (push (cons 'PHOTO (widget-create `(radio-button-choice (const :tag "None" nil) ,@(when photo (list `(const :tag ,(concat "Existing: " (jabber-propertize " " 'display (jabber-avatar-image avatar))) ,(cdr photo)))) (file :must-match t :tag "From file")) :value (cdr photo))) jabber-widget-alist)) (widget-insert "\n") (widget-create 'push-button :notify #'jabber-vcard-submit "Submit") (widget-setup) (widget-minor-mode 1) (switch-to-buffer (current-buffer)) (goto-char start-position)))) (defun jabber-vcard-submit (&rest _ignore) (let ((to-publish (jabber-vcard-reassemble (mapcar (lambda (entry) (cons (car entry) (widget-value (cdr entry)))) jabber-widget-alist)))) (jabber-send-iq jabber-buffer-connection nil "set" to-publish #'jabber-report-success "Changing vCard" #'jabber-report-success "Changing vCard") (when (bound-and-true-p jabber-vcard-avatars-publish) (jabber-vcard-avatars-update-current jabber-buffer-connection (and jabber-vcard-photo (avatar-sha1-sum jabber-vcard-photo)))))) (provide 'jabber-vcard) ;;; jabber-vcard.el ends hereemacs-jabber/lisp/jabber-version.el000066400000000000000000000072001476345337400176110ustar00rootroot00000000000000;;; jabber-version.el --- version reporting by JEP-0092 -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; This file is a part of jabber.el. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA (require 'jabber-iq) (require 'jabber-util) (require 'jabber-disco) (require 'jabber-menu) (require 'find-func) (require 'lisp-mnt) (defcustom jabber-version-show t "Show our client version to others. Acts on loading." :type 'boolean :group 'jabber) (defconst jabber-version (lm-version (find-library-name "jabber")) "Version string extracted from jabber.el. This value provides the version field of the XEP-0092 Service Discovery jabber:iq:version query response, when `jabber-version-show` is non `nil`.") (add-to-list 'jabber-jid-info-menu (cons "Request software version" 'jabber-get-version)) (defun jabber-get-version (jc to) "Request software version. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Request version of: " nil nil nil 'full t))) (jabber-send-iq jc to "get" '(query ((xmlns . "jabber:iq:version"))) #'jabber-process-data #'jabber-process-version #'jabber-process-data "Version request failed")) ;; called by jabber-process-data (defun jabber-process-version (_jc xml-data) "Handle results from jabber:iq:version requests. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((query (jabber-iq-query xml-data))) (dolist (x '((name . "Name:\t\t") (version . "Version:\t") (os . "OS:\t\t"))) (let ((data (car (jabber-xml-node-children (car (jabber-xml-get-children query (car x))))))) (when data (insert (cdr x) data "\n")))))) (if jabber-version-show (and (add-to-list 'jabber-iq-get-xmlns-alist (cons "jabber:iq:version" 'jabber-return-version)) (jabber-disco-advertise-feature "jabber:iq:version"))) (defun jabber-return-version (jc xml-data) "Return client version as defined in XEP-0092. Sender and ID are determined from the incoming packet passed in XML-DATA. JC is the Jabber connection." ;; Things we might check: does this iq message really have type='get' and ;; exactly one child, namely query with xmlns='jabber:iq:version'? ;; Then again, jabber-process-iq should take care of that. (let ((to (jabber-xml-get-attribute xml-data 'from)) (id (jabber-xml-get-attribute xml-data 'id)) (os (format "%s %d.%d (%s)" (cond ((featurep 'xemacs) "XEmacs") (t "Emacs")) emacs-major-version emacs-minor-version system-type))) (jabber-send-iq jc to "result" `(query ((xmlns . "jabber:iq:version")) (name () "jabber.el") (version () ,jabber-version) ;; Booting... /vmemacs.el ;; Shamelessly stolen from someone's sig. (os () ,os)) nil nil nil nil id))) (provide 'jabber-version) ;;; jabber-version.el ends hereemacs-jabber/lisp/jabber-watch.el000066400000000000000000000057321476345337400172420ustar00rootroot00000000000000;;; jabber-watch.el --- get notified when certain persons go online -*- lexical-binding: t; -*- ;; 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) (require 'jabber-alert) (defcustom jabber-watch-alist nil "Alist of buddies for which an extra notification should be sent when they come online, with comment strings as values." ;; XXX: change symbol to jid-symbol or something, and update ;; documentation :type '(alist :key-type symbol :value-type string) :group 'jabber-watch) (defun jabber-presence-watch (who oldstatus newstatus _statustext proposed-alert) "Send a message if one of your extra-important buddies comes online. The buddies are stored in `jabber-watch-alist' and are added and removed by calling `jabber-watch-add' and `jabber-watch-remove'." ;; check that buddy was previously offline and now online (if (and (null oldstatus) (not (null newstatus))) (let ((entry (assq who jabber-watch-alist))) (when entry ;; Give an intrusive message. With a window system, ;; that's easy. (if window-system (message-box "%s%s" proposed-alert (if (cdr entry) (format ": %s" (cdr entry)) "")) ;; Without a window system, yes-or-no-p should be ;; sufficient. (while (not (yes-or-no-p (format "%s%s Got that? " proposed-alert (if (cdr entry) (format ": %s" (cdr entry)) "")))))))))) (defun jabber-watch-add (buddy &optional comment) (interactive (list (jabber-read-jid-completing "Add buddy to watch list: ") (read-string "Comment: "))) (unless (memq 'jabber-presence-watch jabber-presence-hooks) (error "The jabber-presence-watch function is not in jabber-presence-hooks")) (add-to-list 'jabber-watch-alist (cons (jabber-jid-symbol buddy) (and (not (zerop (length comment))) comment)))) (defun jabber-watch-remove (buddy) (interactive (list (jabber-read-jid-completing "Remove buddy from watch list: " (or (mapcar #'car jabber-watch-alist) (error "Watch list is empty")) t))) (setq jabber-watch-alist (delq (assq (jabber-jid-symbol buddy) jabber-watch-alist) jabber-watch-alist))) (provide 'jabber-watch) ;;; jabber-watch.el ends hereemacs-jabber/lisp/jabber-widget.el000066400000000000000000000323751476345337400174220ustar00rootroot00000000000000;;; jabber-widget.el --- display various kinds of forms -*- lexical-binding: t; -*- ;; 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.") ;; Global reference declarations (defvar *jabber-roster*) ; jabber-core.el ;; (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 #'jid-complete) (defun jid-complete (widget) "Perform completion on JID preceding point." ;; 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))) (message "Making completion list...done"))))) (defun jabber-init-widget-buffer (submit-to) "Setup buffer-local variables for widgets." (make-local-variable 'jabber-widget-alist) (make-local-variable 'jabber-submit-to) (setq jabber-widget-alist nil) (setq jabber-submit-to submit-to) (setq buffer-read-only nil) ;; XXX: This is because data from other queries would otherwise be ;; appended to this buffer, which would fail since widget buffers ;; are read-only... or something like that. Maybe there's a ;; better way. (rename-uniquely)) (defun jabber-render-register-form (query &optional default-username) "Display widgets from element in IQ register or search namespace. Display widgets from element in jabber:iq:{register,search} namespace. DEFAULT-USERNAME is the default value for the username field." (make-local-variable 'jabber-widget-alist) (setq jabber-widget-alist nil) (make-local-variable 'jabber-form-type) (setq jabber-form-type 'register) (if (jabber-xml-get-children query 'instructions) (widget-insert "Instructions: " (car (jabber-xml-node-children (car (jabber-xml-get-children query 'instructions)))) "\n")) (if (jabber-xml-get-children query 'registered) (widget-insert "You are already registered. You can change your details here.\n")) (widget-insert "\n") (let ((possible-fields ;; taken from XEP-0077 '((username . "Username") (nick . "Nickname") (password . "Password") (name . "Full name") (first . "First name") (last . "Last name") (email . "E-mail") (address . "Address") (city . "City") (state . "State") (zip . "Zip") (phone . "Telephone") (url . "Web page") (date . "Birth date")))) (dolist (field (jabber-xml-node-children query)) (let ((entry (assq (jabber-xml-node-name field) possible-fields))) (when entry (widget-insert (cdr entry) "\t") ;; Special case: when registering a new account, the default ;; username is the one specified in jabber-username. Things ;; will break if the user changes that name, though... (let ((default-value (or (when (eq (jabber-xml-node-name field) 'username) default-username) ""))) (setq jabber-widget-alist (cons (cons (car entry) (widget-create 'editable-field :secret (if (eq (car entry) 'password) ?* nil) (or (car (jabber-xml-node-children field)) default-value))) jabber-widget-alist))) (widget-insert "\n")))))) (defun jabber-parse-register-form () "Return children of a tag containing information entered. Return children of a tag containing information entered in the widgets of the current buffer." (mapcar (lambda (widget-cons) (list (car widget-cons) nil (widget-value (cdr widget-cons)))) jabber-widget-alist)) (defun jabber-render-xdata-form (x &optional defaults) "Display widgets from element in jabber:x:data namespace. DEFAULTS is an alist associating variable names with default values. DEFAULTS takes precedence over values specified in the form." (make-local-variable 'jabber-widget-alist) (setq jabber-widget-alist nil) (make-local-variable 'jabber-form-type) (setq jabber-form-type 'xdata) (let ((title (car (jabber-xml-node-children (car (jabber-xml-get-children x 'title)))))) (if (stringp title) (widget-insert (jabber-propertize title 'face 'jabber-title-medium) "\n\n"))) (let ((instructions (car (jabber-xml-node-children (car (jabber-xml-get-children x 'instructions)))))) (if (stringp instructions) (widget-insert "Instructions: " instructions "\n\n"))) (dolist (field (jabber-xml-get-children x 'field)) (let* ((var (jabber-xml-get-attribute field 'var)) (label (jabber-xml-get-attribute field 'label)) (type (jabber-xml-get-attribute field 'type)) (values (jabber-xml-get-children field 'value)) (options (jabber-xml-get-children field 'option)) (desc (car (jabber-xml-get-children field 'desc))) (default-value (assoc var defaults))) ;; "required" not implemented yet (cond ((string= type "fixed") (widget-insert (car (jabber-xml-node-children (car values))))) ((string= type "text-multi") (if (or label var) (widget-insert (or label var) ":\n")) (push (cons (cons var type) (widget-create 'text (or (cdr default-value) (mapconcat #'(lambda (val) (car (jabber-xml-node-children val))) values "\n") ""))) jabber-widget-alist)) ((string= type "list-single") (if (or label var) (widget-insert (or label var) ":\n")) (push (cons (cons var type) (apply #'widget-create 'radio-button-choice :value (or (cdr default-value) (car (xml-node-children (car values)))) (mapcar (lambda (option) `(item :tag ,(jabber-xml-get-attribute option 'label) :value ,(car (jabber-xml-node-children (car (jabber-xml-get-children option 'value)))))) options))) jabber-widget-alist)) ((string= type "boolean") (push (cons (cons var type) (widget-create 'checkbox :tag (or label var) :value (if default-value (cdr default-value) (not (null (member (car (xml-node-children (car values))) '("1" "true"))))))) jabber-widget-alist) (if (or label var) (widget-insert " " (or label var) "\n"))) (t ; in particular including text-single and text-private (if (or label var) (widget-insert (or label var) ": ")) (setq jabber-widget-alist (cons (cons (cons var type) (widget-create 'editable-field :secret (if (string= type "text-private") ?* nil) (or (cdr default-value) (car (jabber-xml-node-children (car values))) ""))) jabber-widget-alist)))) (when (and desc (car (jabber-xml-node-children desc))) (widget-insert "\n" (car (jabber-xml-node-children desc)))) (widget-insert "\n")))) (defun jabber-parse-xdata-form () "Return an tag containing information entered in the widgets. Return an tag containing information entered in the widgets of the current buffer." `(x ((xmlns . "jabber:x:data") (type . "submit")) ,@(mapcar (lambda (widget-cons) (let ((values (jabber-xdata-value-convert (widget-value (cdr widget-cons)) (cdar widget-cons)))) ;; empty fields are not included (when values `(field ((var . ,(caar widget-cons))) ,@(mapcar (lambda (value) (list 'value nil value)) values))))) jabber-widget-alist))) (defun jabber-xdata-value-convert (value type) "Convert VALUE from form used by widget library to form required by XEP-0004. Return a list of strings, each of which to be included as cdata in a tag." (cond ((string= type "boolean") (if value (list "1") (list "0"))) ((string= type "text-multi") (split-string value "[\n\r]")) (t ; in particular including text-single, text-private and list-single (if (zerop (length value)) nil (list value))))) (defun jabber-render-xdata-search-results (xdata) "Render search results in x:data form." (let ((title (car (jabber-xml-get-children xdata 'title)))) (when title (insert (jabber-propertize (car (jabber-xml-node-children title)) 'face 'jabber-title-medium) "\n"))) (if (jabber-xml-get-children xdata 'reported) (jabber-render-xdata-search-results-multi xdata) (jabber-render-xdata-search-results-single xdata))) (defun jabber-render-xdata-search-results-multi (xdata) "Render multi-record search results." (let (fields (jid-fields 0)) (let ((reported (car (jabber-xml-get-children xdata 'reported))) (column 0)) (dolist (field (jabber-xml-get-children reported 'field)) (let (width) ;; Clever algorithm for estimating width based on field type goes here. (setq width 20) (setq fields (append fields (list (cons (jabber-xml-get-attribute field 'var) (list 'label (jabber-xml-get-attribute field 'label) 'type (jabber-xml-get-attribute field 'type) 'column column))))) (setq column (+ column width)) (if (string= (jabber-xml-get-attribute field 'type) "jid-single") (setq jid-fields (1+ jid-fields)))))) (dolist (field-cons fields) (indent-to (plist-get (cdr field-cons) 'column) 1) (insert (jabber-propertize (plist-get (cdr field-cons) 'label) 'face 'bold))) (insert "\n\n") ;; Now, the items (dolist (item (jabber-xml-get-children xdata 'item)) (let ((start-of-line (point)) jid) ;; The following code assumes that the order of the s in each ;; is the same as in the tag. (dolist (field (jabber-xml-get-children item 'field)) (let ((field-plist (cdr (assoc (jabber-xml-get-attribute field 'var) fields))) (value (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value)))))) (indent-to (plist-get field-plist 'column) 1) ;; Absent values are sometimes "", sometimes nil. insert ;; doesn't like nil. (when value ;; If there is only one JID field, let the whole row ;; have the jabber-jid property. If there are many JID ;; fields, the string belonging to each field has that ;; property. (if (string= (plist-get field-plist 'type) "jid-single") (if (not (eq jid-fields 1)) (insert (jabber-propertize value 'jabber-jid value)) (setq jid value) (insert value)) (insert value))))) (if jid (put-text-property start-of-line (point) 'jabber-jid jid)) (insert "\n"))))) (defun jabber-render-xdata-search-results-single (xdata) "Render single-record search results." (dolist (field (jabber-xml-get-children xdata 'field)) (let ((label (jabber-xml-get-attribute field 'label)) (values (mapcar #'(lambda (val) (car (jabber-xml-node-children val))) (jabber-xml-get-children field 'value)))) ;; XXX: consider type (insert (jabber-propertize (concat label ": ") 'face 'bold)) (indent-to 30) (insert (apply #'concat values) "\n")))) (defun jabber-xdata-formtype (x) "Return the form type of the xdata form in X, by XEP-0068. Return nil if no form type is specified." (catch 'found-formtype (dolist (field (jabber-xml-get-children x 'field)) (when (and (string= (jabber-xml-get-attribute field 'var) "FORM_TYPE") (string= (jabber-xml-get-attribute field 'type) "hidden")) (throw 'found-formtype (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value))))))))) (provide 'jabber-widget) ;;; jabber-widget.el ends hereemacs-jabber/lisp/jabber-wmii.el000066400000000000000000000045011476345337400170720ustar00rootroot00000000000000;;; jabber-wmii.el --- emacs-jabber interface to wmii -*- lexical-binding: t; -*- ;; Copyright (C) 2007 - Detlev Zundel - dzu@gnu.org ;; This file is a part of jabber.el. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA (eval-when-compile (require 'jabber-alert)) (defvar jabber-wmii-color "#ffffff #335577 #447799" "Color specification for the wmii window manager. This color specification is used for presenting alert messages.") (defvar jabber-wmii-reset-time "20 sec" "Duration of alert message presentation. If non-nil, duration of wmii message visibility. If nil the message has to be cleared by other means, i.e. from wmiirc.") (defvar jabber-wmii-timer nil "Timer to clear wmii message.") (defun jabber-wmii-clear () "Clear any previous message output through wmii window manager." (condition-case nil (call-process "wmiir" nil nil nil "remove" "/rbar/jabber") (error nil))) (defun jabber-wmii-message (text &optional title) "Show MSG in wmii." (when jabber-wmii-timer (cancel-timer jabber-wmii-timer)) (let ((tmp (make-temp-file temporary-file-directory))) (with-temp-file tmp (insert jabber-wmii-color " " (or title text))) ;; Possible errors include not finding the wmiir binary, and ;; too many pipes open because of message flood. (condition-case nil (call-process "wmiir" tmp nil nil "create" "/rbar/jabber") (error nil)) (delete-file tmp)) (when jabber-wmii-reset-time (setq jabber-wmii-timer (run-at-time jabber-wmii-reset-time nil #'jabber-wmii-clear)))) (define-jabber-alert wmii "Show a message through the wmii window manager." 'jabber-wmii-message) (provide 'jabber-wmii) ;;; jabber-wmii.el ends hereemacs-jabber/lisp/jabber-xmessage.el000066400000000000000000000033221476345337400177410ustar00rootroot00000000000000;;; jabber-xmessage.el --- emacs-jabber interface to xmessage -*- lexical-binding: t; -*- ;; Copyright (C) 2008 - Magnus Henoch ;; Copyright (C) 2005 - Mario Domenech Goulart ;; This file is a part of jabber.el. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA (eval-when-compile (require 'jabber-alert)) (defcustom jabber-xmessage-timeout 15 "Timeout in seconds for xmessage alerts. Set this to nil to have no timeout." :type '(choice (integer :tag "Seconds") (const :tag "No timeout" nil)) :group 'jabber-alerts) (defun jabber-xmessage-display-message (text &optional title) "Displays MESSAGE using the xmessage program." (let* ((process-connection-type nil) (timeout-args (when jabber-xmessage-timeout (list "-timeout" (number-to-string jabber-xmessage-timeout)))) (args (append timeout-args (list (or title text))))) (apply #'start-process "xmessage" nil "xmessage" args))) (define-jabber-alert xmessage "Display a message using the xmessage program." 'jabber-xmessage-display-message) (provide 'jabber-xmessage) ;;; jabber-xmessage.el ends hereemacs-jabber/lisp/jabber-xml.el000066400000000000000000000243231476345337400167310ustar00rootroot00000000000000;;; jabber-xml.el --- XML functions -*- lexical-binding: t; -*- ;; 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) (eval-when-compile (require 'cl-lib)) (defsubst jabber-replace-in-string (string regexp newtext) "Return STRING with all matches for REGEXP replaced with NEWTEXT. NEWTEXT is inserted literally, without changing its case or treating \"\\\" specially." (replace-regexp-in-string regexp newtext string t t)) (defun jabber-escape-xml (string) "Escape STRING for XML." (if (stringp string) (let ((newstr (concat string))) ;; 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) string)) (defun jabber-unescape-xml (string) "Unescape STRING for XML." ;; Eventually this can be done with `xml-substitute-special', but the ;; version in xml.el of GNU Emacs 21.3 is buggy. (if (stringp string) (let ((newstr string)) (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) string)) (defun jabber-sexp2xml (sexp) "Return SEXP as well-formatted XML. SEXP should be in the form: (tagname ((attribute-name . attribute-value)...) children...)" (cond ((stringp sexp) (jabber-escape-xml sexp)) ((listp (car sexp)) (let ((xml "")) (dolist (tag sexp) (setq xml (concat xml (jabber-sexp2xml tag)))) xml)) ;; work around bug in old versions of xml.el, where ("") can appear ;; as children of a node ((and (consp sexp) (stringp (car sexp)) (zerop (length (car sexp)))) "") (t (let ((xml "")) (setq xml (concat "<" (symbol-name (car sexp)))) (dolist (attr (cadr sexp)) (if (consp attr) (setq xml (concat xml (format " %s='%s'" (symbol-name (car attr)) (jabber-escape-xml (cdr attr))))))) (if (cddr sexp) (progn (setq xml (concat xml ">")) (dolist (child (cddr sexp)) (setq xml (concat xml (jabber-sexp2xml child)))) (setq xml (concat xml ""))) (setq xml (concat xml "/>"))) xml)))) (defun jabber-xml-skip-tag-forward (&optional dont-recurse-into-stream) "Skip to end of tag or matching closing tag if present. Return t iff after a closing tag, otherwise throws an `unfinished' tag with value nil. If DONT-RECURSE-INTO-STREAM is non-nil, stop after an opening tag. The version of `sgml-skip-tag-forward' in Emacs 21 isn't good enough for us." (skip-chars-forward "^<") (cond ((looking-at "" nil t) (goto-char (match-end 0)) (throw 'unfinished nil))) ((looking-at "<\\([^[:space:]/>]+\\)\\([[:space:]]+[^=>]+=[[:space:]]*'[^']*'\\|[[:space:]]+[^=>]+=[[:space:]]*\"[^\"]*\"\\)*") (let ((node-name (match-string 1))) (goto-char (match-end 0)) (skip-syntax-forward "\s-") ; Skip over trailing white space. (cond ((looking-at "/>") (goto-char (match-end 0)) t) ((looking-at ">") (goto-char (match-end 0)) (unless (and dont-recurse-into-stream (equal node-name "stream:stream")) (cl-loop do (skip-chars-forward "^<") until (looking-at (regexp-quote (concat ""))) 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'. (defsubst jabber-xml-get-attribute (node attribute) "Get from NODE the value of ATTRIBUTE. Return nil if the attribute was not found." (when (consp node) (xml-get-attribute-or-nil node attribute))) (defsubst jabber-xml-get-xmlns (node) "Get \"xmlns\" attribute of NODE, or nil if not present." (jabber-xml-get-attribute node 'xmlns)) (defun jabber-xml-path (xml-data path) "Find sub-node of XML-DATA according to PATH. PATH is a vaguely XPath-inspired list. Each element can be: a symbol go to first child node with this node name cons cell car is string containing namespace URI, cdr is string containing node name. Find first matching child node. any string character data of this node." (let ((node xml-data)) (while (and path node) (let ((step (car path))) (cond ((symbolp step) (setq node (car (jabber-xml-get-children node step)))) ((consp step) ;; This will be easier with namespace-aware use ;; of xml.el. It will also be more correct. ;; Now, it only matches explicit namespace declarations. (setq node (cl-dolist (x (jabber-xml-get-children node (intern (cdr step)))) (when (string= (jabber-xml-get-attribute x 'xmlns) (car step)) (cl-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) "Evaluate BODY with ATTRIBUTES bound to their values in XML-DATA. ATTRIBUTES must be a list of symbols, as present in XML-DATA." (declare (indent 2) (debug (sexp form body))) `(let ,(mapcar #'(lambda (attr) (list attr `(jabber-xml-get-attribute ,xml-data ',attr))) attributes) ,@body)) (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) ;;; jabber-xml.el ends here. emacs-jabber/lisp/jabber.el000066400000000000000000000201311476345337400161240ustar00rootroot00000000000000;;; jabber.el --- A minimal Jabber client -*- lexical-binding: t; -*- ;; Author: Magnus Henoch ;; Maintainer: wgreenhouse ;; Keywords: comm ;; Homepage: https://codeberg.org/emacs-jabber/emacs-jabber ;; Package-Requires: ((emacs "27.1") (fsm "0.2.0") (srv "0.2")) ;; Version: 0.9.0 ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - Tom Berger - object@intelectronica.net ;; SSL - Support, mostly inspired by Gnus ;; Copyright (C) 2005 - Georg Lehner - jorge@magma.com.ni ;; This file is a part of jabber.el. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; Commentary: ;; jabber.el is an XMPP client for Emacs. XMPP (also known as ;; 'Jabber') is the IETF-standard federated instant messaging protocol ;; - see http://xmpp.org for more information. ;;; History: ;; ;;; Code: (require 'cl-lib) (require 'goto-addr) ;; These are variables shared with more than one section. For ;; instance, `jabber-process-buffer' is used in jabber-core.el but also in ;; jabber-conn.el. ;; Placing these variable definitions before using them avoid ;; byte-compile warnings. Moreover, it is common practice to define ;; variables before its usage. (defvar jabber-enable-legacy-features-p nil) ;; This was originally defined in jabber-core.el (defvar jabber-process-buffer " *-jabber-process-*" "The name of the process buffer.") ;; Shared between jabber-core.el and jabber-alert.el (defvar jabber-xml-data) (defcustom jabber-debug-keep-process-buffers nil "If nil, kill process buffers when the process dies. Contents of process buffers might be useful for debugging." :type 'boolean :group 'jabber-debug) (defcustom jabber-silent-mode nil "If non-nil, do not ask for confirmation for some operations. DANGEROUS!" :type 'boolean :group 'jabber) ;;; these customize fields should come first (defgroup jabber nil "Jabber instant messaging" :group 'applications) ;;;###autoload (defcustom jabber-account-list nil "List of Jabber accounts. Each element of the list is a cons cell describing a Jabber account, where the car is a JID and the CDR is an alist. JID is a full Jabber ID string (e.g. foo@bar.tld). You can also specify the resource (e.g. foo@bar.tld/emacs). The following keys can be present in the alist: :password is a string to authenticate ourself against the server. It can be empty. If you don't want to store your password in your Emacs configuration, try auth-source (info node `(auth)Top'). :network-server is a string identifying the address to connect to, if it's different from the server part of the JID. :port is the port to use (default depends on connection type). :connection-type is a symbol. Valid symbols are `starttls', `network' and `ssl'. Only JID is mandatory. The rest can be guessed at run-time. Examples: Two accounts without any special configuration: \((\"foo@example.com\") (\"bar@example.net\")) One disabled account with a non-standard port: \((\"romeo@montague.net\" (:port . 5242) (:disabled . t))) If you don't have SRV and STARTTLS capabilities in your Emacs, configure a Google Talk account like this: \((\"username@gmail.com\" (:network-server . \"talk.google.com\") (:connection-type . ssl)))" :type '(repeat (cons :tag "Account information" (string :tag "JID") (set :format "%v" (cons :format "%v" (const :format "" :disabled) (const :tag "Disabled" t)) (cons :format "%v" (const :format "" :password) (string :tag "Password")) (cons :format "%v" (const :format "" :network-server) (string :tag "Network server")) (cons :format "%v" (const :format "" :port) (integer :tag "Port" 5222)) (cons :format "%v" (const :format "" :connection-type) (choice :tag "Connection type" ;; XXX: detect whether we have STARTTLS? option ;; for enforcing encryption? (const :tag "STARTTLS" starttls) (const :tag "Unencrypted" network) (const :tag "Legacy SSL/TLS" ssl)))))) :group 'jabber) (defcustom jabber-default-show "" "Default show state." :type '(choice (const :tag "Online" "") (const :tag "Chatty" "chat") (const :tag "Away" "away") (const :tag "Extended away" "xa") (const :tag "Do not disturb" "dnd")) :group 'jabber) (defcustom jabber-default-status "" "Default status string." :type 'string :group 'jabber) (defcustom jabber-default-priority 10 "Default priority." :type 'integer :group 'jabber) ;;; guess internal dependencies! (require 'jabber-util) (require 'jabber-menu) (require 'jabber-xml) (require 'jabber-conn) (require 'jabber-core) (require 'jabber-logon) (require 'jabber-roster) (require 'jabber-presence) (require 'jabber-alert) (require 'jabber-chat) (require 'jabber-disco) (require 'jabber-iq) (require 'jabber-widget) (require 'jabber-register) (require 'jabber-search) (require 'jabber-browse) (require 'jabber-muc) (require 'jabber-muc-nick-completion) (require 'jabber-version) (require 'jabber-ahc-presence) (require 'jabber-modeline) (require 'jabber-watch) (require 'jabber-activity) (require 'jabber-vcard) (require 'jabber-events) (require 'jabber-chatstates) (require 'jabber-vcard-avatars) (require 'jabber-autoaway) (require 'jabber-time) (require 'jabber-truncate) ;;;###autoload (defvar *jabber-current-status* nil "The user's current presence status.") ;;;###autoload (defvar *jabber-current-show* nil "The user's current presence show.") ;;;###autoload (defvar *jabber-current-priority* nil "The user's current priority.") (defvar *jabber-status-history* nil "History of status messages.") (defgroup jabber-faces nil "Faces for displaying Jabber instant messaging." :group 'jabber) (defface jabber-title-small '((t (:weight bold :width semi-expanded :height 1.0 :inherit variable-pitch))) "Face for small titles." :group 'jabber-faces) (defface jabber-title-medium '((t (:weight bold :width expanded :height 2.0 :inherit variable-pitch))) "Face for medium titles." :group 'jabber-faces) (defface jabber-title-large '((t (:weight bold :width ultra-expanded :height 3.0 :inherit variable-pitch))) "Face for large titles." :group 'jabber-faces) (defgroup jabber-debug nil "debugging options" :group 'jabber) ;;;###autoload (defconst jabber-presence-faces '(("" . jabber-roster-user-online) ("away" . jabber-roster-user-away) ("xa" . jabber-roster-user-xa) ("dnd" . jabber-roster-user-dnd) ("chat" . jabber-roster-user-chatty) ("error" . jabber-roster-user-error) (nil . jabber-roster-user-offline)) "Mapping from presence types to faces.") (defconst jabber-presence-strings `(("" . ,(jabber-propertize "Online" 'face 'jabber-roster-user-online)) ("away" . ,(jabber-propertize "Away" 'face 'jabber-roster-user-away)) ("xa" . ,(jabber-propertize "Extended Away" 'face 'jabber-roster-user-xa)) ("dnd" . ,(jabber-propertize "Do not Disturb" 'face 'jabber-roster-user-dnd)) ("chat" . ,(jabber-propertize "Chatty" 'face 'jabber-roster-user-chatty)) ("error" . ,(jabber-propertize "Error" 'face 'jabber-roster-user-error)) (nil . ,(jabber-propertize "Offline" 'face 'jabber-roster-user-offline))) "Mapping from presence types to readable, colorized strings.") ;;;###autoload (defun jabber-customize () "Customize Jabber options." (interactive) (customize-group 'jabber)) ;;;###autoload (defun jabber-info () "Open jabber.el manual." (interactive) (info "jabber")) (provide 'jabber) ;;; jabber.el ends here. emacs-jabber/tests/000077500000000000000000000000001476345337400145535ustar00rootroot00000000000000emacs-jabber/tests/Makefile.am000066400000000000000000000006141476345337400166100ustar00rootroot00000000000000# LOG_COMPILER was introduced in Automake 1.12; don't expect "make # check" or "make distcheck" to work with earlier versions. LOG_COMPILER = env top_builddir=$(top_builddir) $(EMACS) -batch -L $(top_builddir) -L $(top_srcdir) -L $(srcdir) -l TESTS = load-all.el skip-tag-forward.el history.el jabberd.el nick-change-fail.el TESTS += caps-hash.el parse-next-stanza.el dist_noinst_DATA = $(TESTS) emacs-jabber/tests/caps-hash.el000066400000000000000000000031271476345337400167470ustar00rootroot00000000000000;; Test disco hash against examples in XEP-0115 -*- lexical-binding: t; -*- (message "Let's go") (condition-case e (require 'jabber-disco) (error (message "disco bad! %S" e))) (message "more") (condition-case e (require 'jabber-widget) (error (message "bad! %S" e))) (message "done!") (let ((query (with-temp-buffer (insert " urn:xmpp:dataforms:softwareinfo ipv4 ipv6 Mac 10.5.1 Psi 0.11 ") (car (xml-parse-region (point-min) (point-max)))))) (message "parsed xml") (unless (equal "q07IKJEyjvHSyhy//CH0CxmKi8w=" (jabber-caps-ver-string query "sha-1")) (error "Incorrect caps hash"))) emacs-jabber/tests/history.el000066400000000000000000000032121476345337400165740ustar00rootroot00000000000000;; Tests for history -*- lexical-binding: t; -*- (require 'jabber-history) ;; 1. Smoke test (let ((jabber-use-global-history t) (jabber-global-history-filename (make-temp-file "history-test")) ;; Jabber's birthday :) (our-time (encode-time 0 0 0 4 1 1999 0))) (unwind-protect (progn (jabber-history-log-message "in" "romeo@montague.net/Balcony" nil "hi" our-time) (with-temp-buffer (insert-file-contents-literally jabber-global-history-filename) (let ((expected "\\[\"\\([^\"]+\\)\" \"in\" \"romeo@montague.net/Balcony\" \"me\" \"hi\"]\n") (actual (buffer-string))) (unless (string-match expected actual) (error "Testcase 1 failed; %S doesn't match %S" actual expected)) ;; The timestamps don't match for some reason... ;; (let ((timestamp (match-string 1 actual))) ;; (unless (equal (jabber-parse-time timestamp) our-time) ;; (error "Testcase 1 failed; timestamp %S didn't match %S (%S vs %S)" timestamp (jabber-encode-time our-time) (jabber-parse-time timestamp) our-time))) ))) (delete-file jabber-global-history-filename))) ;; 2. Test with unwritable history file - should not signal an error ;; This should reflect out-of-disk condition too. (let ((jabber-use-global-history t) (jabber-global-history-filename (make-temp-file "history-test"))) (set-file-modes jabber-global-history-filename #o444) (unwind-protect (progn (jabber-history-log-message "in" "romeo@montague.net/Balcony" nil "hi" nil) (message "Please ignore the preceding \"Unable to write history\" error message.") ;; No error signalled - we're done. ) (delete-file jabber-global-history-filename))) emacs-jabber/tests/jabberd.el000066400000000000000000000115151476345337400164710ustar00rootroot00000000000000;;; tests/jabberd.el --- -*- lexical-binding: t; -*- ;; Test the client by capturing its input and output into a virtual ;; jabber server. This is not a test in itself, but a framework for ;; actual tests. (require 'jabber) (defvar jabberd-stanza-handlers '(jabberd-sasl jabberd-iq) "List of stanza handler hooks. These functions are called in order with two arguments, the client FSM and the stanza, until one function returns non-nil, indicating that it has handled the stanza.") (defvar jabberd-iq-get-handlers '(("jabber:iq:roster" . jabberd-iq-empty-success) ("jabber:iq:auth" . jabberd-iq-auth-get)) "Alist of handlers for IQ get stanzas. The key is the namespace of the request (a string), and the value is a function to handle the request. The function takes two arguments, the client FSM and the stanza.") (defvar jabberd-iq-set-handlers '(("urn:ietf:params:xml:ns:xmpp-bind" . jabberd-iq-bind) ("urn:ietf:params:xml:ns:xmpp-session" . jabberd-iq-empty-success) ("jabber:iq:auth" . jabberd-iq-empty-success)) "Alist of handlers for IQ set stanzas. The key is the namespace of the request (a string), and the value is a function to handle the request. The function takes two arguments, the client FSM and the stanza.") (defun jabberd-connect () (setq *jabber-virtual-server-function* #'jabberd-handle) (jabber-connect "romeo" "montague.net" nil nil "foo" nil nil 'virtual)) (defun jabberd-handle (fsm text) ;; First, parse stanzas from text into sexps. (let (stanzas) (with-temp-buffer (insert text) (goto-char (point-min)) ;; Skip processing directive (when (looking-at "<\\?xml[^?]*\\?>") (delete-region (match-beginning 0) (match-end 0))) (catch 'unfinished (while t (push (if (prog1 (looking-at ". (when (string-match "version=[\"']" stanza) (jabberd-send fsm '(features ((xmlns . "http://etherx.jabber.org/streams")) ;; Interesting implementation details ;; of jabber.el permit us to send all ;; features at once, without caring about ;; which step we are at. (mechanisms ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl")) (mechanism () "DIGEST-MD5")) (bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind"))) (session ((xmlns . "urn:ietf:params:xml:ns:xmpp-session"))))))) (t (run-hook-with-args-until-success 'jabberd-stanza-handlers fsm stanza)))))) (defun jabberd-send (fsm stanza) (jabber-log-xml fsm "receive" stanza) (fsm-send fsm (list :stanza stanza))) (defun jabberd-sasl (fsm stanza) "Pretend to authenticate the client by SASL." (when (eq (jabber-xml-node-name stanza) 'auth) (jabberd-send fsm '(success ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl")))) t)) (defun jabberd-iq (fsm stanza) "Handle IQs from the client." (when (eq (jabber-xml-node-name stanza) 'iq) (jabber-xml-let-attributes (type _id) stanza (cond ((member type '("get" "set")) (let* ((table (if (string= type "get") jabberd-iq-get-handlers jabberd-iq-set-handlers)) (ns (jabber-iq-xmlns stanza)) (function (cdr (assoc ns table)))) (when function (funcall function fsm stanza))))) t))) (defun jabberd-iq-empty-success (fsm stanza) "Send an empty IQ result to STANZA." (jabber-xml-let-attributes (id) stanza (jabberd-send fsm `(iq ((type . "result") (id . ,id)))))) (defun jabberd-iq-bind (fsm stanza) "Do resource binding for the virtual server." (let ((id (jabber-xml-get-attribute stanza 'id))) (jabberd-send fsm `(iq ((type . "result") (id . ,id)) (bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind")) (jid () "romeo@montague.net/Orchard")))))) (defun jabberd-iq-auth-get (fsm stanza) (jabber-xml-let-attributes (id) stanza (jabberd-send fsm `(iq ((type . "result") (id . ,id)) (query ((xmlns . "jabber:iq:auth")) (username) (password) (digest) (resource)))))) (provide 'jabberd) emacs-jabber/tests/load-all.el000066400000000000000000000003541476345337400165640ustar00rootroot00000000000000;; Test that all files can be loaded -*- lexical-binding: t; -*- (let* ((default-directory (expand-file-name (getenv "top_builddir"))) (elc-files (file-expand-wildcards "*.elc" t))) (dolist (f elc-files) (load f nil t))) emacs-jabber/tests/nick-change-fail.el000066400000000000000000000060451476345337400201620ustar00rootroot00000000000000;; -*- lexical-binding: t; -*- ;; When the user tries to change nickname in an MUC room, and the ;; server denies this, we should detect this instead of believing ;; that the user was thrown out of the room. (require 'jabberd) (defconst ncf-room-name "orchard@romeo-and-juliet.shakespeare.lit" "The MUC room used for this test.") (defun ncf-presence (fsm stanza) "Stanza handler. This function is a very simple MUC implementation. It allows a user to enter the room named by `ncf-room-name' with the nick \"Romeo\"." (jabber-xml-let-attributes (to) stanza (when (and (eq (jabber-xml-node-name stanza) 'presence) (string= (jabber-jid-user to) ncf-room-name)) (let ((nick (jabber-jid-resource to))) ;; Allow only the nick Romeo (if (string= nick "Romeo") (jabberd-send fsm `(presence ((from . ,to)) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((affiliation . "none") (role . "participant")))))) (jabberd-send fsm `(presence ((from . ,to) (type . "error")) (x ((xmlns . "http://jabber.org/protocol/muc#user"))) (error ((code . "409") (type . "cancel")) (conflict ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))))))))))) (add-hook 'jabberd-stanza-handlers #'ncf-presence) (add-hook 'jabber-post-connect-hooks #'ncf-do) (setq jabber-muc-disable-disco-check t) (setq jabber-debug-log-xml t) (defvar ncf-done nil) ;; We need an extra variable for the error, as errors from timers are ;; ignored. (defvar ncf-error nil) (defun ncf-assert (assert-this format &rest args) (unless assert-this (let ((msg (apply #'format format args))) (setq ncf-error msg) (error "%s" msg)))) (defun ncf-do (jc) (setq ncf-done t) (jabber-muc-join jc ncf-room-name "Romeo") ;; We need a delay here, so that the client can process the response ;; stanza. (sit-for 0.01) (let ((buffer (jabber-muc-get-buffer ncf-room-name))) (ncf-assert (get-buffer buffer) "Couldn't enter MUC room") (ncf-assert *jabber-active-groupchats* "Entering room not recorded") ;; Now, do an unallowed nickname change. (jabber-muc-join jc ncf-room-name "Mercutio") (sit-for 0.01) ;; We should still consider ourselves to be in the room as Romeo (ncf-assert (assoc ncf-room-name *jabber-active-groupchats*) "We thought we left the room, but we didn't") (ncf-assert (string= (cdr (assoc ncf-room-name *jabber-active-groupchats*)) "Romeo") "We thought we changed nickname, but we didn't"))) (jabberd-connect) (with-timeout (5 (error "Timeout")) (while (not ncf-done) (sit-for 0.1))) (when ncf-error (princ (format "nick-change-fail test FAILED: %s " ncf-error)) (princ "Conversation was:\n") (with-current-buffer "*-jabber-xml-log-romeo@montague.net-*" (princ (buffer-string))) (let ((muc-buffer (get-buffer (jabber-muc-get-buffer ncf-room-name)))) (if muc-buffer (with-current-buffer muc-buffer (princ "Contents of groupchat buffer:\n") (princ (buffer-string))) (princ "Groupchat buffer not created.\n"))) (kill-emacs 1)) emacs-jabber/tests/parse-next-stanza.el000066400000000000000000000010521476345337400204570ustar00rootroot00000000000000;; Tests for jabber-xml-parse-next-stanza -*- lexical-binding: t; -*- (require 'jabber-xml) (defun parse-it (text) (with-temp-buffer (insert text) (jabber-xml-parse-next-stanza))) (unless (equal (parse-it "") '((presence ((from . "foo@example.com/resource") (type . "unavailable") (to . "bar@example.com"))))) (error "Testcase 1 failed")) (unless (equal (parse-it "ANONYMOUSDIGEST-MD5PLAIN") (error "Testcase 1 failed")) ;; 2. XML with CDATA (unless (parses-p "]]>") (error "Testcase 2 failed")))