tclxmpp000075500000000000000000000000001470446212700120515ustar00nobodynobodytclxmpp/ChangeLog000064400000000000000000001067761470446212700137230ustar00nobodynobody2024-10-18 Sergei Golovan * xmpp/xml.tcl: Encode XML to UTF-8 before sending it to the tDom XML parser. This implements a workaround for a bug in tDom which cannot parse a string with characters beyond BMP. * xmpp/sasl.tcl: Implement the SCRAM-SHA-256 authentication mechanism. 2019-12-06 Sergei Golovan * xmpp/muc.tcl: Do not call the roster callback if a presence stanza is received from the room itself (with empty resource part). these stanzas don't update the room roster. 2019-10-11 Sergei Golovan * examples/jsend.tcl: Add -xml option to send a prepared XML stanza. 2016-01-11 Sergei Golovan * xmpp/xml.tcl: Replace a bunch of control characters by spaces when create XML data to send. 2016-01-07 Sergei Golovan * xmpp/sasl.tcl: Add the user's JID as cdata to the EXTERNAL SASL authentication response. This helps with prosody's mod_auth_ccert. Also, don't register the server part for the EXTERNAL SASL authentication mechaism. * examples/jsend.tcl: Added -cert option with a path to a client certificate. 2016-01-06 Sergei Golovan * xmpp/pkgIndex.tcl, xmpp/sasl.tcl, xmpp/xmpp.tcl: Added preliminary support for the EXTERNAL SASL authentication mechanism. Since it results in adding -from attribute to the ::xmpp::openStream command, the xmpp package version is bumped to 0.3. 2015-12-29 Sergei Golovan * xmpp/starttls.tcl, xmpp/tls.tcl: Added -tls1.1 and -tls1.2 options to support TLS1.1 and TLS1.2 protocols and enabled them by default. Disabled SSLv3 by default. * xmpp/bosh.tcl, xmpp/poll.tcl: Disabled SSLv3 and enabled TLS1.1 and TLS1.2 protocols if available. 2015-12-21 Sergei Golovan * xmpp/pkgIndex.tcl, xmpp/roster.tcl: Fixed the ::xmpp::roster::send routine to send only one item in jabber:iq:roster query (and actually send it). Bumped the xmpp::roster package version to 0.2. 2015-12-20 Sergei Golovan * xmpp/xmpp.tcl: Always add the id attribute to outgoing IQ get or set stanzas. 2015-12-11 Sergei Golovan * xmpp/hints.tcl, xmpp/pkgIndex.tcl: Implemented creating and parsing message processing hints (XEP-0334). * license.terms: Updated copyright years. 2015-11-15 Sergei Golovan * examples/chessbot.tcl, examples/echo.tcl, examples/jsend.tcl, examples/rssbot.tcl: Added the project directory to auto_path to make sure the examples are working in-place. 2015-06-03 Sergei Golovan * Makefile: Added clean target. 2015-06-02 Sergei Golovan * Makefile: Added a simple makefile which installs the TclXMPP and bundled TclXML into /usr/lib and jsend.tcl and rssbot.tcl into /usr/local/bin (by default). * examples/rssbot.tcl: Replaced the literal rssbot.tcl string by $argv0 in short help notice. * examples/rssbot.man: Added a short manpage for the rssbot RSS/XMPP gateway example. 2015-06-01 Sergei Golovan * examples/jsend.tcl: Allow one to rename the jsend.tcl to jsend when installing the examples. * examples/jsend.man: Added a short manual page for the jsend command line client example. 2015-05-11 Sergei Golovan * xmpp/blocking.tcl, xmpp/bosh.tcl, xmpp/muc.tcl, xmpp/ping.tcl, xmpp/poll.tcl: Removed tabulation characters and trailing whitespaces. 2015-04-16 Sergei Golovan * xmpp/search.tcl: Fixed returning the parsed search items list. 2015-04-08 Sergei Golovan * xmpp/sm.tcl: Fixed error with undefined $xlib. 2015-04-07 Sergei Golovan * xmpp/sasl.tcl, xmpp/sm.tcl: Reset the stream management state on new login attempt without resumption. 2015-04-05 Sergei Golovan * xmpp/sm.tcl: Implemented stream resumption support (it's still never used yet). * xmpp/roster.tcl: Removed too modern [lassign] call. * xmpp/auth.tcl, xmpp/component.tcl, xmpp/pkgIndex.tcl, xmpp/sasl.tcl, xmpp/sm.tcl, xmpp/xmpp.tcl: Started implementing the stream management (XEP-0198) protocol. Currently only enabling stream management and requesting/sending acknowledgements is impemented. Stream resumption and calling back the client are to follow. 2015-04-02 Sergei Golovan * xmpp/sasl.tcl: Added a description header to the ::xmpp::sasl::auth command. 2015-03-30 Sergei Golovan * xmpp/data.tcl: Removed Tclx's [lcontain] calls. 2015-03-29 Sergei Golovan * *: Removed no longer used SVN keyword placeholders. 2015-03-25 Sergei Golovan * doc/xmpp_xml.man, examples/chessbot.tcl, license.terms, xmpp/sasl.tcl, xmpp/starttls.tcl: Fixed copyright years. 2014-04-11 Sergei Golovan * examples/chessbot.tcl: Fixed typo and made it work with the newer GNUChess. 2014-02-16 Sergei Golovan * xmpp/roster.tcl: Removed usage of -index lsearch option because it doesn't work with Tcl 8.4. 2014-02-02 Sergei Golovan * xmpp/xmpp.tcl: Added function which returns the current XMPP stream features. * xmpp/roster.tcl: Implemented roster versioning as in XEP-0237 and later in RFC-6121 (thanks to Jan Zachorowski). 2014-01-30 Sergei Golovan * xmpp/sasl.tcl: Send XMPP session IQ only if it's present in the stream features list. 2014-01-28 Sergei Golovan * doc/xmpp_xml.man: Fixed header (Fixes issue 3). 2013-12-23 Sergei Golovan * xmpp/bosh.tcl, xmpp/poll.tcl, xmpp/starttls.tcl, xmpp/tls.tcl: Explicitly disabled SSLv2 and enabled TLSv1 protocols. 2013-12-04 Sergei Golovan * xmpp/bosh.tcl: Reduced empty packets polling frequency. Fixed attributes list on rescheduling. * xmpp/bosh.tcl: Fixed sending of the terminate stream request. 2013-12-03 Sergei Golovan * xmpp/bosh.tcl: Initially implemented BOSH (XEP-0124 and XEP-0206) transport support. * xmpp/poll.tcl, xmpp/tcp.tcl, xmpp/tls.tcl, xmpp/zlib.tcl: Added reopenStream command, enabled synchronous closing of XMPP stream. Bumped package versions to 0.2. * xmpp/xmpp.tcl: Added synchronous closing of XMPP stream. Use reopenStream transport command were appropriate. Bumped package version to 0.1.1. * xmpp/pkgIndex.tcl: Bumped transport package versions to 0.2 because their user interface has been changed and the XMPP package version to 0.1.1. * xmpp/poll.tcl: Code cleanup with using security keys. * xmpp/transport.tcl: Added support for reopenStream command. Bumped package version to 0.2. * xmpp/sasl.tcl: Added another call to Debug proc. * examples/jsend.tcl: Removed cdata payload from jabber:iq:last response. Use synchronous stream closing before exit. Added BOSH transport support. 2013-11-10 Sergei Golovan * license.terms: Fixed copyright years. 2013-11-08 Sergei Golovan * xmpp/sasl.tcl: Added preliminary SCRAM mechanism support (it requires not included into Tcllib yet SASL::SCRAM package, see http://core.tcl.tk/tcllib/tktview?name=b8f35b9883). Use empty authzid instead of user's bare JID. * examples/jsend.tcl: Use -host option for a server to connect to. Added -digest option to allow jsend to use plaintext-based SASL protocols. 2013-04-21 Sergei Golovan * xmpp/https.tcl: Removed domain flag from the NTLM greeting message. This fixes authentication on ISA 2006 proxy. * xmpp/sasl.tcl: Added EXTERNAL mechanism. * xmpp/xml.tcl: Added -from option to the stream header, which is useful for components. 2012-05-18 Sergei Golovan * xmpp/zlib.tcl: Added support for the native zlib coming with Tcl 8.6. It takes precedense over the Ztcl package. * xmpp/pkgIndex.tcl: Added the xmpp::sasl package requirement into xmpp::full loading code. 2012-05-10 Sergei Golovan * xmpp/pconnect.tcl, xmpp/tcp.tcl, xmpp/tls.tcl, xmpp/zlib.tcl: Removed use of ceptcl because IPv6 support is now transparently provided by Tcl/Tk 8.6. Also, removed -domain from the listed socket options. 2012-02-02 Sergei Golovan * xmpp/jid.tcl: Don't crash if stringprepped JID contains prohibited characters in it as they might be outside BMP which Tcl/Tk don't support properly. 2011-02-27 Sergei Golovan * xmpp/disco.tcl: Removed [lassign] because it requires Tcl 8.5. * xmpp/stanzaerror.tcl: Fixed message for 'auth' error type (autorization error instead of authentication error). 2010-11-11 Sergei Golovan * examples/rssbot.tcl: Fixed typos in IQ registration. * xmpp/iq.tcl: Explicitly add from attribute to the response stanzas to make IQ registering working in connections serving multiple JIDs. * xmpp/https.tcl, xmpp/socks4.tcl, xmpp/socks5.tcl: Moved canceling timeout events up before debug output to prevent accidental firing. 2010-09-27 Sergei Golovan * xmpp/privacy.tcl: Fixed processing zero order when parsing incoming privacy list (thanks to Vitaly Takmazov for bug triaging). * xmpp/xmpp.tcl: Don't call non-existent status procedure (closes: #1). 2010-07-31 Sergei Golovan * xmpp/zlib.tcl: Forget about zlib package from Ztcl to prevent another clash with http package. 2010-05-02 Sergei Golovan * xmpp/muc.tcl: Fixed race condition when reporting MUC joininig result back to a caller. 2010-04-30 Sergei Golovan * xmpp/privacy.tcl: Fixed registering jabber:iq:privacy namespace for privacy lists pushes. 2010-03-08 Sergei Golovan * xmpp/pubsub.tcl: Fixed a few typos (thanks to Jan Zachorowski). 2010-02-15 Sergei Golovan * xmpp/muc.tcl: Fixed lowering affiliation to outcast. 2010-02-13 Sergei Golovan * xmpp/muc.tcl: Fixed processing error answer to join or change nickname queries. 2010-02-08 Sergei Golovan * xmpp/muc.tcl: Fixed typos. 2010-02-06 Sergei Golovan * xmpp/muc.tcl: Execute callback on nickname change after the new presence stanza with affiliation and role is arrived. Added an experimental workaround for services which don't mirror stanza id in error presences and don't add status code 110 to my own stanzas. 2010-02-01 Sergei Golovan * xmpp/jid.tcl, doc/xmpp_jid.man, xmpp/muc.tcl, xmpp/presence.tcl: Added a new command replaceResource which replaces the resource part of a JID by a given string. Renamed bareJid to removeResource for consistency. * xmpp/muc.tcl: Added medium lebel commands to unban user and to destroy a room. Fixed malformed JIDs creation in case when their resource parts are empty. Don't reset own nickname on exit from a room. 2010-01-30 Sergei Golovan * xmpp/muc.tcl: Added a new reported MUC event (disconnect). Fixed race condition on leaving room and immediately entering. * xmpp/muc.tcl: Fixed calling events command on affiliation and role changes. Implemented low and medium level commands for manipulating users affiliations and roles. 2010-01-29 Sergei Golovan * xmpp/stanzaerror.tcl: Fixed numeric code processing for legacy (pre-XMPP) error stanzas. * xmpp/jid.tcl: Cache stringprepped JID parts because stringprep is really slow. * xmpp/data.tcl, xmpp/delay.tcl, xmpp/register.tcl, xmpp/roster.tcl, xmpp/search.tcl, xmpp/stanzaerror.tcl: Don't use true and false as boolean values because Tcl 8.3 doesn't understand them. * xmpp/presence.tcl: Added a new package xmpp::presence which stores received presence information and allows to register presence callbacks inside TclXMPP library. * xmpp/xmpp.tcl: Require xmpp::presence package and ignore illegal received presence priorities (non-integer) and presence statuses (not 'avay', 'chat', 'dnd', 'xa'). * xmpp/muc.tcl: Started to implement MUC (XEP-0045). Currently joining, leaving room, and changing nickname are implemented. * xmpp/pkgIndex.tcl: Added xmpp::presence and xmpp::muc packages. 2010-01-25 Sergei Golovan * *: Added 2010 to copyright statements. 2010-01-24 Sergei Golovan * xmpp/jid.tcl: Added stringprep support in JID normalization. 2010-01-23 Sergei Golovan * xmpp/negotiate.tcl, xmpp/register.tcl, xmpp/search.tcl: Reimplemented calling back in a more sane way. Removed unused variable tmp. * xmpp/jid.tcl, doc/xmpp_jid.man: Renamed stripResource procedure to bareJid. The former name is retained for backward compatibility. * xmpp/annotations.tcl, xmpp/blocking.tcl, xmpp/bob.tcl, xmpp/bookmarks.tcl, xmpp/delimiter.tcl, xmpp/disco.tcl, xmpp/metacontacts.tcl, xmpp/ping.tcl, xmpp/privacy.tcl, xmpp/private.tcl, xmpp/roster.tcl, xmpp/xmpp.tcl: Removed useless errorcodes from error returns. * xmpp/auth.tcl, xmpp/disco.tcl, xmpp/register.tcl, xmpp/search.tcl, xmpp/starttls.tcl: Fixed labels (capitalization) and error messages which are displayed to a user. 2010-01-18 Sergei Golovan * xmpp/privacy.tcl: Fixed processing server replies in synchronous mode if multiple connections are opened (closes: http://yo.jabber.ru/bugzilla/show_bug.cgi?id=394). 2010-01-17 Sergei Golovan * xmpp/https.tcl, xmpp/socks4.tcl, xmpp/socks5.tcl, xmpp/pconnect.tcl: Return "timeout" status instead of "abort" in case of timeout because "abort" means breaking connection process by a user. 2010-01-16 Sergei Golovan * xmpp/tcp.tcl, xmpp/tls.tcl, xmpp/zlib.tcl: Fixed opening connection in asynchronous mode where the operation must always succeede and its status is reported via a callback. * xmpp/sasl.tcl, xmpp/stanzaerror.tcl, xmpp/streamerror.tcl: Changed capitalization of error messages. 2010-01-14 Sergei Golovan * xmpp/tcp.tcl, xmpp/tls.tcl, xmpp/zlib.tcl: Fixed aborting underlying connection. Fixed connecting in asynchronous mode. 2010-01-08 Sergei Golovan * xmpp/compress.tcl, xmpp/starttls.tcl, xmpp/tls.tcl, xmpp/zlib.tcl: Process errors when switching to or opening ZLIB or TLS channel and don't throw it immediately to a user. 2010-01-04 Sergei Golovan * xmpp/pkgIndex.tcl, xmpp/privacy.tcl: Implemented low-level interface to XMPP privacy lists (XEP-0016). Synchronous and asynchronous query modes are supported. 2009-12-29 Sergei Golovan * xmpp/auth.tcl, xmpp/component.tcl, xmpp/compress.tcl, xmpp/iq.tcl, xmpp/pconnect.tcl, xmpp/sasl.tcl, xmpp/starttls.tcl, xmpp/tcp.tcl, xmpp/tls.tcl, xmpp/transport.tcl, xmpp/xml.tcl, xmpp/xmpp.tcl, xmpp/zlib.tcl: Removed incorrect -errorinfo options from return calls, and a bit improved error reporting in some catch calls. * xmpp/xmpp.tcl: Disconnect before connecting a stream if it isn't in disconnected state. Also, don't react to stale stream headers after stream abortion. 2009-10-27 Sergei Golovan * xmpp/poll.tcl, xmpp/xml.tcl: Removed trailing whitespaces. 2009-10-18 Sergei Golovan * xmpp/disco.tcl: Fixed calling back when info or items are received with status error or abort. 2009-10-12 Sergei Golovan * examples/rssbot.tcl: Ignore messages with empty bodies. 2009-10-11 Sergei Golovan * examples/rssbot.tcl: Fixed removing extra space characters from HTML descriptions. Fixed processing uppercase tags in HTML descriptions. * examples/jsend.tcl: Use ::xmpp::jid::split to parse from JID instead of ::mime::parseaddress. 2009-10-10 Sergei Golovan * examples/rssbot.tcl: Get XML encoding from XML document itself and not from HTTP header. Also, strip HTML markup from items description. 2009-10-04 Sergei Golovan * examples/jsend.tcl: Restored historical name and added -date option to include delay subelement with a given date. * examples/rssbot.tcl: Adapted RSS bot from tkabber examples/tools to TclXMPP. Also, added thorough dates parsers taken from Tclers' wiki (http://wiki.tcl.tk/13094 and http://wiki.tcl.tk/24074). 2009-08-17 Sergei Golovan * auth.tcl, component.tcl, compress.tcl, sasl.tcl, starttls.tcl: Added protection from a duble abort or timeout. Set JID after authentiaction only in case of success. * streamerror.tcl, xml.tcl: Changed the way of generating stream XMLNS prefix. 2009-08-11 Sergei Golovan * xmpp/ping.tcl: Fixed IQ registering (register ping tag instead of query) and removed received XML from regitered callback invocation because it's useless as it's supposed to be always empty. * xmpp/blocking.tcl: Added support for Simple Communication Blocking (XEP-0191). It is untested because there's no server implementations yet. 2009-08-03 Sergei Golovan * xmpp/ping.tcl, xmpp/pkgIndex.tcl: Added support for XMPP Ping (XEP-0199). Client-side only for now. * xmpp/ping.tcl: Added reply to XMPP ping requests support. 2009-07-31 Sergei Golovan * xmpp/xml.tcl: Add unique XMLNS prefixes when serializing XML element if it contains complex attributes with XMLNS prefix prepended to attribute names. Otherwise serializing of parsed XML could end by not-well-formed stanza. * examples/chessbot.tcl, examples/echo.tcl, examples/xsend.tcl: Fixed processing secrets in config files, and enclosed all arithmetic expressions into curly brackets. 2009-05-21 Sergei Golovan * xmpp/search.tcl: Fixed typo in procedure name. 2009-04-23 Sergei Golovan * xmpp/disco.tcl: Fixed disco#info and disco#items reply when the query was received to a non-empty node. 2009-04-21 Sergei Golovan * xmpp/pubsub.tcl: Fixed IQ types in queries which request items or configuration forms. * xmpp/pubsub.tcl: Fixed data forms returning when requesting subscription options, node configuration, default node config options. 2009-04-17 Sergei Golovan * xmpp/https.tcl: Fixed typo in status message. * xmpp/disco.tcl: Do not cache certain error conditions which may be temporary. 2009-04-07 Sergei Golovan * xmpp/sasl.tcl: Do encode username and password into UTF-8 charset if SASL package version is less than 1.3.2. 2009-04-05 Sergei Golovan * xmpp/auth.tcl, xmpp/sasl.tcl: Store user JID as a connection property. It is useful for pubsub and PEP modules. * xmpp/pubsub.tcl, xmpp/pkgIndex.tcl: Added new pubsub interface module (XEP-0060). * xmpp/pep.tcl, xmpp/pkgIndex.tcl: Added new PEP interface module (XEP-0163). 2009-04-03 Sergei Golovan * xmpp/https.tcl: Fixed proxy NTLM authentication. Also, added a few additional debug messages. 2009-03-31 Sergei Golovan * xmpp/sasl.tcl: Took into account that MD5-DIGEST SASL mechanism in Tcllib converts username and password to UTF-8 itself. Also, split SASL callbacks into two separate parts (one for users, another for components). 2009-03-30 Sergei Golovan * xmpp/poll.tcl: Do not send Proxy-Authorization header if username and password are empty. * xmpp/https.tcl, xmpp/ntlm.tcl, xmpp/pkgIndex.tcl: Removed redundant ntlm package and switched to SASL::NTLM for NTLM authentication at an HTTPS proxy server. 2009-03-29 Sergei Golovan * xmpp/pconnect.tcl, xmpp/https.tcl, xmpp/socks4.tcl, xmpp/socks5.tcl: Return human-readable messages when errors occur. Added abortion procedures to socks4 and socks5 packages, and a timeout procedure to pconnect package. * xmpp/socks4.tcl, xmpp/socks5.tcl: Fixed reconstructing destination address returned by a SOCKS proxy. Added support for IPv6 adresses to socks5 package. * xmpp/poll.tcl: Added version to http package requirement to prevent version 1.0 loading. 2009-03-27 Sergei Golovan * xmpp/zlib.tcl: Added a hack which doesn't allow to load xmpp::zlib package if zlib from Ztcl can't be found. Also, moved zlib command to ::xmpp::transport::zlib namespace because it isn't standard, so if, for example, http package tries to get compressed data it fails. 2009-03-22 Sergei Golovan * xmpp/negotiate.tcl: Added the possibility of unregistering features. * xmpp/pconnect.tcl, xmpp/poll.tcl: Added -proxyfilter option for a callback which is invoked if a connecting routine needs info on which proxy to use for a particular host. 2009-03-17 Sergei Golovan * xmpp/disco.tcl: Cache negative answers to info and items queries also. Also, check if an item is already in the cache before adding it to prevent duplicates when several queries are run simultaneously. * xmpp/ntlm.tcl: Fixed calls to DES::des procedure in case if the encrypting text begins with dash. 2009-03-15 Sergei Golovan * xmpp/data.tcl: Parse data forms media items. 2009-03-14 Sergei Golovan * xmpp/disco.tcl: Fixed searching cached info and items. 2009-03-13 Sergei Golovan * xmpp/bob.tcl: Removed erroneous cid: prefix from CID values. * xmpp/bob.tcl: Fixed typo. 2009-03-12 Sergei Golovan * xmpp/bob.tcl, xmpp/pkgIndex.tcl: Added a simple interface to Bits of Binary (XEP-0231). 2009-03-05 Sergei Golovan * xmpp/iq.tcl: Fixed unregistering XMLNS if it was registered for more than one callbacks for different types and/or tags. 2009-02-28 Sergei Golovan * xmpp/delay.tcl: Changed output format of ::xmpp::delay::parse procedure to preserve optional from attribute. 2009-02-27 Sergei Golovan * xmpp/disco.tcl: Include in JID identity all received information and not only category, type and name. 2009-02-23 Sergei Golovan * xmpp/disco.tcl, xmpp/pkgIndex.tcl: Added basic Service Discovery support (XEP-0030). * *: Added 2009 to copyright statements. 2009-02-18 Sergei Golovan * xmpp/zlib.tcl: Ignore errors from fconfigure -flush input. * xmpp/https.tcl, xmpp/socks4.tcl, xmpp/socks5.tcl: Fixed comments. 2009-02-15 Sergei Golovan * xmpp/annotations.tcl, xmpp/bookmarks.tcl, xmpp/delimiter.tcl, xmpp/metacontacts.tcl: Added serialize/deserialize procedures which convert from/to internal representaton to/from XML. They are useful in roster export/import routines. 2009-02-12 Sergei Golovan * xmpp/metacontacts.tcl: Made interface to retrieve/store procedures more convenient. 2009-02-11 Sergei Golovan * xmpp/private.tcl: Added simple interface to private XML storage (XEP-0049). * xmpp/annotations.tcl: Added storing/retieving roster notes (XEP-0145). * xmpp/delimiter.tcl: Added storing/retrieving nested groups delimiter (XEP-0083). * xmpp/metacontacts.tcl: Added storing/retrieving roster metacontacts (XEP-0209). * xmpp/pkgIndex.tcl: Added the above packages. * xmpp/bookmarks.tcl, xmpp/pkgIndex.tcl: Added storing/retrieving conference bookmarks (XEP-0048). 2009-02-10 Sergei Golovan * xmpp/tls.tcl: Changed -password option to -passwordcommand to avoid clash with password for proxy. 2009-02-09 Sergei Golovan * xmpp/https.tcl: Changed HTTP protocol version in CONNECT query from 1.1 to 1.0. 2008-12-17 Sergei Golovan * xmpp/poll.tcl: Fixed return value for procedure which pushes text to an XMPP server. 2008-12-14 Sergei Golovan * xmpp/xmpp.tcl: Don't allow arbitrary message type. Made debug messages a bit more clear and added timestamp to them. 2008-11-18 Sergei Golovan * doc/*.man: Made ViM modelines prettier. 2008-11-09 Sergei Golovan * xmpp/xmpp.tcl: Added a new log callback which is invoked on every outgoing and incoming packet. 2008-11-03 Sergei Golovan * xmpp/tcp.tcl, xmpp/zlib.tcl: Fixed typo in a procedure which returns connection socket IP address. * xmpp/negotiate.tcl, pkgIndex.tcl: Added a package which implements feature negotiation protocol (XEP-0020). * xmpp/poll.tcl: Fixed typo. * xmpp/data.tcl: Fixed typo. 2008-11-02 Sergei Golovan * xmpp/data.tcl: Added a procedure which fills in form fields for submission. * xmpp/search.tcl, xmpp/pkgIndex.tcl: Added a package which implements support for Jabber Search (XEP-0055) queries. * xmpp/data.tcl: Treat missing form type as "form". * xmpp/search.tcl: Fixed typo and removed implicit field label. * xmpp/register.tcl, xmpp/pkgIndex.tcl: Added a new package which implements support for In-Band Registration (XEP-0077) queries. * tclxml/*.tcl, doc/*.man, xmpp/register.tcl: Removed tabulation characters from the sources and added ViM modelines which expand them into spaces. * xmpp/xmpp.tcl: Don't add empty "to" attribute to sent IQ stanzas. * xmpp/register.tcl: Added support for data forms in error service responses and added support for changing password. * xmpp/data.tcl: Added support for creating data forms. * xmpp/data.tcl: Added procedure which creates form field tuple in a human readable way. Also, added field description and required fields support for created data forms. Also, added basic result form support. 2008-11-01 Sergei Golovan * xmpp/data.tcl, xmpp/pkgIndex.tcl: Added a new package for working with data forms (XEP-0004). * xmpp/data.tcl: Return form type when searching for a data form. Parse field elements in result forms. * xmpp/data.tcl: Fixed parsing items in a result form. 2008-10-31 Sergei Golovan * xmpp/xmpp.tcl: Protected unsetting of a variable which stores abort commands because it may be unset during abort call. 2008-10-30 Sergei Golovan * xmpp/tcp.tcl, xmpp/tls.tcl, xmpp/zlib.tcl: Protected reading from the XMPP socket and disconnect it in case of read error. 2008-10-27 Sergei Golovan * xmpp/tcp.tcl, xmpp/tls.tcl, xmpp/zlib.tcl: Removed calls to non-existent fubction ::xmpp::log. 2008-10-25 Sergei Golovan * xmpp/xmpp.tcl: Don't check the from address for IQ relies and errors because in order to be reliable it requires full JID normalization. Use random IQ IDs to prevent accidental or malicious ID clashing. * xmpp/iq.tcl: Use empty string instead of "ignore" to signal that the IQ answer will be later. 2008-10-24 Sergei Golovan * xmpp/xmpp.tcl: Fixed error stanza when aborting IQ on timeout, made calling back when sending IQ failed to after idle, fixed IQ callbacks to compare normalized JIDs when searching for reply. 2008-10-21 Sergei Golovan * xmpp/xml.tcl: Fixed typo. * xmpp/https.tcl: Added missing close bracket. * xmpp/socks4.tcl: Fixed version number. 2008-10-20 Sergei Golovan * doc/xmpp_jid.man, doc/xmpp_xml.man: Removed colons from filenames as they cause problems on non-Unix systems. * xmpp/tcp.tcl, xmpp/tls.tcl, xmpp/zlib.tcl: Fixed variable name. * doc/xmpp.man: Added preliminary manual page for xmpp package. * xmpp/starttls.tcl, xmpp/tls.tcl: Changed -callback option to -verifycommand and added -infocommand option which specifies command to call upon successfully established TLS connection with socket TLS status. 2008-10-19 Sergei Golovan * xmpp/xmpp.tcl: Fixed race condition where transport was already closed, but was tried to send packets. * xmpp/tcp.tcl, xmpp/tls.tcl, xmpp/zlib.tcl: Clear readable fileevent script when the socket is closed by the other side. Otherwise it can be triggered continuously. Also, close socket. * xmpp/xmpp.tcl: Removed unnecessary rescheduling of ForcedDisconnect call which now can't be executed twice (one time on the end of strteam, and another time on the closure of the socket). * xmpp/tcp.tcl, xmpp/tls.tcl, xmpp/zlib.tcl: Removed unnecessary error hidings by catch. * doc/xmpp::jid.man, doc/xmpp::xml.man: Added preliminary manual pages for xmpp::jid and xmpp::xml packages. Currently they contain only lists of commands. * xmpp/jid.tcl: Code cleanup. 2008-10-18 Sergei Golovan * xmpp/jid.tcl: Added default resource value (empty string). * xmpp/sasl.tcl: Use jid procedure instead of directly concatenating user and server names. * xmpp/xmpp.tcl: Added packetID command which returns the next free packet ID. Also, removed packet ID resetting on disconnect. * xmpp/xml.tcl: Added toTabbedText procedure for XML pretty-printing. 2008-10-17 Sergei Golovan * xmpp/streamerror.tcl: Added error condition to the call of error client callback in additin to a readable message. * xmpp/xmpp.tcl: Return client callback code and error info to a caller. It is useful for IQ callback where return code "return" prevents processing the packet by internam IQ engine. Also, move general IQ callback upper to make it executed not only for types "get" and "set" but also for all other types. * xmpp/xml.tcl: Added a hack which helps to parse XML file with a declararion at the beginning if tDOM parser is used. Also, fixed a typo in create XML procedure. * xmpp/delay.tcl: Added a new procedure which checks if the message is delayed. * xmpp/sasl.tcl: Renamed local variable which clashed with global one. * xmpp/auth.tcl, xmpp/compress.tcl, xmpp/sasl.tcl, xmpp/starttls.tcl: Return full error stanza instead of error message. * xmpp/xmpp.tcl: Fixed transport switching. * xmpp/sasl.tcl: Fixed typo. * xmpp/xmpp.tcl: Fixed sending text. * xmpp/xml.tcl: Fixed creating XML element if it has empty subelements. * xmpp/streamerror.tcl: Removed extra closing parenthesis from error message. 2008-10-15 Sergei Golovan * xmpp/xml.tcl: Added default (empty) XMLNS for empty prefix. Also, closed the outmost XML element in data parsing routine. * xmpp/xml.tcl: Fixed using of Tcl-only parser from data parsing routine. 2008-10-14 Sergei Golovan * tclxml/sgmlparser.tcl, tclxml/tclparser.tcl, tclxml/xmltcl.tcl, xmpp/xml.tcl: Use non-XMLNS aware parser and process XMLNS prefixes manually. This helps to ignore unbound prefixes when tDOM expat parser is used. * xmpp/iq.tcl: Fixed typo. * xmpp/socks4.tcl: Changed case of ok and error status. * xmpp/xml.tcl: Fixed bug with forgotten namespaces stack while resetting XML parser. Also, simplified prefixes processing. 2008-10-13 Sergei Golovan * xmpp/starttls.tcl, xmpp/tls.tcl: Made TLS import routine use its default options if they weren't specified during STARTTLS or opening TLS socket. Added options to choose protocol version to XMPP TLS interface. * xmpp/xmpp.tcl: Added general IQ command (unfinished yet). 2008-10-12 Sergei Golovan * xmpp/roster.tcl: Removed unnecessary argument from roster item command call. 2008-10-11 Sergei Golovan * xmpp/xmpp.tcl, examples/chessbot.tcl, examples/echo.tcl, examples/xsend.tcl: Changed syntax of host and port arguments in ::xmpp::connect because they clashed with proxy host and port options. * xmpp/compress.tcl, xmpp/starttls.tcl: Made the compress and starttls procedures return new stream session ID in case of success. This allows to perform non-SASL authentication over compressed or encrypted streams if a server offers it. * xmpp/sasl.tcl: Fixed typo. 2008-10-10 Sergei Golovan * xmpp/delay.tcl: Joined procedures which create delay element following different XEPs into a single procedure. * xmpp/dns.tcl: Replaced own procedure which returns nameservers list by a procedure from the dns package. Added DNS lookup abort procedure and procedures to resolve HTTP-poll and BOSH URLs. * examples/xsend.tcl, xmpp/https.tcl, xmpp/starttls.tcl, xmpp/xml.tcl, xmpp/xmpp.tcl: Fitted code into 80-character width strings. * tclxml/*: Removed 8.1 suffix from file names because they will never be used with Tcl 8.0 or older. * examples/xsend.tcl: Added note about the authors. * xmpp/tcp.tcl, xmpp/tls.tcl, xmpp/zlib.tcl: Fixed bugs in abort procedure where XML parser was destroyed unconditionally. * xmpp/zlib.tcl: Added -level option which allows to specify compression level. * xmpp/socks4.tcl, xmpp/socks5.tcl: Moved to ::pconnect namespace. * xmpp/auth.tcl, xmpp/component.tcl, xmpp/ntlm.tcl, xmpp/pconnect.tcl, xmpp/stanzaerror.tcl: Clarified descriptions. * xmpp/compress.tcl, xmpp/sasl.tcl, xmpp/starttls.tcl: Moved removing stream features trace upper in abort procedures. * xmpp/poll.tcl: Changed -proxyHost, -proxyPort, -proxyUsername, -proxyPassword and -proxyUseragent options to -host, -port, -username, -password and -useragent to make them consistent with ::pconnect::socket options. * xmpp/jid.tcl: Fixed file name in description. * xmpp/pkgIndex.tcl: Added xmpp::delay package. * xmpp/starttls.tcl: Changed -cacertstore option to -castore to make it more similar to -cafile and -cadir. * xmpp/compress.tcl, xmpp/dns.tcl, xmpp/iq.tcl, xmpp/poll.tcl, xmpp/starttls.tcl, xmpp/tcp.tcl, xmpp/tls.tcl, xmpp/transport.tcl, xmpp/zlib.tcl: Added descriptions to all defined procedures. * xmpp/compress.tcl: Added -level option to choose compression level when switching transport to zlib. * examples/chessbot.tcl, examples/echo.tcl, examples/xsend.tcl, xmpp/auth.tcl, xmpp/component.tcl, xmpp/poll.tcl, xmpp/roster.tcl, xmpp/tcp.tcl, xmpp/tls.tcl, xmpp/transport.tcl, xmpp/xmpp.tcl, xmpp/zlib.tcl: Removed camel case from dash-options. * xmpp/stanzaerror.tcl: Added creating legacy error to error procedure (with -old option). 2008-10-09 Sergei Golovan * xmpp/auth.tcl: Added a few checks for existing authentication token in callbacks. Also, did a little code cleanup and clarified comments. 2008-10-08 Sergei Golovan * xmpp/transport.tcl, xmpp/poll.tcl, xmpp/tcp.tcl, xmpp/tls.tcl, xmpp/zlib.tcl: Added ip command (it will be used when IP should be reported to another JID, e.g. in file transfer). * xmpp/auth.tcl, xmpp/component.tcl, xmpp/compress.tcl, xmpp/sasl.tcl, xmpp/starttls.tcl, xmpp/xmpp.tcl: Added a simple way to abort long procedures (connection, stream opening, STARTTLS, compress, SASL, authentication). The corresponding abortion procedure is stored in a variable and is called if necessary. * xmpp/auth.tcl, xmpp/component.tcl, xmpp/compress.tcl, xmpp/https.tcl, xmpp/iq.tcl, xmpp/poll.tcl, xmpp/roster.tcl, xmpp/sasl.tcl, xmpp/socks4.tcl, xmpp/socks5.tcl, xmpp/starttls.tcl, xmpp/xmpp.tcl: Changed syntax of debug calls. * xmpp/roster.tcl: Made parsing the server answer a bit more efficient. * xmpp/iq.tcl: Changed the way registered IQ handlers are stored in an array. * xmpp/xmpp.tcl: Added comments before all defined procedures. 2008-10-06 Sergei Golovan * */*: Removed spaces at the end of lines and expanded tabs in all sources (except TclXML code). 2008-10-05 Sergei Golovan * examples/*, tclxml/*, xmpp/*: Initial version of XMPP client library. It includes a Tcl-only XML parser from some old version of TclXML and a few examples. tclxmpp/Makefile000064400000000000000000000030021470446212700135630ustar00nobodynobody# TclXMPP Makefile # Tcl can't find libraries in /usr/local hierarchy, so install # the libraries into /usr/lib LIBDIR = /usr/lib # The binaries and docs go to /usr/local by default PREFIX = /usr/local BINDIR = $(PREFIX)/bin DOCDIR = $(PREFIX)/share/doc/tclxmpp MANDIR = $(PREFIX)/share/man SUBDIRS = xmpp \ tclxml MANPAGES3 = doc/xmpp.3 \ doc/xmpp_jid.3 \ doc/xmpp_xml.3 MANPAGES1 = examples/jsend.1 \ examples/rssbot.1 all: doc clean: rm -f $(MANPAGES3) $(MANPAGES1) doc: $(MANPAGES3) $(MANPAGES1) %.3: %.man mpexpand nroff $< $@ %.1: %.man mpexpand nroff $< $@ install: install-lib install-bin install-doc install-examples install-lib: install -d $(DESTDIR)$(LIBDIR) cp -dr --no-preserve=ownership $(SUBDIRS) $(DESTDIR)$(LIBDIR) install-bin: install -d $(DESTDIR)$(BINDIR) install -m 755 -T examples/jsend.tcl $(DESTDIR)$(BINDIR)/jsend install -m 755 -T examples/rssbot.tcl $(DESTDIR)$(BINDIR)/rssbot install-doc: doc install -d $(DESTDIR)$(DOCDIR) install -d $(DESTDIR)$(MANDIR)/man1 install -d $(DESTDIR)$(MANDIR)/man3 install -m 644 ChangeLog license.terms $(DESTDIR)$(DOCDIR) install -m 644 $(MANPAGES1) $(DESTDIR)$(MANDIR)/man1 install -m 644 $(MANPAGES3) $(DESTDIR)$(MANDIR)/man3 install-examples: install -d $(DESTDIR)$(DOCDIR)/examples install -m 755 examples/*.tcl $(DESTDIR)$(DOCDIR)/examples # Update TclXMPP from Fossil repository up: test -f .fslckout -o -f _FOSSIL_ && fossil update .PHONY: all clean doc install install-lib install-bin install-doc install-examples up tclxmpp/doc000075500000000000000000000000001470446212700126165ustar00nobodynobodytclxmpp/doc/xmpp.man000064400000000000000000000066111470446212700143620ustar00nobodynobody[comment {-*- tcl -*- doctools manpage}] [manpage_begin xmpp 3 0.1] [copyright {2008-2010 Sergei Golovan }] [moddesc {Tcl XMPP library}] [titledesc {The main XMPP library}] [require Tcl 8.3] [require xmpp [opt 0.1]] [description] [para] This module is part of the XMPP library. It implements main XMPP routines. [section "COMMANDS"] [list_begin definitions] [call [cmd "::xmpp::new"] \ [opt [arg "xlib"]] \ [opt [arg "-packetcommand cmd"]] \ [opt [arg "-messagecommand cmd"]] \ [opt [arg "-presencecommand cmd"]] \ [opt [arg "-iqcommand cmd"]] \ [opt [arg "-statuscommand cmd"]] \ [opt [arg "-errorcommand cmd"]] \ [opt [arg "-disconnectcommand cmd"]]] Create new XMPP token. [call [cmd "::xmpp::free"] [arg "xlib"]] Frees XMPP token resources. [call [cmd "::xmpp::connect"] \ [arg "xlib"] \ [opt "[arg "host"] [opt [arg "port"]]"] \ [opt [arg "-transport transport"]] \ [opt [arg "-command cmd"]] \ [opt [arg "args"]]] Connect to a given host. [call [cmd "::xmpp::openStream"] \ [arg "xlib"] \ [arg "server"] \ [opt [arg "-xmlns:stream uri"]] \ [opt [arg "-xmlns uri"]] \ [opt [arg "-xml:lang lang"]] \ [opt [arg "-version ver"]] \ [opt [arg "-timeout timeout"]] \ [opt [arg "-command cmd"]]] Open XMPP stream. [call [cmd "::xmpp::closeStream"] \ [arg "xlib"]] Close XMPP stream. [call [cmd "::xmpp::disconnect"] \ [arg "xlib"]] Close XMPP stream and disconnect. [call [cmd "::xmpp::sendMessage"] \ [arg "xlib"] \ [arg "to"] \ [opt [arg "-from from"]] \ [opt [arg "-type type"]] \ [opt [arg "-id id"]] \ [opt [arg "-subject subject"]] \ [opt [arg "-thread thread"]] \ [opt [arg "-body body"]] \ [opt [arg "-error error"]] \ [opt [arg "-xlist elements"]]] Send XMPP message stanza. [call [cmd "::xmpp::sendPresence"] \ [arg "xlib"] \ [opt [arg "-from from"]] \ [opt [arg "-to to"]] \ [opt [arg "-type type"]] \ [opt [arg "-id id"]] \ [opt [arg "-show show"]] \ [opt [arg "-status status"]] \ [opt [arg "-priority priority"]] \ [opt [arg "-error error"]] \ [opt [arg "-xlist elements"]]] Send XMPP presence stanza. [call [cmd "::xmpp::sendIQ"] \ [arg "xlib"] \ [arg "type"] \ [opt [arg "-from from"]] \ [opt [arg "-to to"]] \ [opt [arg "-id id"]] \ [opt [arg "-query query"]] \ [opt [arg "-error error"]] \ [opt [arg "-timeout timeout"]] \ [opt [arg "-command cmd"]]] Send XMPP info/query stanza. [call [cmd "::xmpp::abortIQ"] \ [arg "xlib"] \ [arg "id"] \ [arg "status"] \ [arg "error"]] Abort waiting for IQ reply. [call [cmd "::xmpp::outXML"] \ [arg "token"] \ [arg "xmlElement"]] Send XML element over the XMPP stream. [call [cmd "::xmpp::outText"] \ [arg "token"] \ [arg "text"]] Send Text over the XMPP stream. [call [cmd "::xmpp::ip"] \ [arg "xlib"]] Return an IP address of an opened socket. [call [cmd "::xmpp::packetID"] \ [arg "xlib"]] Return the next unused ID for XMPP packet. [list_end] [section "AUTHORS"] Sergei Golovan [keywords Tcl XMPP] [comment { vim: set ft=tcl ts=8 sw=4 sts=4 et: }] [manpage_end] tclxmpp/doc/xmpp_jid.man000064400000000000000000000033471470446212700152130ustar00nobodynobody[comment {-*- tcl -*- doctools manpage}] [manpage_begin xmpp::jid 3 0.1] [copyright {2008-2010 Sergei Golovan }] [moddesc {Tcl XMPP library}] [titledesc {Operations with JIDs}] [require Tcl 8.3] [require xmpp::jid [opt 0.1]] [description] [para] This module is part of the XMPP library. It implements basic operations with JIDs (Jabber IDs). [section "COMMANDS"] [list_begin definitions] [call [cmd "::xmpp::jid::jid"] \ [arg "node"] \ [arg "server"] \ [opt [arg "resource"]]] Create JID from node, server and resource parts. If missing, resource is empty. [call [cmd "::xmpp::jid::split"] \ [arg "jid"] \ [arg "nodeVar"] \ [arg "serverVar"] \ [arg "resourceVar"]] Split JID into three parts and assign the specified variables. [call [cmd "::xmpp::jid::node"] [arg "jid"]] Return the node part of a specified JID. [call [cmd "::xmpp::jid::server"] [arg "jid"]] Return the server part of a specified JID. [call [cmd "::xmpp::jid::resource"] [arg "jid"]] Return the resource part of a specified JID. [call [cmd "::xmpp::jid::replaceResource"] [arg "jid"] [arg "resource"]] Replace the resource part of a JID by a given string. [call [cmd "::xmpp::jid::removeResource"] [arg "jid"]] Return the bare JID (a JID without resource part) corresponding to a specified JID. [call [cmd "::xmpp::jid::normalize"] [arg "jid"]] Return the normalized JID corresponding to a specified JID. [call [cmd "::xmpp::jid::equal"] [arg "jid1"] [arg "jid2"]] Compare two given JIDs (in normalized form) and return true if they are equivalent or false otherwise. [list_end] [section "AUTHORS"] Sergei Golovan [keywords Tcl XMPP JID] [comment { vim: set ft=tcl ts=8 sw=4 sts=4 et: }] [manpage_end] tclxmpp/doc/xmpp_xml.man000064400000000000000000000066341470446212700152470ustar00nobodynobody[comment {-*- tcl -*- doctools manpage}] [manpage_begin xmpp::man 3 0.1] [copyright {2008-2014 Sergei Golovan }] [moddesc {Tcl XMPP library}] [titledesc {XML parser wrapper}] [require Tcl 8.3] [require msgcat] [require tdom 0.8] [require xmpp::xml [opt 0.1]] [description] [para] This module is part of the XMPP library. It implements XML parsing and working with. [section "COMMANDS"] [list_begin definitions] [call [cmd "::xmpp::xml::new"] \ [arg "streamHeaderCmd"] \ [arg "streamTrailerCmd"] \ [arg "stanzaCmd"]] Create new XMPP stream parser. [call [cmd "::xmpp::xml::free"] [arg "token"]] Frees XMPP parser resources. [call [cmd "::xmpp::xml::parser"] \ [arg "token"] \ [arg "command"] \ [opt [arg "args"]]] Execute a given command. [call [cmd "::xmpp::xml::reset"] [arg "token"]] Reset XMPP stream parser. [call [cmd "::xmpp::xml::parseData"] \ [arg "data"] \ [opt [arg "stanzaComd"]]] Parse given data using a new XML parser and either return parsed XML or call the callback on every top level XML element. [call [cmd "::xmpp::xml::create"] \ [arg "tag"] \ [opt [arg "-xmlns xmlns"]] \ [opt [arg "-attrs attrs"]] \ [opt [arg "-cdata cdata"]] \ [opt [arg "-subelement subelement"]] \ [opt [arg "-subelements subelementsList"]]] Create XML element. [call [cmd "::xmpp::xml::split"] \ [arg "xmlelement"] \ [arg "tagVar"] \ [arg "xmlnsVar"] \ [arg "attrsVar"] \ [arg "cdataVar"] \ [arg "subelsVar"] \ [opt [arg "nextCdataVar"]]] Split XML data into five or six variables. [call [cmd "::xmpp::xml::merge"] \ [arg "tag"] \ [arg "xmlns"] \ [arg "attrs"] \ [arg "cdata"] \ [arg "subels"] \ [opt [arg "nextCdata"]]] Merge five or six variables into an XML element. [call [cmd "::xmpp::xml::isAttr"] \ [arg "attrList"] \ [arg "attrName"]] Check if a given attribute list contains a given attribute. [call [cmd "::xmpp::xml::getAttr"] \ [arg "attrList"] \ [arg "attrName"]] Return a given attribute value from an attribute list. [call [cmd "::xmpp::xml::getCdata"] \ [arg "xmlElement"]] Return all character data from a given element. [call [cmd "::xmpp::xml::getFirstCdata"] \ [arg "xmlElement"]] Return character data chunk which is located before the first XML subelement in a given element. [call [cmd "::xmpp::xml::getNextCdata"] \ [arg "xmlElement"]] Return character data chunk which is located after the given XML element. [call [cmd "::xmpp::xml::streamHeader"] \ [arg "server"] \ [arg "-xmlns:stream uri"] \ [arg "-xmlns uri"] \ [opt [arg "-xml:lang lang"]] \ [opt [arg "-version ver"]]] Return XMPP stream header. [call [cmd "::xmpp::xml::streamTrailer"]] Return XMPP stream trailer. [call [cmd "::xmpp::xml::lang"]] Return XML language string derived from msgcat preferences. [call [cmd "::xmpp::xml::toText"] \ [arg "xmlElement"] \ [opt [arg "parentNamespace"]]] Serialize a given XML element. [call [cmd "::xmpp::xml::toTabbedText"] \ [arg "xmlElement"] \ [opt [arg "parentNamespace"]]] Serialize a given XML element adding indentations. [list_end] [section "AUTHORS"] Sergei Golovan [keywords Tcl XMPP XML] [comment { vim: set ft=tcl ts=8 sw=4 sts=4 et: }] [manpage_end] tclxmpp/examples000075500000000000000000000000001470446212700136675ustar00nobodynobodytclxmpp/examples/chessbot.tcl000075500000000000000000000353361470446212700163010ustar00nobodynobody#!/usr/bin/env tclsh # chessbot.tcl -- # # This file is an example provided with the XMPP library. It implements # a simple XMPP bot which uses GNU Chess engine and Tkabber Chess plugin # protocol to play chess. # # Copyright (c) 2008-2014 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. # HACK: adding the following directory to auto_path to make this script # working in-place lappend auto_path [file join [file dirname [info script]] ..] package require xmpp::full # Register games:board XMLNS ::xmpp::iq::register set * games:board ProcessGamesBoard # ExecChessEngine -- # # Start GNU Chess process and setup the opened pipe. # # Arguments: # xlib XMPP library token. # jid Opponent's JID. # gid Game ID. # # Result: # A pipe to communicate with GNU Chess process. # # Side effects: # A new GNU Chess process is created. # # Bugs: # Since there's a possibility to close game window which will never # be noticed by the bot (and gnuchess will never be killed) the process # is started with option --easy and at least doesn't consume much # processor power. A proper solution would be to monitor game # periodically (though the protocol doesn't give such an option). proc ExecChessEngine {xlib jid gid} { set fd [open "|gnuchess --xboard --easy" r+] fconfigure $fd -blocking 0 -buffering line fileevent $fd readable [list ReadFromChessEngine $xlib $jid $gid $fd] return $fd } # WriteToChessEngine -- # # Send a command to a running chess process. # # Arguments: # jid Opponent's JID. # gid Game ID. # text Text to send. # # Result: # Empty string. # # Side effects: # A chess process gets the specified string (and will reply later). proc WriteToChessEngine {jid gid text} { global games puts "WriteToChessEngine $jid $gid $text" puts $games([list $jid $gid]) $text return } # ReadFromChessEngine -- # # Read a string from a running chess process, and process it. # # Arguments: # xlib XMPP library token. # jid Opponent's JID. # gid Game ID. # fd Pipe to communicate with GNU Chess process. # # Result: # Empty string. # # Side effects: # If EOF is got (chess process is finished) then the corresponding # game is finished. If a move is got then it's sent to the opponent. # If the game is finished with some defined result then quit message # is sent to the engine. proc ReadFromChessEngine {xlib jid gid fd} { global games gets $fd text puts "ReadFromChessEngine $jid $gid $text" if {[eof $fd]} { close $fd catch {unset games([list $jid $gid])} } if {[regexp {^My move is\s*:\s*(\S+)} $text -> move]} { SendTurnIQ $xlib $jid $gid [Move $move] } elseif {[regexp {^offer draw} $text]} { SendTurnIQ $xlib $jid $gid [::xmpp::xml::create accept] } elseif {[regexp {^resign} $text]} { SendTurnIQ $xlib $jid $gid [::xmpp::xml::create resign] } elseif {[regexp {^(1-0|0-1|1/2-1/2) \{.*\}} $text]} { WriteToChessEngine $jid $gid quit } return } # Move -- # # Map GNU Chess move g2g1q to # queen. # # Arguments: # move GNU Chess move. # # Result: # Tkabber chess protocol move XML element. # # Side effects: # None. proc Move {move} { set map {a 0 b 1 c 2 d 3 e 4 f 5 g 6 h 7} set mlist [split $move ""] set cf [string map $map [lindex $mlist 0]] set rf [lindex $mlist 1] incr rf -1 set ct [string map $map [lindex $mlist 2]] set rt [lindex $mlist 3] incr rt -1 switch -- [lindex $mlist 4] { q {set subels [list [::xmpp::xml::create promotion -cdata queen]]} r {set subels [list [::xmpp::xml::create promotion -cdata rook]]} b {set subels [list [::xmpp::xml::create promotion -cdata bishop]]} n {set subels [list [::xmpp::xml::create promotion -cdata knight]]} default {set subels {}} } set pos $cf,$rf\;$ct,$rt return [::xmpp::xml::create move -attrs [list pos $pos] \ -subelements $subels] } # SendTurnIQ -- # # Send chess turn query to an opponent. # # Arguments: # xlib XMPP library token. # jid Opponent's JID. # gid Game ID. # xmlElement Turn subelement (move, resign etc.) # # Result: # Empty string. # # Side effects. # A query is sent. proc SendTurnIQ {xlib jid gid xmlElement} { ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create turn \ -xmlns games:board \ -attrs [list type chess id $gid] \ -subelement $xmlElement] \ -to $jid \ -command [list CheckTurnResult $jid $gid] return } # CheckTurnResult -- # # Check the answer on chess turn query. # # Arguments: # jid Opponent's JID. # gid Game ID. # status Query status (ok or error). # xml Either error stanza (if status is error) or result stanza. # # Result: # Empty string. # # Side effects: # If status isn't ok then game $gid with opponent $jid is finished. proc CheckTurnResult {jid gid status xml} { if {![string equal $status ok]} { WriteToChessEngine $jid $gid quit } return } # Turn -- # # Parse received turn XML element and send it to GNU Chess process. # # Arguments: # jid Opponent's JID. # gid Game ID. # xmlElements Turn subelements (move, resign etc.). # # Result: # Either tuple {error, ...} or tuple {result, ...}. # # Side effects: # A move is passed to GNU Chess engine in case of successful parsing. # # Bugs: # A success is returned regardless if the move is legal or not. This # means that illegal move will break game process (GNU Chess will not # accept it, but the opponent will not receive error). proc Turn {jid gid xmlElements} { global games set map {0 a 1 b 2 c 3 d 4 e 5 f 6 g 7 h} set move 0 set draw 0 foreach element $xmlElements { ::xmpp::xml::split $element tag xmlns attrs cdata subels switch -- $tag { move { set pos [::xmpp::xml::getAttr $attrs pos] set poss [split $pos ";"] if {[llength $poss] == 2} { set pos1 [split [lindex $poss 0] ,] set pos2 [split [lindex $poss 1] ,] if {[llength $pos1] == 2 && [llength $pos2] == 2} { set cf [string map $map [lindex $pos1 0]] set rf [lindex $pos1 1] incr rf set ct [string map $map [lindex $pos2 0]] set rt [lindex $pos2 1] incr rt set prom "" foreach selement $subels { ::xmpp::xml::split $selement stag sxmlns sattrs \ scdata ssubels if {[string equal $stag promotion]} { switch -- $scdata { queen {set prom q} rook {set prom r} bishop {set prom b} knight {set prom n} } } } set move 1 } } } resign { WriteToChessEngine $jid $gid quit return [list result [::xmpp::xml::create turn \ -xmlns games::board \ -attrs [list type chess \ id $gid]]] } accept { # TODO if {0} { WriteToChessEngine $jid $gid quit return [list result [::xmpp::xml::create turn \ -xmlns games::board \ -attrs [list type chess \ id $gid]]] } else { return {error modify not-acceptable} } } draw { set draw 1 } } } if {$move} { WriteToChessEngine $jid $gid $cf$rf$ct$rt$prom if {$draw} { WriteToChessEngine $jid $gid draw } return [list result [::xmpp::xml::create turn \ -xmlns games:board \ -attrs [list type chess id $gid]]] } else { return {error modify not-acceptable} } } # CreateGame -- # # Create new chess game. # # Arguments: # xlib XMPP library token. # jid Opponent's JID. # gid Game ID. # color Opponents figures color (white or black). # # Result: # XML stanza to return to opponent. # # Side effects: # A new GNU Chess process is started (its pipe is stored in a global # variable) and if color is black then the engine is asked to make turn # first. proc CreateGame {xlib jid gid color} { global games set games([list $jid $gid]) [ExecChessEngine $xlib $jid $gid] if {[string equal $color black]} { WriteToChessEngine $jid $gid go } return [list result \ [::xmpp::xml::create create \ -xmlns games:board \ -attrs [list type chess id $gid]]] } # Exists -- # # Check if the game exists. # # Arguments: # jid Opponent's JID. # gid Game ID. # # Result: # 1 if a variable with corresponding pipe exists, 0 otherwise. # # Side effects: # None. proc Exists {jid gid} { global games return [info exists games([list $jid $gid])] } # ProcessGamesBoard -- # # Parse query with XMLNS games:board and return result or error. # # Arguments: # xlib XMPP library token. # from From JID. # xmlElement Query stanza. # # Result: # Either tuple {error, ...} or tuple {result, ...}. # # Side effects: # If a query is correct then the corresponding procedure is called. proc ProcessGamesBoard {xlib from xmlElement args} { ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels set game [::xmpp::xml::getAttr $attrs type] if {![string equal $game chess]} { return {error cancel service-not-available} } if {[::xmpp::xml::isAttr $attrs id]} { set gid [::xmpp::xml::getAttr $attrs id] } else { return {error modify bad-request} } switch -- $tag { create { if {[::xmpp::xml::isAttr $attrs color]} { set color [::xmpp::xml::getAttr $attrs color] switch -- $color { white - black {} default { return {error modify bad-request} } } } else { set color white } if {[Exists $from $gid]} { return {error modify bad-request} } else { return [CreateGame $xlib $from $gid $color] } } turn { if {[Exists $from $gid]} { return [Turn $from $gid $subels] } else { return {error cancel item-not-found} } } } return {error modify bad-request} } array set options [list -host "" \ -port 5222 \ -server localhost \ -username user \ -resource "GNU Chess" \ -password secret \ -compress false \ -tls false \ -starttls true \ -sasl true \ -poll false \ -url ""] if {[catch { if {([file exists [set file .chessbotrc.tcl]]) \ || ([file exists [set file ~/.chessbotrc.tcl]])} { set args {} source $file array set at [list -permissions 600] array set at [file attributes $file] if {([set x [lsearch -exact $args "-password"]] >= 0) \ && ![expr {$x % 2}] \ && ![string match *00 $at(-permissions)]} { error "file should be mode 0600" } if {[llength $args] > 0} { array set options $args } } } result]} { puts stderr "error in $file: $result" } array set options $argv if {[string equal $options(-host) ""]} { set options(-host) $options(-server) } # Create an XMPP library instance set xlib [::xmpp::new] # Connect to a server if {$options(-poll)} { # HTTP-polling ::xmpp::connect $xlib -transport poll \ -url $options(-url) } elseif {$options(-tls)} { # Legacy SSL ::xmpp::connect $xlib $options(-host) $options(-port) -transport tls } else { # TCP channel (with possible upgrade) ::xmpp::connect $xlib $options(-host) $options(-port) } if {$options(-sasl) || \ (!$options(-tls) && ($options(-starttls) || $options(-compress)))} { # STARTTLS and stream compression require SASL authentication # Open XMPP stream ::xmpp::openStream $xlib $options(-server) -version 1.0 if {!$options(-tls) && $options(-starttls)} { # STARTTLS ::xmpp::starttls::starttls $xlib } elseif {!$options(-tls) && $options(-compress)} { # Compression ::xmpp::compress::compress $xlib } # Authenticate ::xmpp::sasl::auth $xlib -username $options(-username) \ -password $options(-password) \ -resource $options(-resource) \ } else { # Non-SASL authentication # Open XMPP stream set sessionID [::xmpp::openStream $xlib $options(-server)] # Authenticate ::xmpp::auth::auth $xlib -sessionid $sessionID \ -username $options(-username) \ -password $options(-password) \ -resource $options(-resource) } # Send initial presence ::xmpp::sendPresence $xlib -priority -1 # Start event loop vwait forever # vim:ts=8:sw=4:sts=4:et tclxmpp/examples/echo.tcl000075500000000000000000000074211470446212700153770ustar00nobodynobody#!/usr/bin/env tclsh # echo.tcl -- # # This file is an example provided with the XMPP library. It implements # a simple XMPP server-side component which returns every received packet # to sender. This component authenticates using XEP-0225 (Component # Connections) or XEP-0114 (Jabber Component Protocol). # # Copyright (c) 2008-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. # HACK: adding the following directory to auto_path to make this script # working in-place lappend auto_path [file join [file dirname [info script]] ..] package require xmpp package require xmpp::sasl package require xmpp::component # ProcessPacket -- # # Swap from and to packet attribytes and send back the resulting packet. # # Arguments: # xlib XMPP library instance. # xmlElement XMPP packet. # # Result: # Empty string. # # Side effects: # An XMPP packet is sent. proc ProcessPacket {xlib xmlElement} { ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels nextCdata array set tmp $attrs if {![info exists tmp(from)] || ![info exists tmp(to)]} { return } set to $tmp(to) set from $tmp(from) set tmp(to) $from set tmp(from) $to set attrs [array get tmp] set packet \ [::xmpp::xml::merge $tag $xmlns $attrs $cdata $subels $nextCdata] ::xmpp::outXML $xlib $packet return } array set options [list -host "" \ -port 5666 \ -server localhost \ -domain echo.localhost \ -secret secret \ -extra "" \ -jcp true] if {[catch { if {([file exists [set file .echorc.tcl]]) \ || ([file exists [set file ~/.echorc.tcl]])} { set args {} source $file array set at [list -permissions 600] array set at [file attributes $file] if {([set x [lsearch -exact $args "-secret"]] >= 0) \ && ![expr {$x % 2}] \ && ![string match *00 $at(-permissions)]} { error "file should be mode 0600" } if {[llength $args] > 0} { array set options $args } } } result]} { puts stderr "error in $file: $result" } array set options $argv if {[string equal $options(-host) ""]} { set options(-host) $options(-server) } # Create an XMPP instance. set xlib [::xmpp::new -packetcommand ProcessPacket] # Connect to an XMPP server. ::xmpp::connect $xlib $options(-host) $options(-port) if {!$options(-jcp)} { # XEP-0225 # Open XMPP stream. set sessionID \ [::xmpp::openStream $xlib $options(-server) -version 1.0] # Authenticate as a component (XEP-0225). ::xmpp::sasl::auth $xlib -domain $options(-domain) \ -secret $options(-secret) # Bind an extra domain name (XEP-0225). if {![string equal $options(-extra) ""]} { ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create bind \ -xmlns urn:xmpp:component \ -subelement [::xmpp::xml::create hostname \ -cdata $options(-extra)]] } } else { # XEP-0114 # Open XMPP stream (XEP-0114). set sessionID \ [::xmpp::openStream $xlib $options(-domain) \ -xmlns jabber:component:accept] # Authenticate as a component (XEP-0114). ::xmpp::component::auth $xlib -sessionid $sessionID \ -secret $options(-secret) } # Enter event loop. vwait forever # vim:ts=8:sw=4:sts=4:et tclxmpp/examples/jsend.man000064400000000000000000000071441470446212700155540ustar00nobodynobody[comment {-*- tcl -*- doctools manpage}] [manpage_begin jsend 1 0.1] [copyright {2015 Sergei Golovan }] [moddesc {Tcl XMPP library}] [titledesc {Tcl XMPP command line send utility}] [description] [para] This utility is a part of the Tcl XMPP library. It implements a command line client which can send a single or multiple messages via XMPP network. To do that it connects to an XMPP server using specified login and password. [list_begin definitions] [call [cmd jsend] [arg recipient] \ [opt "[option -option] [arg value] ..."]] [para] The required Tcl packages for the [cmd jsend] utility are [arg tls] and quite a few modules from the [arg Tcllib] collection. [para] The client takes one mandatory argument [arg recipient] and a few option-value pairs. The [arg recipient] can be either a JID ot send the messages or literal "[const -]" in which case the messages will be sent to all roster members of the connected JID. [para] The message body to send can be specified in three ways. First it can be a value of "[option -body]" option. Second, if "[option -follow]" is specified, it points to a file which contents will be sent line by line, and after that any apended line will be sent also. And finally, if there's no "[option -body]" or "[option -follow]" options then the message is taken from the standard input. [para] The full list of the command line options follows below: [list_begin definitions] [def "[option -from] [arg jid]"] [para] The sender JID. If there's no [option -host] option then the server part of the specified JID is used to connect to. [def "[option -password] [arg string]"] [para] The sender password. [def "[option -type] [arg normal|chat]"] [para] The message type. Must be one of [const normal] or [const chat]. Defaults to [const chat]. [def "[option -subject] [arg string]"] [para] The message subject. [def "[option -body] [arg string]"] [para] The message body. [def "[option -xhtml] [arg string]"] [para] The XHTML message (see XEP-0071 for details). [def "[option -url] [arg string]"] [para] The URL to attach (see XEP-0066 for details). [def "[option -description] [arg string]"] [para] The description for the URL attached (see XEP-0066 for details). [def "[option -follow] [arg file]"] [para] Follow the specified file for the messages stream. [def "[option -pidfile] [arg file]"] [para] Create the specified file with the PID of the running process. This option is useful together with [option -follow] option. [def "[option -host] [arg hostname]"] [para] Explicit hostname to connect to. [def "[option -port] [arg number]"] [para] Explicit port to connect to. [def "[option -bosh] [arg string]"] [para] BOSH URL (see XEP-0124 and XEP-0206 for details). [def "[option -tls] [arg boolean]"] [para] Whether the old legacy SSL encryption is to be used (defaults to [const false]). [def "[option -starttls] [arg boolean]"] [para] Whether the STARTTLS and therefore the TLS encryption is to be used (defaults to [const true]). [def "[option -sasl] [arg boolean]"] [para] Whether the SASL authentication is to be used (defaults to [const true]). [list_end] [list_end] [section "FILES"] The file .jsendrc.tcl in the current directory or in the current user's home directory is sourced if it's available and is not world readable. It can contain any Tcl code and modify the jsend behavior in any way but its primary goal is to define [var args] list of option-value pairs, e.g. [example { set args {-from fred@example.com/bedrock -password wilma} }] [section "AUTHORS"] Marshall T. Rose, Sergei Golovan [keywords Tcl XMPP] [comment { vim: set ft=tcl ts=8 sw=4 sts=4 et: }] [manpage_end] tclxmpp/examples/jsend.tcl000075500000000000000000000452261470446212700155710ustar00nobodynobody#!/usr/bin/env tclsh # jsend.tcl -- # # This file is an example provided with the XMPP library. It allows to # send messages via XMPP non-interactively. It was initially developed # by Marshall T. Rose and adapted to the XMPP library by Sergei Golovan. # # Copyright (c) 2008-2013 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require sha1 package require tls # HACK: adding the following directory to auto_path to make this script # working in-place lappend auto_path [file join [file dirname [info script]] ..] package require xmpp package require xmpp::transport::bosh package require xmpp::auth package require xmpp::sasl package require xmpp::starttls package require xmpp::roster package require xmpp::delay # Register IQ XMLNS ::xmpp::iq::register get * http://jabber.org/protocol/disco#info \ jsend::iqDiscoInfo ::xmpp::iq::register get * http://jabber.org/protocol/disco#items \ jsend::iqDiscoItems ::xmpp::iq::register get * jabber:iq:last jsend::iqLast ::xmpp::iq::register get * jabber:iq:time jsend::iqTime ::xmpp::iq::register get * jabber:iq:version jsend::iqVersion namespace eval jsend {} proc jsend::sendit {stayP to args} { global xlib global env variable lib variable sendit_result array set options [list -to $to \ -from "" \ -password "" \ -host "" \ -port "" \ -activity "" \ -type chat \ -subject "" \ -body "" \ -xml "" \ -xhtml "" \ -date "" \ -description "" \ -url "" \ -bosh "" \ -tls false \ -starttls true \ -cert "" \ -sasl true \ -digest true] array set options $args if {[string equal $options(-host) ""]} { if {[string first @ $options(-from)] < 0} { set options(-host) [info hostname] } else { set options(-host) [::xmpp::jid::server $options(-from)] } } set params [list from] if {![string equal $options(-to) "-"]} { lappend params to } foreach k $params { if {[string first @ $options(-$k)] < 0} { if {[set x [string first / $options(-$k)]] >= 0} { set options(-$k) [string replace $options(-$k) $x $x \ @$options(-host)/] } else { append options(-$k) @$options(-host) } } if {([string first @ $options(-$k)] == 0) \ && ([info exists env(USER)])} { set options(-$k) $env(USER)$options(-$k) } } if {![string equal $options(-to) "-"]} { set options(-to) [list $options(-to)] } foreach k [list tls starttls] { switch -- [string tolower $options(-$k)] { 1 - 0 {} false - no - off { set options(-$k) 0 } true - yes - on { set options(-$k) 1 } default { error "invalid value for -$k: $options(-$k)" } } } ::xmpp::jid::split $options(-from) node domain resource if {[string equal $resource ""]} { set resource "jsend" } if {[string equal $options(-xml) ""]} { if {[string equal $options(-body) ""] && $stayP < 2} { set options(-body) [read -nonewline stdin] } } set options(-xlist) {} if {![string equal $options(-url)$options(-description) ""]} { lappend options(-xlist) \ [::xmpp::xml::create x \ -xmlns jabber:x:oob \ -subelement [::xmpp::xml::create url \ -cdata $options(-url)] \ -subelement [::xmpp::xml::create desc \ -cdata $options(-description)]] } if {[string compare $options(-date) ""]} { lappend options(-xlist) \ [::xmpp::delay::create $options(-date)] } if {![string equal $options(-xhtml) ""] \ && ![string equal $options(-body) ""] \ && $stayP < 1} { lappend options(-xlist) \ [::xmpp::xml::create html \ -xmlns http://jabber.org/protocol/xhtml-im \ -subelement [::xmpp::xml::create body \ -xmlns http://www.w3.org/1999/xhtml \ -subelements [jsend::parse_xhtml \ $options(-xhtml)]]] } if {[string equal $options(-type) announce]} { set options(-type) normal set announce [sha1::sha1 \ [clock seconds]$options(-subject)$options(-body)] lappend options(-xlist) \ [::xmpp::xml::create x \ -xmlns http://2entwine.com/protocol/gush-announce-1_0 \ -subelement [::xmpp::xml::create id -cdata $announce]] } set lib(lastwhat) $options(-activity) if {[catch { clock scan $options(-time) } lib(lastwhen)]} { set lib(lastwhen) [clock seconds] } set params {} foreach k [list body subject type xlist] { if {![string equal $options(-$k) ""]} { lappend params -$k $options(-$k) } } if {![info exists xlib]} { # Create an XMPP library instance set xlib [::xmpp::new] if (![string equal $options(-bosh) ""]) { set transport bosh set port 0 } elseif {$options(-tls)} { set transport tls if {![string equal $options(-port) ""]} { set port $options(-port) } else { set port 5223 } } else { set transport tcp if {![string equal $options(-port) ""]} { set port $options(-port) } else { set port 5222 } } # Connect to a server ::xmpp::connect $xlib $options(-host) $port \ -transport $transport \ -url $options(-bosh) if {[string equal $options(-bosh) ""] && !$options(-tls) && $options(-starttls)} { # Open XMPP stream set sessionID [::xmpp::openStream $xlib $domain \ -from [::xmpp::jid::jid $node $domain] \ -version 1.0] ::xmpp::starttls::starttls $xlib -certfile $options(-cert) ::xmpp::sasl::auth $xlib -username $node \ -password $options(-password) \ -resource $resource \ -digest $options(-digest) } elseif {$options(-sasl)} { # Open XMPP stream set sessionID [::xmpp::openStream $xlib $domain \ -version 1.0] ::xmpp::sasl::auth $xlib -username $node \ -password $options(-password) \ -resource $resource \ -digest $options(-digest) } else { # Open XMPP stream set sessionID [::xmpp::openStream $xlib $domain] # Authenticate ::xmpp::auth::auth $xlib -sessionid $sessionID \ -username $node \ -password $options(-password) \ -resource $resource } set roster [::xmpp::roster::new $xlib] ::xmpp::roster::get $roster } if {[string equal $options(-to) "-"]} { set options(-to) [::xmpp::roster::items $roster] } if {$stayP > 1} { ::xmpp::sendPresence $xlib -status Online if {[string equal $options(-type) groupchat]} { set nick [::xmpp::jid::jid $username $domain $resource] set nick [string range [sha1::sha1 $nick+[clock seconds]] 0 7] foreach to $options(-to) { ::xmpp::sendPresence $xlib -to $to/$nick } } return 1 } if {![string equal $options(-xml) ""]} { ::xmpp::outText $xlib $options(-xml) } else { foreach to $options(-to) { switch -- [eval [list ::xmpp::sendMessage $xlib $to] $params] { -1 - -2 { if {$stayP} { set cmd [list ::LOG] } else { set cmd [list error] } eval $cmd [list "error writing to socket, continuing..."] return 0 } default {} } } } if {!$stayP} { set jsend::stayP 0 ::xmpp::disconnect $xlib -wait 1 } return 1 } proc jsend::iqDiscoInfo {xlib from xmlElement args} { ::LOG "jsend::iqDiscoInfo $from" ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels if {[::xmpp::xml::isAttr $attrs node]} { return [list error cancel service-unavailable] } set identity [::xmpp::xml::create identity \ -attrs [list name jsend \ category client \ type bot]] set subelements {} foreach var [list http://jabber.org/protocol/disco#info \ http://jabber.org/protocol/disco#items \ jabber:iq:last \ jabber:iq:time \ jabber:iq:version] { lappend subelements [::xmpp::xml::create feature \ -attrs [list var $var]] } set xmldata \ [::xmpp::xml::create query -xmlns $xmlns \ -attrs [list type client] \ -subelement $identity \ -subelements $subelements] return [list result $xmldata] } proc jsend::iqDiscoItems {xlib from xmlElement args} { ::LOG "jsend::iqDiscoItems $from" ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels if {[::xmpp::xml::isAttr $attrs node]} { return [list error cancel service-unavailable] } return [list result [::xmpp::xml::create query -xmlns $xmlns]] } proc jsend::iqLast {xlib from xmlElement args} { variable lib ::LOG "jsend::iqLast $from" set now [clock seconds] set xmldata \ [::xmpp::xml::create query -xmlns jabber:iq:last \ -attrs [list seconds \ [expr {$now - $lib(lastwhen)}]]] return [list result $xmldata] } proc jsend::iqTime {xlib from xmlElement args} { ::LOG "jsend::iqTime $from" set now [clock seconds] set gmtP true foreach {k f} [list utc "%Y%m%dT%T" \ tz "%Z" \ display "%a %b %d %H:%M:%S %Z %Y"] { lappend tags [::xmpp::xml::create $k -cdata [clock format $now \ -format $f \ -gmt $gmtP]] set gmtP false } set xmldata [::xmpp::xml::create query -xmlns jabber:iq:time \ -subelements $tags] return [list result $xmldata] } proc jsend::iqVersion {xlib from xmlElement args} { global argv0 tcl_platform ::LOG "jsend::iqVersion $from" foreach {k v} [list name [file tail [file rootname $argv0]] \ version "1.0 (Tcl [info patchlevel])" \ os "$tcl_platform(os) $tcl_platform(osVersion)"] { lappend tags [::xmpp::xml::create $k -cdata $v] } set xmldata [::xmpp::xml::create query -xmlns jabber:iq:version \ -subelements $tags] return [list result $xmldata] } proc client:reconnect {xlib} { jsend::reconnect } proc client:disconnect {xlib} { jsend::reconnect } proc client:status {args} { ::LOG "client:status $args" } namespace eval jsend { variable stayP 1 } proc jsend::follow {file argv} { proc [namespace current]::reconnect {} \ [list [namespace current]::reconnect_aux $argv] if {[catch { eval [list jsend::sendit 2] $argv } result]} { ::bgerror $result return } set buffer "" set fd "" set newP 1 array set st [list dev 0 ino 0 size 0] for {set i 0} {1} {incr i} { if {[expr {$i % 5}] == 0} { if {[catch { file stat $file st2 } result]} { ::LOG $result break } if {($st(dev) != $st2(dev)) \ || ($st(ino) != $st2(ino)) \ || ($st(size) > $st2(size))} { if {$newP} { catch { close $fd } } fconfigure [set fd [open $file { RDONLY }]] -blocking off unset st array set st [array get st2] if {!$newP && [string equal $st(type) file]} { seek $fd 0 end } if {!$newP} { set newP 0 } if {[string length $buffer] > 0} { if {[catch { eval [list jsend::sendit 1] $argv \ [parse $buffer] \ [list -body $buffer] } result]} { ::LOG $result break } elseif {$result} { set buffer "" } } } } if {[fblocked $fd]} { } elseif {[catch { set len [string length [set line [read $fd]]] append buffer $line } result]} { ::LOG $result break } elseif {[set x [string first "\n" $buffer]] < 0} { } else { set body [string range $buffer 0 [expr {$x-1}]] while {[catch { eval [list jsend::sendit 1] $argv [parse $body] \ [list -body $body] } result]} { ::LOG $result } if {$result} { set buffer [string range $buffer [expr {$x + 1}] end] } } after 1000 "set alarmP 1" vwait alarmP } } proc jsend::parse {line} { set args {} if {![string equal [string index $line 15] " "]} { return $args } catch { lappend args -time [clock scan [string range $line 0 14]] } set line [string range $line 16 end] if {([set d [string first " " $line]] > 0) \ && ([string first ": " $line] > $d)} { lappend args -activity [string trim [string range $line $d end]] } return $args } proc jsend::reconnect_aux {argv} { variable stayP while {$stayP} { after [expr {60*1000}] if {![catch { eval [list jsend::sendit 2] $argv } result]} { break } ::LOG $result } } proc jsend::parse_xhtml {text} { return [::xmpp::xml::parseData "$text"] } proc ::LOG {text} { # puts stderr $text } proc ::debugmsg {args} { # ::LOG "debugmsg: $args" } proc ::bgerror {err} { global errorInfo ::LOG "$err\n$errorInfo" } set status 1 array set jsend::lib [list lastwhen [clock seconds] lastwhat ""] if {[string equal [file rootname [file tail [lindex $argv 0]]] jsend]} { incr argc -1 set argv [lrange $argv 1 end] } if {(([set x [lsearch -exact $argv -help]] >= 0) \ || ([set x [lsearch -exact $argv --help]] >= 0)) \ && (($x == 0) || ([expr {$x % 2}]))} { puts stdout \ "usage: $argv0 recipient ?options...? -follow file -pidfile file -from jid -host hostname -port number -password string -type string (e.g., 'chat') -subject string -body string -xhtml string -xml string -description string -url string -bosh string (BOSH URL) -tls boolean (e.g., 'false') -starttls boolean (e.g., 'true') -sasl boolean (e.g., 'true') If recipient is '-', roster is used. If both '-body' and '-follow' are absent, the standard input is used. The file .jsendrc.tcl in the current or in home directory is consulted, e.g., set args {-from fred@example.com/bedrock -password wilma} for default values." set status 0 } elseif {($argc < 1) || (![expr {$argc % 2}])} { puts stderr "usage: $argv0 recipent ?-key value?..." } elseif {[catch { if {([file exists [set file .jsendrc.tcl]]) \ || ([file exists [set file ~/.jsendrc.tcl]])} { set args {} source $file array set at [list -permissions 600] array set at [file attributes $file] if {[set x [lsearch -exact $args "-password"]] >= 0 \ && ![expr {$x % 2}] \ && ![string match *00 $at(-permissions)]} { error "file should be mode 0600" } if {[llength $args] > 0} { set argv [eval [list linsert $argv 1] $args] } } } result]} { puts stderr "error in $file: $result" } elseif {[set x [lsearch -exact $argv "-follow"]] > 0 && [expr {$x % 2}]} { set keep_alive 1 set keep_alive_interval 3 if {[set y [lsearch -exact $argv "-pidfile"]] > 0 && [expr {$y % 2}]} { set fd [open [set pf [lindex $argv [expr {$y + 1}]]] \ {WRONLY CREAT TRUNC}] puts $fd [pid] close $fd } jsend::follow [lindex $argv [expr {$x + 1}]] $argv catch { file delete -- $pf } } elseif {[catch { eval [list jsend::sendit 0] $argv } result]} { puts stderr $result } else { set status 0 } exit $status # vim:ft=tcl:ts=8:sw=4:sts=4:et tclxmpp/examples/rssbot.man000064400000000000000000000067061470446212700157700ustar00nobodynobody[comment {-*- tcl -*- doctools manpage}] [manpage_begin rssbot 1 0.1] [copyright {2015 Sergei Golovan }] [moddesc {Tcl XMPP library}] [titledesc {Tcl command line RSS/XMPP gateway}] [description] [para] This gateway is a part of the Tcl XMPP library. It implements a command line bot which perodically polls a set of RSS feeds and resend the new messages to its roster items via XMPP network. To do that it connects to an XMPP server using specified login and password. [list_begin definitions] [call [cmd rssbot] [opt "[option -option] [arg value] ..."]] [para] The required Tcl packages for the [cmd rssbot] utility are [arg tls] and quite a few modules from the [arg Tcllib] collection. [para] After the [cmd rssbot] is connected to the XMPP server, it parses chat messages from its roster contacts. These messages may contain the following commands: [list_begin definitions] [def "[cmd subscribe] [arg URL] [opt [arg URL]\ ...]"] [para] Subscribe to the specified RSS feeds and send its messages to the subscriber's JID. Only members of the rssbot roster can subscribe to RSS feeds, though the bot doesn't manage the roster itself. Note that all the subscription data is stored server-side using the mechanism described in XEP-0049 (Private XML Storage). [def "[cmd unsubscribe] [opt [arg URL]\ ...]"] [para] Unsubscribe from the specified RSS feeds (or from all the feeds). [def "[cmd list]"] [para] List all subscribed feeds. [def "[cmd reset] [opt [arg TIME]]"] [para] Reset the RSS history to the specified time (or to zero). [def "[cmd flush]"] [para] Drop all unsent RSS articles. [def "[cmd dump]"] [para] Dump all the current subscriptions to XML. [list_end] [para] The client takes a few option-value pairs as its command line arguments. The full list of the command line options follows below: [list_begin definitions] [def "[option -from] [arg jid]"] [para] The sender JID. If there's no [option -host] option then the server part of the specified JID is used to connect to. [def "[option -password] [arg string]"] [para] The sender password. [def "[option -type] [arg headline|normal|chat]"] [para] The message type. Must be one of [const headline], [const normal] or [const chat]. Defaults to [const headline]. [def "[option -pidfile] [arg file]"] [para] Create the specified file with the PID of the running process. This option is useful together with [option -follow] option. [def "[option -host] [arg hostname]"] [para] Explicit hostname to connect to. [def "[option -port] [arg number]"] [para] Explicit port to connect to. [def "[option -tls] [arg boolean]"] [para] Whether the old legacy SSL encryption is to be used (defaults to [const false]). [def "[option -starttls] [arg boolean]"] [para] Whether the STARTTLS and therefore the TLS encryption is to be used (defaults to [const true]). [def "[option -sasl] [arg boolean]"] [para] Whether the SASL authentication is to be used (defaults to [const true]). [list_end] [list_end] [section "FILES"] The file .jsendrc.tcl in the current directory or in the current user's home directory is sourced if it's available and is not world readable. It can contain any Tcl code and modify the [cmd rssbot] behavior in any way but its primary goal is to define [var args] list of option-value pairs, e.g. [example { set args {-from fred@example.com/bedrock -password wilma} }] [section "AUTHORS"] Marshall T. Rose, Sergei Golovan [keywords Tcl XMPP] [comment { vim: set ft=tcl ts=8 sw=4 sts=4 et: }] [manpage_end] tclxmpp/examples/rssbot.tcl000075500000000000000000001372611470446212700160030ustar00nobodynobody#!/usr/bin/env tclsh # rssbot.tcl -- # # This file is an example provided with the XMPP library. It implements # RSS/XMPP gateway. It was initially developed by Marshall T. Rose and # adapted to the XMPP library by Sergei Golovan. # # Copyright (c) 2009-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require Tcl 8.5 package require http 2 package require tls package require uri package require htmlparse # HACK: adding the following directory to auto_path to make this script # working in-place lappend auto_path [file join [file dirname [info script]] ..] package require xmpp package require xmpp::auth package require xmpp::sasl package require xmpp::starttls package require xmpp::roster package require xmpp::private package require xmpp::delay # Register IQ XMLNS ::xmpp::iq::register get * http://jabber.org/protocol/disco#info \ rssbot::iqDiscoInfo ::xmpp::iq::register get * http://jabber.org/protocol/disco#items \ rssbot::iqDiscoItems ::xmpp::iq::register get * jabber:iq:last rssbot::iqLast ::xmpp::iq::register get * jabber:iq:time rssbot::iqTime ::xmpp::iq::register get * jabber:iq:version rssbot::iqVersion namespace eval rssbot {} proc rssbot::sendit {stayP to args} { global env global xlib variable lib variable roster array set options [list -to $to \ -from "" \ -password "" \ -host "" \ -port "" \ -activity "" \ -type headline \ -subject "" \ -date "" \ -body "" \ -description "" \ -url "" \ -tls false \ -starttls true \ -sasl true] array set options $args if {![string compare $options(-host) ""]} { set options(-host) [info hostname] } set params [list from] foreach k $params { if {[string first @ $options(-$k)] < 0} { if {[set x [string first / $options(-$k)]] >= 0} { set options(-$k) [string replace $options(-$k) $x $x \ @$options(-host)/] } else { append options(-$k) @$options(-host) } } if {([string first @ $options(-$k)] == 0) \ && ([info exists env(USER)])} { set options(-$k) $env(USER)$options(-$k) } } foreach k [list tls starttls] { switch -- [string tolower $options(-$k)] { 1 - 0 {} false - no - off { set options(-$k) 0 } true - yes - on { set options(-$k) 1 } default { error "invalid value for -$k: $options(-$k)" } } } ::xmpp::jid::split $options(-from) node domain resource if {[string equal $resource ""]} { set resource "rssbot" } set options(-xlist) {} if {[string compare $options(-url)$options(-description) ""]} { lappend options(-xlist) \ [::xmpp::xml::create x \ -xmlns jabber:x:oob \ -subelement [::xmpp::xml::create url \ -cdata $options(-url)] \ -subelement [::xmpp::xml::create desc \ -cdata $options(-description)]] } if {[string compare $options(-date) ""]} { lappend options(-xlist) \ [::xmpp::delay::create $options(-date)] } set lib(lastwhat) $options(-activity) if {[catch { clock scan $options(-time) } lib(lastwhen)]} { set lib(lastwhen) [clock seconds] } set params {} foreach k [list body subject type xlist] { if {[string compare $options(-$k) ""]} { lappend params -$k $options(-$k) } } if {![info exists xlib]} { # Create an XMPP library instance set xlib [::xmpp::new -messagecommand [namespace current]::message \ -presencecommand [namespace current]::presence] if {$options(-tls)} { set transport tls if {![string equal $options(-port) ""]} { set port $options(-port) } else { set port 5223 } } else { set transport tcp if {![string equal $options(-port) ""]} { set port $options(-port) } else { set port 5222 } } # Connect to a server ::xmpp::connect $xlib $domain $port -transport $transport if {!$options(-tls) && $options(-starttls)} { # Open XMPP stream set sessionID [::xmpp::openStream $xlib $domain \ -version 1.0] ::xmpp::starttls::starttls $xlib ::xmpp::sasl::auth $xlib -username $node \ -password $options(-password) \ -resource $resource } elseif {$options(-sasl)} { # Open XMPP stream set sessionID [::xmpp::openStream $xlib $domain \ -version 1.0] ::xmpp::sasl::auth $xlib -username $node \ -password $options(-password) \ -resource $resource } else { # Open XMPP stream set sessionID [::xmpp::openStream $xlib $domain] # Authenticate ::xmpp::auth::auth $xlib -sessionid $sessionID \ -username $node \ -password $options(-password) \ -resource $resource } set roster [::xmpp::roster::new $xlib] ::xmpp::roster::get $roster } if {$stayP > 1} { ::xmpp::sendPresence $xlib -status Online return 1 } foreach to $options(-to) { switch -- [eval [list ::xmpp::sendMessage $xlib $to] $params] { -1 - -2 { if {$stayP} { set cmd [list ::LOG] } else { set cmd [list error] } eval $cmd [list "error writing to socket, continuing..."] return 0 } default {} } } if {!$stayP} { ::xmpp::disconnect $xlib } return 1 } proc rssbot::message {xlib from type x args} { ::LOG "rssbot::message $from $type $x $args" set jid [::xmpp::jid::stripResource $from] switch -- $type { normal - chat { } "" { set type normal } default { ::LOG "$from ignoring $type" return } } set body "" set subject "" foreach {key val} $args { switch -- $key { -body { set body $val } -subject { set subject $val } } } if {[string equal $body ""]} return if {[catch { rssbot::message_aux $jid $body } answer]} { ::LOG "$jid/$body: $answer" set answer "internal error, sorry! ($answer)" } if {[catch { rssbot::sendit 1 "" \ -to $from \ -activity "$jid: $body" \ -type $type \ -subject $subject \ -body $answer } result]} { ::LOG "$from: $result" } } proc rssbot::presence {xlib from type x args} { variable articles variable sources variable subscribers ::LOG "rssbot:presence $from $type $x $args" set jid [::xmpp::jid::stripResource $from] switch -- $type { available - unavailable { } "" { set type available } default { ::LOG "$from ignoring $type" return } } rssbot::presence_aux $jid $type } proc rssbot::iqDiscoInfo {xlib from xmlElement args} { ::LOG "rssbot::iqDiscoInfo $from" ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels if {[::xmpp::xml::isAttr $attrs node]} { return [list error cancel service-unavailable] } set identity [::xmpp::xml::create identity \ -attrs [list name rssbot \ category client \ type bot]] set subelements {} foreach var [list http://jabber.org/protocol/disco#info \ http://jabber.org/protocol/disco#items \ jabber:iq:last \ jabber:iq:time \ jabber:iq:version] { lappend subelements [::xmpp::xml::create feature \ -attrs [list var $var]] } set xmldata \ [::xmpp::xml::create query -xmlns $xmlns \ -attrs [list type client] \ -subelement $identity \ -subelements $subelements] return [list result $xmldata] } proc rssbot::iqDiscoItems {xlib from xmlElement args} { ::LOG "rssbot::iqDiscoItems $from" ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels if {[::xmpp::xml::isAttr $attrs node]} { return [list error cancel service-unavailable] } return [list result [::xmpp::xml::create query -xmlns $xmlns]] } proc rssbot::iqLast {xlib from xmlElement args} { variable lib ::LOG "rssbot::iqLast $from" set now [clock seconds] set xmldata \ [::xmpp::xml::create query -xmlns jabber:iq:last \ -attrs [list seconds \ [expr {$now - $lib(lastwhen)}]] \ -cdata $lib(lastwhat)] return [list result $xmldata] } proc rssbot::iqTime {xlib from xmlElement args} { ::LOG "rssbot::iqTime $from" set now [clock seconds] set gmtP true foreach {k f} [list utc "%Y%m%dT%T" \ tz "%Z" \ display "%a %b %d %H:%M:%S %Z %Y"] { lappend tags [::xmpp::xml::create $k -cdata [clock format $now \ -format $f \ -gmt $gmtP]] set gmtP false } set xmldata [::xmpp::xml::create query -xmlns jabber:iq:time \ -subelements $tags] return [list result $xmldata] } proc rssbot::iqVersion {xlib from xmlElement args} { global argv0 tcl_platform ::LOG "rssbot::iqVersion $from" foreach {k v} [list name [file tail [file rootname $argv0]] \ version "1.0 (Tcl [info patchlevel])" \ os "$tcl_platform(os) $tcl_platform(osVersion)"] { lappend tags [::xmpp::xml::create $k -cdata $v] } set xmldata [::xmpp::xml::create query -xmlns jabber:iq:version \ -subelements $tags] return [list result $xmldata] } proc client:reconnect {xlib} { rssbot::reconnect } proc client:disconnect {xlib} { rssbot::reconnect } proc client:status {args} { ::LOG "client:status $args" } # state variables # mtime - modified time # ntime - expiration time # # # articles(source,url) [list mtime ... ntime ... args { ... } source "..."] # sources(site) [list mtime ... ntime ...] # subscribers(jid) [list mtime ... sites { ... } status "..."] # proc rssbot::begin {argv} { global xlib global doneP variable iqP variable loopID variable parser variable articles variable sources variable subscribers proc [namespace current]::reconnect {} \ [list [namespace current]::reconnect_aux $argv] if {[catch { set loopID "" [set parser [xml::parser]] configure \ -elementstartcommand [namespace code [list element begin]] \ -elementendcommand [namespace code [list element end]] \ -characterdatacommand [namespace code pcdata] array set articles {} array set sources {} array set subscribers {} eval [list rssbot::sendit 2 ""] $argv set iqP 0 foreach array [list articles sources subscribers] { incr iqP ::xmpp::private::retrieve $xlib \ [list [::xmpp::xml::create $array \ -xmlns rssbot.$array]] \ -command [namespace code [list iq_private 0]] } while {$iqP > 0} { vwait [namespace current]::iqP } loop $argv } result]} { set doneP 1 bgerror $result } } proc rssbot::loop {argv} { variable loopID set loopID "" if {[catch { loop_aux $argv } result]} { bgerror $result } set loopID [after [expr {30*60*1000}] [list [namespace current]::loop $argv]] } proc rssbot::loop_aux {argv} { global xlib variable articles variable sources variable subscribers variable lib array set updateP [list articles 0 sources 0 subscribers 0] set sites {} foreach jid [array names subscribers] { array set props $subscribers($jid) if {![string compare $props(status) available]} { foreach site $props(sites) { if {[lsearch -exact $sites $site] < 0} { lappend sites $site } } } } set now [clock seconds] foreach site $sites { catch { array unset sprops } array set sprops [list ntime 0] catch { array set sprops $sources($site) } if {$sprops(ntime) > $now} { continue } # Sometimes the RSS encoding can be application/xml instead of text/xml, # so treat all data as binary and recode it separately if {[catch { ::http::geturl $site -binary 1 } httpT]} { ::LOG "$site: $httpT" continue } switch -exact -- [set status [::http::status $httpT]] { ok { if {![string match 2* [set ncode [::http::ncode $httpT]]]} { ::LOG "$site: returns code $ncode" } else { catch { unset state } upvar #0 $httpT state catch { unset array meta } array set meta $state(meta) if {![info exists meta(Last-Modified)]} { set mtime $now } elseif {[catch { rfc2822::parseDate $meta(Last-Modified) } t]} { ::LOG "$site: invalid Last-Modified meta-data $meta(Last-Modified)" set mtime $now } else { set mtime $t } foreach {k v} [process $site $mtime [expr {$now + (30*60)}] \ $now [recodeXML [::http::data $httpT]]] { if {$v} { set updateP($k) 1 } } } } timeout - default { ::LOG "$site: $status" } } ::http::cleanup $httpT } foreach jid [array names subscribers] { catch { array unset props } array set props $subscribers($jid) if {[catch { set props(mtime) } mtime]} { set mtime 0 } set xtime 0 foreach site $props(sites) { foreach article [array names articles] { catch { array unset aprops } array set aprops $articles($article) if {$aprops(ntime) <= $now} { unset articles($article) set updateP(articles) 1 continue } if {[string first "$site," $article]} { continue } if {$aprops(mtime) <= $mtime} { continue } if {[catch { eval [list rssbot::sendit 1 $jid] $argv \ $aprops(args) } result]} { ::LOG "$jid: $result" } else { if {$xtime < $aprops(mtime)} { set xtime $aprops(mtime) } set lib(lastwhat) $aprops(source) set lib(lastwhen) $aprops(mtime) } } } if {$xtime > $mtime} { set updateP(subscribers) 1 set props(mtime) $xtime set subscribers($jid) [array get props] } } foreach array [list articles sources subscribers] { if {$updateP($array)} { ::xmpp::private::store $xlib \ [list [::xmpp::xml::create $array \ -xmlns rssbot.$array \ -cdata [array get $array]]] \ -command [namespace code [list iq_private 1]] } } } proc rssbot::process {site mtime ntime now data} { variable info variable parser variable stack variable sources array set info [list site $site ctime $mtime now $now articleP 0] set stack {} if {[catch { $parser parse $data } result]} { ::LOG "$site: $result" } else { set sources($site) [list mtime $mtime ntime $ntime] } return [list articles $info(articleP) sources $info(articleP)] } proc rssbot::element {tag name {av {}} args} { variable info variable stack variable articles switch -- $tag { begin { set parent [lindex [lindex $stack end] 0] lappend stack [list $name $av] switch -- $parent/$name { channel/title { array set info [list subject ""] } channel/item - rdf:RDF/item - RDF/item { array set info [list description "" \ body "" \ url "" \ date ""] } } } end { set stack [lreplace $stack end end] set parent [lindex [lindex $stack end] 0] switch -- $parent/$name { channel/item - rdf:RDF/item - RDF/item {} default { return } } if {[string compare $info(date) ""]} { if {[catch { iso8601::parse_date $info(date) } info(mtime)] && \ [catch { iso8601::parse_time $info(date) } info(mtime)] && \ [catch { rfc2822::parseDate $info(date) } info(mtime)]} { ::LOG "$info(site): invalid date $info(date)" set info(mtime) $info(ctime) } } else { set info(mtime) $info(ctime) } if {![string compare [set url $info(url)] ""]} { ::LOG "$info(site): missing URL in item" return } set ntime [expr {$info(mtime) + (7*24*60*60)}] if {$ntime <= $info(now)} { ::LOG "DEBUG $info(site): article for $url at $info(date) is expired" return } set site $info(site) if {[info exists articles($site,$url)]} { ::LOG "DEBUG $info(site): article for $url already exists" return } set info(description) [removeHTTPMarkup $info(description)] if {![string compare $info(body) ""]} { set info(body) [string trim "$info(description)\n$info(url)"] } else { set info(body) [removeHTTPMarkup $info(body)] } set args {} foreach k [list subject body description url] { lappend args -$k [string trim $info($k)] } lappend args -date $info(mtime) set articles($site,$url) \ [list mtime $info(mtime) \ ntime $ntime \ source [string trim $info(subject)] \ args $args] set info(articleP) 1 } } } proc rssbot::pcdata {text} { variable info variable stack if {![string compare [string trim $text] ""]} { return } set name [lindex [lindex $stack end] 0] set parent [lindex [lindex $stack end-1] 0] switch -- $parent/$name { channel/title { append info(subject) $text } item/title { append info(description) $text } item/link { append info(url) $text } item/description { append info(body) $text } item/dc:date - item/date - item/pubDate { append info(date) $text } } } proc rssbot::message_aux {jid request} { global xlib variable loopID variable articles variable sources variable subscribers variable roster if {[catch { split [string trim $request] } args]} { return $args } set answer "" set updateP 0 set arrayL [list subscribers] set fmt "%a %b %d %H:%M:%S %Z %Y" switch -glob -- [set arg0 [string tolower [lindex $args 0]]] { h* { set answer {commands are: subscribe URL unsubscribe [URL ...] reset [DATE-TIME] list dump [URL ...] flush help} } sub* { if {[llength $args] <= 1} { return "usage: subscribe URL ..." } array set props [list mtime 0 sites {} status available] if {([catch { array set props $subscribers($jid) }]) \ && ([lsearch -exact [::xmpp::roster::items $roster] $jid] < 0)} { return "not authorized" } set s "" foreach arg [lrange $args 1 end] { if {![string compare $arg ""]} { append answer $s "invalid source: empty URL" } elseif {[lsearch -exact $props(sites) $arg] >= 0} { append answer $s "already subscribed to $arg" } elseif {[catch { uri::split $arg } result]} { append answer $s "invalid source: $arg ($result)" } else { lappend props(sites) $arg set updateP 1 append answer $s "added subscription to $arg" } set s "\n" } } unsub* { if {![info exists subscribers($jid)]} { return "no subscriptions" } array set props $subscribers($jid) if {[llength $args] <= 1} { set s {} foreach site $props(sites) { lappend s "cancelled subscription to $site" } append answer [join $s \n] set props(sites) {} set updateP 1 } else { set s {} foreach arg [lrange $args 1 end] { if {[set x [lsearch -exact $props(sites) $arg]] < 0} { lappend s "not subscribed to $arg" } else { set props(sites) [lreplace $props(sites) $x $x] set updateP 1 lappend s "cancelled subscription to $arg" } } append answer [join $s \n] } } reset { if {![info exists subscribers($jid)]} { return "no subscriptions" } array set props $subscribers($jid) append answer "subscription history reset" if {[llength $args] <= 1} { set props(mtime) 0 } elseif {[catch { clock scan [concat [lrange $args 1 end]] \ -base [clock seconds] } m]} { return "invalid date-time: [concat [lrange $args 1 end]] ($m)" } else { set props(mtime) $m append answer " to [clock format $m -format $fmt]" } set updateP 1 } list { if {![info exists subscribers($jid)]} { return "no subscriptions" } array set props $subscribers($jid) if {[llength $props(sites)] == 0} { append answer "no sites" } else { append answer [join $props(sites) \n] } } dump { if {![info exists subscribers($jid)]} { return [::xmpp::xml::toTabbedText \ [::xmpp::xml::create subscriber \ -attrs [list jid $jid]]] } array set props $subscribers($jid) set tags {} if {[info exists props(mtime)]} { set cdata [clock format $props(mtime) -format $fmt] } else { set cdata never } lappend tags [::xmpp::xml::create updated -cdata $cdata] foreach site $props(sites) { if {([llength $args] > 1) && \ ([lsearch -exact [lrange $args 1 end] $site] < 0)} { continue } catch { unset array sprops } array set sprops $sources($site) set stags {} lappend stags [::xmpp::xml::create url -cdata $site] lappend stags [::xmpp::xml::create modified \ -cdata [clock format $sprops(mtime) \ -format $fmt]] lappend stags [::xmpp::xml::create expires \ -cdata [clock format $sprops(ntime) \ -format $fmt]] set atags {} foreach article [array names articles] { if {[string first "$site," $article]} { continue } set url [string range $article [string length "$site,"] end] catch { array unset aprops } array set aprops $articles($article) set atag {} lappend atag [::xmpp::xml::create url -cdata $url] lappend atag [::xmpp::xml::create modified \ -cdata [clock format $aprops(mtime) \ -format $fmt]] lappend atag [::xmpp::xml::create expires \ -cdata [clock format $aprops(ntime) \ -format $fmt]] lappend atag [::xmpp::xml::create args \ -cdata $aprops(args)] lappend atags [::xmpp::xml::create article \ -subelements $atag] } lappend stags [::xmpp::xml::create articles \ -subelements $atags] lappend tags [::xmpp::xml::create site \ -subelements $stags] } set answer [::xmpp::xml::toTabbedText \ [::xmpp::xml::create subscriber \ -attrs [list jid $jid] \ -subelement [::xmpp::xml::create sites \ -subelements $tags]]] } flush { if {![info exists subscribers($jid)]} { return "no subscriptions" } array set props $subscribers($jid) foreach array [set arrayL [list articles sources]] { lappend arrayL $array array unset $array array set $array {} } set updateP 1 append answer "cache flushed" } default { append answer "unknown request: $arg0\n" append answer "try \"help\" instead" } } if {$updateP} { set subscribers($jid) [array get props] foreach array $arrayL { ::xmpp::private::store $xlib \ [list [::xmpp::xml::create $array \ -xmlns rssbot.$array \ -cdata [array get $array]]] \ -command [namespace code [list iq_private 1]] } if {[string compare $loopID ""]} { set script [lindex [after info $loopID] 0] after cancel $loopID set loopID [after idle $script] } } return $answer } proc rssbot::presence_aux {jid status} { global xlib variable loopID variable articles variable sources variable subscribers if {![info exists subscribers($jid)]} { ::LOG "$jid not subscribed?!?" return } array set props $subscribers($jid) if {[string compare $props(status) $status]} { set props(status) $status set subscribers($jid) [array get props] ::xmpp::private::store $xlib \ [list [::xmpp::xml::create subscribers \ -xmlns rssbot.subscribers \ -cdata [array get subscribers]]] \ -command [namespace code [list iq_private 1]] if {(![string compare $status available]) \ && ([string compare $loopID ""])} { set script [lindex [after info $loopID] 0] after cancel $loopID set loopID [after idle $script] } } } proc rssbot::reconnect_aux {argv} { while {1} { after [expr {60*1000}] if {![catch { eval [list rssbot::sendit 2 ""] $argv } result]} { break } ::LOG $result } } proc rssbot::iq_private {setP status xmlList} { global doneP variable iqP variable articles variable sources variable subscribers if {[set code [catch { if {[string compare $status ok]} { error "iq_private: [lindex $xmlList 0]" } if {$setP} { return } ::xmpp::xml::split [lindex $xmlList 0] tag xmlns attrs cdata subels if {[catch { llength $cdata }]} { error "iq_private: bad data: $cdata" } switch -- $xmlns { rssbot.articles - rssbot.sources - rssbot.subscribers { array set [string range $xmlns 7 end] $cdata } default { error "iq_private: unexpected namespace: $xmlns" } } incr iqP -1 } result]]} { if {$code == 2} { return } set doneP 1 set iqP 0 bgerror $result } } proc rssbot::removeHTTPMarkup {html} { set text "" ::htmlparse::parse \ -cmd [namespace code [list processHTTPTag [info level] text]] $html return $text } proc rssbot::processHTTPTag {level var tag slash attrs cdata} { upvar #$level $var text regsub -all {\s+} [::htmlparse::mapEscapes $cdata] { } cdata switch -glob -- [string tolower $tag]:$slash { p: - br: { append text "\n" $cdata } tr: { append text "\n" } th: - td: { append text "\t" $cdata } default { append text $cdata } } } # The following code is mostly taken from http://wiki.tcl.tk/15326 proc rssbot::recodeXML {xml} { # The autodetection of the encoding follows # XML Recomendation, Appendix F set closeIndex 0 if {![binary scan $xml "H8" firstBytes]} { # very short (< 4 Bytes) file set encoding utf-8 } # If the entity has a XML Declaration, the first four characters # must be "" $xml] if {$closeIndex < 0} { error "Weird XML data or not XML data at all" } set xmlDeclaration [string range $xml 0 $closeIndex] incr closeIndex # extract the encoding information set pattern {^[^>]+encoding=[\x20\x9\xd\xa]*["']([^ "']+)['"]} # emacs or vim: " if {![regexp $pattern $xmlDeclaration - encStr]} { # Probably something like . # Without encoding declaration, pass-thru set encoding utf-8 } else { set encoding [::http::CharsetToEncoding $encStr] } } default { # TODO: 16 and 32-bit encodings # pass-thru set encoding iso8859-1 } } return [encoding convertfrom $encoding [string range $xml $closeIndex end]] } # The following code is taken from http://wiki.tcl.tk/13094 namespace eval iso8601 { namespace export parse_date parse_time # Enumerate the patterns that we recognize for an ISO8601 date as both # the regexp patterns that match them and the [clock] patterns that scan # them. variable DatePatterns { {\d\d\d\d-\d\d-\d\d} {%Y-%m-%d} {\d\d\d\d\d\d\d\d} {%Y%m%d} {\d\d\d\d-\d\d\d} {%Y-%j} {\d\d\d\d\d\d\d} {%Y%j} {\d\d-\d\d-\d\d} {%y-%m-%d} {\d\d\d\d\d\d} {%y%m%d} {\d\d-\d\d\d} {%y-%j} {\d\d\d\d\d} {%y%j} {--\d\d-\d\d} {--%m-%d} {--\d\d\d\d} {--%m%d} {--\d\d\d} {--%j} {---\d\d} {---%d} {\d\d\d\d-W\d\d-\d} {%G-W%V-%u} {\d\d\d\dW\d\d\d} {%GW%V%u} {\d\d-W\d\d-\d} {%g-W%V-%u} {\d\dW\d\d\d} {%gW%V%u} {-W\d\d-\d} {-W%V-%u} {-W\d\d\d} {-W%V%u} {-W-\d} {%u} } # MatchTime -- (constructed procedure) # # Match an ISO8601 date/time string and indicate how it matched. # # Parameters: # string -- String to match. # fieldArray -- Name of an array in caller's scope that will receive # parsed fields of the time. # # Results: # Returns 1 if the time was scanned successfully, 0 otherwise. # # Side effects: # Initializes the field array. The keys that are significant: # - Any date pattern in 'DatePatterns' indicates that the # corresponding value, if non-empty, contains a date string # in the given format. # - The patterns T, Hcolon, and Mcolon indicate a literal # T preceding the time, a colon following the hour, or # a colon following the minute. # - %H, %M, %S, and %Z indicate the presence of the # corresponding parts of the time. proc init {} { variable DatePatterns set cmd {regexp -expanded -nocase -- {PATTERN} $timeString ->} set re \(?:\(?: set sep {} foreach {regex interpretation} $DatePatterns { append re $sep \( $regex \) append cmd " " [list field($interpretation)] set sep | } append re \) {(T|[[:space:]]+)} \)? append cmd { field(T)} append re {(\d\d)(?:(:?)(\d\d)(?:(:?)(\d\d)))} append cmd { field(%H) field(Hcolon) } \ {field(%M) field(Mcolon) field(%S)} append re {[[:space:]]*(Z|[-+]\d\d\d\d)?} append cmd { field(%Z)} set cmd [string map [list {{PATTERN}} [list $re]] \ $cmd] proc MatchTime { timeString fieldArray } " upvar 1 \$fieldArray field $cmd " } init rename init {} } # iso8601::parse_date -- # # Parse an ISO8601 date/time string in an unknown variant. # # Parameters: # string -- String to parse # args -- Arguments as for [clock scan]; may include any of # the '-base', '-gmt', '-locale' or '-timezone options. # # Results: # Returns the given date in seconds from the Posix epoch. proc iso8601::parse_date { string args } { variable DatePatterns foreach { regex interpretation } $DatePatterns { if { [regexp "^$regex\$" $string] } { return [eval [linsert $args 0 \ clock scan $string -format $interpretation]] } } return -code error "not an iso8601 date string" } # iso8601::parse_time -- # # Parse a point-in-time in ISO8601 format # # Parameters: # string -- String to parse # args -- Arguments as for [clock scan]; may include any of # the '-base', '-gmt', '-locale' or '-timezone options. # # Results: # Returns the given time in seconds from the Posix epoch. proc iso8601::parse_time { timeString args } { variable DatePatterns MatchTime $timeString field set pattern {} foreach {regex interpretation} $DatePatterns { if { $field($interpretation) ne {} } { append pattern $interpretation } } append pattern $field(T) if { $field(%H) ne {} } { append pattern %H $field(Hcolon) if { $field(%M) ne {} } { append pattern %M $field(Mcolon) if { $field(%S) ne {} } { append pattern %S } } } if { $field(%Z) ne {} } { append pattern %Z } return [eval [linsert $args 0 clock scan $timeString -format $pattern]] } # The following code is taken from http://wiki.tcl.tk/13094 namespace eval rfc2822 { namespace export parseDate variable datepats {} } # AddDatePat -- # # Internal procedure that adds a date pattern to the pattern list # # Parameters: # wpat - Regexp pattern that matches the weekday # wgrp - Format group that matches the weekday # ypat - Regexp pattern that matches the year # ygrp - Format group that matches the year # mdpat - Regexp pattern that matches month and day # mdgrp - Format group that matches month and day # spat - Regexp pattern that matches the seconds of the minute # sgrp - Format group that matches the seconds of the minute # zpat - Regexp pattern that matches the time zone # zgrp - Format group that matches the time zone # # Results: # None # # Side effects: # Adds a complete regexp and a complete [clock scan] pattern to # 'datepats' proc rfc2822::AddDatePat { wpat wgrp ypat ygrp mdpat mdgrp spat sgrp zpat zgrp } { variable datepats set regexp {^[[:space:]]*} set pat {} append regexp $wpat $mdpat {[[:space:]]+} $ypat append pat $wgrp $mdgrp $ygrp append regexp {[[:space:]]+\d\d?:\d\d} $spat append pat { %H:%M} $sgrp append regexp $zpat append pat $zgrp append regexp {[[:space:]]*$} lappend datepats $regexp $pat return } # InitDatePats -- # # Internal rocedure that initializes the set of date patterns allowed in # an RFC2822 date # # Parameters: # permissible - 1 if erroneous (but common) time zones are to be # allowed, 0 if they are to be rejected # # Results: # None. # # Side effects: proc rfc2822::InitDatePats { permissible } { # Produce formats for the observed variants of ISO2822 dates. Permissible # variants come first in the list; impermissible ones come later. # The month and day may be "%b %d" or "%d %b" foreach mdpat {{[[:alpha:]]+[[:space:]]+\d\d?} {\d\d?[[:space:]]+[[:alpha:]]+}} \ mdgrp {{%b %d} {%d %b}} \ mdperm {0 1} { # The year may be two digits, or four. Four digit year is done # first. foreach ypat {{\d\d\d\d} {\d\d}} ygrp {%Y %y} { # The seconds of the minute may be provided, or omitted. foreach spat {{:\d\d} {}} sgrp {:%S {}} { # The weekday may be provided or omitted. It is common but # impermissible to omit the comma after the weekday name. foreach wpat { {(?:Mon|T(?:ue|hu)|Wed|Fri|S(?:at|un)),[[:space:]]+} {(?:Mon|T(?:ue|hu)|Wed|Fri|S(?:at|un))[[:space:]]+} {} } wgrp { {%a, } {%a } {} } wperm { 1 0 1 } { # Time zone is defined as +/- hhmm, or as a # named time zone. Other common but buggy # formats are GMT+-hh:mm, a time zone name in # quotation marks, and complete omission of # the time zone. foreach zpat { {[[:space:]]+(?:[-+]\d\d\d\d|[[:alpha:]]+)} {[[:space:]]+GMT[-+]\d\d:?\d\d} {[[:space:]]+"[[:alpha:]]+"} {} } zgrp { { %Z} { GMT%Z} { "%Z"} {} } zperm { 1 0 0 0 } { if { ($zperm && $wperm && $mdperm) == $permissible } { AddDatePat $wpat $wgrp $ypat $ygrp \ $mdpat $mdgrp \ $spat $sgrp $zpat $zgrp } } } } } } return } # Initialize the date patterns namespace eval rfc2822 { InitDatePats 1 InitDatePats 0 rename AddDatePat {} rename InitDatePats {} } # rfc2822::parseDate -- # # Parses a date expressed in RFC2822 format # # Parameters: # date - The date to parse # # Results: # Returns the date expressed in seconds from the Epoch, or throws # an error if the date could not be parsed. proc rfc2822::parseDate { date } { variable datepats # Strip comments and excess whitespace from the date field regsub -all -expanded { \( # open parenthesis (:? [^()[.\.]] # character other than ()\ |\\. # or backslash escape )* # any number of times \) # close paren } $date {} date set date [string trim $date] # Match the patterns in order of preference, returning the first success foreach {regexp pat} $datepats { if { [regexp -nocase $regexp $date] } { return [clock scan $date -format $pat] } } return -code error -errorcode {RFC2822 BADDATE} \ "expected an RFC2822 date, got \"$date\"" } ####################################################################### # HACK: Adding missing legacy timezones if {[catch { clock scan msk }]} { lappend ::tcl::clock::LegacyTimeZone msk +0300 msd +0400 } set debugP 0 set logFile "" proc ::LOG {message} { global debugP logFile if {$debugP > 0} { puts stderr $message } if {([string first "DEBUG " $message] == 0) \ || (![string compare $logFile ""]) \ || ([catch { set fd [open $logFile { WRONLY CREAT APPEND }] }])} { return } regsub -all "\n" $message " " message set now [clock seconds] if {[set x [string first . [set host [info hostname]]]] > 0} { set host [string range $host 0 [expr {$x - 1}]] } catch { puts -nonewline $fd \ [format "%s %2d %s %s personal\[%d\]: %s\n" \ [clock format $now -format %b] \ [string trimleft [clock format $now -format %d] 0] \ [clock format $now -format %T] $host \ [expr {[pid] % 65535}] $message] } catch { close $fd } } proc ::bgerror {err} { global errorInfo ::LOG "$err\n$errorInfo" } set status 1 array set rssbot::lib [list lastwhen [clock seconds] lastwhat ""] if {(([set x [lsearch -exact $argv -help]] >= 0) \ || ([set x [lsearch -exact $argv --help]] >= 0)) \ && (![expr {$x % 2}])} { puts stdout "usage: $argv0 ?options...? -pidfile file -from jid -password string -tls boolean (e.g., 'true') The file .jsendrc.tcl is consulted, e.g., set args {-from fred@example.com/bedrock -password wilma} for default values." set status 0 } elseif {[expr {$argc % 2}]} { puts stderr "usage: $argv0 ?-key value?..." } elseif {[catch { if {([file exists [set file .jsendrc.tcl]]) \ || ([file exists [set file ~/.jsendrc.tcl]])} { set args {} source $file array set at [list -permissions 600] array set at [file attributes $file] if {([set x [lsearch -exact $args "-password"]] > 0) \ && (![expr {$x % 2}]) \ && (![string match *00 $at(-permissions)])} { error "file should be mode 0600" } if {[llength $args] > 0} { set argv [eval [list linsert $argv 0] $args] } } } result]} { puts stderr "error in $file: $result" } else { if {([set x [lsearch -exact $argv -debug]] >= 0) && (![expr {$x % 2}])} { switch -- [string tolower [lindex $argv [expr {$x + 1}]]] { 1 - true - yes - on { set debugP 1 } } } if {([set x [lsearch -exact $argv -logfile]] >= 0) && (![expr {$x % 2}])} { set logFile [lindex $argv [expr {$x + 1}]] } if {([set x [lsearch -exact $argv "-pidfile"]] >= 0) && (![expr {$x % 2}])} { set fd [open [set pf [lindex $argv [expr {$x + 1}]]] \ { WRONLY CREAT TRUNC }] puts $fd [pid] close $fd } after idle [list rssbot::begin $argv] set doneP 0 vwait doneP catch { file delete -- $pf } set status 0 } exit $status # vim:ft=tcl:ts=8:sw=4:sts=4:et tclxmpp/license.terms000064400000000000000000000024351470446212700146320ustar00nobodynobodyCopyright (c) 2008-2015 Sergei Golovan All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. tclxmpp/tclxml000075500000000000000000000000001470446212700133545ustar00nobodynobodytclxmpp/tclxml/pkgIndex.tcl000064400000000000000000000012401470446212700157050ustar00nobodynobody# plkIndex.tcl -- # # Tcl package index file for TclXML package ifneeded xml 2.0 { package require -exact xml::tcl 2.0 package require -exact xmldefs 2.0 package require -exact xml::tclparser 2.0 package provide xml 2.0 } package ifneeded xml::tcl 2.0 [list source [file join $dir xmltcl.tcl]] package ifneeded sgmlparser 1.0 [list source [file join $dir sgmlparser.tcl]] package ifneeded sgml 1.8 [list source [file join $dir sgml.tcl]] package ifneeded xmldefs 2.0 [list source [file join $dir xml.tcl]] package ifneeded xml::tclparser 2.0 [list source [file join $dir tclparser.tcl]] # vim:ft=tcl:ts=8:sw=4:sts=4:et tclxmpp/tclxml/sgml.tcl000064400000000000000000000167561470446212700151200ustar00nobodynobody# sgml.tcl -- # # This file provides generic parsing services for SGML-based # languages, namely HTML and XML. # This file supports Tcl 8.1 characters and regular expressions. # # NB. It is a misnomer. There is no support for parsing # arbitrary SGML as such. # # Copyright (c) 1998-2001 Zveno Pty Ltd # http://www.zveno.com/ # # Zveno makes this software available free of charge for any purpose. # Copies may be made of this software but all of this notice must be included # on any copy. # # The software was developed for research purposes only and Zveno does not # warrant that it is error free or fit for any purpose. Zveno disclaims any # liability for all claims, expenses, losses, damages and costs any user may # incur as a result of using, copying or modifying this software. # # Copyright (c) 1997 ANU and CSIRO on behalf of the # participants in the CRC for Advanced Computational Systems ('ACSys'). # # ACSys makes this software and all associated data and documentation # ('Software') available free of charge for any purpose. You may make copies # of the Software but you must include all of this notice on any copy. # # The Software was developed for research purposes and ACSys does not warrant # that it is error free or fit for any purpose. ACSys disclaims any # liability for all claims, expenses, losses, damages and costs any user may # incur as a result of using, copying or modifying the Software. package require Tcl 8.1 package provide sgml 1.8 namespace eval sgml { # Convenience routine proc cl x { return "\[$x\]" } # Define various regular expressions # Character classes variable Char \t\n\r\ -\uD7FF\uE000-\uFFFD\u10000-\u10FFFF variable BaseChar \u0041-\u005A\u0061-\u007A\u00C0-\u00D6\u00D8-\u00F6\u00F8-\u00FF\u0100-\u0131\u0134-\u013E\u0141-\u0148\u014A-\u017E\u0180-\u01C3\u01CD-\u01F0\u01F4-\u01F5\u01FA-\u0217\u0250-\u02A8\u02BB-\u02C1\u0386\u0388-\u038A\u038C\u038E-\u03A1\u03A3-\u03CE\u03D0-\u03D6\u03DA\u03DC\u03DE\u03E0\u03E2-\u03F3\u0401-\u040C\u040E-\u044F\u0451-\u045C\u045E-\u0481\u0490-\u04C4\u04C7-\u04C8\u04CB-\u04CC\u04D0-\u04EB\u04EE-\u04F5\u04F8-\u04F9\u0531-\u0556\u0559\u0561-\u0586\u05D0-\u05EA\u05F0-\u05F2\u0621-\u063A\u0641-\u064A\u0671-\u06B7\u06BA-\u06BE\u06C0-\u06CE\u06D0-\u06D3\u06D5\u06E5-\u06E6\u0905-\u0939\u093D\u0958-\u0961\u0985-\u098C\u098F-\u0990\u0993-\u09A8\u09AA-\u09B0\u09B2\u09B6-\u09B9\u09DC-\u09DD\u09DF-\u09E1\u09F0-\u09F1\u0A05-\u0A0A\u0A0F-\u0A10\u0A13-\u0A28\u0A2A-\u0A30\u0A32-\u0A33\u0A35-\u0A36\u0A38-\u0A39\u0A59-\u0A5C\u0A5E\u0A72-\u0A74\u0A85-\u0A8B\u0A8D\u0A8F-\u0A91\u0A93-\u0AA8\u0AAA-\u0AB0\u0AB2-\u0AB3\u0AB5-\u0AB9\u0ABD\u0AE0\u0B05-\u0B0C\u0B0F-\u0B10\u0B13-\u0B28\u0B2A-\u0B30\u0B32-\u0B33\u0B36-\u0B39\u0B3D\u0B5C-\u0B5D\u0B5F-\u0B61\u0B85-\u0B8A\u0B8E-\u0B90\u0B92-\u0B95\u0B99-\u0B9A\u0B9C\u0B9E-\u0B9F\u0BA3-\u0BA4\u0BA8-\u0BAA\u0BAE-\u0BB5\u0BB7-\u0BB9\u0C05-\u0C0C\u0C0E-\u0C10\u0C12-\u0C28\u0C2A-\u0C33\u0C35-\u0C39\u0C60-\u0C61\u0C85-\u0C8C\u0C8E-\u0C90\u0C92-\u0CA8\u0CAA-\u0CB3\u0CB5-\u0CB9\u0CDE\u0CE0-\u0CE1\u0D05-\u0D0C\u0D0E-\u0D10\u0D12-\u0D28\u0D2A-\u0D39\u0D60-\u0D61\u0E01-\u0E2E\u0E30\u0E32-\u0E33\u0E40-\u0E45\u0E81-\u0E82\u0E84\u0E87-\u0E88\u0E8A\u0E8D\u0E94-\u0E97\u0E99-\u0E9F\u0EA1-\u0EA3\u0EA5\u0EA7\u0EAA-\u0EAB\u0EAD-\u0EAE\u0EB0\u0EB2-\u0EB3\u0EBD\u0EC0-\u0EC4\u0F40-\u0F47\u0F49-\u0F69\u10A0-\u10C5\u10D0-\u10F6\u1100\u1102-\u1103\u1105-\u1107\u1109\u110B-\u110C\u110E-\u1112\u113C\u113E\u1140\u114C\u114E\u1150\u1154-\u1155\u1159\u115F-\u1161\u1163\u1165\u1167\u1169\u116D-\u116E\u1172-\u1173\u1175\u119E\u11A8\u11AB\u11AE-\u11AF\u11B7-\u11B8\u11BA\u11BC-\u11C2\u11EB\u11F0\u11F9\u1E00-\u1E9B\u1EA0-\u1EF9\u1F00-\u1F15\u1F18-\u1F1D\u1F20-\u1F45\u1F48-\u1F4D\u1F50-\u1F57\u1F59\u1F5B\u1F5D\u1F5F-\u1F7D\u1F80-\u1FB4\u1FB6-\u1FBC\u1FBE\u1FC2-\u1FC4\u1FC6-\u1FCC\u1FD0-\u1FD3\u1FD6-\u1FDB\u1FE0-\u1FEC\u1FF2-\u1FF4\u1FF6-\u1FFC\u2126\u212A-\u212B\u212E\u2180-\u2182\u3041-\u3094\u30A1-\u30FA\u3105-\u312C\uAC00-\uD7A3 variable Ideographic \u4E00-\u9FA5\u3007\u3021-\u3029 variable CombiningChar \u0300-\u0345\u0360-\u0361\u0483-\u0486\u0591-\u05A1\u05A3-\u05B9\u05BB-\u05BD\u05BF\u05C1-\u05C2\u05C4\u064B-\u0652\u0670\u06D6-\u06DC\u06DD-\u06DF\u06E0-\u06E4\u06E7-\u06E8\u06EA-\u06ED\u0901-\u0903\u093C\u093E-\u094C\u094D\u0951-\u0954\u0962-\u0963\u0981-\u0983\u09BC\u09BE\u09BF\u09C0-\u09C4\u09C7-\u09C8\u09CB-\u09CD\u09D7\u09E2-\u09E3\u0A02\u0A3C\u0A3E\u0A3F\u0A40-\u0A42\u0A47-\u0A48\u0A4B-\u0A4D\u0A70-\u0A71\u0A81-\u0A83\u0ABC\u0ABE-\u0AC5\u0AC7-\u0AC9\u0ACB-\u0ACD\u0B01-\u0B03\u0B3C\u0B3E-\u0B43\u0B47-\u0B48\u0B4B-\u0B4D\u0B56-\u0B57\u0B82-\u0B83\u0BBE-\u0BC2\u0BC6-\u0BC8\u0BCA-\u0BCD\u0BD7\u0C01-\u0C03\u0C3E-\u0C44\u0C46-\u0C48\u0C4A-\u0C4D\u0C55-\u0C56\u0C82-\u0C83\u0CBE-\u0CC4\u0CC6-\u0CC8\u0CCA-\u0CCD\u0CD5-\u0CD6\u0D02-\u0D03\u0D3E-\u0D43\u0D46-\u0D48\u0D4A-\u0D4D\u0D57\u0E31\u0E34-\u0E3A\u0E47-\u0E4E\u0EB1\u0EB4-\u0EB9\u0EBB-\u0EBC\u0EC8-\u0ECD\u0F18-\u0F19\u0F35\u0F37\u0F39\u0F3E\u0F3F\u0F71-\u0F84\u0F86-\u0F8B\u0F90-\u0F95\u0F97\u0F99-\u0FAD\u0FB1-\u0FB7\u0FB9\u20D0-\u20DC\u20E1\u302A-\u302F\u3099\u309A variable Digit \u0030-\u0039\u0660-\u0669\u06F0-\u06F9\u0966-\u096F\u09E6-\u09EF\u0A66-\u0A6F\u0AE6-\u0AEF\u0B66-\u0B6F\u0BE7-\u0BEF\u0C66-\u0C6F\u0CE6-\u0CEF\u0D66-\u0D6F\u0E50-\u0E59\u0ED0-\u0ED9\u0F20-\u0F29 variable Extender \u00B7\u02D0\u02D1\u0387\u0640\u0E46\u0EC6\u3005\u3031-\u3035\u309D-\u309E\u30FC-\u30FE variable Letter $BaseChar|$Ideographic # white space variable Wsp " \t\r\n" variable noWsp [cl ^$Wsp] # Various XML names variable NameChar \[-$Letter$Digit._:$CombiningChar$Extender\] variable Name \[_:$BaseChar$Ideographic\]$NameChar* variable Names ${Name}(?:$Wsp$Name)* variable Nmtoken $NameChar+ variable Nmtokens ${Nmtoken}(?:$Wsp$Nmtoken)* # table of predefined entities for XML variable EntityPredef array set EntityPredef { lt < gt > amp & quot \" apos ' } } # These regular expressions are defined here once for better performance namespace eval sgml { variable Wsp # Watch out for case-sensitivity set attlist_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#REQUIRED|#IMPLIED) set attlist_enum_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*\\(([cl ^)]*)\\)[cl $Wsp]*("([cl ^")]*)")? ;# " set attlist_fixed_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#FIXED)[cl $Wsp]*([cl ^$Wsp]+) set param_entity_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^"$Wsp]*)[cl $Wsp]*"([cl ^"]*)" set notation_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(.*) } ### Utility procedures # sgml::noop -- # # A do-nothing proc # # Arguments: # args arguments # # Results: # Nothing. proc sgml::noop args { return 0 } # sgml::identity -- # # Identity function. # # Arguments: # a arbitrary argument # # Results: # $a proc sgml::identity a { return $a } # sgml::Error -- # # Throw an error # # Arguments: # args arguments # # Results: # Error return condition. proc sgml::Error args { uplevel return -code error [list $args] } ### Following procedures are based on html_library # sgml::zapWhite -- # # Convert multiple white space into a single space. # # Arguments: # data plain text # # Results: # As above proc sgml::zapWhite data { regsub -all "\[ \t\r\n\]+" $data { } data return $data } proc sgml::Boolean value { regsub {1|true|yes|on} $value 1 value regsub {0|false|no|off} $value 0 value return $value } # vim:ft=tcl:ts=8:sw=4:sts=4:et tclxmpp/tclxml/sgmlparser.tcl000064400000000000000000003161761470446212700163340ustar00nobodynobody# sgmlparser.tcl -- # # This file provides the generic part of a parser for SGML-based # languages, namely HTML and XML. # # NB. It is a misnomer. There is no support for parsing # arbitrary SGML as such. # # See sgml.tcl for variable definitions. # # Copyright (c) 1998-2002 Zveno Pty Ltd # http://www.zveno.com/ # # Zveno makes this software available free of charge for any purpose. # Copies may be made of this software but all of this notice must be included # on any copy. # # The software was developed for research purposes only and Zveno does not # warrant that it is error free or fit for any purpose. Zveno disclaims any # liability for all claims, expenses, losses, damages and costs any user may # incur as a result of using, copying or modifying this software. # # Copyright (c) 1997 ANU and CSIRO on behalf of the # participants in the CRC for Advanced Computational Systems ('ACSys'). # # ACSys makes this software and all associated data and documentation # ('Software') available free of charge for any purpose. You may make copies # of the Software but you must include all of this notice on any copy. # # The Software was developed for research purposes and ACSys does not warrant # that it is error free or fit for any purpose. ACSys disclaims any # liability for all claims, expenses, losses, damages and costs any user may # incur as a result of using, copying or modifying the Software. package require -exact sgml 1.8 package require uri 1.0 package provide sgmlparser 1.0 namespace eval sgml { namespace export tokenise parseEvent namespace export parseDTD # NB. Most namespace variables are defined in sgml-8.[01].tcl # to account for differences between versions of Tcl. # This especially includes the regular expressions used. variable ParseEventNum if {![info exists ParseEventNum]} { set ParseEventNum 0 } variable ParseDTDnum if {![info exists ParseDTDNum]} { set ParseDTDNum 0 } variable declExpr [cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*) variable EntityExpr [cl $::sgml::Wsp]*(%[cl $::sgml::Wsp])?[cl $::sgml::Wsp]*($::sgml::Name)[cl $::sgml::Wsp]+(.*) #variable MarkupDeclExpr <([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*)> #variable MarkupDeclSub "} {\\1} {\\2} {\\3} {" variable MarkupDeclExpr <[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^>]*)> variable MarkupDeclSub "\} {\\1} {\\2} \{" variable ExternalEntityExpr ^(PUBLIC|SYSTEM)[cl $::sgml::Wsp]+("|')(.*?)\\2([cl $::sgml::Wsp]+("|')(.*?)\\2)?([cl $::sgml::Wsp]+NDATA[cl $::sgml::Wsp]+($::xml::Name))?\$ variable StdOptions array set StdOptions [list \ -elementstartcommand [namespace current]::noop \ -elementendcommand [namespace current]::noop \ -characterdatacommand [namespace current]::noop \ -processinginstructioncommand [namespace current]::noop \ -externalentitycommand {} \ -xmldeclcommand [namespace current]::noop \ -doctypecommand [namespace current]::noop \ -commentcommand [namespace current]::noop \ -entitydeclcommand [namespace current]::noop \ -unparsedentitydeclcommand [namespace current]::noop \ -parameterentitydeclcommand [namespace current]::noop \ -notationdeclcommand [namespace current]::noop \ -elementdeclcommand [namespace current]::noop \ -attlistdeclcommand [namespace current]::noop \ -paramentityparsing 1 \ -defaultexpandinternalentities 1 \ -startdoctypedeclcommand [namespace current]::noop \ -enddoctypedeclcommand [namespace current]::noop \ -entityreferencecommand {} \ -warningcommand [namespace current]::noop \ -errorcommand [namespace current]::Error \ -final 1 \ -validate 0 \ -baseurl {} \ -name {} \ -emptyelement [namespace current]::EmptyElement \ -parseattributelistcommand [namespace current]::noop \ -parseentitydeclcommand [namespace current]::noop \ -normalize 1 \ -internaldtd {} \ -reportempty 0 \ ] } # sgml::tokenise -- # # Transform the given HTML/XML text into a Tcl list. # # Arguments: # sgml text to tokenize # elemExpr RE to recognise tags # elemSub transform for matched tags # args options # # Valid Options: # -internaldtdvariable # -final boolean True if no more data is to be supplied # -statevariable varName Name of a variable used to store info # # Results: # Returns a Tcl list representing the document. proc sgml::tokenise {sgml elemExpr1 elemExpr2 elemExpr3 elemSub args} { array set options {-final 1} array set options $args set options(-final) [Boolean $options(-final)] # If the data is not final then there must be a variable to store # unused data. if {!$options(-final) && ![info exists options(-statevariable)]} { return -code error {option "-statevariable" required if not final} } if {[info exists options(-statevariable)]} { # Several rewrites here to handle -final 0 option. # If any cached unparsed xml (state(leftover)), prepend it. upvar #0 $options(-statevariable) state set sgml $state(leftover)$sgml set state(leftover) {} } # Pre-process stage # # Extract the internal DTD subset, if any catch {upvar #0 $options(-internaldtdvariable) dtd} if {[regexp {$comm1] unset state(commentdata) set tag {} set param {} set close {} set state(mode) normal } elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm1 text]} { # end of comment (in text) uplevel #0 $options(-commentcommand) [list $state(commentdata)<$close$tag$param>$comm1] unset state(commentdata) set tag {} set param {} set close {} set state(mode) normal } else { # comment continues append state(commentdata) <$close$tag$param>$text continue } } cdata { if {[regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $tag discard cdata1]} { # end of CDATA (in tag) uplevel #0 $options(-characterdatacommand) \ [list $state(cdata)<[subst -nocommand -novariable $close$cdata1]] set text [subst -novariable -nocommand $text] set tag {} unset state(cdata) set state(mode) normal } elseif {[regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $param discard cdata1]} { # end of CDATA (in attributes) uplevel #0 $options(-characterdatacommand) \ [list $state(cdata)<[subst -nocommand -novariable $close$tag$cdata1]] set text [subst -novariable -nocommand $text] set tag {} set param {} unset state(cdata) set state(mode) normal } elseif {[regexp (.*)\]\][cl $Wsp]*>(.*) $text discard cdata1 text]} { # end of CDATA (in text) uplevel #0 $options(-characterdatacommand) \ [list $state(cdata)<[subst -nocommand -novariable $close$tag$param>$cdata1]] set text [subst -novariable -nocommand $text] set tag {} set param {} set close {} unset state(cdata) set state(mode) normal } else { # CDATA continues append state(cdata) [subst -nocommand -novariable <$close$tag$param>$text] continue } } continue { # We're skipping elements looking for the close tag switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close { 0,* { continue } *,0, { if {![string compare $tag $state(continue:tag)]} { set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]] if {![string length $empty]} { incr state(continue:level) } } continue } *,0,/ { if {![string compare $tag $state(continue:tag)]} { incr state(continue:level) -1 } if {!$state(continue:level)} { unset state(continue:tag) unset state(continue:level) set state(mode) {} } } default { continue } } } default { # The trailing slash on empty elements can't be automatically separated out # in the RE, so we must do it here. regexp (.*)(/)[cl $Wsp]*$ $param discard param empty } } # default: normal mode # Bug: if the attribute list has a right angle bracket then the empty # element marker will not be seen set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]] switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close,$empty { 0,0,, { # Ignore empty tag - dealt with non-normal mode above } *,0,, { # Start tag for an element. # Check if the internal DTD entity is in an attribute value regsub -all &xml:intdtd\; $param \[$options(-internaldtd)\] param set code [catch {ParseEvent:ElementOpen $tag $param [array get options]} msg] set state(haveDocElement) 1 switch -- $code { 0 {# OK} 3 { # break return {} } 4 { # continue # Remember this tag and look for its close set state(continue:tag) $tag set state(continue:level) 1 set state(mode) continue continue } default { return -code $code -errorinfo $::errorInfo $msg } } } *,0,/, { # End tag for an element. set code [catch {ParseEvent:ElementClose $tag [array get options]} msg] switch -- $code { 0 {# OK} 3 { # break return {} } 4 { # continue # skip sibling nodes set state(continue:tag) [lindex $state(stack) end] set state(continue:level) 1 set state(mode) continue continue } default { return -code $code -errorinfo $::errorInfo $msg } } } *,0,,/ { # Empty element # The trailing slash sneaks through into the param variable regsub -all /[cl $::sgml::Wsp]*\$ $param {} param set code [catch {ParseEvent:ElementOpen $tag $param [array get options] -empty 1} msg] set state(haveDocElement) 1 switch -- $code { 0 {# OK} 3 { # break return {} } 4 { # continue # Pretty useless since it closes straightaway } default { return -code $code -errorinfo $::errorInfo $msg } } set code [catch {ParseEvent:ElementClose $tag [array get options] -empty 1} msg] switch -- $code { 0 {# OK} 3 { # break return {} } 4 { # continue # skip sibling nodes set state(continue:tag) [lindex $state(stack) end] set state(continue:level) 1 set state(mode) continue continue } default { return -code $code -errorinfo $::errorInfo $msg } } } *,1,* { # Processing instructions or XML declaration switch -glob -- $tag { {\?xml} { # XML Declaration if {$state(haveXMLDecl)} { uplevel #0 $options(-errorcommand) \ [list illegalcharacter \ "unexpected characters \"<$tag\" around line $state(line)"] } elseif {![regexp {\?$} $param]} { uplevel #0 $options(-errorcommand) \ [list missingcharacters \ "XML Declaration missing characters \"?>\" around line $state(line)"] } else { # We can do the parsing in one step with Tcl 8.1 RE's # This has the benefit of performing better WF checking set adv_re [format {^[%s]*version[%s]*=[%s]*(\"|')(-+|[a-zA-Z0-9_.:]+)\1([%s]+encoding[%s]*=[%s]*("|')([A-Za-z][-A-Za-z0-9._]*)\4)?([%s]*standalone[%s]*=[%s]*("|')(yes|no)\7)?[%s]*\?$} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] if {![regexp $adv_re $param discard delimiter version discard \ delimiter encoding discard delimiter standalone]} { uplevel #0 $options(-errorcommand) \ [list illformeddeclaration \ "XML Declaration not well-formed around line $state(line)"] } else { # Invoke the callback uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone] } } } {\?*} { # Processing instruction set tag [string range $tag 1 end] if {[regsub {\?$} $tag {} tag]} { if {[string length [string trim $param]]} { uplevel #0 $options(-errorcommand) \ [list [list unexpectedtext "unexpected text \"$param\"\ in processing instruction around line $state(line)"]] } } elseif {![regexp ^$Name\$ $tag]} { uplevel #0 $options(-errorcommand) \ [list illegalcharacter "illegal character in processing instruction target \"$tag\""] } elseif {[regexp {^[xX][mM][lL]$} $tag]} { uplevel #0 $options(-errorcommand) \ [list illegalcharacters "characters \"xml\" not\ permitted in processing instruction target \"$tag\""] } elseif {![regsub {\?$} $param {} param]} { uplevel #0 $options(-errorcommand) \ [list missingquestion "PI: expected '?' character around line $state(line)"] } set code [catch { uplevel #0 $options(-processinginstructioncommand) \ [list $tag [string trimleft $param]] } msg] switch -- $code { 0 {# OK} 3 { # break return {} } 4 { # continue # skip sibling nodes set state(continue:tag) [lindex $state(stack) end] set state(continue:level) 1 set state(mode) continue continue } default { return -code $code -errorinfo $::errorInfo $msg } } } !DOCTYPE { # External entity reference # This should move into xml.tcl # Parse the params supplied. Looking for Name, ExternalID and MarkupDecl set matched [regexp ^[cl $Wsp]*($Name)[cl $Wsp]*(.*) $param x state(doc_name) param] set state(doc_name) [Normalize $state(doc_name) $options(-normalize)] set externalID {} set pubidlit {} set systemlit {} set externalID {} if {[regexp -nocase ^[cl $Wsp]*(SYSTEM|PUBLIC)(.*) $param x id param]} { switch -- [string toupper $id] { SYSTEM { if {[regexp ^[cl $Wsp]+\"([cl ^\"]*)\"(.*) $param x systemlit param] || \ [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} { set externalID [list SYSTEM $systemlit] ;# " } else { uplevel #0 $options(-errorcommand) \ [list XXX "syntax error: SYSTEM identifier not followed by literal"] } } PUBLIC { if {[regexp ^[cl $Wsp]+\"([cl ^\"]*)\"(.*) $param x pubidlit param] || \ [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x pubidlit param]} { if {[regexp ^[cl $Wsp]+\"([cl ^\"]*)\"(.*) $param x systemlit param] || \ [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} { set externalID [list PUBLIC $pubidlit $systemlit] } else { uplevel #0 $options(-errorcommand) \ [list syntaxerror "syntax error: PUBLIC identifier\ not followed by system literal around line $state(line)"] } } else { uplevel #0 $options(-errorcommand) \ [list syntaxerror "syntax error: PUBLIC identifier\ not followed by literal around line $state(line)"] } } } if {[regexp -nocase ^[cl $Wsp]+NDATA[cl $Wsp]+($Name)(.*) $param x notation param]} { lappend externalID $notation } } set state(inDTD) 1 ParseEvent:DocTypeDecl [array get options] $state(doc_name) \ $pubidlit $systemlit $options(-internaldtd) set state(inDTD) 0 } !--* { # Start of a comment # See if it ends in the same tag, otherwise change the # parsing mode regexp {!--(.*)} $tag discard comm1 if {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $comm1 discard comm1_1]} { # processed comment (end in tag) uplevel #0 $options(-commentcommand) [list $comm1_1] } elseif {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $param discard comm2]} { # processed comment (end in attributes) uplevel #0 $options(-commentcommand) [list $comm1$comm2] } elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm2 text]} { # processed comment (end in text) uplevel #0 $options(-commentcommand) [list $comm1$param$empty>$comm2] } else { # start of comment set state(mode) comment set state(commentdata) "$comm1$param$empty>$text" continue } } {!\[CDATA\[*} { regexp {!\[CDATA\[(.*)} $tag discard cdata1 if {[regexp {(.*)]]$} $cdata1 discard cdata2]} { # processed CDATA (end in tag) uplevel #0 $options(-characterdatacommand) [list [subst -novariable -nocommand $cdata2]] set text [subst -novariable -nocommand $text] } elseif {[regexp {(.*)]]$} $param discard cdata2]} { # processed CDATA (end in attribute) # Backslashes in param are quoted at this stage uplevel #0 $options(-characterdatacommand) \ [list $cdata1[subst -novariable -nocommand $cdata2]] set text [subst -novariable -nocommand $text] } elseif {[regexp {(.*)]]>(.*)} $text discard cdata2 text]} { # processed CDATA (end in text) # Backslashes in param and text are quoted at this stage uplevel #0 $options(-characterdatacommand) \ [list $cdata1[subst -novariable -nocommand $param]$empty>[subst -novariable -nocommand $cdata2]] set text [subst -novariable -nocommand $text] } else { # start CDATA set state(cdata) "$cdata1$param>$text" set state(mode) cdata continue } } !ELEMENT - !ATTLIST - !ENTITY - !NOTATION { uplevel #0 $options(-errorcommand) \ [list illegaldeclaration "[string range $tag 1 end] declaration\ not expected in document instance around line $state(line)"] } default { uplevel #0 $options(-errorcommand) \ [list unknowninstruction "unknown processing\ instruction \"<$tag>\" around line $state(line)"] } } } *,1,* - *,0,/,/ { # Syntax error uplevel #0 $options(-errorcommand) \ [list syntaxerror "syntax error: closed/empty tag:\ tag $tag param $param empty $empty close $close around line $state(line)"] } } # Process character data if {$state(haveDocElement) && [llength $state(stack)]} { # Check if the internal DTD entity is in the text regsub -all &xml:intdtd\; $text \[$options(-internaldtd)\] text # Look for entity references if {([array size entities] || \ [string length $options(-entityreferencecommand)]) && \ $options(-defaultexpandinternalentities) && \ [regexp {&[^;]+;} $text]} { # protect Tcl specials # NB. braces and backslashes may already be protected regsub -all {\\({|}|\\)} $text {\1} text regsub -all {([][$\\{}])} $text {\\\1} text # Mark entity references regsub -all {&([^;]+);} $text \ [format {%s; %s {\1} ; %s %s} \}\} \ [namespace code \ [list Entity [array get options] \ $options(-entityreferencecommand) \ $options(-characterdatacommand) \ $options(entities)]] \ [namespace code [list DeProtect $options(-characterdatacommand)]] \ \{\{] text set text "uplevel #0 [namespace code [list DeProtect1 $options(-characterdatacommand)]] {{$text}}" eval $text } else { # Restore protected special characters regsub -all {\\([][{}\\])} $text {\1} text uplevel #0 $options(-characterdatacommand) [list $text] } } elseif {[string length [string trim $text]]} { uplevel #0 $options(-errorcommand) \ [list unexpectedtext "unexpected text \"$text\" in document prolog around line $state(line)"] } } # If this is the end of the document, close all open containers if {$options(-final) && [llength $state(stack)]} { eval $options(-errorcommand) \ [list unclosedelement "element [lindex $state(stack) end] remains unclosed around line $state(line)"] } return {} } # sgml::DeProtect -- # # Invoke given command after removing protecting backslashes # from given text. # # Arguments: # cmd Command to invoke # text Text to deprotect # # Results: # Depends on command proc sgml::DeProtect1 {cmd text} { if {[string compare {} $text]} { regsub -all {\\([]$[{}\\])} $text {\1} text uplevel #0 $cmd [list $text] } } proc sgml::DeProtect {cmd text} { set text [lindex $text 0] if {[string compare {} $text]} { regsub -all {\\([]$[{}\\])} $text {\1} text uplevel #0 $cmd [list $text] } } # sgml::ParserDelete -- # # Free all memory associated with parser # # Arguments: # var global state array # # Results: # Variables unset proc sgml::ParserDelete var { upvar #0 $var state if {![info exists state]} { return -code error "unknown parser" } catch {unset $state(entities)} catch {unset $state(parameterentities)} catch {unset $state(elementdecls)} catch {unset $state(attlistdecls)} catch {unset $state(notationdecls)} catch {unset $state(namespaces)} unset state return {} } # sgml::ParseEvent:ElementOpen -- # # Start of an element. # # Arguments: # tag Element name # attr Attribute list # opts Options # args further configuration options # # Options: # -empty boolean # indicates whether the element was an empty element # # Results: # Modify state and invoke callback proc sgml::ParseEvent:ElementOpen {tag attr opts args} { variable Name variable Wsp array set options $opts upvar #0 $options(-statevariable) state array set cfg {-empty 0} array set cfg $args if {$options(-normalize)} { set tag [string toupper $tag] } # Update state lappend state(stack) $tag # Parse attribute list into a key-value representation if {[string compare $options(-parseattributelistcommand) {}]} { if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $opts $attr]} attr]} { if {[string compare [lindex $attr 0] "unterminated attribute value"]} { uplevel #0 $options(-errorcommand) \ [list unterminatedattribute "$attr around line $state(line)"] set attr {} } else { # It is most likely that a ">" character was in an attribute value. # This manifests itself by ">" appearing in the element's text. # In this case the callback should return a three element list; # the message "unterminated attribute value", the attribute list it # did manage to parse and the remainder of the attribute list. foreach {msg attlist brokenattr} $attr break upvar text elemText if {[string first > $elemText] >= 0} { # Now piece the attribute list back together regexp ($Name)[cl $Wsp]*=[cl $Wsp]*(\"|')(.*) $brokenattr discard attname delimiter attvalue regexp (.*)>([cl ^>]*)\$ $elemText discard remattlist elemText regexp ([cl ^$delimiter]*)${delimiter}(.*) $remattlist discard remattvalue remattlist append attvalue >$remattvalue lappend attlist $attname $attvalue # Complete parsing the attribute list if {[catch { uplevel #0 $options(-parseattributelistcommand) \ [list $options(-statevariable) $remattlist] } attr]} { uplevel #0 $options(-errorcommand) [list $attr around line $state(line)] set attr {} set attlist {} } else { eval lappend attlist $attr } set attr $attlist } else { uplevel #0 $options(-errorcommand) \ [list unterminatedattribute "$attr around line $state(line)"] set attr {} } } } } set empty {} if {$cfg(-empty) && $options(-reportempty)} { set empty {-empty 1} } if {$options(-namespace)} { # Check for namespace declarations upvar #0 $options(namespaces) namespaces set nsdecls {} if {[llength $attr]} { array set attrlist $attr foreach {attrName attrValue} [array get attrlist xmlns*] { unset attrlist($attrName) set colon [set prefix {}] if {[regexp {^xmlns(:(.+))?$} $attrName discard colon prefix]} { switch -glob -- [string length $colon],[string length $prefix] { *,0 - 0,0 { # *,0 is a HACK: Ignore empty namespace prefix # TODO: investigate it # default NS declaration lappend state(defaultNSURI) $attrValue lappend state(defaultNS) [llength $state(stack)] lappend nsdecls $attrValue {} } 0,* { # Huh? } *,0 { # Error uplevel #0 $state(-warningcommand) \ "no prefix specified for namespace URI \"$attrValue\" in element \"$tag\"" } default { set namespaces($prefix,[llength $state(stack)]) $attrValue lappend nsdecls $attrValue $prefix } } } } if {[llength $nsdecls]} { set nsdecls [list -namespacedecls $nsdecls] } set attr [array get attrlist] } # Check whether this element has an expanded name set ns {} if {[regexp {([^:]+):(.*)$} $tag discard prefix tag1]} { set nsspec [lsort -dictionary -decreasing [array names namespaces $prefix,*]] if {[llength $nsspec]} { set tag $tag1 set nsuri $namespaces([lindex $nsspec 0]) set ns [list -namespace $nsuri] } else { # HACK: ignore undeclared namespace (and replace it by default one) # TODO: investigate it #uplevel #0 $options(-errorcommand) \ # [list namespaceundeclared "no namespace declared for prefix \"$prefix\" in element $tag"] if {[llength $state(defaultNSURI)]} { set ns [list -namespace [lindex $state(defaultNSURI) end]] } } } elseif {[llength $state(defaultNSURI)]} { set ns [list -namespace [lindex $state(defaultNSURI) end]] } # Prepend attributes with XMLNS URI set attr1 {} foreach {key val} $attr { if {[regexp {([^:]+):(.*)$} $key discard prefix key1]} { set nsspec [lsort -dictionary -decreasing [array names namespaces $prefix,*]] if {[llength $nsspec]} { set nsuri $namespaces([lindex $nsspec 0]) lappend attr1 $nsuri:$key1 $val } else { # HACK: ignore undeclared namespace # TODO: investigate it #uplevel #0 $options(-errorcommand) \ # [list namespaceundeclared "no namespace declared for prefix \"$prefix\" in attribute $key"] lappend attr1 $key $val } } else { lappend attr1 $key $val } } # Invoke callback set code [catch {uplevel #0 $options(-elementstartcommand) [list $tag $attr1] $empty $ns $nsdecls} msg] } else { # Invoke callback set code [catch {uplevel #0 $options(-elementstartcommand) [list $tag $attr] $empty} msg] } return -code $code -errorinfo $::errorInfo $msg } # sgml::ParseEvent:ElementClose -- # # End of an element. # # Arguments: # tag Element name # opts Options # args further configuration options # # Options: # -empty boolean # indicates whether the element as an empty element # # Results: # Modify state and invoke callback proc sgml::ParseEvent:ElementClose {tag opts args} { array set options $opts upvar #0 $options(-statevariable) state array set cfg {-empty 0} array set cfg $args # WF check if {[string compare $tag [lindex $state(stack) end]]} { uplevel #0 $options(-errorcommand) \ [list illegalendtag "end tag \"$tag\" does not match open\ element \"[lindex $state(stack) end]\" around line $state(line)"] return } # Check whether this element has an expanded name upvar #0 $options(namespaces) namespaces set ns {} if {[regexp {([^:]+):(.*)$} $tag discard prefix tag1]} { set nsspec [lsort -dictionary -decreasing [array names namespaces $prefix,*]] if {[llength $nsspec]} { set tag $tag1 set nsuri $namespaces([lindex $nsspec 0]) set ns [list -namespace $nsuri] } else { # HACK: ignore undeclared namespace (and replace it by default one) if {[llength $state(defaultNSURI)]} { set ns [list -namespace [lindex $state(defaultNSURI) end]] } } } elseif {[llength $state(defaultNSURI)]} { set ns [list -namespace [lindex $state(defaultNSURI) end]] } # Pop namespace stacks, if any if {[llength $state(defaultNS)]} { if {[llength $state(stack)] == [lindex $state(defaultNS) end]} { set state(defaultNS) [lreplace $state(defaultNS) end end] set state(defaultNSURI) [lreplace $state(defaultNSURI) end end] } } foreach nsspec [array names namespaces *,[llength $state(stack)]] { unset namespaces($nsspec) } # Update state set state(stack) [lreplace $state(stack) end end] set empty {} if {$cfg(-empty) && $options(-reportempty)} { set empty {-empty 1} } # Invoke callback # Mats: Shall be same as sgml::ParseEvent:ElementOpen to handle exceptions in callback. set code [catch {uplevel #0 $options(-elementendcommand) [list $tag] $empty $ns} msg] return -code $code -errorinfo $::errorInfo $msg } # sgml::Normalize -- # # Perform name normalization if required # # Arguments: # name name to normalize # req normalization required # # Results: # Name returned as upper-case if normalization required proc sgml::Normalize {name req} { if {$req} { return [string toupper $name] } else { return $name } } # sgml::Entity -- # # Resolve XML entity references (syntax: &xxx;). # # Arguments: # opts options # entityrefcmd application callback for entity references # pcdatacmd application callback for character data # entities name of array containing entity definitions. # ref entity reference (the "xxx" bit) # # Results: # Returns substitution text for given entity. proc sgml::Entity {opts entityrefcmd pcdatacmd entities ref} { array set options $opts upvar #0 $options(-statevariable) state if {![string length $entities]} { set entities [namespace current]::EntityPredef } switch -glob -- $ref { %* { # Parameter entity - not recognised outside of a DTD } #x* { # Character entity - hex if {[catch {format %c [scan [string range $ref 2 end] %x tmp; set tmp]} char]} { return -code error "malformed character entity \"$ref\"" } uplevel #0 $pcdatacmd [list $char] return {} } #* { # Character entity - decimal if {[catch {format %c [scan [string range $ref 1 end] %d tmp; set tmp]} char]} { return -code error "malformed character entity \"$ref\"" } uplevel #0 $pcdatacmd [list $char] return {} } default { # General entity upvar #0 $entities map if {[info exists map($ref)]} { if {![regexp {<|&} $map($ref)]} { # Simple text replacement - optimise uplevel #0 $pcdatacmd [list $map($ref)] return {} } # Otherwise an additional round of parsing is required. # This only applies to XML, since HTML doesn't have general entities # Must parse the replacement text for start & end tags, etc # This text must be self-contained: balanced closing tags, and so on set tokenised [tokenise $map($ref) $::xml::tokExpr1 $::xml::tokExpr2 $::xml::tokExpr3 $::xml::substExpr] set options(-final) 0 eval parseEvent [list $tokenised] [array get options] return {} } elseif {[string compare $entityrefcmd "::sgml::noop"]} { set result [uplevel #0 $entityrefcmd [list $ref]] if {[string length $result]} { uplevel #0 $pcdatacmd [list $result] } return {} } else { # Reconstitute entity reference uplevel #0 $options(-errorcommand) \ [list illegalentity "undefined entity reference \"$ref\""] return {} } } } # If all else fails leave the entity reference untouched uplevel #0 $pcdatacmd [list &$ref\;] return {} } #################################### # # DTD parser for SGML (XML). # # This DTD actually only handles XML DTDs. Other language's # DTD's, such as HTML, must be written in terms of a XML DTD. # #################################### # sgml::ParseEvent:DocTypeDecl -- # # Entry point for DTD parsing # # Arguments: # opts configuration options # docEl document element name # pubId public identifier # sysId system identifier (a URI) # intSSet internal DTD subset proc sgml::ParseEvent:DocTypeDecl {opts docEl pubId sysId intSSet} { array set options {} array set options $opts set code [catch {uplevel #0 $options(-doctypecommand) [list $docEl $pubId $sysId $intSSet]} err] switch -- $code { 3 { # break return {} } 0 - 4 { # continue } default { return -code $code $err } } # Otherwise we'll parse the DTD and report it piecemeal # The internal DTD subset is processed first (XML 2.8) # During this stage, parameter entities are only allowed # between markup declarations ParseDTD:Internal [array get options] $intSSet # The external DTD subset is processed last (XML 2.8) # During this stage, parameter entities may occur anywhere # We must resolve the external identifier to obtain the # DTD data. The application may supply its own resolver. if {[string length $pubId] || [string length $sysId]} { uplevel #0 $options(-externalentitycommand) [list $options(-name) $options(-baseurl) $sysId $pubId] } return {} } # sgml::ParseDTD:Internal -- # # Parse the internal DTD subset. # # Parameter entities are only allowed between markup declarations. # # Arguments: # opts configuration options # dtd DTD data # # Results: # Markup declarations parsed may cause callback invocation proc sgml::ParseDTD:Internal {opts dtd} { variable MarkupDeclExpr variable MarkupDeclSub array set options {} array set options $opts upvar #0 $options(-statevariable) state upvar #0 $options(parameterentities) PEnts upvar #0 $options(externalparameterentities) ExtPEnts # Tokenize the DTD # Protect Tcl special characters regsub -all {([{}\\])} $dtd {\\\1} dtd regsub -all $MarkupDeclExpr $dtd $MarkupDeclSub dtd # Entities may have angle brackets in their replacement # text, which breaks the RE processing. So, we must # use a similar technique to processing doc instances # to rebuild the declarations from the pieces set mode {} ;# normal set delimiter {} set name {} set param {} set state(inInternalDTD) 1 # Process the tokens foreach {decl value text} [lrange "{} {} \{$dtd\}" 3 end] { # Keep track of line numbers incr state(line) [regsub -all \n $text {} discard] ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode replText text param # There may be parameter entity references between markup decls if {[regexp {%.*;} $text]} { # Protect Tcl special characters regsub -all {([{}\\])} $text {\\\1} text regsub -all %($::sgml::Name)\; $text "\} {\\1} \{" text set PElist "\{$text\}" set PElist [lreplace $PElist end end] foreach {text entref} $PElist { if {[string length [string trim $text]]} { uplevel #0 $options(-errorcommand) \ [list unexpectedtext "unexpected text in internal DTD subset around line $state(line)"] } # Expand parameter entity and recursively parse # BUG: no checks yet for recursive entity references if {[info exists PEnts($entref)]} { set externalParser [$options(-name) entityparser] $externalParser parse $PEnts($entref) -dtdsubset internal } elseif {[info exists ExtPEnts($entref)]} { set externalParser [$options(-name) entityparser] $externalParser parse $ExtPEnts($entref) -dtdsubset external #$externalParser free } else { uplevel #0 $options(-errorcommand) \ [list illegalreference "reference to undeclared parameter entity \"$entref\""] } } } } return {} } # sgml::ParseDTD:EntityMode -- # # Perform special processing for various parser modes # # Arguments: # opts configuration options # modeVar pass-by-reference mode variable # replTextVar pass-by-ref # declVar pass-by-ref # valueVar pass-by-ref # textVar pass-by-ref # delimiter delimiter currently in force # name # param # # Results: # Depends on current mode proc sgml::ParseDTD:EntityMode {opts modeVar replTextVar declVar valueVar textVar delimiter name param} { upvar 1 $modeVar mode upvar 1 $replTextVar replText upvar 1 $declVar decl upvar 1 $valueVar value upvar 1 $textVar text array set options $opts switch -- $mode { {} { # Pass through to normal processing section } entity { # Look for closing delimiter if {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $decl discard val1 remainder]} { append replText <$val1 DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter set decl / set text $remainder\ $value>$text set value {} set mode {} } elseif {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $value discard val2 remainder]} { append replText <$decl\ $val2 DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter set decl / set text $remainder>$text set value {} set mode {} } elseif {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $text discard val3 remainder]} { append replText <$decl\ $value>$val3 DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter set decl / set text $remainder set value {} set mode {} } else { # Remain in entity mode append replText <$decl\ $value>$text return -code continue } } ignore { upvar #0 $options(-statevariable) state if {[regexp {]](.*)$} $decl discard remainder]} { set state(condSections) [lreplace $state(condSections) end end] set decl $remainder set mode {} } elseif {[regexp {]](.*)$} $value discard remainder]} { set state(condSections) [lreplace $state(condSections) end end] regexp <[cl $::sgml::Wsp]*($::sgml::Name)(.*) $remainder discard decl value set mode {} } elseif {[regexp {]]>(.*)$} $text discard remainder]} { set state(condSections) [lreplace $state(condSections) end end] set decl / set value {} set text $remainder #regexp <[cl $::sgml::Wsp]*($::sgml::Name)([cl ^>]*)>(.*) $remainder discard decl value text set mode {} } else { set decl / } } comment { # Look for closing comment delimiter upvar #0 $options(-statevariable) state if {[regexp (.*?)--(.*)\$ $decl discard data1 remainder]} { } elseif {[regexp (.*?)--(.*)\$ $value discard data1 remainder]} { } elseif {[regexp (.*?)--(.*)\$ $text discard data1 remainder]} { } else { # comment continues append state(commentdata) <$decl\ $value>$text set decl / set value {} set text {} } } } return {} } # sgml::ParseDTD:ProcessMarkupDecl -- # # Process a single markup declaration # # Arguments: # opts configuration options # declVar pass-by-ref # valueVar pass-by-ref # delimiterVar pass-by-ref for current delimiter in force # nameVar pass-by-ref # modeVar pass-by-ref for current parser mode # replTextVar pass-by-ref # textVar pass-by-ref # paramVar pass-by-ref # # Results: # Depends on markup declaration. May change parser mode proc sgml::ParseDTD:ProcessMarkupDecl {opts declVar valueVar delimiterVar nameVar modeVar replTextVar textVar paramVar} { upvar 1 $modeVar mode upvar 1 $replTextVar replText upvar 1 $textVar text upvar 1 $declVar decl upvar 1 $valueVar value upvar 1 $nameVar name upvar 1 $delimiterVar delimiter upvar 1 $paramVar param variable declExpr variable ExternalEntityExpr array set options $opts upvar #0 $options(-statevariable) state switch -glob -- $decl { / { # continuation from entity processing } !ELEMENT { # Element declaration if {[regexp $declExpr $value discard tag cmodel]} { DTD:ELEMENT [array get options] $tag $cmodel } else { uplevel #0 $options(-errorcommand) \ [list illegaldeclaration "malformed element declaration around line $state(line)"] } } !ATTLIST { # Attribute list declaration variable declExpr if {[regexp $declExpr $value discard tag attdefns]} { if {[catch {DTD:ATTLIST [array get options] $tag $attdefns} err]} { #puts stderr "Stack trace: $::errorInfo\n***\n" # Atttribute parsing has bugs at the moment #return -code error "$err around line $state(line)" return {} } } else { uplevel #0 $options(-errorcommand) \ [list illegaldeclaration "malformed attribute list declaration around line $state(line)"] } } !ENTITY { # Entity declaration variable EntityExpr if {[regexp $EntityExpr $value discard param name value]} { # Entity replacement text may have a '>' character. # In this case, the real delimiter will be in the following # text. This is complicated by the possibility of there # being several '<','>' pairs in the replacement text. # At this point, we are searching for the matching quote delimiter. if {[regexp $ExternalEntityExpr $value]} { DTD:ENTITY [array get options] $name [string trim $param] $value } elseif {[regexp (\"|')(.*?)\\1(.*) $value discard delimiter replText value]} { if {[string length [string trim $value]]} { uplevel #0 $options(-errorcommand) \ [list illegaldeclaration "malformed entity declaration around line $state(line)"] } else { DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter } } elseif {[regexp (\"|')(.*) $value discard delimiter replText]} { append replText >$text set text {} set mode entity } else { uplevel #0 $options(-errorcommand) \ [list illegaldeclaration "no delimiter for entity declaration around line $state(line)"] } } else { uplevel #0 $options(-errorcommand) \ [list illegaldeclaration "malformed entity declaration around line $state(line)"] } } !NOTATION { # Notation declaration if {[regexp $declExpr param discard tag notation]} { DTD:ENTITY [array get options] $tag $notation } else { uplevel #0 $options(-errorcommand) \ [list illegaldeclaration "malformed entity declaration around line $state(line)"] } } !--* { # Start of a comment if {[regexp !--(.*?)--\$ $decl discard data]} { if {[string length [string trim $value]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$value\""] } uplevel #0 $options(-commentcommand) [list $data] set decl / set value {} } elseif {[regexp -- ^(.*?)--\$ $value discard data2]} { regexp !--(.*)\$ $decl discard data1 uplevel #0 $options(-commentcommand) [list $data1\ $data2] set decl / set value {} } elseif {[regexp (.*?)-->(.*)\$ $text discard data3 remainder]} { regexp !--(.*)\$ $decl discard data1 uplevel #0 $options(-commentcommand) [list $data1\ $value>$data3] set decl / set value {} set text $remainder } else { regexp !--(.*)\$ $decl discard data1 set state(commentdata) $data1\ $value>$text set decl / set value {} set text {} set mode comment } } !*INCLUDE* - !*IGNORE* { if {$state(inInternalDTD)} { uplevel #0 $options(-errorcommand) \ [list illegalsection "conditional section not permitted in internal DTD\ subset around line $state(line)"] } if {[regexp {^!\[INCLUDE\[(.*)} $decl discard remainder]} { # Push conditional section stack, popped by ]]> sequence if {[regexp {(.*?)]]$} $remainder discard r2]} { # section closed immediately if {[string length [string trim $r2]]} { uplevel #0 $options(-errorcommand) \ [list unexpectedtext "unexpected text \"$r2\" in conditional section"] } } elseif {[regexp {(.*?)]](.*)} $value discard r2 r3]} { # section closed immediately if {[string length [string trim $r2]]} { uplevel #0 $options(-errorcommand) \ [list unexpectedtext "unexpected text \"$r2\" in conditional section"] } if {[string length [string trim $r3]]} { uplevel #0 $options(-errorcommand) \ [list "unexpected text \"$r3\" in conditional section"] } } else { lappend state(condSections) INCLUDE set parser [$options(-name) entityparser] $parser parse $remainder\ $value> -dtdsubset external #$parser free if {[regexp {(.*?)]]>(.*)} $text discard t1 t2]} { if {[string length [string trim $t1]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""] } if {![llength $state(condSections)]} { uplevel #0 $options(-errorcommand) \ [list illegalsection "extraneous conditional section close"] } set state(condSections) [lreplace $state(condSections) end end] set text $t2 } } } elseif {[regexp {^!\[IGNORE\[(.*)} $decl discard remainder]} { # Set ignore mode. Still need a stack set mode ignore if {[regexp {(.*?)]]$} $remainder discard r2]} { # section closed immediately if {[string length [string trim $r2]]} { uplevel #0 $options(-errorcommand) \ [list unexpectedtext "unexpected text \"$r2\" in conditional section"] } } elseif {[regexp {(.*?)]](.*)} $value discard r2 r3]} { # section closed immediately if {[string length [string trim $r2]]} { uplevel #0 $options(-errorcommand) \ [list unexpectedtext "unexpected text \"$r2\" in conditional section"] } if {[string length [string trim $r3]]} { uplevel #0 $options(-errorcommand) \ [list unexpectedtext "unexpected text \"$r3\" in conditional section"] } } else { lappend state(condSections) IGNORE if {[regexp {(.*?)]]>(.*)} $text discard t1 t2]} { if {[string length [string trim $t1]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""] } if {![llength $state(condSections)]} { uplevel #0 $options(-errorcommand) \ [list illegalsection "extraneous conditional section close"] } set state(condSections) [lreplace $state(condSections) end end] set text $t2 } } } else { uplevel #0 $options(-errorcommand) \ [list illegaldeclaration "illegal markup declaration \"$decl\" around line $state(line)"] } } default { if {[regexp {^\?(.*)} $decl discard target]} { # Processing instruction } else { uplevel #0 $options(-errorcommand) [list illegaldeclaration "illegal markup declaration \"$decl\""] } } } return {} } # sgml::ParseDTD:External -- # # Parse the external DTD subset. # # Parameter entities are allowed anywhere. # # Arguments: # opts configuration options # dtd DTD data # # Results: # Markup declarations parsed may cause callback invocation proc sgml::ParseDTD:External {opts dtd} { variable MarkupDeclExpr variable MarkupDeclSub variable declExpr array set options $opts upvar #0 $options(parameterentities) PEnts upvar #0 $options(externalparameterentities) ExtPEnts upvar #0 $options(-statevariable) state # As with the internal DTD subset, watch out for # entities with angle brackets set mode {} ;# normal set delimiter {} set name {} set param {} set oldState 0 catch {set oldState $state(inInternalDTD)} set state(inInternalDTD) 0 # Initialise conditional section stack if {![info exists state(condSections)]} { set state(condSections) {} } set startCondSectionDepth [llength $state(condSections)] while {[string length $dtd]} { set progress 0 set PEref {} if {![string compare $mode "ignore"]} { set progress 1 if {[regexp {]]>(.*)} $dtd discard dtd]} { set remainder {} set mode {} ;# normal set state(condSections) [lreplace $state(condSections) end end] continue } else { uplevel #0 $options(-errorcommand) \ [list missingdelimiter "IGNORE conditional section closing delimiter not found"] } } elseif {[regexp ^(.*?)%($::sgml::Name)\;(.*)\$ $dtd discard data PEref remainder]} { set progress 1 } else { set data $dtd set dtd {} set remainder {} } # Tokenize the DTD (so far) # Protect Tcl special characters regsub -all {([{}\\])} $data {\\\1} dataP set n [regsub -all $MarkupDeclExpr $dataP $MarkupDeclSub dataP] if {$n} { set progress 1 # All but the last markup declaration should have no text set dataP [lrange "{} {} \{$dataP\}" 3 end] if {[llength $dataP] > 3} { foreach {decl value text} [lrange $dataP 0 [expr [llength $dataP] - 4]] { ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode repltextVar text param if {[string length [string trim $text]]} { # check for conditional section close if {[regexp {]]>(.*)$} $text discard text]} { if {[string length [string trim $text]]} { uplevel #0 $options(-errorcommand) \ [list unexpectedtext "unexpected text \"$text\""] } if {![llength $state(condSections)]} { uplevel #0 $options(-errorcommand) \ [list illegalsection "extraneous conditional section close"] } set state(condSections) [lreplace $state(condSections) end end] if {![string compare $mode "ignore"]} { set mode {} ;# normal } } else { uplevel #0 $options(-errorcommand) \ [list unexpectedtext "unexpected text \"$text\""] } } } } # Do the last declaration foreach {decl value text} [lrange $dataP [expr [llength $dataP] - 3] end] { ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode repltextVar text param } } # Now expand the PE reference, if any switch -glob -- $mode,[string length $PEref],$n { ignore,0,* { set dtd $text } ignore,*,* { set dtd $text$remainder } *,0,0 { set dtd $data } *,0,* { set dtd $text } *,*,0 { if {[catch {append data $PEnts($PEref)}]} { if {[info exists ExtPEnts($PEref)]} { set externalParser [$options(-name) entityparser] $externalParser parse $ExtPEnts($PEref) -dtdsubset external #$externalParser free } else { uplevel #0 $options(-errorcommand) \ [list entityundeclared "parameter entity \"$PEref\" not declared"] } } set dtd $data$remainder } default { if {[catch {append text $PEnts($PEref)}]} { if {[info exists ExtPEnts($PEref)]} { set externalParser [$options(-name) entityparser] $externalParser parse $ExtPEnts($PEref) -dtdsubset external #$externalParser free } else { uplevel #0 $options(-errorcommand) \ [list entityundeclared "parameter entity \"$PEref\" not declared"] } } set dtd $text$remainder } } # Check whether a conditional section has been terminated if {[regexp {^(.*?)]]>(.*)$} $dtd discard t1 t2]} { if {![regexp <.*> $t1]} { if {[string length [string trim $t1]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""] } if {![llength $state(condSections)]} { uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"] } set state(condSections) [lreplace $state(condSections) end end] if {![string compare $mode "ignore"]} { set mode {} ;# normal } set dtd $t2 set progress 1 } } if {!$progress} { # No parameter entity references were found and # the text does not contain a well-formed markup declaration # Avoid going into an infinite loop upvar #0 $options(-errorcommand) \ [list syntaxerror "external entity does not contain well-formed markup declaration"] break } } set state(inInternalDTD) $oldState # Check that conditional sections have been closed properly if {[llength $state(condSections)] > $startCondSectionDepth} { uplevel #0 $options(-errorcommand) \ [list syntaxerror "[lindex $state(condSections) end] conditional section not closed"] } if {[llength $state(condSections)] < $startCondSectionDepth} { uplevel #0 $options(-errorcommand) [list syntaxerror "too many conditional section closures"] } return {} } # Procedures for handling the various declarative elements in a DTD. # New elements may be added by creating a procedure of the form # parse:DTD:_element_ # For each of these procedures, the various regular expressions they use # are created outside of the proc to avoid overhead at runtime # sgml::DTD:ELEMENT -- # # defines an element. # # The content model for the element is stored in the contentmodel array, # indexed by the element name. The content model is parsed into the # following list form: # # {} Content model is EMPTY. # Indicated by an empty list. # * Content model is ANY. # Indicated by an asterix. # {ELEMENT ...} # Content model is element-only. # {MIXED {element1 element2 ...}} # Content model is mixed (PCDATA and elements). # The second element of the list contains the # elements that may occur. #PCDATA is assumed # (ie. the list is normalised). # # Arguments: # opts configuration options # name element GI # modspec unparsed content model specification proc sgml::DTD:ELEMENT {opts name modspec} { variable Wsp array set options $opts upvar #0 $options(elementdecls) elements if {$options(-validate) && [info exists elements($name)]} { eval $options(-errorcommand) elementdeclared [list "element \"$name\" already declared"] } else { switch -- $modspec { EMPTY { set elements($name) {} uplevel #0 $options(-elementdeclcommand) $name {{}} } ANY { set elements($name) * uplevel #0 $options(-elementdeclcommand) $name * } default { # Don't parse the content model for now, # just pass the model to the application if {0 && [regexp [format {^\([%s]*#PCDATA[%s]*(\|([^)]+))?[%s]*\)*[%s]*$} $Wsp $Wsp $Wsp $Wsp] \ discard discard mtoks]} { set cm($name) [list MIXED [split $mtoks |]] } elseif {0} { if {[catch {CModelParse $state(state) $value} result]} { eval $options(-errorcommand) element [list $result] } else { set cm($id) [list ELEMENT $result] } } else { set elements($name) $modspec uplevel #0 $options(-elementdeclcommand) $name [list $modspec] } } } } } # sgml::CModelParse -- # # Parse an element content model (non-mixed). # A syntax tree is constructed. # A transition table is built next. # # This is going to need alot of work! # # Arguments: # state state array variable # value the content model data # # Results: # A Tcl list representing the content model. proc sgml::CModelParse {state value} { upvar #0 $state var # First build syntax tree set syntaxTree [CModelMakeSyntaxTree $state $value] # Build transition table set transitionTable [CModelMakeTransitionTable $state $syntaxTree] return [list $syntaxTree $transitionTable] } # sgml::CModelMakeSyntaxTree -- # # Construct a syntax tree for the regular expression. # # Syntax tree is represented as a Tcl list: # rep {:choice|:seq {{rep list1} {rep list2} ...}} # where: rep is repetition character, *, + or ?. {} for no repetition # listN is nested expression or Name # # Arguments: # spec Element specification # # Results: # Syntax tree for element spec as nested Tcl list. # # Examples: # (memo) # {} {:seq {{} memo}} # (front, body, back?) # {} {:seq {{} front} {{} body} {? back}} # (head, (p | list | note)*, div2*) # {} {:seq {{} head} {* {:choice {{} p} {{} list} {{} note}}} {* div2}} # (p | a | ul)+ # + {:choice {{} p} {{} a} {{} ul}} proc sgml::CModelMakeSyntaxTree {state spec} { upvar #0 $state var variable Wsp variable name # Translate the spec into a Tcl list. # None of the Tcl special characters are allowed in a content model spec. if {[regexp {\$|\[|\]|\{|\}} $spec]} { return -code error "illegal characters in specification" } regsub -all [format {(%s)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $name $Wsp $Wsp] $spec \ [format {%sCModelSTname %s {\1} {\2} {\3}} \n $state] spec regsub -all {\(} $spec "\nCModelSTopenParen $state " spec regsub -all [format {\)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $Wsp $Wsp] $spec \ [format {%sCModelSTcloseParen %s {\1} {\2}} \n $state] spec array set var {stack {} state start} eval $spec # Peel off the outer seq, its redundant return [lindex [lindex $var(stack) 1] 0] } # sgml::CModelSTname -- # # Processes a name in a content model spec. # # Arguments: # state state array variable # name name specified # rep repetition operator # cs choice or sequence delimiter # # Results: # See CModelSTcp. proc sgml::CModelSTname {state name rep cs args} { if {[llength $args]} { return -code error "syntax error in specification: \"$args\"" } CModelSTcp $state $name $rep $cs } # sgml::CModelSTcp -- # # Process a content particle. # # Arguments: # state state array variable # name name specified # rep repetition operator # cs choice or sequence delimiter # # Results: # The content particle is added to the current group. proc sgml::CModelSTcp {state cp rep cs} { upvar #0 $state var switch -glob -- [lindex $var(state) end]=$cs { start= { set var(state) [lreplace $var(state) end end end] # Add (dummy) grouping, either choice or sequence will do CModelSTcsSet $state , CModelSTcpAdd $state $cp $rep } :choice= - :seq= { set var(state) [lreplace $var(state) end end end] CModelSTcpAdd $state $cp $rep } start=| - start=, { set var(state) [lreplace $var(state) end end [expr {$cs == "," ? ":seq" : ":choice"}]] CModelSTcsSet $state $cs CModelSTcpAdd $state $cp $rep } :choice=| - :seq=, { CModelSTcpAdd $state $cp $rep } :choice=, - :seq=| { return -code error \ "syntax error in specification: incorrect delimiter\ after \"$cp\", should be \"[expr {$cs == "," ? "|" : ","}]\"" } end=* { return -code error "syntax error in specification: no delimiter before \"$cp\"" } default { return -code error "syntax error" } } } # sgml::CModelSTcsSet -- # # Start a choice or sequence on the stack. # # Arguments: # state state array # cs choice oir sequence # # Results: # state is modified: end element of state is appended. proc sgml::CModelSTcsSet {state cs} { upvar #0 $state var set cs [expr {$cs == "," ? ":seq" : ":choice"}] if {[llength $var(stack)]} { set var(stack) [lreplace $var(stack) end end $cs] } else { set var(stack) [list $cs {}] } } # sgml::CModelSTcpAdd -- # # Append a content particle to the top of the stack. # # Arguments: # state state array # cp content particle # rep repetition # # Results: # state is modified: end element of state is appended. proc sgml::CModelSTcpAdd {state cp rep} { upvar #0 $state var if {[llength $var(stack)]} { set top [lindex $var(stack) end] lappend top [list $rep $cp] set var(stack) [lreplace $var(stack) end end $top] } else { set var(stack) [list $rep $cp] } } # sgml::CModelSTopenParen -- # # Processes a '(' in a content model spec. # # Arguments: # state state array # # Results: # Pushes stack in state array. proc sgml::CModelSTopenParen {state args} { upvar #0 $state var if {[llength $args]} { return -code error "syntax error in specification: \"$args\"" } lappend var(state) start lappend var(stack) [list {} {}] } # sgml::CModelSTcloseParen -- # # Processes a ')' in a content model spec. # # Arguments: # state state array # rep repetition # cs choice or sequence delimiter # # Results: # Stack is popped, and former top of stack is appended to previous element. proc sgml::CModelSTcloseParen {state rep cs args} { upvar #0 $state var if {[llength $args]} { return -code error "syntax error in specification: \"$args\"" } set cp [lindex $var(stack) end] set var(stack) [lreplace $var(stack) end end] set var(state) [lreplace $var(state) end end] CModelSTcp $state $cp $rep $cs } # sgml::CModelMakeTransitionTable -- # # Given a content model's syntax tree, constructs # the transition table for the regular expression. # # See "Compilers, Principles, Techniques, and Tools", # Aho, Sethi and Ullman. Section 3.9, algorithm 3.5. # # Arguments: # state state array variable # st syntax tree # # Results: # The transition table is returned, as a key/value Tcl list. proc sgml::CModelMakeTransitionTable {state st} { upvar #0 $state var # Construct nullable, firstpos and lastpos functions array set var {number 0} foreach {nullable firstpos lastpos} [ \ TraverseDepth1st $state $st { # Evaluated for leaf nodes # Compute nullable(n) # Compute firstpos(n) # Compute lastpos(n) set nullable [nullable leaf $rep $name] set firstpos [list {} $var(number)] set lastpos [list {} $var(number)] set var(pos:$var(number)) $name } { # Evaluated for nonterminal nodes # Compute nullable, firstpos, lastpos set firstpos [firstpos $cs $firstpos $nullable] set lastpos [lastpos $cs $lastpos $nullable] set nullable [nullable nonterm $rep $cs $nullable] } \ ] break set accepting [incr var(number)] set var(pos:$accepting) # # var(pos:N) maps from position to symbol. # Construct reverse map for convenience. # NB. A symbol may appear in more than one position. # var is about to be reset, so use different arrays. foreach {pos symbol} [array get var pos:*] { set pos [lindex [split $pos :] 1] set pos2symbol($pos) $symbol lappend sym2pos($symbol) $pos } # Construct the followpos functions catch {unset var} followpos $state $st $firstpos $lastpos # Construct transition table # Dstates is [union $marked $unmarked] set unmarked [list [lindex $firstpos 1]] while {[llength $unmarked]} { set T [lindex $unmarked 0] lappend marked $T set unmarked [lrange $unmarked 1 end] # Find which input symbols occur in T set symbols {} foreach pos $T { if {$pos != $accepting && [lsearch $symbols $pos2symbol($pos)] < 0} { lappend symbols $pos2symbol($pos) } } foreach a $symbols { set U {} foreach pos $sym2pos($a) { if {[lsearch $T $pos] >= 0} { # add followpos($pos) if {$var($pos) == {}} { lappend U $accepting } else { eval lappend U $var($pos) } } } set U [makeSet $U] if {[llength $U] && [lsearch $marked $U] < 0 && [lsearch $unmarked $U] < 0} { lappend unmarked $U } set Dtran($T,$a) $U } } return [list [array get Dtran] [array get sym2pos] $accepting] } # sgml::followpos -- # # Compute the followpos function, using the already computed # firstpos and lastpos. # # Arguments: # state array variable to store followpos functions # st syntax tree # firstpos firstpos functions for the syntax tree # lastpos lastpos functions # # Results: # followpos functions for each leaf node, in name/value format proc sgml::followpos {state st firstpos lastpos} { upvar #0 $state var switch -- [lindex [lindex $st 1] 0] { :seq { for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} { followpos $state [lindex [lindex $st 1] $i] \ [lindex [lindex $firstpos 0] [expr $i - 1]] \ [lindex [lindex $lastpos 0] [expr $i - 1]] foreach pos [lindex [lindex [lindex $lastpos 0] [expr $i - 1]] 1] { eval lappend var($pos) [lindex [lindex [lindex $firstpos 0] $i] 1] set var($pos) [makeSet $var($pos)] } } } :choice { for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} { followpos $state [lindex [lindex $st 1] $i] \ [lindex [lindex $firstpos 0] [expr $i - 1]] \ [lindex [lindex $lastpos 0] [expr $i - 1]] } } default { # No action at leaf nodes } } switch -- [lindex $st 0] { ? { # We having nothing to do here ! Doing the same as # for * effectively converts this qualifier into the other. } * { foreach pos [lindex $lastpos 1] { eval lappend var($pos) [lindex $firstpos 1] set var($pos) [makeSet $var($pos)] } } } } # sgml::TraverseDepth1st -- # # Perform depth-first traversal of a tree. # A new tree is constructed, with each node computed by f. # # Arguments: # state state array variable # t The tree to traverse, a Tcl list # leaf Evaluated at a leaf node # nonTerm Evaluated at a nonterminal node # # Results: # A new tree is returned. proc sgml::TraverseDepth1st {state t leaf nonTerm} { upvar #0 $state var set nullable {} set firstpos {} set lastpos {} switch -- [lindex [lindex $t 1] 0] { :seq - :choice { set rep [lindex $t 0] set cs [lindex [lindex $t 1] 0] foreach child [lrange [lindex $t 1] 1 end] { foreach {childNullable childFirstpos childLastpos} \ [TraverseDepth1st $state $child $leaf $nonTerm] break lappend nullable $childNullable lappend firstpos $childFirstpos lappend lastpos $childLastpos } eval $nonTerm } default { incr var(number) set rep [lindex [lindex $t 0] 0] set name [lindex [lindex $t 1] 0] eval $leaf } } return [list $nullable $firstpos $lastpos] } # sgml::firstpos -- # # Computes the firstpos function for a nonterminal node. # # Arguments: # cs node type, choice or sequence # firstpos firstpos functions for the subtree # nullable nullable functions for the subtree # # Results: # firstpos function for this node is returned. proc sgml::firstpos {cs firstpos nullable} { switch -- $cs { :seq { set result [lindex [lindex $firstpos 0] 1] for {set i 0} {$i < [llength $nullable]} {incr i} { if {[lindex [lindex $nullable $i] 1]} { eval lappend result [lindex [lindex $firstpos [expr $i + 1]] 1] } else { break } } } :choice { foreach child $firstpos { eval lappend result $child } } } return [list $firstpos [makeSet $result]] } # sgml::lastpos -- # # Computes the lastpos function for a nonterminal node. # Same as firstpos, only logic is reversed # # Arguments: # cs node type, choice or sequence # lastpos lastpos functions for the subtree # nullable nullable functions forthe subtree # # Results: # lastpos function for this node is returned. proc sgml::lastpos {cs lastpos nullable} { switch -- $cs { :seq { set result [lindex [lindex $lastpos end] 1] for {set i [expr [llength $nullable] - 1]} {$i >= 0} {incr i -1} { if {[lindex [lindex $nullable $i] 1]} { eval lappend result [lindex [lindex $lastpos $i] 1] } else { break } } } :choice { foreach child $lastpos { eval lappend result $child } } } return [list $lastpos [makeSet $result]] } # sgml::makeSet -- # # Turn a list into a set, ie. remove duplicates. # # Arguments: # s a list # # Results: # A set is returned, which is a list with duplicates removed. proc sgml::makeSet s { foreach r $s { if {[llength $r]} { set unique($r) {} } } return [array names unique] } # sgml::nullable -- # # Compute the nullable function for a node. # # Arguments: # nodeType leaf or nonterminal # rep repetition applying to this node # name leaf node: symbol for this node, nonterm node: choice or seq node # subtree nonterm node: nullable functions for the subtree # # Results: # Returns nullable function for this branch of the tree. proc sgml::nullable {nodeType rep name {subtree {}}} { switch -glob -- $rep:$nodeType { :leaf - +:leaf { return [list {} 0] } \\*:leaf - \\?:leaf { return [list {} 1] } \\*:nonterm - \\?:nonterm { return [list $subtree 1] } :nonterm - +:nonterm { switch -- $name { :choice { set result 0 foreach child $subtree { set result [expr $result || [lindex $child 1]] } } :seq { set result 1 foreach child $subtree { set result [expr $result && [lindex $child 1]] } } } return [list $subtree $result] } } } # sgml::DTD:ATTLIST -- # # defines an attribute list. # # Arguments: # opts configuration opions # name Element GI # attspec unparsed attribute definitions # # Results: # Attribute list variables are modified. proc sgml::DTD:ATTLIST {opts name attspec} { variable attlist_exp variable attlist_enum_exp variable attlist_fixed_exp array set options $opts # Parse the attribute list. If it were regular, could just use foreach, # but some attributes may have values. regsub -all {([][$\\])} $attspec {\\\1} attspec regsub -all $attlist_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {} \{" attspec regsub -all $attlist_enum_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {} {\\4} \{" attspec regsub -all $attlist_fixed_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {\\4} \{" attspec eval "noop \{$attspec\}" return {} } # sgml::DTDAttribute -- # # Parse definition of a single attribute. # # Arguments: # callback attribute defn callback # name element name # var array variable # att attribute name # type type of this attribute # default default value of the attribute # value other information # text other text (should be empty) # # Results: # Attribute defn added to array, unless it already exists proc sgml::DTDAttribute args { # BUG: Some problems with parameter passing - deal with it later foreach {callback name var att type default value text} $args break upvar #0 $var atts if {[string length [string trim $text]]} { return -code error "unexpected text \"$text\" in attribute definition" } # What about overridden attribute defns? # A non-validating app may want to know about them # (eg. an editor) if {![info exists atts($name/$att)]} { set atts($name/$att) [list $type $default $value] uplevel #0 $callback [list $name $att $type $default $value] } return {} } # sgml::DTD:ENTITY -- # # declaration. # # Callbacks: # -entitydeclcommand for general entity declaration # -unparsedentitydeclcommand for unparsed external entity declaration # -parameterentitydeclcommand for parameter entity declaration # # Arguments: # opts configuration options # name name of entity being defined # param whether a parameter entity is being defined # value unparsed replacement text # # Results: # Modifies the caller's entities array variable proc sgml::DTD:ENTITY {opts name param value} { array set options $opts if {[string compare % $param]} { # Entity declaration - general or external upvar #0 $options(entities) ents upvar #0 $options(extentities) externals if {[info exists ents($name)] || [info exists externals($name)]} { eval $options(-warningcommand) entity [list "entity \"$name\" already declared"] } else { if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} { return -code error "unable to parse entity declaration due to \"$value\"" } switch -glob -- [lindex $value 0],[lindex $value 3] { internal, { set ents($name) [EntitySubst [array get options] [lindex $value 1]] uplevel #0 $options(-entitydeclcommand) [list $name $ents($name)] } internal,* { return -code error "unexpected NDATA declaration" } external, { set externals($name) [lrange $value 1 2] uplevel #0 $options(-entitydeclcommand) [eval list $name [lrange $value 1 2]] } external,* { set externals($name) [lrange $value 1 3] uplevel #0 $options(-unparsedentitydeclcommand) [eval list $name [lrange $value 1 3]] } default { return -code error "internal error: unexpected parser state" } } } } else { # Parameter entity declaration upvar #0 $options(parameterentities) PEnts upvar #0 $options(externalparameterentities) ExtPEnts if {[info exists PEnts($name)] || [info exists ExtPEnts($name)]} { eval $options(-warningcommand) parameterentity [list "parameter entity \"$name\" already declared"] } else { if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} { return -code error "unable to parse parameter entity declaration due to \"$value\"" } if {[string length [lindex $value 3]]} { return -code error "NDATA illegal in parameter entity declaration" } switch -- [lindex $value 0] { internal { # Substitute character references and PEs (XML: 4.5) set value [EntitySubst [array get options] [lindex $value 1]] set PEnts($name) $value uplevel #0 $options(-parameterentitydeclcommand) [list $name $value] } external - default { # Get the replacement text now. # Could wait until the first reference, but easier # to just do it now. set token [uri::geturl [uri::resolve $options(-baseurl) [lindex $value 1]]] set ExtPEnts($name) [lindex [array get $token data] 1] uplevel #0 $options(-parameterentitydeclcommand) [eval list $name [lrange $value 1 2]] } } } } } # sgml::EntitySubst -- # # Perform entity substitution on an entity replacement text. # This differs slightly from other substitution procedures, # because only parameter and character entity substitution # is performed, not general entities. # See XML Rec. section 4.5. # # Arguments: # opts configuration options # value Literal entity value # # Results: # Expanded replacement text proc sgml::EntitySubst {opts value} { array set options $opts # Protect Tcl special characters regsub -all {([{}\\])} $value {\\\1} value # Find entity references regsub -all (&#\[0-9\]+|&#x\[0-9a-fA-F\]+|%${::sgml::Name})\; $value "\[EntitySubstValue [list $options(parameterentities)] {\\1}\]" value set result [subst $value] return $result } # sgml::EntitySubstValue -- # # Handle a single character or parameter entity substitution # # Arguments: # PEvar array variable containing PE declarations # ref character or parameter entity reference # # Results: # Replacement text proc sgml::EntitySubstValue {PEvar ref} { switch -glob -- $ref { &#x* { scan [string range $ref 3 end] %x hex return [format %c $hex] } &#* { return [format %c [string range $ref 2 end]] } %* { upvar #0 $PEvar PEs set ref [string range $ref 1 end] if {[info exists PEs($ref)]} { return $PEs($ref) } else { return -code error "parameter entity \"$ref\" not declared" } } default { return -code error "internal error - unexpected entity reference" } } return {} } # sgml::DTD:NOTATION -- # # Process notation declaration # # Arguments: # opts configuration options # name notation name # value unparsed notation spec proc sgml::DTD:NOTATION {opts name value} { return {} variable notation_exp upvar opts state if {[regexp $notation_exp $value x scheme data] == 2} { } else { eval $state(-errorcommand) notationvalue [list "notation value \"$value\" incorrectly specified"] } } # sgml::ResolveEntity -- # # Default entity resolution routine # # Arguments: # name name of parent parser # base base URL for relative URLs # sysId system identifier # pubId public identifier proc sgml::ResolveEntity {name base sysId pubId} { variable ParseEventNum if {[catch {uri::resolve $base $sysId} url]} { return -code error "unable to resolve system identifier \"$sysId\"" } if {[catch {uri::geturl $url} token]} { return -code error "unable to retrieve external entity \"$url\" for system identifier \"$sysId\"" } upvar #0 $token data set parser [uplevel #0 $name entityparser] $parser parse $data(body) -dtdsubset external #$parser free return {} } # vim:ft=tcl:ts=8:sw=4:sts=4:et tclxmpp/tclxml/tclparser.tcl000064400000000000000000000442321470446212700161430ustar00nobodynobody# tclparser.tcl -- # # This file provides a Tcl implementation of a XML parser. # This file supports Tcl 8.1. # # See xml-8.[01].tcl for definitions of character sets and # regular expressions. # # Copyright (c) 1998-2002 Zveno Pty Ltd # http://www.zveno.com/ # # Zveno makes this software and all associated data and documentation # ('Software') available free of charge for any purpose. # Copies may be made of this Software but all of this notice must be included # on any copy. # # The Software was developed for research purposes and Zveno does not warrant # that it is error free or fit for any purpose. Zveno disclaims any # liability for all claims, expenses, losses, damages and costs any user may # incur as a result of using, copying or modifying the Software. # # Copyright (c) 1997 Australian National University (ANU). # # ANU makes this software and all associated data and documentation # ('Software') available free of charge for any purpose. You may make copies # of the Software but you must include all of this notice on any copy. # # The Software was developed for research purposes and ANU does not warrant # that it is error free or fit for any purpose. ANU disclaims any # liability for all claims, expenses, losses, damages and costs any user may # incur as a result of using, copying or modifying the Software. package require Tcl 8.1 package provide xml::tclparser 2.0 package require -exact xmldefs 2.0 package require -exact sgmlparser 1.0 namespace eval xml::tclparser { namespace export create createexternal externalentity parse \ configure get delete # Tokenising expressions variable tokExpr1 $::xml::tokExpr1 variable tokExpr2 $::xml::tokExpr2 variable tokExpr3 $::xml::tokExpr3 variable substExpr $::xml::substExpr # Register this parser class ::xml::parserclass create tcl \ -createcommand [namespace code create] \ -createentityparsercommand [namespace code createentityparser] \ -parsecommand [namespace code parse] \ -configurecommand [namespace code configure] \ -deletecommand [namespace code delete] } # xml::tclparser::create -- # # Creates XML parser object. # # Arguments: # name unique identifier for this instance # # Results: # The state variable is initialised. proc xml::tclparser::create name { # Initialise state variable upvar \#0 [namespace current]::$name parser array set parser [list \ -name $name \ -final 1 \ -namespace 1 \ -validate 0 \ -statevariable [namespace current]::$name \ -baseurl {} \ internaldtd {} \ entities [namespace current]::Entities$name \ extentities [namespace current]::ExtEntities$name \ parameterentities [namespace current]::PEntities$name \ externalparameterentities [namespace current]::ExtPEntities$name \ elementdecls [namespace current]::ElDecls$name \ attlistdecls [namespace current]::AttlistDecls$name \ notationdecls [namespace current]::NotDecls$name \ depth 0 \ leftover {} \ ] # Initialise entities with predefined set array set [namespace current]::Entities$name [array get ::sgml::EntityPredef] return $name } # xml::tclparser::createentityparser -- # # Creates XML parser object for an entity. # # Arguments: # name name for the new parser # parent name of parent parser # # Results: # The state variable is initialised. proc xml::tclparser::createentityparser {parent name} { upvar #0 [namespace current]::$parent p # Initialise state variable upvar \#0 [namespace current]::$name external array set external [array get p] array set external [list \ -name $name \ -statevariable [namespace current]::$name \ internaldtd {} \ line 0 \ ] incr external(depth) return $name } # xml::tclparser::configure -- # # Configures a XML parser object. # # Arguments: # name unique identifier for this instance # args option name/value pairs # # Results: # May change values of config options proc xml::tclparser::configure {name args} { upvar \#0 [namespace current]::$name parser # BUG: very crude, no checks for illegal args # Mats: Should be synced with sgmlparser.tcl set options { -elementstartcommand -elementendcommand \ -characterdatacommand -processinginstructioncommand \ -externalentitycommand -xmldeclcommand \ -doctypecommand -commentcommand \ -entitydeclcommand -unparsedentitydeclcommand \ -parameterentitydeclcommand -notationdeclcommand \ -elementdeclcommand -attlistdeclcommand \ -paramentityparsing -defaultexpandinternalentities \ -startdoctypedeclcommand -enddoctypedeclcommand \ -entityreferencecommand -warningcommand \ -errorcommand -final -namespace \ -validate -baseurl \ -name -emptyelement \ -parseattributelistcommand -parseentitydeclcommand \ -normalize -internaldtd \ -reportempty -ignorewhitespace \ -reportempty \ } set usage [join $options ", "] regsub -all -- - $options {} options set pat ^-([join $options |])$ foreach {flag value} $args { if {[regexp $pat $flag]} { # Validate numbers if {[info exists parser($flag)] && \ [string is integer -strict $parser($flag)] && \ ![string is integer -strict $value]} { return -code error "Bad value for $flag ($value), must be integer" } set parser($flag) $value } else { return -code error "Unknown option $flag, can be: $usage" } } return {} } # xml::tclparser::parse -- # # Parses document instance data # # Arguments: # name parser object # xml data # args configuration options # # Results: # Callbacks are invoked proc xml::tclparser::parse {name xml args} { array set options $args upvar \#0 [namespace current]::$name parser variable tokExpr1 variable tokExpr2 variable tokExpr3 variable substExpr # Mats: if {[llength $args]} { eval {configure $name} $args } set parseOptions [list \ -emptyelement [namespace code ParseEmpty] \ -parseattributelistcommand [namespace code ParseAttrs] \ -parseentitydeclcommand [namespace code ParseEntity] \ -normalize 0] eval lappend parseOptions \ [array get parser -*command] \ [array get parser -reportempty] \ [array get parser -name] \ [array get parser -baseurl] \ [array get parser -validate] \ [array get parser -namespace] \ [array get parser -final] \ [array get parser -defaultexpandinternalentities] \ [array get parser entities] \ [array get parser extentities] \ [array get parser parameterentities] \ [array get parser externalparameterentities] \ [array get parser elementdecls] \ [array get parser attlistdecls] \ [array get parser notationdecls] # Mats: # If -final 0 we also need to maintain the state with a -statevariable ! if {!$parser(-final)} { eval lappend parseOptions [array get parser -statevariable] } set dtdsubset no catch {set dtdsubset $options(-dtdsubset)} switch -- $dtdsubset { internal { # Bypass normal parsing lappend parseOptions -statevariable $parser(-statevariable) array set intOptions [array get ::sgml::StdOptions] array set intOptions $parseOptions ::sgml::ParseDTD:Internal [array get intOptions] $xml return {} } external { # Bypass normal parsing lappend parseOptions -statevariable $parser(-statevariable) array set intOptions [array get ::sgml::StdOptions] array set intOptions $parseOptions ::sgml::ParseDTD:External [array get intOptions] $xml return {} } default { # Pass through to normal processing } } lappend tokenOptions \ -internaldtdvariable [namespace current]::${name}(internaldtd) # Mats: If -final 0 we also need to maintain the state with a -statevariable ! if {!$parser(-final)} { eval lappend tokenOptions [array get parser -statevariable] \ [array get parser -final] } # Mats: # Why not the first four? Just padding? Lrange undos \n interp. # It is necessary to have the first four as well if chopped off in # middle of pcdata. set tokenised [lrange \ [eval {::sgml::tokenise $xml $tokExpr1 $tokExpr2 $tokExpr3 $substExpr} $tokenOptions] \ 0 end] lappend parseOptions -internaldtd [list $parser(internaldtd)] eval ::sgml::parseEvent [list $tokenised] $parseOptions return {} } # xml::tclparser::ParseEmpty -- Tcl 8.1+ version # # Used by parser to determine whether an element is empty. # This is usually dead easy in XML, but as always not quite. # Have to watch out for empty element syntax # # Arguments: # tag element name # attr attribute list (raw) # e End tag delimiter. # # Results: # Return value of e proc xml::tclparser::ParseEmpty {tag attr e} { switch -glob -- [string length $e],[regexp "/[::xml::cl $::xml::Wsp]*$" $attr] { 0,0 { return {} } 0,* { return / } default { return $e } } } # xml::tclparser::ParseAttrs -- Tcl 8.1+ version # # Parse element attributes. # # There are two forms for name-value pairs: # # name="value" # name='value' # # Arguments: # opts parser options # attrs attribute string given in a tag # # Results: # Returns a Tcl list representing the name-value pairs in the # attribute string # # A ">" occurring in the attribute list causes problems when parsing # the XML. This manifests itself by an unterminated attribute value # and a ">" appearing the element text. # In this case return a three element list; # the message "unterminated attribute value", the attribute list it # did manage to parse and the remainder of the attribute list. proc xml::tclparser::ParseAttrs {opts attrs} { set result {} while {[string length [string trim $attrs]]} { if {[regexp ($::xml::Name)[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*(\"|')([::sgml::cl ^<]*?)\\2(.*) \ $attrs -> attrName delimiter value attrs]} { lappend result $attrName [NormalizeAttValue $opts $value] } elseif {[regexp $::xml::Name[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*(\"|')[::sgml::cl ^<]*\$ \ $attrs]} { return -code error [list {unterminated attribute value} $result $attrs] } else { return -code error "invalid attribute list" } } return $result } # xml::tclparser::NormalizeAttValue -- # # Perform attribute value normalisation. This involves: # . character references are appended to the value # . entity references are recursively processed and replacement value appended # . whitespace characters cause a space to be appended # . other characters appended as-is # # Arguments: # opts parser options # value unparsed attribute value # # Results: # Normalised value returned. proc xml::tclparser::NormalizeAttValue {opts value} { # sgmlparser already has backslashes protected # Protect Tcl specials regsub -all {([][$])} $value {\\\1} value # Deal with white space regsub -all "\[$::xml::Wsp\]" $value { } value # Find entity refs regsub -all {&([^;]+);} $value {[NormalizeAttValue:DeRef $opts {\1}]} value return [subst $value] } # xml::tclparser::NormalizeAttValue:DeRef -- # # Handler to normalize attribute values # # Arguments: # opts parser options # ref entity reference # # Results: # Returns character proc xml::tclparser::NormalizeAttValue:DeRef {opts ref} { switch -glob -- $ref { #x* { scan [string range $ref 2 end] %x value set char [format %c $value] # Check that the char is legal for XML if {[regexp [format {^[%s]$} $::xml::Char] $char]} { return $char } else { return -code error "illegal character" } } #* { scan [string range $ref 1 end] %d value set char [format %c $value] # Check that the char is legal for XML if {[regexp [format {^[%s]$} $::xml::Char] $char]} { return $char } else { return -code error "illegal character" } } lt - gt - amp - quot - apos { array set map {lt < gt > amp & quot \" apos '} return $map($ref) } default { # A general entity. Must resolve to a text value - no element structure. array set options $opts upvar #0 $options(entities) map if {[info exists map($ref)]} { if {[regexp < $map($ref)]} { return -code error "illegal character \"<\" in attribute value" } if {![regexp & $map($ref)]} { # Simple text replacement return $map($ref) } # There are entity references in the replacement text. # Can't use child entity parser since must catch element structures return [NormalizeAttValue $opts $map($ref)] } elseif {[string compare $options(-entityreferencecommand) "::sgml::noop"]} { set result [uplevel #0 $options(-entityreferencecommand) [list $ref]] return $result } else { return -code error "unable to resolve entity reference \"$ref\"" } } } } # xml::tclparser::ParseEntity -- # # Parse general entity declaration # # Arguments: # data text to parse # # Results: # Tcl list containing entity declaration proc xml::tclparser::ParseEntity data { set data [string trim $data] if {[regexp $::sgml::ExternalEntityExpr $data \ -> type delimiter1 id1 discard delimiter2 id2 optNDATA ndata]} { switch -- $type { PUBLIC { return [list external $id2 $id1 $ndata] } SYSTEM { return [list external $id1 {} $ndata] } } } elseif {[regexp {^(\"|')(.*?)\1$} $data discard delimiter value]} { return [list internal $value] } else { return -code error "badly formed entity declaration" } } # xml::tclparser::delete -- # # Destroy parser data # # Arguments: # name parser object # # Results: # Parser data structure destroyed proc xml::tclparser::delete name { upvar \#0 [namespace current]::$name parser catch {::sgml::ParserDelete $parser(-statevariable)} catch {unset parser} return {} } # xml::tclparser::get -- # # Retrieve additional information from the parser # # Arguments: # name parser object # method info to retrieve # args additional arguments for method # # Results: # Depends on method proc xml::tclparser::get {name method args} { upvar #0 [namespace current]::$name parser switch -- $method { elementdecl { switch -- [llength $args] { 0 { # Return all element declarations upvar #0 $parser(elementdecls) elements return [array get elements] } 1 { # Return specific element declaration upvar #0 $parser(elementdecls) elements if {[info exists elements([lindex $args 0])]} { return [array get elements [lindex $args 0]] } else { return -code error "element \"[lindex $args 0]\" not\ declared" } } default { return -code error "wrong number of arguments: should be\ \"elementdecl ?element?\"" } } } attlist { if {[llength $args] != 1} { return -code error "wrong number of arguments: should be\ \"get attlist element\"" } upvar #0 $parser(attlistdecls) return {} } entitydecl { } parameterentitydecl { } notationdecl { } default { return -code error "unknown method \"$method\"" } } return {} } # xml::tclparser::ExternalEntity -- # # Resolve and parse external entity # # Arguments: # name parser object # base base URL # sys system identifier # pub public identifier # # Results: # External entity is fetched and parsed proc xml::tclparser::ExternalEntity {name base sys pub} {} # vim:ft=tcl:ts=8:sw=4:sts=4:et tclxmpp/tclxml/xml.tcl000064400000000000000000000077071470446212700147520ustar00nobodynobody# xml.tcl -- # # This file provides generic XML services for all implementations. # This file supports Tcl 8.1 regular expressions. # # See tclparser.tcl for the Tcl implementation of a XML parser. # # Copyright (c) 1998-2000 Zveno Pty Ltd # http://www.zveno.com/ # # Zveno makes this software and all associated data and documentation # ('Software') available free of charge for any purpose. # Copies may be made of this Software but all of this notice must be included # on any copy. # # The Software was developed for research purposes and Zveno does not warrant # that it is error free or fit for any purpose. Zveno disclaims any # liability for all claims, expenses, losses, damages and costs any user may # incur as a result of using, copying or modifying the Software. # # Copyright (c) 1997 Australian National University (ANU). # # ANU makes this software and all associated data and documentation # ('Software') available free of charge for any purpose. You may make copies # of the Software but you must include all of this notice on any copy. # # The Software was developed for research purposes and ANU does not warrant # that it is error free or fit for any purpose. ANU disclaims any # liability for all claims, expenses, losses, damages and costs any user may # incur as a result of using, copying or modifying the Software. package require Tcl 8.1 package provide xmldefs 2.0 package require -exact sgml 1.8 namespace eval xml { namespace export qnamesplit # Convenience routine proc cl x { return "\[$x\]" } # Define various regular expressions # Characters variable Char $::sgml::Char # white space variable Wsp " \t\r\n" variable allWsp [cl $Wsp]* variable noWsp [cl ^$Wsp] # Various XML names and tokens variable NameChar $::sgml::NameChar variable Name $::sgml::Name variable Names $::sgml::Names variable Nmtoken $::sgml::Nmtoken variable Nmtokens $::sgml::Nmtokens # XML Namespaces names # NCName ::= Name - ':' variable NCName $::sgml::Name regsub -all : $NCName {} NCName variable QName (${NCName}:)?$NCName ; # (Prefix ':')? LocalPart # table of predefined entities variable EntityPredef array set EntityPredef { lt < gt > amp & quot \" apos ' } # Expressions for pulling things apart #variable tokExpr <(/?)([::xml::cl ^$::xml::Wsp>/]+)([::xml::cl $::xml::Wsp]*[::xml::cl ^>]*)> variable tokExpr1 {<()(\?[^\s>]+)(([^>]+|[^?]>)*\?)>} variable tokExpr2 {<()(![^\s>]+)(\s*[^>]*)>} variable tokExpr3 {<(/?)([^!?][^\s>/]*)((\s*[^'\"\s]+\s*=\s*('[^']*'|\"[^\"]*\"))*\s*/?)>} variable substExpr "\}\n{\\2} {\\1} {\\3} \{" } ### ### Exported procedures ### # xml::qnamesplit -- # # Split a QName into its constituent parts: # the XML Namespace prefix and the Local-name # # Arguments: # qname XML Qualified Name (see XML Namespaces [6]) # # Results: # Returns prefix and local-name as a Tcl list. # Error condition returned if the prefix or local-name # are not valid NCNames (XML Name) proc xml::qnamesplit qname { variable NCName variable Name set prefix {} set localname $qname if {[regexp : $qname]} { if {![regexp ^($NCName)?:($NCName)\$ $qname discard prefix localname]} { return -code error "name \"$qname\" is not a valid QName" } } elseif {![regexp ^$Name\$ $qname]} { return -code error "name \"$qname\" is not a valid Name" } return [list $prefix $localname] } ### ### General utility procedures ### # xml::noop -- # # A do-nothing proc proc xml::noop args {} ### Following procedures are based on html_library # xml::zapWhite -- # # Convert multiple white space into a single space. # # Arguments: # data plain text # # Results: # As above proc xml::zapWhite data { regsub -all "\[ \t\r\n\]+" $data { } data return $data } # vim:ft=tcl:ts=8:sw=4:sts=4:et tclxmpp/tclxml/xmltcl.tcl000064400000000000000000000174531470446212700154540ustar00nobodynobody# xmltcl.tcl -- # # This file provides a Tcl implementation of the parser # class support found in ../tclxml.c. It is only used # when the C implementation is not installed (for some reason). # # Copyright (c) 2000 Zveno Pty Ltd # http://www.zveno.com/ # # Zveno makes this software and all associated data and documentation # ('Software') available free of charge for any purpose. # Copies may be made of this Software but all of this notice must be included # on any copy. # # The Software was developed for research purposes and Zveno does not warrant # that it is error free or fit for any purpose. Zveno disclaims any # liability for all claims, expenses, losses, damages and costs any user may # incur as a result of using, copying or modifying the Software. package provide xml::tcl 2.0 namespace eval xml { namespace export configure parser parserclass # Parser implementation classes variable classes array set classes {} # Default parser class variable default {} # Counter for generating unique names variable counter 0 } # xml::configure -- # # Configure the xml package # # Arguments: # None # # Results: # None (not yet implemented) proc xml::configure args {} # xml::parserclass -- # # Implements the xml::parserclass command for managing # parser implementations. # # Arguments: # method subcommand # args method arguments # # Results: # Depends on method proc xml::parserclass {method args} { variable classes variable default switch -- $method { create { if {[llength $args] < 1} { return -code error "wrong number of arguments, should be\ xml::parserclass create name ?args?" } set name [lindex $args 0] if {[llength [lrange $args 1 end]] % 2} { return -code error "missing value for option\ \"[lindex $args end]\"" } array set classes [list $name [list \ -createcommand [namespace current]::noop \ -createentityparsercommand [namespace current]::noop \ -parsecommand [namespace current]::noop \ -configurecommand [namespace current]::noop \ -getcommand [namespace current]::noop \ -deletecommand [namespace current]::noop \ ]] # BUG: we're not checking that the arguments are kosher set classes($name) [lrange $args 1 end] set default $name } destroy { if {[llength $args] < 1} { return -code error "wrong number of arguments, should be\ xml::parserclass destroy name" } if {[info exists classes([lindex $args 0])]} { unset classes([lindex $args 0]) } else { return -code error "no such parser class \"[lindex $args 0]\"" } } info { if {[llength $args] < 1} { return -code error "wrong number of arguments, should be\ xml::parserclass info method" } switch -- [lindex $args 0] { names { return [array names classes] } default { return $default } } } default { return -code error "unknown method \"$method\"" } } return {} } # xml::parser -- # # Create a parser object instance # # Arguments: # args optional name, optional -namespace, configuration options # # Results: # Returns object name. Parser instance created. proc xml::parser {args} { variable classes variable default if {[llength $args] < 1} { # Create unique name, no options set parserName [FindUniqueName] } else { if {[string index [lindex $args 0] 0] == "-"} { # Create unique name, have options set parserName [FindUniqueName] } else { # Given name, optional options set parserName [lindex $args 0] set args [lrange $args 1 end] } # consume first -namespace if any if {[string equal [lindex $args 0] "-namespace"]} { set args [linsert $args 1 1] } else { set args [linsert $args 0 -namespace 0] } } array set options [list \ -parser $default ] array set options $args if {![info exists classes($options(-parser))]} { return -code error "no such parser class \"$options(-parser)\"" } # Now create the parser instance command and data structure # The command must be created in the caller's namespace uplevel 1 [list proc $parserName {method args} \ "eval [namespace current]::ParserCmd [list $parserName]\ \[list \$method\] \$args"] upvar #0 [namespace current]::$parserName data array set data [list class $options(-parser)] array set classinfo $classes($options(-parser)) if {[string compare $classinfo(-createcommand) ""]} { eval $classinfo(-createcommand) [list $parserName] } if {[string compare $classinfo(-configurecommand) ""] && \ [llength $args]} { eval $classinfo(-configurecommand) [list $parserName] $args } return $parserName } # xml::FindUniqueName -- # # Generate unique object name # # Arguments: # None # # Results: # Returns string. proc xml::FindUniqueName {} { variable counter return xmlparser[incr counter] } # xml::ParserCmd -- # # Implements parser object command # # Arguments: # name object reference # method subcommand # args method arguments # # Results: # Depends on method proc xml::ParserCmd {name method args} { variable classes upvar #0 [namespace current]::$name data array set classinfo $classes($data(class)) switch -- $method { configure { # BUG: We're not checking for legal options array set data $args eval $classinfo(-configurecommand) [list $name] $args return {} } cget { return $data([lindex $args 0]) } entityparser { set new [FindUniqueName] upvar #0 [namespace current]::$name parent upvar #0 [namespace current]::$new data array set data [array get parent] uplevel 1 [list proc $new {method args} \ "eval [namespace current]::ParserCmd [list $new]\ \[list \$method\] \$args"] eval $classinfo(-createentityparsercommand) [list $name $new] $args return $new } free { eval $classinfo(-deletecommand) [list $name] unset data uplevel 1 [list rename $name {}] } get { eval $classinfo(-getcommand) [list $name] $args } parse { if {[llength $args] < 1} { return -code error "wrong number of arguments, should be\ $name parse xml ?options?" } eval $classinfo(-parsecommand) [list $name] $args } reset { eval $classinfo(-deletecommand) [list $name] eval $classinfo(-createcommand) [list $name] } default { return -code error "unknown method" } } return {} } # xml::noop -- # # Do nothing utility proc # # Arguments: # args whatever # # Results: # Nothing happens proc xml::noop args {} # vim:ft=tcl:ts=8:sw=4:sts=4:et tclxmpp/xmpp000075500000000000000000000000001470446212700130355ustar00nobodynobodytclxmpp/xmpp/annotations.tcl000064400000000000000000000110171470446212700161550ustar00nobodynobody# annotations.tcl -- # # This file is a part of the XMPP library. It implements storing # and retieving roster notes (XEP-0145). # # Copyright (c) 2009-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp::private package provide xmpp::roster::annotations 0.1 namespace eval ::xmpp::roster::annotations { namespace export store retrieve serialize deserialize } proc ::xmpp::roster::annotations::retrieve {xlib args} { set commands {} set timeout 0 foreach {key val} $args { switch -- $key { -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } set id \ [::xmpp::private::retrieve \ $xlib \ [list [::xmpp::xml::create storage \ -xmlns storage:rosternotes]] \ -command [namespace code [list ProcessRetrieveAnswer $commands]] \ -timeout $timeout] return $id } proc ::xmpp::roster::annotations::ProcessRetrieveAnswer {commands status xml} { if {[llength $commands] == 0} return if {![string equal $status ok]} { uplevel #0 [lindex $commands 0] [list $status $xml] } uplevel #0 [lindex $commands 0] [list ok [deserialize $xml]] return } proc ::xmpp::roster::annotations::deserialize {xml} { set notes {} foreach xmldata $xml { ::xmpp::xml::split $xmldata tag xmlns attrs cdata subels if {[string equal $xmlns storage:rosternotes]} { foreach note $subels { ::xmpp::xml::split $note stag sxmlns sattrs scdata ssubels set jid [::xmpp::xml::getAttr $sattrs jid] set cdate [::xmpp::xml::getAttr $sattrs cdate] set mdate [::xmpp::xml::getAttr $sattrs mdate] if {[catch { ScanTime $cdate } cdate]} { set cdate [clock seconds] } if {[catch { ScanTime $mdate } mdate]} { set mdate [clock seconds] } lappend notes [list jid $jid cdate $cdate mdate $mdate note $scdata] } } } return $notes } proc ::xmpp::roster::annotations::ScanTime {timestamp} { if {[regexp {(.*)T(.*)Z} $timestamp -> date time]} { return [clock scan "$date $time" -gmt true] } else { return [clock scan $timestamp -gmt true] } } proc ::xmpp::roster::annotations::serialize {notes} { set tags {} foreach note $notes { array unset n array set n $note if {[string equal $n(note) ""]} continue set vars [list jid $n(jid)] if {![catch {clock format $n(cdate) \ -format "%Y-%m-%dT%TZ" -gmt true} cdate]} { lappend vars cdate $cdate } if {![catch {clock format $n(mdate) \ -format "%Y-%m-%dT%TZ" -gmt true} mdate]} { lappend vars mdate $mdate } lappend tags [::xmpp::xml::create note \ -attrs $vars \ -cdata $n(note)] } return [::xmpp::xml::create storage \ -xmlns storage:rosternotes \ -subelements $tags] } proc ::xmpp::roster::annotations::store {xlib notes args} { set commands {} set timeout 0 foreach {key val} $args { switch -- $key { -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } set id \ [::xmpp::private::store \ $xlib \ [list [serialize $notes]] \ -command [namespace code [list ProcessStoreAnswer $commands]] \ -timeout $timeout] return $id } proc ::xmpp::roster::annotations::ProcessStoreAnswer {commands status xml} { if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/auth.tcl000064400000000000000000000410131470446212700145600ustar00nobodynobody# auth.tcl -- # # This file is part of the XMPP library. It provides support for the # non-SASL authentication layer (XEP-0078). # # Copyright (c) 2008-2015 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require sha1 package require xmpp package provide xmpp::auth 0.2 namespace eval ::xmpp::auth { namespace export auth abort } # ::xmpp::auth::auth -- # # Authenticate an existing XMPP stream using non-SASL method described # in XEP-0078. # # Arguments: # xlib XMPP token. It must be connected and XMPP # stream must be opened. # -sessionid sessionid Stream session ID (as returned by server in # stream header. # -username username Username to authenticate. # -password password Password to use in authentication. # -resource resource XMPP resource to bind to the stream after # successful authentication. # -digest digest (optional, defaults to "yes") Boolean value # which specifies if a digest authentication # method should be used. A special value "auto" # allows to select digest authentication if it's # available and fallback to plaintext if the # digest method isn't provided by server. # -timeout timeout (optional, defaults to 0 which means infinity) # Timeout (in milliseconds) for authentication # queries. # -command callback (optional) If present, it turns on asynchronous # mode. After successful or failed authentication # "callback" is invoked with two appended # arguments: status ("ok", "error", "abort" or # "timeout") and either authenticated JID if # status is "ok", or error stanza otherwise. # # Result: # In asynchronous mode a control token is returned (it allows to abort # authentication process). In synchronous mode either authenticated JID # is returned (if authentication succeded) or IQ error (with return code # error in case of error, or break in case of abortion). # # Side effects: # A variable in ::xmpp::auth namespace is created and auth state is # stored in it in asunchronous mode. In synchronous mode the Tcl event # loop is entered and processing until return. proc ::xmpp::auth::auth {xlib args} { variable id if {![info exists id]} { set id 0 } set token [namespace current]::[incr id] variable $token upvar 0 $token state ::xmpp::Debug $xlib 2 "$token" ::xmpp::Set $xlib abortCommand [namespace code [abort $token]] set state(xlib) $xlib set state(-digest) 1 set timeout 0 foreach {key val} $args { switch -- $key { -sessionid - -username - -password - -resource - -sm - -command { set state($key) $val } -timeout { set timeout $val } -digest { if {[string is true -strict $val]} { set state(-digest) 1 } elseif {[string is false -strict $val]} { set state(-digest) 0 } elseif {[string equal $val auto]} { set state(-digest) 0.5 } else { unset state return -code error \ [::msgcat::mc "Illegal value \"%s\" for\ option \"%s\"" $val $key] } } default { unset state return -code error [::msgcat::mc "Illegal option \"%s\"" $key] } } } foreach key {-sessionid -username -password -resource} { if {![info exists state($key)]} { unset state return -code error [::msgcat::mc "Missing option \"%s\"" $key] } } if {$timeout > 0} { set state(afterid) \ [after $timeout \ [namespace code \ [list AbortAuth $token timeout \ [::msgcat::mc "Non-SASL authentication\ timed out"]]]] } ::xmpp::TraceStreamFeatures $xlib [namespace code [list Continue $token]] if {[info exists state(-command)]} { # Asynchronous mode return $token } else { # Synchronous mode vwait $token\(status) foreach {status msg} $state(status) break unset state if {[string equal $status ok]} { return $msg } else { if {[string equal $status abort]} { return -code break $msg } else { return -code error $msg } } } } # ::xmpp::auth::abort -- # # Abort an existion authentication procedure, or do nothing if it's # already finished. # # Arguments: # token Authentication control token which is returned by # ::xmpp::auth::auth procedure. # # Result: # Empty string. # # Side effects: # In state of waiting for reply from server terminates waiting process. proc ::xmpp::auth::abort {token} { AbortAuth $token abort [::msgcat::mc "Non-SASL authentication aborted"]] } # ::xmpp::auth::AbortAuth -- # # Abort an existion authentication procedure, or do nothing if it's # already finished. # # Arguments: # token Authentication control token which is returned by # ::xmpp::auth::auth procedure. # status (error, abort or timeout) Status code of the abortion. # msg Error message. # # Result: # Empty string. # # Side effects: # In state of waiting for reply from server terminates waiting process. proc ::xmpp::auth::AbortAuth {token status msg} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" ::xmpp::RemoveTraceStreamFeatures $xlib \ [namespace code [list Continue $token]] set error [::xmpp::xml::create error -cdata $msg] if {[info exists state(id)]} { ::xmpp::abortIQ $xlib $state(id) $status $error } else { Finish $token $status $error } return } # ::xmpp::auth::Continue -- # # A hepler procedure which checks if there is an auth feature in a # features list provided by server and continues or finishes # authentication. # # Arguments: # token Authentication control token which is returned by # ::xmpp::auth::auth procedure. # featuresList XMPP features list from server. # # Result: # Empty string. # # Side effects: # Either an auth form query is sent to server or authentication is # finished with error. proc ::xmpp::auth::Continue {token featuresList} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token $featuresList" if {![FindFeature $featuresList]} { Finish $token error \ [::xmpp::stanzaerror::error modify not-acceptable \ -text [::msgcat::mc "Server hasn't provided non-SASL\ authentication feature"]] return } set data [::xmpp::xml::create query \ -xmlns jabber:iq:auth \ -subelement [::xmpp::xml::create username \ -cdata $state(-username)]] ::xmpp::CallBack $xlib \ status [::msgcat::mc "Waiting for non-SASL\ authentication fields"] set state(id) \ [::xmpp::sendIQ $xlib get \ -query $data \ -command [namespace code [list Continue2 $token]]] return } # ::xmpp::auth::FindFeature -- # # A helper procedure which searches for iq-auth feature in features # list. # # Arguments: # featuresList List of XMPP stream features as provided by server. # # Result: # 1 if iq-auth featue is found, 0 otherwise. # # Side effects: # None. proc ::xmpp::auth::FindFeature {featuresList} { foreach feature $featuresList { ::xmpp::xml::split $feature tag xmlns attrs cdata subels switch -- $tag/$xmlns { auth/http://jabber.org/features/iq-auth { return 1 } } } return 0 } # ::xmpp::auth::Continue2 -- # # A hepler procedure which receives authentication form, checks # for allowed authentication methods and continues or finishes # authentication. # # Arguments: # token Authentication control token which is returned by # ::xmpp::auth::auth procedure. # status Status of the previous IQ request (ok means success). # xmldata Either an auth form (if status is ok) or error stanza. # # Result: # Empty string. # # Side effects: # Either a filled auth form is sent to server or authentication is # finished with error. proc ::xmpp::auth::Continue2 {token status xmldata} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token $status" if {![string equal $status ok]} { Finish $token $status $xmldata return } ::xmpp::xml::split $xmldata tag xmlns attrs cdata subels set authtype none foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -glob -- $stag/$authtype { password/none - password/forbidden { if {$state(-digest) < 1} { set authtype plain } else { set authtype forbidden } } digest/plain { if {$state(-digest) > 0} { set authtype digest } } digest/* { if {$state(-digest) > 0} { set authtype digest } else { set authtype forbidden } } } } switch -glob -- $authtype/$state(-digest) { plain/* { set data [::xmpp::xml::create query \ -xmlns jabber:iq:auth \ -subelements [list [::xmpp::xml::create username \ -cdata $state(-username)] \ [::xmpp::xml::create password \ -cdata $state(-password)] \ [::xmpp::xml::create resource \ -cdata $state(-resource)]]] } digest/* { set secret [encoding convertto utf-8 $state(-sessionid)] append secret [encoding convertto utf-8 $state(-password)] set digest [sha1::sha1 $secret] set data [::xmpp::xml::create query \ -xmlns jabber:iq:auth \ -subelements [list [::xmpp::xml::create username \ -cdata $state(-username)] \ [::xmpp::xml::create digest \ -cdata $digest] \ [::xmpp::xml::create resource \ -cdata $state(-resource)]]] } forbidden/1 { Finish $token error \ [::xmpp::stanzaerror::error modify not-acceptable -text \ [::msgcat::mc "Server doesn't support digest\ non-SASL authentication"]] return } forbidden/0 { Finish $token error \ [::xmpp::stanzaerror::error modify not-acceptable -text \ [::msgcat::mc "Server doesn't support plaintext\ non-SASL authentication"]] return } default { Finish $token error \ [::xmpp::stanzaerror::error modify not-acceptable -text \ [::msgcat::mc "Server doesn't support plaintext or\ digest non-SASL authentication"]] return } } ::xmpp::CallBack $xlib status \ [::msgcat::mc "Waiting for non-SASL authentication\ results"] set state(id) \ [::xmpp::sendIQ $xlib set \ -query $data \ -command [namespace code [list EnableSM $token]]] return } # ::xmpp::auth::EnableSM -- # # A helper procedure which requests enabling the stream management # (XEP-1098) over the given connection. # # Arguments: # token Authentication control token which is returned by # ::xmpp::auth::auth procedure. # status Status of the authentication (ok means success). It's # passed (along with the next xmlData argument) to the # Finish procedure if SM hasn't been required. # xmlData Either a result (usually empty) if status is ok or # error message. # # Result: # Empty string. # # Side effects: # If SM was requested then XEP-0198 request is transmitted to the server. proc ::xmpp::auth::EnableSM {token status xmlData} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$xmlData" if {![string equal $state(-sm) enable]} { Finish $token $status $xmlData } else { ::xmpp::sm::enable [::xmpp::Set $xlib sm] \ -resume 0 \ -command [namespace code [list Finish $token]] } } # ::xmpp::auth::Finish -- # # A hepler procedure which receives an answer for the authentication # form request and finishes authentication. # # Arguments: # token Authentication control token which is returned by # ::xmpp::auth::auth procedure. # status Status of the previous IQ request (ok means success). # xmlData Either a result (usually empty) if status is ok or # error stanza. # # Result: # Empty string. # # Side effects: # In asynchronous mode a control token is destroyed and a callback is # called. In synchronous mode vwait in ::xmpp::auth::auth is triggered. proc ::xmpp::auth::Finish {token status xmlData} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) if {[info exists state(afterid)]} { after cancel $state(afterid) } ::xmpp::Unset $xlib abortCommand if {[string equal $status ok]} { set jid [::xmpp::jid::jid $state(-username) \ [::xmpp::Set $xlib server] \ $state(-resource)] ::xmpp::Set $xlib jid $jid } # Cleanup in asynchronous mode if {[info exists state(-command)]} { set cmd $state(-command) unset state } ::xmpp::Debug $xlib 2 "$token $status $xmlData" if {[string equal $status ok]} { set msg $jid ::xmpp::CallBack $xlib status \ [::msgcat::mc "Non-SASL authentication succeeded"] } else { set msg $xmlData ::xmpp::CallBack $xlib status \ [::msgcat::mc "Non-SASL authentication failed"] } if {[info exists cmd]} { # Asynchronous mode uplevel #0 $cmd [list $status $msg] } else { # Synchronous mode # Trigger vwait in [auth] set state(status) [list $status $msg] } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/blocking.tcl000064400000000000000000000277641470446212700154300ustar00nobodynobody# blocking.tcl -- # # This file is part of the XMPP library. It implements interface to # Simple Communications Blocking (XEP-0191) # # Copyright (c) 2009-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp::iq package provide xmpp::blocking 0.1 namespace eval ::xmpp::blocking { namespace export blocklist block unblock register unregister } # ::xmpp::blocking::blocklist -- # # Request blocking list from the own XMPP server. # # Arguments: # xlib XMPP token. # -timeout msecs (optional) Timeout in milliseconds of waiting for # answer. # -command cmd (optional) Command to call back on receiving reply. # # Result: # ID of outgoing IQ. # # Side effects: # A blocklist request is sent over the XMPP connection $xlib. proc ::xmpp::blocking::blocklist {xlib args} { set commands {} set timeout 0 foreach {key val} $args { switch -- $key { -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create blocklist -xmlns urn:xmpp:blocking] \ -command [namespace code [list ParseBlocklistAnswer $commands]] \ -timeout $timeout } # ::xmpp::blocking::ParseBlocklistAnswer -- # # A helper procedure which is called upon blocklist is received. # It calls back the status and error message if any. # # Arguments: # commands A list of callbacks to call (only the first of them # is invoked. Status and list of blocked jids or error # stanza are appended to the called command. # status blocking request status (ok, error, abort, timeout). # xml Error message or result. # # Result: # Empty string. # # Side effects: # A callback is called if their list isn't empty. proc ::xmpp::blocking::ParseBlocklistAnswer {commands status xml} { if {[llength $commands] == 0} return if {[string equal $status ok]} { ::xmpp::xml::split $xml tag xmlns attrs cdata subels set items {} foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag/$sxmlns { item/urn:xmpp:blocking { if {[::xmpp::xml::isAttr $sattrs jid]} { lappend items [::xmpp::xml::getAttr $sattrs jid] } } } } uplevel #0 [lindex $commands 0] [list $status $items] } else { uplevel #0 [lindex $commands 0] [list $status $xml] } return } # ::xmpp::blocking::block -- # # Block specified JIDs. If no JIDs are specified then error is returned. # # Arguments: # xlib XMPP token. # -jid jid JID to block (may appear multiple times). # -jids jids List of JIDs to block (may appear multiple times). # -timeout msecs (optional) Timeout in milliseconds of waiting for # answer. # -command cmd (optional) Command to call back on receiving reply. # # Result: # ID of outgoing IQ. # # Side effects: # A block request is sent over the XMPP connection $xlib. proc ::xmpp::blocking::block {xlib args} { set commands {} set timeout 0 set items {} foreach {key val} $args { switch -- $key { -jid { if {![string equal $val ""]} { lappend items [::xmpp::xml::create item \ -attrs [list jid $val]] } } -jids { foreach jid $val { if {![string equal $jid ""]} { lappend items [::xmpp::xml::create item \ -attrs [list jid $jid]] } } } -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } if {[llength $items] == 0} { return -code error \ [::msgcat::mc "Nothing to block"] } ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create block \ -xmlns urn:xmpp:blocking \ -subelements $items] \ -command [namespace code [list ParseBlockAnswer $commands]] \ -timeout $timeout } # ::xmpp::blocking::ParseBlockAnswer -- # # A helper procedure which is called upon block result is received. # It calls back the status and error message if any. # # Arguments: # commands A list of callbacks to call (only the first of them # is invoked. Status and result or error # stanza are appended to the called command. # status Blocking request status (ok, error, abort, timeout). # xml Error message or result. # # Result: # Empty string. # # Side effects: # A callback is called if their list isn't empty. proc ::xmpp::blocking::ParseBlockAnswer {commands status xml} { if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } return } # ::xmpp::blocking::unblock -- # # Unblock specified JIDs. If no JIDs are specified then all blocked JIDs # are unblocked. # # Arguments: # xlib XMPP token. # -jid jid JID to unblock (may appear multiple times). # -jids jids List of JIDs to unblock (may appear multiple times). # -timeout msecs (optional) Timeout in milliseconds of waiting for # answer. # -command cmd (optional) Command to call back on receiving reply. # # Result: # ID of outgoing IQ. # # Side effects: # A block request is sent over the XMPP connection $xlib. proc ::xmpp::blocking::unblock {xlib args} { set commands {} set timeout 0 set items {} foreach {key val} $args { switch -- $key { -jid { if {![string equal $val ""]} { lappend items [::xmpp::xml::create item \ -attrs [list jid $val]] } } -jids { foreach jid $val { if {![string equal $jid ""]} { lappend items [::xmpp::xml::create item \ -attrs [list jid $jid]] } } } -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create unblock \ -xmlns urn:xmpp:blocking \ -subelements $items] \ -command [namespace code [list ParseUnblockAnswer $commands]] \ -timeout $timeout } # ::xmpp::blocking::ParseUnblockAnswer -- # # A helper procedure which is called upon unblock result is received. # It calls back the status and error message if any. # # Arguments: # commands A list of callbacks to call (only the first of them # is invoked. Status and result or error # stanza are appended to the called command. # status Unblocking request status (ok, error, abort, timeout). # xml Error message or result. # # Result: # Empty string. # # Side effects: # A callback is called if their list isn't empty. proc ::xmpp::blocking::ParseUnblockAnswer {commands status xml} { if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } return } # ::xmpp::blocking::register -- # # Register handler to process blocking IQ pushes. # # Arguments: # -command cmd (optional) Command to call when blocking push is # arrived. The result of the command is sent back. # It must be either {result {}}, or {error type condition}, # or empty string if the application will reply to the # request separately. # The command's arguments are xlib, from, xml, and # optional parameters -to, -id, -lang. # # Result: # Empty string. # # Side effects: # XMPP blocking push callback is registered. proc ::xmpp::blocking::register {args} { set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } ::xmpp::iq::register set * urn:xmpp:blocking \ [namespace code [list ParsePush $commands]] return } # ::xmpp::blocking::ParsePush -- # # A helper procedure which is called on any incoming XMPP blocking request. # It either calls a command specified during registration or simply # returns result (if there weren't any command). # # Arguments: # commands A list of commands to call (only the first one # will be invoked). # xlib XMPP token where request was received. # from JID of user who sent the request. # xml Request XML element (in blocking requests it is empty). # args optional arguments (-lang, -to, -id). # # Result: # Either {result, {}}, or {error type condition}, or empty string, if # the application desided to reply later. # # Side effects: # Side effects of the called command. proc ::xmpp::blocking::ParsePush {commands xlib from xml args} { # -to attribute contains the own JID, so check from JID to prevent # malicious users to pretend they perform blocking push set to [::xmpp::xml::getAttr $args -to] if {![string equal $from ""] && \ ![::xmpp::jid::equal $from $to] && \ ![::xmpp::jid::equal $from [::xmpp::jid::stripResource $to]] && \ ![::xmpp::jid::equal $from [::xmpp::jid::server $to]]} { return [list error cancel service-unavailable] } ::xmpp::xml::split $xml tag xmlns attrs cdata subels switch -- $tag/$xmlns { block/urn:xmpp:blocking - unblock/urn:xmpp:blocking {} default { return [list error modify bad-request] } } set items {} foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag/$sxmlns { item/urn:xmpp:blocking { if {[::xmpp::xml::isAttr $sattrs jid]} { lappend items [::xmpp::xml::getAttr $sattrs jid] } } } } if {[llength $commands] > 0} { return [uplevel #0 [lindex $commands 0] [list $xlib $tag $items] $args] } else { return [list result {}] } } # ::xmpp::blocking::unregister -- # # Unregister handler which used to answer XMPP blocking IQ pushes. # # Arguments: # None. # # Result: # Empty string. # # Side effects: # XMPP blocking push callback is registered. proc ::xmpp::blocking::unregister {} { ::xmpp::iq::unregister set * urn:xmpp:blocking return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/bob.tcl000064400000000000000000000116331470446212700143660ustar00nobodynobody# bob.tcl -- # # This file is part of the XMPP library. It implements interface to # Bits of Binary (XEP-0231) # # Copyright (c) 2009-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require sha1 package require base64 package provide xmpp::bob 0.1 namespace eval ::xmpp::bob { variable cache array set cache {} } # ::xmpp::bob::clear -- # # Clear bits-of-binary cache element (or the whole cache). # # Arguments: # cid (optional) CID of data to delete from cache. # # Result: # Empty string. # # Side effects: # The element is deleted from cache of bits or the cache is emptied. proc ::xmpp::bob::clear {{cid *}} { variable cache array unset cache $cid return } # ::xmpp::bob::cache -- # # Find bob element in a list and cache it. # # Arguments: # xmlElements XML elements list. # # Result: # Empty string. # # Side effects: # If there are bits-of-binary elements in XML elements then they # are stored in the cache and are scheduled for removal. proc ::xmpp::bob::cache {xmlElements} { variable cache foreach element $xmlElements { ::xmpp::xml::split $element tag xmlns attrs cdata subels switch -- $xmlns { urn:xmpp:bob { set cid [::xmpp::xml::getAttr $attrs cid] set type [::xmpp::xml::getAttr $attrs type] if {[string equal $cid ""] || [string equal $type ""]} { return } set maxAge [::xmpp::xml::getAttr $attrs max-age -1] set data [base64::decode $cdata] if {![regexp {(.*)\+(.*)@bob\.xmpp\.org} $cid -> \ algo hash]} { return } switch -- $algo { sha1 { if {![string equal [sha1::sha1 $data] $hash]} { return } } default { return } } set cache($cid) [list $type $data] if {$maxAge >= 0} { after [expr {$maxAge * 1000}] \ [namespace code [list clear $cid]] } } } } return } proc ::xmpp::bob::get {cid} { variable cache if {[info exists cache($cid)]} { return $cache($cid) } else { return {} } } # ::xmpp::bob::request -- # # Request bits-of-binary element. # # Arguments: # xlib XMPP token. # jid JID to request BOB data. # cid CID of data. # # Result: # # Side effects: # None. proc ::xmpp::bob::request {xlib jid cid args} { variable cache set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } if {[info exists cache($cid)]} { if {[llength $commands] > 0} { after idle \ [list uplevel #0 [lindex $commands 0] [list ok $cache($cid)]] return } else { return $cache($cid) } } ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create data \ -xmlns urn:xmpp:bob \ -attrs [list cid $cid]] \ -to $jid \ -command [namespace code [list ParseAnswer $xlib $jid $cid $commands]] return } proc ::xmpp::bob::ParseAnswer {xlib jid cid commands status xml} { if {![string equal $status ok]} { if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } return } cache [list $xml] if {[info exists cache($cid)]} { if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list ok $cache($cid)]] } } } proc ::xmpp::bob::cid {data} { return sha1+[sha1::sha1 $data]@bob.xmpp.org } proc ::xmpp::bob::data {type data args} { set maxAge -1 foreach {key val} $args { switch -- $key { -maxage { set maxAge $val } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } set attrs [list cid [cid $data] \ type $type] if {$maxAge >= 0} { lappend attrs max-age $maxAge } return [::xmpp::xml::create data -xmlns urn:xmpp:bob \ -attrs $attrs \ -cdata [base64::encode $data]] } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/bookmarks.tcl000064400000000000000000000115761470446212700156220ustar00nobodynobody# bookmarks.tcl -- # # This file is a part of the XMPP library. It implements storing # and retieving conference bookmarks (XEP-0048). # # Copyright (c) 2009-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp::private package provide xmpp::roster::bookmarks 0.1 namespace eval ::xmpp::roster::bookmarks { namespace export store retrieve serialize deserialize } proc ::xmpp::roster::bookmarks::retrieve {xlib args} { set commands {} set timeout 0 foreach {key val} $args { switch -- $key { -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } set id \ [::xmpp::private::retrieve \ $xlib \ [list [::xmpp::xml::create storage \ -xmlns storage:bookmarks]] \ -command [namespace code [list ProcessRetrieveAnswer $commands]] \ -timeout $timeout] return $id } proc ::xmpp::roster::bookmarks::ProcessRetrieveAnswer {commands status xml} { if {[llength $commands] == 0} return if {![string equal $status ok]} { uplevel #0 [lindex $commands 0] [list $status $xml] } uplevel #0 [lindex $commands 0] [list ok [deserialize $xml]] return } proc ::xmpp::roster::bookmarks::deserialize {xml} { set bookmarks {} foreach xmldata $xml { ::xmpp::xml::split $xmldata tag xmlns attrs cdata subels if {[string equal $xmlns storage:bookmarks]} { foreach bookmark $subels { ::xmpp::xml::split $bookmark stag sxmlns sattrs scdata ssubels set res [list jid [::xmpp::xml::getAttr $sattrs jid]] if {[::xmpp::xml::isAttr $sattrs autojoin]} { set autojoin [::xmpp::xml::getAttr $sattrs autojoin] if {[string is boolean -strict $autojoin]} { lappend res autojoin [::xmpp::xml::getAttr $sattrs autojoin] } } if {[::xmpp::xml::isAttr $sattrs name]} { lappend res name [::xmpp::xml::getAttr $sattrs name] } foreach subel $ssubels { ::xmpp::xml::split $subel sstag ssxmlns ssattrs sscdata sssubels switch -- $sstag { nick { lappend res nick $sscdata } password { lappend res password $sscdata } } } lappend bookmarks $res } } } return $bookmarks } proc ::xmpp::roster::bookmarks::serialize {bookmarks} { set tags {} foreach bookmark $bookmarks { array unset n array set n $bookmark set vars [list jid $n(jid)] if {[info exists n(name)]} { lappend vars name $n(name) } if {[info exists n(autojoin)]} { lappend vars autojoin $n(autojoin) } set subels {} if {[info exists n(nick)]} { lappend subels [::xmpp::xml::create nick -cdata $n(nick)] } if {[info exists n(password)]} { lappend subels [::xmpp::xml::create password -cdata $n(password)] } lappend tags [::xmpp::xml::create conference \ -attrs $vars \ -subelements $subels] } return [::xmpp::xml::create storage \ -xmlns storage:bookmarks \ -subelements $tags] } proc ::xmpp::roster::bookmarks::store {xlib bookmarks args} { set commands {} set timeout 0 foreach {key val} $args { switch -- $key { -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } set id \ [::xmpp::private::store \ $xlib \ [list [serialize $bookmarks]] \ -command [namespace code [list ProcessStoreAnswer $commands]] \ -timeout $timeout] return $id } proc ::xmpp::roster::bookmarks::ProcessStoreAnswer {commands status xml} { if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/bosh.tcl000064400000000000000000000746221470446212700145660ustar00nobodynobody# bosh.tcl -- # # This file is a part of the XMPP library. It implements XMPP over BOSH # (XEP-0124 and XEP-0206). # # Copyright (c) 2013-2015 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require sha1 package require http package require xmpp::transport 0.2 package require xmpp::xml package provide xmpp::transport::bosh 0.2 namespace eval ::xmpp::transport::bosh { namespace export open abort close reset flush ip outXML outText \ openStream reopenStream closeStream ::xmpp::transport::register bosh \ -opencommand [namespace code open] \ -abortcommand [namespace code abort] \ -closecommand [namespace code close] \ -resetcommand [namespace code reset] \ -flushcommand [namespace code flush] \ -ipcommand [namespace code ip] \ -outxmlcommand [namespace code outXML] \ -outtextcommand [namespace code outText] \ -openstreamcommand [namespace code openStream] \ -reopenstreamcommand [namespace code reopenStream] \ -closestreamcommand [namespace code closeStream] if {![catch { package require tls 1.4 }]} { ::http::register https 443 [namespace code sock] } # Supported BOSH version variable ver 1.10 # Namespaces used in BOSH and XMPP over BOSH variable NS array set NS {bind http://jabber.org/protocol/httpbind bosh urn:xmpp:xbosh} # Set this to 1 or 2 to get debug messages on standard output variable debug 0 } # ::xmpp::transport::bosh::sock -- # # Wrapper over the tls::socket command which provides sane defaults. # # Arguments: # options Options for tls::socket # host Host to connect to. # port Port to connect to. # # Result: # A channel with performed TLS handshake. # # Side effects: # A new socket is created. proc ::xmpp::transport::bosh::sock {args} { if {![catch ::tls::ciphers tls1.1]} { set args [linsert $args 0 -tls1.1 1] } if {![catch ::tls::ciphers tls1.2]} { set args [linsert $args 0 -tls1.2 1] } eval [linsert $args 0 ::tls::socket -ssl2 0 -ssl3 0 -tls1 1] } # ::xmpp::transport::bosh::open -- # # Open connection to XMPP server. For BOSH transport this means # "store BOSH parameters, create XML parser, and return or call back # with success. # # Arguments: # server (ignored, -url option is used) XMPP server # hostname. # port (ignored, -url option is used) XMPP server # port. # -url url (mandatory) BOSH URL to request. # -streamheadercommand cmd Command to call when server stream header # is parsed. # -streamtrailercommand cmd Command to call when server stream trailer # is parsed. # -stanzacommand cmd Command to call when top-level stream # stanza is parsed. # -eofcommand cmd Command to call when server (or proxy) # breaks connection. # -command cmd Command to call upon a successfull or # failed connect (for this transport failing # during connect is impossible). # -timeout timeout Timeout for HTTP queries (it's value must # be higher than -wait). # -wait int The longest time the connection manager is # allowed to wait before responding (in # milliseconds). # -hold requests Maximum number of requests the connection # manager is allowed to keep waiting. # -usekeys usekeys (default true) Use security keys to # protect connection. # -numkeys numkeys (default 100) Number of keys in a series. # -host proxyHost Proxy hostname. # -port proxyPort Proxy port. # -username proxyUsername Proxy username. # -password proxyPassword Proxy password. # -useragent proxyUseragent Proxy useragent. # # Result: # Transport token which is to be used for communication with XMPP server. # # Side effects: # A new variable is created where BOSH options are stored. Also, a new # XML parser is created. proc ::xmpp::transport::bosh::open {server port args} { variable id if {![info exists id]} { set id 0 } set token [namespace current]::[incr id] variable $token upvar 0 $token state set state(transport) bosh set state(streamHeaderCmd) # set state(streamTrailerCmd) # set state(stanzaCmd) # set state(eofCmd) # set state(-timeout) 0 set state(-wait) 30000 set state(-hold) 1 set state(-url) "" set state(-usekeys) 0 set state(-numkeys) 100 foreach {key val} $args { switch -- $key { -streamheadercommand {set state(streamHeaderCmd) $val} -streamtrailercommand {set state(streamTrailerCmd) $val} -stanzacommand {set state(stanzaCmd) $val} -eofcommand {set state(eofCmd) $val} -command {set cmd $val} -timeout - -wait - -hold - -url - -usekeys - -numkeys {set state($key) $val} -proxyfilter {set proxyFilter $val} -host {set proxyHost $val} -port {set proxyPort $val} -username {set proxyUsername $val} -password {set proxyPassword $val} -useragent {set proxyUseragent $val} } } set state(open) 0 set state(secure) 0 set state(outdata) "" set state(keys) {} set state(proxyAuth) {} set state(wait) disconnected set state(sid) "" set state(requests) [expr {$state(-hold)+1}] set state(queries) 0 set state(polling) 2000 set state(id) "" if {[info exists proxyUseragent]} { ::http::config -useragent $proxyUseragent } if {[info exists proxyFilter]} { # URLmatcher is borrowed from http package. set URLmatcher {(?x) # this is _expanded_ syntax ^ (?: (\w+) : ) ? # (?: // (?: ( [^@/\#?]+ # ) @ )? ( [^/:\#?]+ ) # (?: : (\d+) )? # )? ( / [^\#?]* (?: \? [^\#?]* )?)? # (including query) (?: \# (.*) )? # $ } if {[regexp -- $URLmatcher $state(-url) -> \ proto user host port srvurl]} { if {![catch {eval $proxyFilter $host} answer]} { foreach {phost pport proxyUsername proxyPassword} $answer { break } } } ::http::config -proxyfilter $proxyFilter } if {[info exists proxyHost] && [info exists proxyPort]} { ::http::config -proxyhost $proxyHost -proxyport $proxyPort } if {[info exists proxyUsername] && [info exists proxyPassword] && \ !([string equal $proxyUsername ""] && \ [string equal $proxyPassword ""])} { set auth \ [base64::encode \ [encoding convertto $proxyUsername:$proxyPassword]] set state(proxyAuth) [list Proxy-Authorization "Basic $auth"] } if {$state(-usekeys)} { Debug $token 2 "generating keys" set state(keys) [GenKeys $state(-numkeys)] } # BOSH doesn't wrap stanzas into , so we don't need parser # to call back for stream header and trailer. set state(parser) \ [::xmpp::xml::new # # \ [namespace code [list InXML $token \ $state(streamHeaderCmd) \ $state(streamTrailerCmd) \ $state(stanzaCmd)]]] SetWait $token connected if {[info exists cmd]} { # Asynchronous mode is almost synchronous CallBack $cmd [list ok $token] } return $token } # ::xmpp::transport::bosh::outText -- # # Send text to XMPP server. # # Arguments: # token Transport token. # text Text to send. # attrs (optional, defaults to {}) A list of attributes for # the element (body of the POST query). # # Result: # Empty string. # # Side effects: # Sending text to the server is scheduled. proc ::xmpp::transport::bosh::outText {token text {attrs {}}} { variable $token upvar 0 $token state if {![info exists state(wait)]} { return -1 } switch -- $state(wait) { disconnected - disconnecting { # TODO return -1 } default { Request $token $text $attrs } } # TODO return [string bytelength $text] } # ::xmpp::transport::bosh::outXML -- # # Send XML element to XMPP server. # # Arguments: # token Transport token. # xml XML stanza to send. # # Result: # Empty string. # # Side effects: # Sending XML to the server is scheduled. proc ::xmpp::transport::bosh::outXML {token xml} { variable $token upvar 0 $token state if {![info exists state(wait)] || [string equal $state(wait) disconnected]} { return -1 } ::xmpp::xml::split $xml tag xmlns attrs1 cdata subels nextCdata # The default XMLNS of BOSH element is # http://jabber.org/protocol/httpbind, so stanzas require specifying # XMLNS explicitly. if {[string equal $xmlns ""]} { set xml [::xmpp::xml::merge $tag $state(xmlns) $attrs1 \ $cdata $subels $nextCdata] } # HACK: Adding xmlns:stream definition if stream prefix is found # in the stanza if {[FindXMLNS $xml $state(xmlns:stream)]} { set attrs [list xmlns:stream $state(xmlns:stream)] } else { set attrs {} } return [outText $token [::xmpp::xml::toText $xml] $attrs] } # ::xmpp::transport::bosh::FindXMLNS -- # # Return 1 if the XML element contains the given XMLNS. # # Arguments: # xml XML stanza to check. # ns XMLNS to find. # # Result: # 1 if the namespace is found, 0 otherwise. # # Side effects: # None. proc ::xmpp::transport::bosh::FindXMLNS {xml ns} { ::xmpp::xml::split $xml tag xmlns attrs cdata subels if {[string equal $xmlns $ns]} { return 1 } foreach subel $subels { if {[FindXMLNS $subel $ns]} { return 1 } } return 0 } # ::xmpp::transport::bosh::openStream -- # # Initiate new BOSH session. # # Arguments: # token Transport token. # server XMPP server. # args Arguments for [::xmpp::xml::streamHeader]. # # Result: # 0 # # Side effects: # Sending string to the server is scheduled. proc ::xmpp::transport::bosh::openStream {token server args} { eval OpenStreamAux [list $token open $server] $args } # ::xmpp::transport::bosh::reopenStream -- # # Reopen BOSH stream. # # Arguments: # token Transport token. # server XMPP server. # args Arguments for [::xmpp::xml::streamHeader]. # # Result: # 0 # # Side effects: # Sending string to the server is scheduled. proc ::xmpp::transport::bosh::reopenStream {token server args} { eval OpenStreamAux [list $token reopen $server] $args } # ::xmpp::transport::bosh::OpenStreamAux -- # # Auxiliary proc which opens or reopens BOSH session. # # Arguments: # token Transport token. # mode 'open' or 'reopen' # server XMPP server. # args Arguments for [::xmpp::xml::streamHeader]. # # Result: # 0 # # Side effects: # Sending string to the server is scheduled. proc ::xmpp::transport::bosh::OpenStreamAux {token mode server args} { variable $token upvar 0 $token state variable ver variable NS if {![info exists state(wait)] || [string equal $state(wait) disconnected]} { return -1 } Debug $token 2 "$mode $server $args" # Fake XMPP stream header (parser invokes callback for every level 1 # stanza). ::xmpp::xml::parser $state(parser) parse set appendXmlns 0 set attrs [list xmlns $NS(bind) ver $ver to $server] if {[string equal $mode open]} { # Opening a new stream lappend attrs wait [expr {int(($state(-wait)+999)/1000.0)}] \ hold $state(-hold) } else { # Reopening stream lappend attrs sid $state(sid) \ xmpp:restart true set appendXmlnsXmpp 1 } foreach {key val} $args { switch -- $key { -from { lappend attrs from $val } -xml:lang { lappend attrs xml:lang $val } -version { lappend attrs xmpp:version $val set appendXmlnsXmpp 1 } -xmlns:stream { set state(xmlns:stream) $val } -xmlns { set state(xmlns) $val } default { return -code error [::msgcat::mc "Invalid option \"%s\"" $key] } } } if {$appendXmlnsXmpp} { # Define XMLNS for xmpp prefix if it was used lappend attrs xmlns:xmpp $NS(bosh) } set state(open) 0 return [outText $token "" $attrs] } # ::xmpp::transport::bosh::closeStream -- # # Send XMPP stream trailer to XMPP server and start disconnecting # procedure. # # Arguments: # token Transport token. # -wait bool (optional, default is 0) Wait for real disconnect. # # Result: # Empty string. # # Side effects: # Sending stream trailer to the server is scheduled. proc ::xmpp::transport::bosh::closeStream {token args} { variable $token upvar 0 $token state if {![info exists state(wait)] || [string equal $state(wait) disconnected]} { return -1 } Debug $token 2 "" set attrs [list type terminate] set len [outText $token "" $attrs] SetWait $token disconnecting set wait 0 foreach {key val} $args { switch -- $key { -wait { set wait $val } } } if {$wait} { while {[info exists state(wait)] && \ ![string equal $state(wait) disconnected]} { vwait $token\(wait) } } return $len } # ::xmpp::transport::bosh::flush -- # # Flush XMPP channel. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # Pending data is sent to the server. proc ::xmpp::transport::bosh::flush {token} { # TODO } # ::xmpp::transport::bosh::ip -- # # Return IP of an outgoing socket. # # Arguments: # token Transport token. # # Result: # Empty string (until really implemented). # # Side effects: # None. proc ::xmpp::transport::bosh::ip {token} { variable $token upvar 0 $token state # TODO return "" } # ::xmpp::transport::bosh::close -- # # Close XMPP channel. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # Transport token and XML parser are destroyed. proc ::xmpp::transport::bosh::close {token} { variable $token upvar 0 $token state if {![info exists state(wait)]} { # The channel is already closed return } SetWait $token disconnected if {[info exists state(parser)]} { ::xmpp::xml::free $state(parser) } catch {unset state} return } # ::xmpp::transport::bosh::reset -- # # Reset XMPP stream. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # XML parser is reset. proc ::xmpp::transport::bosh::reset {token} { variable $token upvar 0 $token state if {![info exists state(wait)] || [string equal $state(wait) disconnected]} { return } Debug $token 2 "" ::xmpp::xml::reset $state(parser) return } # ::xmpp::transport::bosh::InText -- # # A helper procedure which is called when a new portion of data is # received from XMPP server. It feeds XML parser with this data. # # Arguments: # token Transport token. # text Text to parse. # # Result: # Empty string. # # Side effects: # The text is parsed and if it completes top-level stanza then an # appropriate callback is invoked. proc ::xmpp::transport::bosh::InText {token text} { variable $token upvar 0 $token state Debug $token 2 $text ::xmpp::xml::parser $state(parser) parse $text return } # ::xmpp::transport::bosh::InXML -- # # A helper procedure which is called when a new XML stanza is parsed. # It then calls a specified command as an idle callback. # # Arguments: # token Transport token. # headerCmd Command to call if XMPP session is started. # trailerCmd Command to call if XMPP session is ended. # stanzaCmdmd Command to call if XMPP stanza is received. # xml BOSH body XML stanza. # # Result: # Empty string. # # Side effects: # After entering event loop the specified command is called. proc ::xmpp::transport::bosh::InXML {token headerCmd trailerCmd stanzaCmd xml} { variable $token upvar $token state variable NS Debug $token 2 "$state(open) $xml" ::xmpp::xml::split $xml tag xmlns attrs cdata subels if {![string equal $xmlns $NS(bind)]} { return -code error "Unexpected XMLNS in BOSH reply: $xmlns" } set type "" set condition "" foreach {key val} $attrs { switch -- $key \ sid { set state(sid) $val } \ wait { set state(-wait) [expr {$val*1000}] } \ ver { set state(var) $val } \ polling { set state(polling) [expr {$val*1000}] } \ inactivity { # TODO } \ requests { set requests $val } \ maxpause { # TODO } \ secure { set state(secure) $val } \ accept { # TODO } \ ack { # TODO } \ hold { set state(-hold) $val } \ from { set state(-from) $val } \ $NS(bosh):version { set state(-version) $val } \ authid { set state(-id) $val } \ type { set type $val } \ condition { set condition $val } } if {![info exists requests]} { set state(requests) [expr {$state(-hold)+1}] } else { set state(requests) $requests } if {!$state(open)} { set newattrs {} foreach key {from version id} { if {[info exists state(-$key)]} { lappend newattrs $key $state(-$key) } } set state(open) 1 CallBack $headerCmd [list $newattrs] } # Process received stanzas foreach subel $subels { CallBack $stanzaCmd [list $subel] } if {[string equal $type terminate]} { SetWait $token disconnected CallBack $state(eofCmd) } return } # ::xmpp::transport::bosh::CallBack -- # # A helper procedure which is called when XMPP stream is finished. # It then calls a specified command as an idle callback. # # Arguments: # cmd Command to call. # # Result: # Empty string. # # Side effects: # After entering event loop the specified command is called. proc ::xmpp::transport::bosh::CallBack {cmd args} { eval [list after idle $cmd] $args return } # ::xmpp::transport::bosh::Body -- # # Create textual representation of BOSH body XML element. # # Arguments: # token Tranport token. # attrs Attribute key-value pairs list. # text (Optional, defaults to empty string) Textual representation # of body subelements. # # Result: # BOSH body XML element. # # Side effects: # None. proc ::xmpp::transport::bosh::Body {token attrs {text ""}} { variable $token upvar 0 $token state variable NS if {![::xmpp::xml::isAttr $attrs xmlns]} { set attrs [linsert $attrs 0 xmlns $NS(bind) \ sid $state(sid)] } # We have to construct body XML element by hands to be able to put # arbitrary text inside it. set retext "" } else { append retext ">$text" } return $retext } # ::xmpp::transport::bosh::Request -- # # Schedule BOSH request procedure to output given text. # # Arguments: # token Tranport token. # text Text to output. # # Result: # Empty string. # # Side effects: # If there's no request which is waited for then a new request is sent, # otherwise a new call to [Request] is scheduled. proc ::xmpp::transport::bosh::Request {token text attrs} { variable $token upvar 0 $token state Debug $token 2 "'$text' '$attrs'" if {![info exists state(wait)]} { # Trying to poll an already closed connection Debug $token 2 NON-EXISTENT return } append state(outdata) $text switch -- $state(wait) { disconnected { Debug $token 2 DISCONNECTED return } disconnecting { Debug $token 2 DISCONNECTING return } default { if {![string equal [::xmpp::xml::getAttr $attrs type] terminate] && \ ($state(queries) >= $state(requests) || \ ($state(queries) > 0 && [string equal $state(outdata) ""]))} { Debug $token 2 RESCHEDULING after cancel $state(id) set state(id) \ [after $state(polling) \ [namespace code [list Request $token "" {}]]] return } } } set newattrs $attrs if {![info exists state(rid)]} { # The first request ever set state(rid) [expr {round(rand()*10000000)}] if {$state(-usekeys)} { # Won't work with number of keys equal to 1 (which is ridiculous # anyway) lappend newattrs newkey [lindex $state(keys) end] set state(keys) [lrange $state(keys) 0 end-1] } } else { # The next request ID set state(rid) [NextRid $state(rid)] if {$state(-usekeys)} { lappend newattrs key [lindex $state(keys) end] set state(keys) [lrange $state(keys) 0 end-1] if {[llength $state(keys)] == 0} { # Regenerate keys Debug $token 2 "Regenerating keys" set state(keys) [GenKeys $state(-numkeys)] lappend newattrs newkey [lindex $state(keys) end] set state(keys) [lrange $state(keys) 0 end-1] } } } set query [Body $token [linsert $newattrs 0 rid $state(rid)] $state(outdata)] Debug $token 2 "query: '$query'" incr state(queries) set state(outdata) "" after cancel $state(id) set state(id) \ [after $state(polling) [namespace code [list Request $token "" {}]]] GetURL $token 0 [encoding convertto utf-8 $query] return } # ::xmpp::transport::bosh::ProcessReply -- # # Process BOSH reply from the XMPP server. # # Arguments: # token Tranport token. # try Number of the previous requests of the same query. # query Query string. # httpToken HTTP token to get server answer. # # Result: # Empty string. # # Side effects: # If query failed then it is retried (not more than thrice), otherwise the # answer is received and pushed to XML parser. proc ::xmpp::transport::bosh::ProcessReply {token try query httpToken} { variable $token upvar 0 $token state if {![info exists state(wait)]} { # A reply for an already closed connection return } upvar #0 $httpToken httpState if {[::http::ncode $httpToken] != 200} { Debug $token 1 "HTTP returned [::http::ncode $httpToken]\ [http::status $httpToken]" Debug $token 2 "[::http::meta $httpToken]" Debug $token 2 "[::http::data $httpToken]" if {$try < 3} { GetURL $token [incr try] $query } else { # Don't care about state(queries) since the connection is broken SetWait $token disconnected CallBack $state(eofCmd) } ::http::cleanup $httpToken return } incr state(queries) -1 if {$state(queries) < 0} { # Something wrong, received more replies then sent Debug $token 1 "state(queries) < 0" set state(queries) 0 } Debug $token 2 [::http::meta $httpToken] set inmsg [encoding convertfrom utf-8 [::http::data $httpToken]] ::http::cleanup $httpToken Debug $token 2 '$inmsg' InText $token $inmsg } # ::xmpp::transport::bosh::GetURL -- # # Fetch BOSH URL. # # Arguments: # token Transport token. # try Number of previous tries of the same query # (sometimes query fails because of proxy errors, so # it's better to try once more). # query Query to send to the server. # # Result: # Empty string. # # Side effects: # BOSH HTTP request is sent and ProcessReply call is scheduled on reply. proc ::xmpp::transport::bosh::GetURL {token try query} { variable $token upvar 0 $token state Debug $token 2 $try # Option -keepalive 1 (which reuse open sockets - a good thing) doesn't # work well if we do multiple requests in parallel, so do open a separate # socket for every request (which creates a lot of overhead, but...) ::http::geturl $state(-url) \ -binary 1 \ -keepalive 0 \ -headers $state(proxyAuth) \ -type "text/xml; charset=utf-8" \ -query $query \ -timeout $state(-timeout) \ -command [namespace code [list ProcessReply $token \ $try \ $query]] return } # ::xmpp::transport::bosh::SetWait -- # # Set polling state for a given connection (if it exists) and if the # state is "disconnected" then cancel future requesting attempts. # # Arguments: # token Tranport token. # opt State name ("connected", "disconnecting", # "disconnected"). # # Result: # Empty string. # # Side effects: # Polling state is changed. If it becomes "disconnected" then the next # requesting attempt is canceled. proc ::xmpp::transport::bosh::SetWait {token opt} { variable $token upvar 0 $token state if {![info exists state(wait)]} { return } set state(wait) $opt switch -- $opt { disconnected { after cancel $state(id) } } return } # ::xmpp::transport::bosh::NextRid -- # # Return the next request ID. # # Arguments: # rid The current request ID. # # Result: # Incremented request ID. If it is greater than 2^53, the result is 0. # # Side effects: # None. proc ::xmpp::transport::bosh::NextRid {rid} { incr rid if {$rid > 0 && $rid <= 1<<53} { return $rid } else { return 0 } } # ::xmpp::transport::bosh::GenKeys -- # # Generate a sequence of security keys (see XEP-0124 section 15 for # details). # # Arguments: # numKeys Number of keys to generate. # # Result: # List of keys. # # Side effects: # None. proc ::xmpp::transport::bosh::GenKeys {numKeys} { set seed [expr {round(1000000000 * rand())}] set oldKey $seed set keys {} while {$numKeys > 0} { set nextKey [sha1::sha1 $oldKey] # Skip the initial seed lappend keys $nextKey set oldKey $nextKey incr numKeys -1 } return $keys } # ::xmpp::transport::bosh::Debug -- # # Print debug information. # # Arguments: # token Transport token. # level Debug level. # str Debug message. # # Result: # An empty string. # # Side effects: # A debug message is printed to the console if the value of # ::xmpp::transport::bosh::debug variable is not less than num. proc ::xmpp::transport::bosh::Debug {token level str} { variable debug if {$debug >= $level} { puts "[clock format [clock seconds] -format %T]\ [lindex [info level -1] 0] $token $str" } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/component.tcl000064400000000000000000000234271470446212700156320ustar00nobodynobody# component.tcl -- # # This file is part of the XMPP library. It provides support for the # Jabber Component Protocol (XEP-0114). # # Copyright (c) 2008-2015 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require sha1 package require xmpp package provide xmpp::component 0.2 namespace eval ::xmpp::component { namespace export auth abort } # ::xmpp::component::auth -- # # Authenticate an existing XMPP stream using Jabber Component Protocol # described in XEP-0114. # # Arguments: # xlib XMPP token. It must be connected and XMPP # stream with XMLNS jabber:component:accept must # be started. # -sessionid sessionid Stream session ID (as returned by server in # stream header. # -secret secret Shared secret to use in authentication. # -timeout timeout (optional, defaults to 0 which means infinity) # Timeout (in milliseconds) for authentication # queries. # -command callback (optional) If present, it turns on asynchronous # mode. After successful or failed authentication # "callback" is invoked with two appended # arguments: status ("ok", "error", "abort" or # "timeout") and either IQ result or error. # # Result: # In asynchronous mode a control token is returned (it allows to abort # authentication process). In synchronous mode either IQ result is # returned (if authentication succeded) or IQ error (with return code # error in case of error, or break in case of abortion). # # Side effects: # A variable in ::xmpp::component namespace is created and auth state is # stored in it in asunchronous mode. In synchronous mode the Tcl event # loop is entered and processing until return. proc ::xmpp::component::auth {xlib args} { variable id if {![info exists id]} { set id 0 } set token [namespace current]::[incr id] variable $token upvar 0 $token state ::xmpp::Debug $xlib 2 "$token" ::xmpp::Set $xlib abortCommand [namespace code [abort $token]] set state(xlib) $xlib set timeout 0 foreach {key val} $args { switch -- $key { -sessionid - -secret - -sm - -command { set state($key) $val } -timeout { set timeout $val } default { unset state return -code error [::msgcat::mc "Illegal option \"%s\"" $key] } } } foreach key {-sessionid -secret} { if {![info exists state($key)]} { unset state return -code error [::msgcat::mc "Missing option \"%s\"" $key] } } if {$timeout > 0} { set state(afterid) \ [after $timeout \ [namespace code \ [list AbortAuth $token timeout \ [::msgcat::mc "Component handshake\ timed out"]]]] } # handshake element indicates success, error indicates failure ::xmpp::RegisterElement $xlib handshake * \ [namespace code [list Parse $token]] ::xmpp::RegisterElement $xlib error http://etherx.jabber.org/streams \ [namespace code [list Parse $token]] set secret [encoding convertto utf-8 $state(-sessionid)] append secret [encoding convertto utf-8 $state(-secret)] set digest [sha1::sha1 $secret] set data [::xmpp::xml::create handshake -cdata $digest] ::xmpp::Debug $xlib 2 "$token digest = $digest" ::xmpp::CallBack $xlib status \ [::msgcat::mc "Waiting for component handshake result"] ::xmpp::outXML $xlib $data if {[info exists state(-command)]} { # Asynchronous mode return $token } else { # Synchronous mode vwait $token\(status) foreach {status msg} $state(status) break unset state if {[string equal $status ok]} { return $msg } else { if {[string equal $status abort]} { return -code break $msg } else { return -code error $msg } } } } # ::xmpp::component::abort -- # # Abort an existion authentication procedure, or do nothing if it's # already finished. # # Arguments: # token Authentication control token which is returned by # ::xmpp::component::auth procedure. # # Result: # Empty string. # # Side effects: # In state of waiting for reply from server terminates waiting process. proc ::xmpp::component::abort {token} { AbortAuth $token abort [::msgcat::mc "Component handshake aborted"] } # ::xmpp::component::AbortAuth -- # # Abort an existion authentication procedure, or do nothing if it's # already finished. # # Arguments: # token Authentication control token which is returned by # ::xmpp::component::auth procedure. # status (error, abort or timeout) Status code of the abortion. # msg Error message. # # Result: # Empty string. # # Side effects: # In state of waiting for reply from server terminates waiting process. proc ::xmpp::component::AbortAuth {token status msg} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" if {[info exists $xlib]} { Finish $token $status $msg } return } # ::xmpp::component::Parse -- # # A helper procedure which parses server answer on a handshake stanza # and finishes authentication process. # # Arguments: # token Authentication control token which is returned by # ::xmpp::component::auth procedure. # xmlElement XML element to parse. # # Result: # Empty string. # # Side effects: # If an answer to handshake is received then authentication is finished. proc ::xmpp::component::Parse {token xmlElement} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token $xmlElement" ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels switch -- $tag { handshake { EnableSM $token ok {} } error { Finish $token error [::xmpp::streamerror::message $xmlElement] } } return } # ::xmpp::component::EnableSM -- # # A helper procedure which requests enabling the stream management # (XEP-1098) over the given connection. # # Arguments: # token Authentication control token which is returned by # ::xmpp::component::auth procedure. # status Status of the authentication (ok means success). It's # passed (along with the next xmlData argument) to the # Finish procedure if SM hasn't been required. # xmlData Either a result (usually empty) if status is ok or # error message. # # Result: # Empty string. # # Side effects: # If SM was requested then XEP-0198 request is transmitted to the server. proc ::xmpp::component::EnableSM {token status xmlData} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$xmlData" if {![string equal $state(-sm) enable]} { Finish $token $status $xmlData } else { ::xmpp::sm::enable [::xmpp::Set $xlib sm] \ -resume 0 \ -command [namespace code [list Finish $token]] } } # ::xmpp::component::Finish -- # # A hepler procedure which finishes authentication. # # Arguments: # token Authentication control token which is returned by # ::xmpp::component::auth procedure. # status Status of the authentication (ok means success). # msg Either a result (usually empty) if status is ok or # error message. # # Result: # Empty string. # # Side effects: # In asynchronous mode a control token is destroyed and a callback is # called. In synchronous mode vwait in ::xmpp::component::auth is # triggered. proc ::xmpp::component::Finish {token status msg} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) if {[info exists state(afterid)]} { after cancel $state(afterid) } ::xmpp::Unset $xlib abortCommand # Cleanup in asynchronous mode if {[info exists state(-command)]} { set cmd $state(-command) unset state } ::xmpp::Debug $xlib 2 "$token $status" if {[string equal $status ok]} { ::xmpp::CallBack $xlib status \ [::msgcat::mc "Component handshake succeeded"] } else { ::xmpp::CallBack $xlib status \ [::msgcat::mc "Component handshake failed"] } # Unregister elements after handshake ::xmpp::UnregisterElement $xlib handshake * ::xmpp::UnregisterElement $xlib error http://etherx.jabber.org/streams if {[info exists cmd]} { # Asynchronous mode uplevel #0 $cmd [list $status $msg] } else { # Synchronous mode # Trigger vwait in [auth] set state(status) [list $status $msg] } } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/compress.tcl000064400000000000000000000336731470446212700154670ustar00nobodynobody# compress.tcl -- # # This file is part of the XMPP library. It provides support for # Stream Compression (XEP-0138). # # Copyright (c) 2008-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp::stanzaerror 0.1 package require xmpp::transport::zlib 0.1 package provide xmpp::compress 0.1 namespace eval ::xmpp::compress { variable SupportedMethods {zlib} foreach {lcode type cond description} [list \ 409 modify setup-failed [::msgcat::mc "Compression setup\ failed"] \ 409 modify unsupported-method [::msgcat::mc "Unsupported compression\ method"]] \ { ::xmpp::stanzaerror::registerError $lcode $type $cond $description } } # ::xmpp::compress::compress -- # # Negotiate XMPP stream compression using method from XEP-0138 and switch # to a compressed stream. # # Arguments: # xlib XMPP token. It must be connected and XMPP # stream must be opened. # -timeout timeout (optional, defaults to 0 which means infinity) # Timeout (in milliseconds) for compression # negotiation. # -command callback (optional) If present, it turns on asynchronous # mode. After successful or failed authentication # "callback" is invoked with two appended # arguments: status ("ok", "error", "abort" or # "timeout") and either new stream session ID if # status is "ok", or error stanza otherwise. # -level level Compression level. # # Result: # In asynchronous mode a control token is returned (it allows to abort # compression process). In synchronous mode either new stream session ID # is returned (if compression succeded) or IQ error (with return code # error in case of error, or break in case of abortion). # # Side effects: # A variable in ::xmpp::compress namespace is created and compression # state is stored in it in asynchronous mode. In synchronous mode the # Tcl event loop is entered and processing until return. proc ::xmpp::compress::compress {xlib args} { variable id if {![info exists id]} { set id 0 } set token [namespace current]::[incr id] variable $token upvar 0 $token state ::xmpp::Debug $xlib 2 "$token" ::xmpp::Set $xlib abortCommand [namespace code [abort $token]] set state(xlib) $xlib set state(zlibArgs) {} set timeout 0 foreach {key val} $args { switch -- $key { -level { lappend state(zlibArgs) $key $val } -command { set state($key) $val } -timeout { set timeout $val } default { return -code error [::msgcat::mc "Illegal option \"%s\"" $key] } } } ::xmpp::RegisterElement $xlib * http://jabber.org/protocol/compress \ [namespace code [list Parse $token]] if {$timeout > 0} { set state(afterid) \ [after $timeout \ [namespace code \ [list AbortCompression $token timeout \ [::msgcat::mc "Compression timed out"]]]] } ::xmpp::TraceStreamFeatures $xlib \ [namespace code [list Continue $token]] if {[info exists state(-command)]} { # Asynchronous mode return $token } else { # Synchronous mode vwait $token\(status) foreach {status msg} $state(status) break unset state if {[string equal $status ok]} { return $msg } else { if {[string equal $status abort]} { return -code break $msg } else { return -code error $msg } } } } # ::xmpp::compress::abort -- # # Abort an existing compression procedure, or do nothing if it's # already finished. # # Arguments: # token Compression control token which is returned by # ::xmpp::compress::compress procedure. # # Result: # Empty string. # # Side effects: # In state of waiting for reply from server terminates waiting process. proc ::xmpp::compress::abort {token} { AbortCompression $token abort [::msgcat::mc "Compression aborted"] } # ::xmpp::compress::AbortCompression -- # # Abort an existing compression procedure, or do nothing if it's # already finished. # # Arguments: # token Compression control token which is returned by # ::xmpp::compress::compress procedure. # status (error, abort or timeout) Status code of the abortion. # msg Error message. # # Result: # Empty string. # # Side effects: # In state of waiting for reply from server terminates waiting process. proc ::xmpp::compress::AbortCompression {token status msg} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" ::xmpp::RemoveTraceStreamFeatures $xlib \ [namespace code [list Continue $token]] if {[info exists state(reopenStream)]} { ::xmpp::GotStream $xlib abort {} return } Finish $token $status [::xmpp::xml::create error -cdata $msg] } # ::xmpp::compress::Parse -- # # Parse XML elemens in http://jabber.org/protocol/compress namespace. # They indicate the result of negotiation procedure (success or failure). # # Arguments: # token Compression control token. # xmlElement Top-level XML stanza. # # Result: # Empty string. # # Side effects: # A corresponding procedure is called in cases of successful or failed # compression negotiation. proc ::xmpp::compress::Parse {token xmlElement} { variable $token upvar 0 $token state ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels switch -- $tag { compressed { Compressed $token } failure { Failure $token $subels } } return } # ::xmpp::compress::Continue -- # # A helper procedure which checks if there is a compression feature and # a supported method in a features list provided by server and continues # or finishes compression negotiation. # # Arguments: # token Compression control token. # featuresList XMPP features list from server. # # Result: # Empty string. # # Side effects: # Either a compression request is sent to server or negotiation is # finished with error. proc ::xmpp::compress::Continue {token featuresList} { variable SupportedMethods variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token $featuresList" if {[catch {FindMethods $featuresList} methods]} { Finish $token error \ [::xmpp::stanzaerror::error modify not-acceptable -text \ [::msgcat::mc "Server hasn't provided\ compress feature"]] return } ::xmpp::Debug $xlib 2 "$token methods: $methods" foreach m $SupportedMethods { if {[lsearch -exact $methods $m] >= 0} { set method $m break } if {![info exists method]} { Finish $token error \ [::xmpp::stanzaerror::error modify not-acceptable \ -text [::msgcat::mc \ "Server hasn't provided supported\ compress method"]] return } } set state(method) $method set data [::xmpp::xml::create compress \ -xmlns http://jabber.org/protocol/compress \ -subelement [::xmpp::xml::create method -cdata $method]] ::xmpp::outXML $xlib $data return } # ::xmpp::compress::FindMethods -- # # A helper procedure which searches for compress feature and extracts # compression methods supported by server in features list. # # Arguments: # featuresList List of XMPP stream features as provided by server. # # Result: # List of supported compression methods if the featue is found, error # otherwise. # # Side effects: # None. proc ::xmpp::compress::FindMethods {featuresList} { set compressFeature 0 set methods {} foreach feature $featuresList { ::xmpp::xml::split $feature tag xmlns attrs cdata subels if {[string equal $xmlns http://jabber.org/features/compress] && \ [string equal $tag compression]} { set compressFeature 1 set methods {} foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels if {[string equal $stag method]} { lappend methods $scdata } } } } if {$compressFeature} { return $methods } else { return -code error } } # ::xmpp::compress::Failure -- # # A helper procedure which is called if compression negotiations failed. # It finishes compression procedure with error. # # Arguments: # token Compression control token. # xmlElements Subelements of element which include error. # # Result: # Empty string. # # Side effects: # Compression negotiation is finished with error. proc ::xmpp::compress::Failure {token xmlElements} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" set error [lindex $xmlElements 0] if {[string equal $error ""]} { set err [::xmpp::stanzaerror::error modify undefined-condition \ -text [::msgcat::mc "Compression negotiation failed"]] } else { ::xmpp::xml::split $error tag xmlns attrs cdata subels set err [::xmpp::stanzaerror::error modify $tag] } Finish $token error $err } # ::xmpp::compress::Compressed -- # # A helper procedure which is called if compression negotiations # succeeded. It switches transport to zlib and reopens XMPP stream. # # Arguments: # token Compression control token. # # Result: # Empty string. # # Side effects: # In case of success XMPP channel becomes compressed, XMPP stream is # reopened. proc ::xmpp::compress::Compressed {token} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" if {[catch {eval [list ::xmpp::SwitchTransport $xlib $state(method)] \ $state(zlibArgs)} msg]} { set err [::xmpp::stanzaerror::error modify undefined-condition \ -text $msg] Finish $token error $err return } set state(reopenStream) \ [::xmpp::ReopenStream $xlib \ -command [namespace code [list Reopened $token]]] return } # ::xmpp::compress::Reopened -- # # A callback which is invoked when the XMPP server responds to stream # reopening. It finishes compression procedure with error or success. # # Arguments: # token Compression control token. # status "ok", "error", "abort", or "timeout". # sessionid Stream session ID in case of success, or error message # otherwise. # # Result: # Empty string. # # Side effects: # Compression negotiation is finished. proc ::xmpp::compress::Reopened {token status sessionid} { variable $token upvar 0 $token state set xlib $state(xlib) unset state(reopenStream) ::xmpp::Debug $xlib 2 "$token $status $sessionid" if {[string equal $status ok]} { Finish $token ok $sessionid } else { Finish $token $status [::xmpp::xml::create error -cdata $sessionid] } } # ::xmpp::compress::Finish -- # # A hepler procedure which finishes negotiation process and destroys # compression control token (or returns to [compress]). # # Arguments: # token Compression control token. # status Status of the negotiations ("ok" means success). # xmlData Either a result (usually empty) if status is ok or # error stanza. # # Result: # Empty string. # # Side effects: # In asynchronous mode a control token is destroyed and a callback is # called. In synchronous mode vwait in [compress] is triggered. proc ::xmpp::compress::Finish {token status xmlData} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) if {[info exists state(afterid)]} { after cancel $state(afterid) } ::xmpp::Unset $xlib abortCommand ::xmpp::UnregisterElement $xlib * http://jabber.org/protocol/compress # Cleanup in asynchronous mode if {[info exists state(-command)]} { set cmd $state(-command) unset state } ::xmpp::Debug $xlib 2 "$token $status" if {[string equal $status ok]} { ::xmpp::CallBack $xlib status \ [::msgcat::mc "Compression negotiation successful"] } else { ::xmpp::CallBack $xlib status \ [::msgcat::mc "Compression negotiation failed"] } if {[info exists cmd]} { # Asynchronous mode uplevel #0 $cmd [list $status $xmlData] } else { # Synchronous mode # Trigger vwait in [compress] set state(status) [list $status $xmlData] } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/data.tcl000064400000000000000000000323751470446212700145430ustar00nobodynobody# data.tcl -- # # This file is a part of the XMPP library. It implements support for # data forms (XEP-0004) and data forms media items (XEP-0221). # # Copyright (c) 2008-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp::xml package provide xmpp::data 0.1 namespace eval ::xmpp::data {} # ::xmpp::data::formField -- proc ::xmpp::data::formField {tag args} { array set params $args switch -- $tag { instructions - title { if {[info exists params(-value)]} { return [list $tag $params(-value)] } else { return -code error "You must define -value" } } field { if {[info exists params(-var)]} { set field [list $params(-var)] } elseif {![string equal $type fixed]} { return -code error "You must define -var" } if {[info exists params(-type)]} { set type $params(-type) lappend field $params(-type) } else { set type "" lappend field "" } if {[info exists params(-label)]} { lappend field $params(-label) } else { lappend field "" } if {[info exists params(-desc)]} { lappend field $params(-desc) } else { lappend field "" } if {[info exists params(-required)]} { lappend field $params(-required) } else { lappend field 0 } if {[lsearch -exact {list-multi list-single} $type] >= 0} { if {[info exists params(-options)]} { lappend field $params(-options) } else { return -code error "You must define -options" } } else { lappend field {} } if {[lsearch -exact {jid-multi text-multi list-multi} $type] >= 0} { if {[info exists params(-values)]} { lappend field $params(-values) } elseif {[lsearch -exact {jid-multi} $type] >= 0} { return -code error "You must define -values" } else { lappend field {} } } else { if {[info exists params(-value)]} { lappend field [list $params(-value)] } elseif {[lsearch -exact {hidden fixed} $type] >= 0} { return -code error "You must define -value" } else { lappend field {} } } return [list field $field] } default { return -code error "Unknown type $type" } } } # ::xmpp::data::form -- proc ::xmpp::data::form {fields} { set subels {} foreach {tag field} $fields { switch -- $tag { title { lappend subels [::xmpp::xml::create title -cdata $field] } instructions { lappend subels [::xmpp::xml::create instructions -cdata $field] } field { foreach {var type label desc required options values} $field break set attrs [list var $var] if {![string equal $type ""]} { lappend attrs type $type } if {![string equal $label ""]} { lappend attrs label $label } set fsubels {} if {![string equal $desc ""]} { lappend fsubels [::xmpp::xml::create desc -cdata $desc] } if {$required} { lappend fsubels [::xmpp::xml::create required] } foreach value $values { lappend fsubels [::xmpp::xml::create value -cdata $value] } foreach {olabel ovalue} $options { if {[string equal $olabel ""]} { set oattrs {} } else { set oattrs [list label $olabel] } lappend fsubels [::xmpp::xml::create option \ -attrs $oattrs \ -subelement [::xmpp::xml::create value \ -cdata $ovalue]] } lappend subels [::xmpp::xml::create field \ -attrs $attrs \ -subelements $fsubels] } } } return [::xmpp::xml::create x \ -xmlns jabber:x:data \ -attrs [list type form] \ -subelements $subels] } # ::xmpp::data::cancelForm -- proc ::xmpp::data::cancelForm {} { return [::xmpp::xml::create x \ -xmlns jabber:x:data \ -attrs [list type cancel]] } # ::xmpp::data::submitForm -- proc ::xmpp::data::submitForm {fields} { set subels {} foreach {var values} $fields { set vsubels {} foreach value $values { lappend vsubels [::xmpp::xml::create value -cdata $value] } lappend subels [::xmpp::xml::create field \ -attrs [list var $var] \ -subelements $vsubels] } return [::xmpp::xml::create x \ -xmlns jabber:x:data \ -attrs [list type submit] \ -subelements $subels] } # ::xmpp::data::resultForm -- # TODO: Add items support. proc ::xmpp::data::resultForm {fields} { set subels {} foreach {tag field} $fields { switch -- $tag { title { lappend subels [::xmpp::xml::create title -cdata $field] } field { foreach {var type label values} $field break set attrs [list var $var] if {![string equal $type ""]} { lappend attrs type $type } if {![string equal $label ""]} { lappend attrs label $label } set fsubels {} foreach value $values { lappend fsubels [::xmpp::xml::create value -cdata $value] } lappend subels [::xmpp::xml::create field \ -attrs $attrs \ -subelements $fsubels] } } } return [::xmpp::xml::create x \ -xmlns jabber:x:data \ -attrs [list type result] \ -subelements $subels] } # ::xmpp::data::findForm -- proc ::xmpp::data::findForm {xmlElements} { foreach xmlElement $xmlElements { ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels if {[string equal $xmlns jabber:x:data]} { set type [::xmpp::xml::getAttr $attrs type form] return [list $type $xmlElement] } } return {{} {}} } # ::xmpp::data::parseForm -- proc ::xmpp::data::parseForm {xmlElement} { set res {} ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { instructions { lappend res instructions $scdata } title { lappend res title $scdata } field { lappend res field [ParseField $subel] } } } return $res } # ::xmpp::data::parseSubmit -- proc ::xmpp::data::parseSubmit {xmlElement} { set res {} ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { field { set type [::xmpp::xml::getAttr $sattrs type] set var [::xmpp::xml::getAttr $sattrs var] set label [::xmpp::xml::getAttr $sattrs label] set values {} foreach ssubel $ssubels { ::xmpp::xml::split $ssubel \ sstag ssxmlns ssattrs sscdata sssubels if {[string equal $sstag value]} { lappend values $sscdata } } lappend res field [list $var $type $label $values] } } } return $res } # ::xmpp::data::parseResult -- proc ::xmpp::data::parseResult {xmlElement} { set res {} ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { title { lappend res title $scdata } reported { set reported {} foreach field $ssubels { ::xmpp::xml::split $field \ sstag ssxmlns ssattrs sscdata sssubels set var [::xmpp::xml::getAttr $ssattrs var] set label [::xmpp::xml::getAttr $ssattrs label] lappend reported $var $label } lappend res reported $reported } item { set fields {} foreach field $ssubels { ::xmpp::xml::split $field \ sstag ssxmlns ssattrs sscdata sssubels if {![string equal $sstag field]} continue set var [::xmpp::xml::getAttr $ssattrs var] set values {} foreach value $sssubels { ::xmpp::xml::split $value s3tag s3xmlns s3attrs s3cdata s3subels if {[string equal $s3tag value]} { lappend values $s3cdata } } lappend fields $var $values } lappend res item $fields } field { set type [::xmpp::xml::getAttr $sattrs type] set var [::xmpp::xml::getAttr $sattrs var] set label [::xmpp::xml::getAttr $sattrs label] set values {} foreach ssubel $ssubels { ::xmpp::xml::split $ssubel \ sstag ssxmlns ssattrs sscdata sssubels if {[string equal $sstag value]} { lappend values $sscdata } } lappend res field [list $var $type $label $values] } } } return $res } # ::xmpp::data::ParseField -- proc ::xmpp::data::ParseField {xmlElement} { ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels set required 0 set desc {} set options {} set values {} set media {} set var [::xmpp::xml::getAttr $attrs var] set type [::xmpp::xml::getAttr $attrs type] set label [::xmpp::xml::getAttr $attrs label] foreach item $subels { ::xmpp::xml::split $item stag sxmlns sattrs scdata ssubels switch -- $stag { required { set required 1 } value { lappend values $scdata } desc { set desc $scdata } option { set slabel [::xmpp::xml::getAttr $sattrs label] foreach sitem $ssubels { ::xmpp::xml::split $sitem \ sstag ssxmlns ssattrs sscdata sssubels switch -- $sstag { value { set svalue $sscdata } } } lappend options $slabel $svalue } media { if {[string equal $sxmlns urn:xmpp:media-element]} { set mitem {} foreach sitem $ssubels { ::xmpp::xml::split $sitem \ sstag ssxmlns ssattrs \ sscdata sssubels switch -- $sstag { uri { if {![::xmpp::xml::isAttr $ssattrs type]} { continue } set mtype [::xmpp::xml::getAttr $ssattrs type] set uri $sscdata lappend mitem $mtype $uri } } } lappend media $mitem } } } } return [list $var $type $label $desc $required $options $values $media] } # vim:ft=tcl:ts=8:sw=4:sts=4:et tclxmpp/xmpp/delay.tcl000064400000000000000000000126071470446212700147240ustar00nobodynobody# delay.tcl -- # # This file is part of the XMPP library. It implements interface to # Delayed Delivery (XEP-0091 and XEP-0203) # # Copyright (c) 2008-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package provide xmpp::delay 0.1 namespace eval ::xmpp::delay {} # ::xmpp::delay::exists -- # # Find delay element in a list and return true if it's found. # # Arguments: # xmlElements XML elements list. # # Result: # If there's a delay elements in the given list then the result is 1 # (true) otherwise it's 0 (false). # # Side effects: # None. proc ::xmpp::delay::exists {xmlElements} { foreach element $xmlElements { ::xmpp::xml::split $element tag xmlns attrs cdata subels switch -- $xmlns { urn:xmpp:delay - jabber:x:delay { return 1 } } } return 0 } # ::xmpp::delay::parse -- # # Find delay element in a list and parse it. # # Arguments: # xmlElements XML elements list. # # Result: # If there's a delay elements in the given list then the result is a # serialized list {stamp $stamp [from $from] seconds $seconds} where # 'stamp' and 'from' are copied verbatim from the stanza and 'seconds' # represent number of seconds since epoch stored in the first delay # element. Otherwise the current time is returned. urn:xmpp:delay # element is preferred to jabber:x:delay one. # # Side effects: # None. proc ::xmpp::delay::parse {xmlElements} { foreach element $xmlElements { ::xmpp::xml::split $element tag xmlns attrs cdata subels switch -- $xmlns { urn:xmpp:delay { # 2006-07-17T05:29:12Z # 2006-11-18T03:35:56.415699Z if {![regexp {(\d+)-(\d\d)-(\d\d)(T\d+:\d+:\d+)[^Z]*Z?} \ [::xmpp::xml::getAttr $attrs stamp] \ -> y m d t]} { set seconds [clock seconds] } elseif {[catch {clock scan $y$m$d$t -gmt 1} seconds]} { set seconds [clock seconds] } return [linsert $attrs end seconds $seconds] } } } foreach element $xmlElements { ::xmpp::xml::split $element tag xmlns attrs cdata subels switch -- $xmlns { jabber:x:delay { # 20060717T05:29:12 # 20061118T03:35:56.415699 if {![regexp {\d+\d\d\d\dT\d+:\d+:\d+} \ [::xmpp::xml::getAttr $attrs stamp] \ stamp]} { set seconds [clock seconds] } elseif {[catch {clock scan $stamp -gmt 1} seconds]} { set seconds [clock seconds] } return [linsert $attrs end seconds $seconds] } } } return [list seconds [clock seconds]] } # ::xmpp::delay::create -- # # Create delay element using XEP-0203 or XEP-0091 (now deprecated) rules. # # Arguments: # seconds (optional, defaults to the current time) Seconds since # epoch to store in XML element. # -old bool (optional, defaults to false) If true then XEP-0091 is # used. If false then XEP-0203 is used. # # Results: # An XML element from XEP-0203 is created (without from attribute and # text cdata). # # Side effects: # None. proc ::xmpp::delay::create {args} { switch -- [llength $args] { 0 { set seconds [clock seconds] set old 0 } 1 { set seconds [lindex $args 0] set old 0 } 2 { switch -- [lindex $args 0] { -old { set seconds [clock seconds] set old [lindex $args 1] } default { return -code error \ "Usage: ::xmpp::delay::create\ ?seconds? ?-old boolean?" } } } 3 { set seconds [lindex $args 0] switch -- [lindex $args 1] { -old { set old [lindex $args 2] } default { return -code error \ "Usage: ::xmpp::delay::create\ ?seconds? ?-old boolean?" } } } default { return -code error "Usage: ::xmpp::delay::create\ ?seconds? ?-old boolean?" } } if {$old} { return [::xmpp::xml::create x \ -xmlns jabber:x:delay \ -attrs [list stamp \ [clock format $seconds \ -format %Y%m%dT%H:%M:%S \ -gmt 1]]] } else { return [::xmpp::xml::create delay \ -xmlns urn:xmpp:delay \ -attrs [list stamp \ [clock format $seconds \ -format %Y-%m-%dT%H:%M:%SZ \ -gmt 1]]] } } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/delimiter.tcl000064400000000000000000000061241470446212700156010ustar00nobodynobody# delimiter.tcl -- # # This file is a part of the XMPP library. It implements nested roster # groups server-side delimiter storing (XEP-0083). # # Copyright (c) 2009-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp::private package provide xmpp::roster::delimiter 0.1 namespace eval ::xmpp::roster::delimiter { namespace export store retrieve serialize deserialize } # # Retrieving nested groups delimiter # proc ::xmpp::roster::delimiter::retrieve {xlib args} { set commands {} set timeout 0 foreach {key val} $args { switch -- $key { -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } set id \ [::xmpp::private::retrieve \ $xlib \ [list [::xmpp::xml::create roster \ -xmlns roster:delimiter]] \ -command [namespace code [list ParseRetrieveResult \ $commands] \ -timeout $timeout] return $id } proc ::xmpp::roster::delimiter::ParseRetireveResult {commands status xml} { if {[llength $commands] == 0} return if {![string equal $status ok]} { uplevel #0 [lindex $commands 0] [list $status $xml] } uplevel #0 [lindex $commands 0] [list ok [deserialize $xml]] return } proc ::xmpp::roster::delimiter::deserialize {xml} { foreach item $xml { ::xmpp::xml::split $item tag xmlns attrs cdata subels if {[string equal $xmlns roster:delimiter]} { return $cdata } } } # # Storing nested groups delimiter # proc ::xmpp::roster::delimiter::serialize {delimiter} { return [::xmpp::xml::create roster \ -xmlns roster:delimiter \ -cdata $delimiter] } proc ::xmpp::roster::delimiter::store {xlib delimiter args} { set commands {} set timeout 0 foreach {key val} $args { switch -- $key { -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } set id \ [::xmpp::private::store \ $xlib \ [list [serialize $delimiter]] \ -command [namespace code [list ParseStoreResult $commands]] \ -timeout $timeout] return $id } proc ::xmpp::roster::delimiter::ParseStoreResult {commands status xml} { if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/disco.tcl000064400000000000000000000333451470446212700147310ustar00nobodynobody# disco.tcl -- # # This file is part of the XMPP library. It implements interface to # Service Discovery (XEP-0030) and Service Discovery Extensions # (XEP-0128) # # Copyright (c) 2009-2011 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package provide xmpp::disco 0.1 namespace eval ::xmpp::disco { # Error conditions which should not be cached variable NonCacheable {internal-server-error remote-server-not-found remote-server-timeout resource-constraint} } # ::xmpp::disco::new -- proc ::xmpp::disco::new {xlib args} { variable id if {![info exists id]} { set id 0 } set token [namespace current]::[incr id] variable $token upvar 0 $token state set state(xlib) $xlib set state(cache) {} set state(size) 200 foreach {key val} $args { switch -- $key { -cachesize { set state(size) $val } -infocommand { ::xmpp::iq::RegisterIQ \ $xlib get * http://jabber.org/protocol/disco#info \ [namespace code [list ParseInfoRequest $token $val]] } -itemscommand { ::xmpp::iq::RegisterIQ \ $xlib get * http://jabber.org/protocol/disco#items \ [namespace code [list ParseItemsRequest $token $val]] } default { unset state return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } return $token } # ::xmpp::disco::free -- proc ::xmpp::disco::free {token} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) ::xmpp::iq::UnregisterIQ $xlib set * http://jabber.org/protocol/disco#info ::xmpp::iq::UnregisterIQ $xlib set * http://jabber.org/protocol/disco#items unset state return } # ::xmpp::disco::requestInfo -- proc ::xmpp::disco::requestInfo {token jid args} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) set node "" set commands {} set cache 0 foreach {key val} $args { switch -- $key { -node { set node $val } -command { set commands [list $val] } -cache { if {[string is true -strict $val]} { set cache 1 } elseif {![string is false -strict $val]} { return -code error \ [::msgcat::mc "Illegal value \"%s\" for option\ \"%s\", boolean expected" $val $key] } } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } if {$cache} { if {[llength $commands] == 0} return set idx [lsearch -glob $state(cache) [list [list info $jid $node] *]] if {$idx >= 0} { set result [lindex $state(cache) $idx] after idle [list uplevel #0 [lindex $commands 0] \ [lrange $result 1 end]] return } } if {[string equal $node ""]} { set attrs {} } else { set attrs [list node $node] } ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create query \ -xmlns http://jabber.org/protocol/disco#info \ -attrs $attrs] \ -to $jid \ -command [namespace code [list ParseInfo \ $token $jid $node $cache $commands]] return } # ::xmpp::disco::ParseInfo -- proc ::xmpp::disco::ParseInfo {token jid node cache commands status xml} { variable NonCacheable variable $token upvar 0 $token state if {![info exists state(xlib)]} return if {[string equal $status error]} { set condition [::xmpp::stanzaerror::condition $xml] if {[lsearch -exact $NonCacheable $condition] >= 0} { # Do not cache certain error conditions } else { if {$cache && [lsearch -glob $state(cache) \ [list [list info $jid $node] *]] < 0} { lappend state(cache) [list [list info $jid $node] $status $xml] if {[llength $state(cache)] > $state(size)} { set state(cache) [lrange $state(cache) 1 end] } } } if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } return } elseif {![string equal $status ok]} { # Do not cache the answer if status is 'abort' if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } return } set identities {} set features {} set extras {} ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { identity { lappend identities $sattrs } feature { lappend features [::xmpp::xml::getAttr $sattrs var] } default { foreach {type form} [::xmpp::data::findForm [list $subel]] break if {[string equal $type result]} { lappend extras [::xmpp::data::parseResult $form] } } } } if {$cache && [lsearch -glob $state(cache) \ [list [list info $jid $node] *]] < 0} { lappend state(cache) \ [list [list info $jid $node] \ ok \ [list $identities $features $extras]] if {[llength $state(cache)] > $state(size)} { set state(cache) [lrange $state(cache) 1 end] } } if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] \ [list ok [list $identities $features $extras]] } return } # ::xmpp::disco::requestItems -- proc ::xmpp::disco::requestItems {token jid args} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) set node "" set commands {} set cache 0 foreach {key val} $args { switch -- $key { -node { set node $val } -command { set commands [list $val] } -cache { if {[string is true -strict $val]} { set cache 1 } elseif {![string is false -strict $val]} { return -code error \ [::msgcat::mc "Illegal value \"%s\" for option\ \"%s\", boolean expected" $val $key] } } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } if {$cache} { if {[llength $commands] == 0} return set idx [lsearch -glob $state(cache) [list [list items $jid $node] *]] if {$idx >= 0} { set result [lindex $state(cache) $idx] after idle [list uplevel #0 [lindex $commands 0] \ [lrange $result 1 end]] return } } if {[string equal $node ""]} { set attrs {} } else { set attrs [list node $node] } ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create query \ -xmlns http://jabber.org/protocol/disco#items \ -attrs $attrs] \ -to $jid \ -command [namespace code [list ParseItems \ $token $jid $node $cache $commands]] return } # ::xmpp::disco::ParseItems -- proc ::xmpp::disco::ParseItems {token jid node cache commands status xml} { variable NonCacheable variable $token upvar 0 $token state if {![info exists state(xlib)]} return if {[string equal $status error]} { set condition [::xmpp::stanzaerror::condition $xml] if {[lsearch -exact $NonCacheable $condition] >= 0} { # Do not cache certain error conditions } else { if {$cache && [lsearch -glob $state(cache) \ [list [list items $jid $node] *]] < 0} { lappend state(cache) [list [list items $jid $node] $status $xml] if {[llength $state(cache)] > $state(size)} { set state(cache) [lrange $state(cache) 1 end] } } } if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } return } elseif {![string equal $status ok]} { # Do not cache the answer if status is 'abort' if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } return } set items {} ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { item { set item [list jid [::xmpp::xml::getAttr $sattrs jid]] if {[::xmpp::xml::isAttr $sattrs node]} { lappend item node [::xmpp::xml::getAttr $sattrs node] } if {[::xmpp::xml::isAttr $sattrs name]} { lappend item name [::xmpp::xml::getAttr $sattrs name] } lappend items $item } } } if {$cache && [lsearch -glob $state(cache) \ [list [list items $jid $node] *]] < 0} { lappend state(cache) [list [list items $jid $node] ok $items] if {[llength $state(cache)] > $state(size)} { set state(cache) [lrange $state(cache) 1 end] } } if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list ok $items] } return } # ::xmpp::disco::ParseInfoRequest -- proc ::xmpp::disco::ParseInfoRequest {token command xlib from xml args} { ::xmpp::xml::split $xml tag xmlns attrs cdata subels set node [::xmpp::xml::getAttr $attrs node] set lang [::xmpp::xml::getAttr $args -lang en] set result [uplevel #0 $command [list $xlib $from $node $lang]] set status [lindex $result 0] if {![string equal $status result]} { return $result } set identities [lindex $result 1] set features [lindex $result 2] set extras [lindex $result 3] set restags {} foreach identity $identities { lappend restags [::xmpp::xml::create identity -attrs $identity] } foreach feature $features { lappend restags [::xmpp::xml::create feature -attrs [list var $feature]] } foreach extra $extras { lappend restags [::xmpp::data::resultForm $extra] } if {[string equal $node ""]} { set resattrs {} } else { set resattrs [list node $node] } return [list result [::xmpp::xml::create query \ -xmlns http://jabber.org/protocol/disco#info \ -attrs $resattrs \ -subelements $restags]] } # ::xmpp::disco::ParseItemsRequest -- proc ::xmpp::disco::ParseItemsRequest {token command xlib from xml args} { ::xmpp::xml::split $xml tag xmlns attrs cdata subels set node [::xmpp::xml::getAttr $attrs node] set lang [::xmpp::xml::getAttr $args -lang en] set result [uplevel #0 $command [list $xlib $from $node $lang]] set status [lindex $result 0] if {![string equal $status result]} { return $result } set items [lindex $result 1] set restags {} foreach item $items { lappend restags [::xmpp::xml::create item -attrs $item] } if {[string equal $node ""]} { set resattrs {} } else { set resattrs [list node $node] } return [list result [::xmpp::xml::create query \ -xmlns http://jabber.org/protocol/disco#items \ -attrs $resattrs \ -subelements $restags]] } # ::xmpp::disco::publishItems -- proc ::xmpp::disco::publishItems {token node items args} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) set commands {} foreach {key val} $args { switch -- { -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } set tags {} foreach item $items { lappend tags [::xmpp::xml::create item -attrs $item] } ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create query \ -xmlns http://jabber.org/protocol/disco#publish \ -attrs [list node $node] \ -subelements $items] \ -command [list [namespace current]::PublishItemsResult $commands] } # ::xmpp::disco::publishItemsResult -- proc ::xmpp::disco::PublishItemsResult {commands status xml} { if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $res $child] } return } # vim:ft=tcl:ts=8:sw=4:sts=4:et tclxmpp/xmpp/dns.tcl000064400000000000000000000330351470446212700144100ustar00nobodynobody# dns.tcl -- # # This file is part of the XMPP library. It provides support for XMPP # Client SRV DNS records (RFC 3920) and DNS TXT Resource Record Format # (XEP-0156). # # Copyright (c) 2006-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require dns 1.3 package provide xmpp::dns 0.1 namespace eval ::xmpp::dns {} # ::xmpp::dns::resolveXMPPClient -- # # Resolve XMPP client SRV record. # # Arguments: # domain Domain to resolve. # -command cmd (optional) If present, resolution is made in # asynchronous mode and the result is reported via # callback. The supplied command is called with # host-port pairs list appended. # # Result: # DNS token in asynchronous mode, or list of host-port pairs in # synchronous mode. proc ::xmpp::dns::resolveXMPPClient {domain args} { return [eval [list resolveSRV _xmpp-client._tcp $domain] $args] } # ::xmpp::dns::resolveXMPPServer -- # # Resolve XMPP server SRV record. # # Arguments: # domain Domain to resolve. # -command cmd (optional) If present, resolution is made in # asynchronous mode and the result is reported via # callback. The supplied command is called with # host-port pairs list appended. # # Result: # DNS token in asynchronous mode, or list of host-port pairs in # synchronous mode. proc ::xmpp::dns::resolveXMPPServer {domain args} { return [eval [list resolveSRV _xmpp-server._tcp $domain] $args] } # ::xmpp::dns::resolveSRV -- # # Resolve any SRV record. # # Arguments: # srv SRV part of DNS record. # domain Domain to resolve. # -command cmd (optional) If present, resolution is made in # asynchronous mode and the result is reported via # callback. The supplied command is called with # host-port pairs list appended. # # Result: # DNS token in asynchronous mode, or list of host-port pairs in # synchronous mode. proc ::xmpp::dns::resolveSRV {srv domain args} { foreach {key val} $args { switch -- $key { -command { set command $val } } } set name $srv.$domain if {![info exists command]} { return [SRVResultToList [Resolve $name SRV]] } else { return [Resolve $name SRV \ [namespace code [list ProcessSRVResult $command]]] } } # ::xmpp::dns::resolveHTTPPoll -- # # Resolve TXT record for HTTP polling (see XEP-0025). # # Arguments: # domain Domain to resolve. # -command cmd (optional) If present, resolution is made in # asynchronous mode and the result is reported via # callback. The supplied command is called with list of # HTTP-poll URLs appended. # # Result: # DNS token in asynchronous mode, or HTTP-poll URL in synchronous mode. proc ::xmpp::dns::resolveHTTPPoll {domain args} { return [eval [list resolveTXT _xmppconnect _xmpp-client-httppoll $domain] \ $args] } # ::xmpp::dns::resolveBOSH -- # # Resolve TXT record for BOSH (HTTP-bind, see XEP-0124 and XEP-0206) # connection. # # Arguments: # domain Domain to resolve. # -command cmd (optional) If present, resolution is made in # asynchronous mode and the result is reported via # callback. The supplied command is called with list of # BOSH URLs appended. # # Result: # DNS token in asynchronous mode, or list of BOSH URLs in synchronous # mode. proc ::xmpp::dns::resolveBOSH {domain args} { return [eval [list resolveTXT _xmppconnect _xmpp-client-xbosh $domain] \ $args] } # ::xmpp::dns::resolveTXT -- # # Resolve TXT record. # # Arguments: # txt Owner of the record. # attr Attribute name of the record. # domain Domain to resolve. # -command cmd (optional) If present, resolution is made in # asynchronous mode and the result is reported via # callback. The supplied command is called with list of # resolved names appended. # # Result: # DNS token in asynchronous mode, or list of resolved names in # synchronous mode. proc ::xmpp::dns::resolveTXT {txt attr domain args} { foreach {key val} $args { switch -- $key { -command { set command $val } } } set name $txt.$domain if {![info exists command]} { return [TXTResultToList $attr [Resolve $name TXT]] } else { return [Resolve $name TXT \ [namespace code [list ProcessTXTResult $attr \ $command]]] } } # ::xmpp::dns::abort -- # # Abort asynchronous DNS lookup procedure. # # Arguments: # token DNS token created in [Resolve]. # # Result: # Empty string. # # Side effects: # DNS lookup is aborted, and callback is called with error. proc ::xmpp::dns::abort {token} { variable $token upvar 0 $token state if {![info exists state(token)]} { dns::reset $state(token) dns::cleanup $state(token) ResolveCallback $token "" "" $state(command) {} "DNS lookup aborted" } return } # ::xmpp::dns::ProcessTXTResult -- # # Convert DNS result of TXT record resolution to a list of strings # corresponding to a specified attribute name if the resolution succeded, # and invoke a callback. # # Arguments: # attr Attribute name of a TXT record. # command Callback to invoke. # status "ok", "error", or "abort" # result List of results from DNS server. # # Result: # Empty string. # # Side effects: # Callback procedure is called. proc ::xmpp::dns::ProcessTXTResult {attr command status result} { if {[string equal $status ok]} { set result [TXTResultToList $attr $result] } eval $command [list $status $result] return } # ::xmpp::dns::TXTResultToList -- # # Convert DNS result of TXT record resolution to a list of strings # corresponding to a specified attribute name. # # Arguments: # attr Attribute name of a TXT record. # res List of results from DNS server. # # Result: # List of results which correspond the specified attribute name. # # Side effects: # None. proc ::xmpp::dns::TXTResultToList {attr res} { set results {} foreach reply $res { array set rr $reply if {[regexp "$attr=(.*)" $rr(rdata) -> url]} { lappend results $url } } return $results } # ::xmpp::dns::ProcessSRVResult -- # # Convert DNS result of SRV record resolution to a list of host-port # pairs ordered in a way to respect priorities and weights if the # resolution succeded, and invoke a callback. # # Arguments: # command Callback to invoke. # status "ok", "error", or "abort" # result List of results from DNS server. # # Result: # Empty string. # # Side effects: # Callback procedure is called. proc ::xmpp::dns::ProcessSRVResult {command status result} { if {[string equal $status ok]} { set result [SRVResultToList $result] } eval $command [list $status $result] } # ::xmpp::dns::SRVResultToList -- # # Convert DNS result of SRV record resolution to a list of host-port # pairs ordered in a way to respect priorities and weights. # # Arguments: # res List of results from DNS server. # # Result: # List of host-port pairs. # # Side effects: # None. proc ::xmpp::dns::SRVResultToList {res} { set results {} foreach reply $res { array unset rr1 array set rr1 $reply if {![info exists rr1(rdata)]} continue array unset rr if {[catch {array set rr $rr1(rdata)}]} continue if {[string equal $rr(target) .]} continue if {[info exists rr(priority)] && [CheckNumber $rr(priority)] && \ [info exists rr(weight)] && [CheckNumber $rr(weight)] && \ [info exists rr(port)] && [CheckNumber $rr(port)] && \ [info exists rr(target)]} { if {$rr(weight) == 0} { set n 0 } else { set n [expr {($rr(weight) + 1) * rand()}] } lappend results [list [expr {$rr(priority) * 65536 - $n}] \ [list $rr(target) $rr(port)]] } } set replies {} foreach hp [lsort -real -index 0 $results] { lappend replies [lindex $hp 1] } return $replies } # ::xmpp::dns::CheckNumber -- # # Check if the value is integer and belongs to 0..65535 interval. # # Arguments: # val Value to check. # # Result: # 1 if value is integer and fits 0..65535, 0 otherwise. # # Side effects: # None. proc ::xmpp::dns::CheckNumber {val} { if {[string is integer -strict $val] && $val >= 0 && $val < 65536} { return 1 } else { return 0 } } # ::xmpp::dns::Resolve -- # # Synchronously or asynchronously resolve a given name of a given type. # # Arguments: # name DNS name to resolve. # type DNS record type to resolve. # command (optional) If present turns asynchronous mode on and # gives a command to call back. # # Result: # A token in asynchronous mode (to make abortion possible), or a DNS # result in synchronous mode. proc ::xmpp::dns::Resolve {name type {command ""}} { variable id set nameservers [dns::nameservers] if {![string equal $command ""]} { if {![info exists id]} { set id 0 } set token [namespace current]::[incr id] variable $token upvar 0 $token state set state(command) $command ResolveCallback $token $name $type $command $nameservers \ "No nameservers found" # Return token to be able to abort DNS lookup return $token } if {[llength $nameservers] == 0} { return -code error "No nameservers found" } foreach ns $nameservers { set token [dns::resolve $name -type $type -nameserver $ns] dns::wait $token if {[string equal [dns::status $token] ok]} { set res [dns::result $token] dns::cleanup $token return $res } else { set err [dns::error $token] dns::cleanup $token } } return -code error $err } # ::xmpp::dns::ResolveCallback -- # # Resolve a specified name of a given type using the first nameserver # in a list, or call back with error if nameserver list is empty. # # Arguments: # token DNS token, created in [Resolve]. # name DNS name to resolve. # type DNS record type to resolve. # command (optional) If present turns asynchronous mode on and # gives a command to call back. # nameservers Nameservers list to use. # err Current error message. # # Result: # Empty string. # # Side effects: # If nameserver list is empty then the callback is invoked with error, # otherwise DNS lookup is started and its token is stored in a variable. proc ::xmpp::dns::ResolveCallback {token name type command nameservers err} { variable $token upvar 0 $token state if {[llength $nameservers] == 0} { after idle $command [list error $err] unset state } else { set state(token) \ [dns::resolve $name -type $type \ -nameserver [lindex $nameservers 0] \ -command [namespace code \ [list ResolveCallbackStep \ $token $name $type $command \ [lrange $nameservers 1 end]]]] } return } # ::xmpp::dns::ResolveCallbackStep -- # # Check DNS server answer and if it's OK then call back, otherwise try # to use the next nameserver. # # Arguments: # token DNS token, created in [Resolve]. # name DNS name to resolve. # type DNS record type to resolve. # command (optional) If present turns asynchronous mode on and # gives a command to call back. # nameservers Nameservers list to use. # dtoken Internal DNS token to examine. # # Result: # Empty string. # # Side effects: # If DNS result is ok then the callback is invoked with status ok, # otherwise the next DNS lookup is started. proc ::xmpp::dns::ResolveCallbackStep {token name type command nameservers dtoken} { variable $token upvar 0 $token state if {[string equal [dns::status $dtoken] ok]} { eval $command [list ok [dns::result $dtoken]] unset state } else { ResolveCallback $token $name $type $command $nameservers \ [dns::error $dtoken] } dns::cleanup $dtoken return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/hints.tcl000064400000000000000000000036551470446212700147560ustar00nobodynobody# hints.tcl -- # # This file is part of the XMPP library. It implements interface to # Message Processing Hints (XEP-0334) # # Copyright (c) 2015 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package provide xmpp::hints 0.1 package require xmpp::xml 0.1 namespace eval ::xmpp::hints {} # ::xmpp::hints::parse -- # # Find hint elements in a list and parse them. # # Arguments: # xmlElements XML elements list. # # Result: # If there are any hints in the given list then the result is a # list of hints {store no-store no-permanent-store no-copy}. # Otherwise an empty list is returned. # # Side effects: # None. proc ::xmpp::hints::parse {xmlElements} { set res {} foreach element $xmlElements { ::xmpp::xml::split $element tag xmlns attrs cdata subels switch -- $xmlns { urn:xmpp:hints { lappend res $tag } } } return $res } # ::xmpp::hints::create -- # # Create a list of hint elements using XEP-0334 rules. # # Arguments: # hints A list of desired hints. May contain values from the # following list: {store no-store no-permanent-store no-copy} # # Results: # A list with XML elements from XEP-0334 is created. # # Side effects: # None. proc ::xmpp::hints::create {hints} { set res {} foreach hint [lsort -unique $hints] { switch -- $hint { no-copy - no-store - no-permanent-store - store { lappend res [::xmpp::xml::create $hint -xmlns urn:xmpp:hints] } default { return -code error \ "Unknown message processing hint: \"$hint\"" } } } return $res } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/https.tcl000064400000000000000000000414571470446212700147750ustar00nobodynobody# https.tcl -- # # Package for using the HTTP CONNECT (it is a common method for # tunnelling HTTPS traffic, so the name is https) method for # connecting TCP sockets. Only client side. # # Copyright (c) 2007-2013 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require base64 package require SASL::NTLM 1.0 package require pconnect 0.1 package require msgcat package provide pconnect::https 0.1 namespace eval ::pconnect::https { namespace export connect abort variable debug 0 ::pconnect::register https [namespace code connect] \ [namespace code abort] } # ::pconnect::https::connect -- # # Negotiates with a HTTPS proxy server. # # Arguments: # sock an open socket token to the proxy server # addr the peer address, not the proxy server # port the peer port number # args # -command tclProc {status socket} # -username userid # -password password # -useragent useragent # -timeout millisecs (default 60000) # # Results: # The connect socket or error if no -command, else control token # (to be able to abort connect process). # # Side effects: # Socket is prepared for data transfer. # If -command specified, the callback tclProc is called with # status ok and socket or error and error message. proc ::pconnect::https::connect {sock addr port args} { variable auth set token [namespace current]::$sock variable $token upvar 0 $token state Debug $token 2 "sock=$sock, addr=$addr, port=$port, args=$args" array set state { -command "" -timeout 60000 -username "" -password "" -useragent "" async 0 status "" } array set state [list addr $addr \ port $port \ sock $sock] array set state $args if {[string length $state(-command)] > 0} { set state(async) 1 } if {[catch {set state(peer) [fconfigure $sock -peername]}]} { catch {close $sock} if {$state(async)} { after idle $state(-command) \ [list error [::msgcat::mc "Failed to connect to HTTPS proxy"]] Free $token return $token } else { Free $token return -code error [::msgcat::mc "Failed to connect to HTTPS proxy"] } } PutsConnectQuery $token fileevent $sock readable \ [namespace code [list Readable $token]] # Setup timeout timer. if {$state(-timeout) > 0} { set state(timeoutid) \ [after $state(-timeout) [namespace code [list Timeout $token]]] } if {$state(async)} { return $token } else { # We should not return from this proc until finished! vwait $token\(status) set status $state(status) set sock $state(sock) Free $token if {[string equal $status ok]} { return $sock } else { catch {close $sock} if {[string equal $status abort]} { return -code break $sock } else { return -code error $sock } } } } # ::pconnect::https::abort -- # # This proc aborts proxy negotiation. # # Arguments: # token A connection token. # # Result: # An empty string. # # Side effects: # A proxy negotiation is finished with error. proc ::pconnect::https::abort {token} { Finish $token abort [::msgcat::mc "HTTPS proxy negotiation aborted"] return } # ::pconnect::https::Readable -- # # Receive the first reply from a proxy and either finish the # negotiations or prepare to autorization process at the proxy. # # Arguments: # token A connection token. # # Result: # An empty string. # # Side effects: # The negotiation is finished or the next turn is started. proc ::pconnect::https::Readable {token} { variable $token upvar 0 $token state Debug $token 2 "" fileevent $state(sock) readable {} set code [ReadProxyAnswer $token] if {$code >= 200 && $code < 300} { # Success while {[string length [gets $state(sock)]]} {} Finish $token ok return } elseif {$code != 407} { # Failure Finish $token error $state(result) return } else { # Authorization required set content_length -1 set method basic while {[string length [set header [gets $state(sock)]]]} { Debug $token 2 "$header" switch -- [HttpHeaderName $header] { proxy-authenticate { if {[string equal -length 4 [HttpHeaderBody $header] \ "NTLM"]} { set method ntlm } } content-length { set content_length [HttpHeaderBody $header] } } } ReadProxyJunk $token $content_length close $state(sock) set state(sock) \ [socket -async [lindex $state(peer) 0] [lindex $state(peer) 2]] fileevent $state(sock) writable \ [namespace code [list Authorize $token $method]] } return } # ::pconnect::https::Authorize -- # # Start the authorization procedure. # # Arguments: # token A connection token. # method (basic or ntlm) authorization method. # # Result: # Empty string. # # Side effects: # Authorization is started. proc ::pconnect::https::Authorize {token method} { variable $token upvar 0 $token state Debug $token 2 "$method" fileevent $state(sock) writable {} switch -- $method { ntlm { AuthorizeNtlmStep1 $token } default { AuthorizeBasicStep1 $token } } return } # https::AuthorizeBasicStep1 -- # # The first step of basic authorization procedure: send authorization # credentials to a socket. # # Arguments: # token A connection token. # # Result: # Empty string. # # Side effects: # Authorization info is sent to a socket. proc ::pconnect::https::AuthorizeBasicStep1 {token} { variable $token upvar 0 $token state Debug $token 2 "" set auth \ [string map {\n {}} \ [base64::encode \ [encoding convertto "$state(-username):$state(-password)"]]] PutsConnectQuery $token "Basic $auth" fileevent $state(sock) readable \ [namespace code [list AuthorizeBasicStep2 $token]] return } # ::pconnect::https::AuthorizeBasicStep2 -- # # The second step of basic authorization procedure: receive and # analyze server reply. # # Arguments: # token A connection token. # # Result: # Empty string. # # Side effects: # Server reply is received from a socket. proc ::pconnect::https::AuthorizeBasicStep2 {token} { variable $token upvar 0 $token state Debug $token 2 "" fileevent $state(sock) readable {} set code [ReadProxyAnswer $token] if {$code >= 200 && $code < 300} { # Success while {[string length [gets $state(sock)]]} { } Finish $token ok return } else { # Failure Finish $token error $state(result) return } return } # ::pconnect::https::AuthorizeNtlmStep1 -- # # The first step of NTLM authorization procedure: send NTLM # message 1 to a socket. # # Arguments: # token A connection token. # # Result: # Empty string. # # Side effects: # Authorization info is sent to a socket. proc ::pconnect::https::AuthorizeNtlmStep1 {token} { variable $token upvar 0 $token state Debug $token 2 "" set message1 \ [string map {\n {}} \ [base64::encode [::SASL::NTLM::CreateGreeting "" "" \ {unicode oem ntlm req_target server}]]] Debug $token 2 "NTLM $message1" PutsConnectQuery $token "NTLM $message1" fileevent $state(sock) readable \ [namespace code [list AuthorizeNtlmStep2 $token]] return } # ::pconnect::https::AuthorizeNtlmStep2 -- # # The first step of basic authorization procedure: send authorization # credentials to a socket. # # Arguments: # token A connection token. # # Result: # Empty string. # # Side effects: # Authorization info is sent to a socket. proc ::pconnect::https::AuthorizeNtlmStep2 {token} { variable $token upvar 0 $token state Debug $token 2 "" fileevent $state(sock) readable {} set code [ReadProxyAnswer $token] if {$code >= 200 && $code < 300} { # Success while {[string length [gets $state(sock)]]} { } Finish $token ok return } elseif {$code != 407} { # Failure Finish $token error $state(result) return } set content_length -1 set message2 "" while {![string equal [set header [gets $state(sock)]] ""]} { Debug $token 2 "$header" switch -- [HttpHeaderName $header] { proxy-authenticate { set body [HttpHeaderBody $header] if {[string equal -length 5 $body "NTLM "]} { set message2 [string trim [string range $body 5 end]] } } content-length { set content_length [HttpHeaderBody $header] } } } ReadProxyJunk $token $content_length Debug $token 2 "NTLM $message2" array set challenge [::SASL::NTLM::Decode [base64::decode $message2]] # if username is domain/username or domain\username # then set domain and username set username $state(-username) regexp {(\w+)[\\/](.*)} $username -> domain username if {![info exists domain]} { set domain $challenge(domain) } set message3 \ [string map {\n {}} \ [base64::encode \ [::SASL::NTLM::CreateResponse $domain \ [info hostname] \ $username \ $state(-password) \ $challenge(nonce) \ $challenge(flags)]]] Debug $token 2 "NTLM $message3" PutsConnectQuery $token "NTLM $message3" fileevent $state(sock) readable \ [namespace code [list AuthorizeNtlmStep3 $token]] return } # ::pconnect::https::AuthorizeNtlmStep3 -- # # The third step of NTLM authorization procedure: receive and # analyze server reply. # # Arguments: # token A connection token. # # Result: # Empty string. # # Side effects: # Server reply is received from a socket. proc ::pconnect::https::AuthorizeNtlmStep3 {token} { variable $token upvar 0 $token state Debug $token 2 "" fileevent $state(sock) readable {} set code [ReadProxyAnswer $token] if {$code >= 200 && $code < 300} { # Success while {[string length [gets $state(sock)]]} { } Finish $token ok return } else { # Failure Finish $token error $state(result) return } return } # ::pconnect::https::PutsConnectQuery -- # # Sends CONNECT query to a proxy server. # # Arguments: # token A connection token. # auth (optional) A proxy authorization string. # # Result: # Empty string. # # Side effects: # Some info is sent to a proxy. proc ::pconnect::https::PutsConnectQuery {token {auth ""}} { variable $token upvar 0 $token state Debug $token 2 "$auth" fconfigure $state(sock) -buffering line -translation auto puts $state(sock) "CONNECT $state(addr):$state(port) HTTP/1.0" puts $state(sock) "Proxy-Connection: keep-alive" if {[string length $state(-useragent)]} { puts $state(sock) "User-Agent: $state(-useragent)" } if {[string length $auth]} { puts $state(sock) "Proxy-Authorization: $auth" } puts $state(sock) "" return } # ::pconnect::https::ReadProxyAnswer -- # # Reads the first line of a proxy answer with a result code. # # Arguments: # token A connection token. # # Result: # The HTTP result code. # # Side effects: # Status line is read form a socket. # Variable state(result) is set to a just read line. proc ::pconnect::https::ReadProxyAnswer {token} { variable $token upvar 0 $token state Debug $token 2 "" fconfigure $state(sock) -buffering line -translation auto set state(result) [gets $state(sock)] set code [lindex [split $state(result) { }] 1] if {[string is integer -strict $code]} { return $code } else { # Invalid code return 0 } } # ::pconnect::https::ReadProxyJunk -- # # Reads the body part of a proxy answer. # # Arguments: # token A connection token. # # Result: # Empty string. # # Side effects: # Some info is read from a socket and discarded. proc ::pconnect::https::ReadProxyJunk {token length} { variable $token upvar 0 $token state Debug $token 2 "$length" fconfigure $state(sock) -buffering none -translation binary if {$length != -1} { read $state(sock) $length } else { read $state(sock) } return } # ::pconnect::https::HttpHeaderName -- # # Returns HTTP header name (converted to lowercase). # # Arguments: # header A HTTP header. # # Result: # A header name. # # Side effects # None. proc ::pconnect::https::HttpHeaderName {header} { set hlist [split $header ":"] return [string tolower [lindex $hlist 0]] } # ::pconnect::https::HttpHeaderBody -- # # Returns HTTP header body. # # Arguments: # header A HTTP header. # # Result: # A header body. # # Side effects # None. proc ::pconnect::https::HttpHeaderBody {header} { set hlist [split $header ":"] set body [join [lrange $hlist 1 end] ":"] return [string trim $body] } # ::pconnect::https::Timeout -- # # This proc is called in case of timeout. # # Arguments: # token A connection token. # # Result: # An empty string. # # Side effects: # A proxy negotiation is finished with error. proc ::pconnect::https::Timeout {token} { Finish $token timeout [::msgcat::mc "HTTPS proxy negotiation timed out"] return } # ::pconnect::https::Free -- # # Frees a connection token. # # Arguments: # token A connection token. # # Result: # An empty string. # # Side effects: # A connection token and its state informationa are destroyed. proc ::pconnect::https::Free {token} { variable $token upvar 0 $token state catch {after cancel $state(timeoutid)} catch {unset state} return } # ::pconnect::https::Finish -- # # Finishes a negotiation process. # # Arguments: # token A connection token. # status ok, abort, or error # errormsg (optional) error message. # # Result: # An empty string. # # Side effects: # If connection is asynchronous then a callback is executed. # Otherwise state(status) is set to allow ::pconnect::https::connect # to return with either success or error. proc ::pconnect::https::Finish {token status {errormsg ""}} { variable $token upvar 0 $token state catch {after cancel $state(timeoutid)} Debug $token 2 "status=$status, errormsg=$errormsg" if {$state(async)} { set command $state(-command) set sock $state(sock) Free $token if {[string equal $status ok]} { uplevel #0 $command [list ok $sock] } else { catch {close $sock} uplevel #0 $command [list $status $errormsg] } } else { if {[string equal $status ok]} { set state(status) ok } else { catch {close $state(sock)} set state(sock) $errormsg set state(status) $status } } return } # ::pconnect::https::Debug -- # # Prints debug information. # # Arguments: # token Token. # level Debug level. # str Debug message. # # Result: # An empty string. # # Side effects: # A debug message is printed to the console if the value of # ::pconnect::https::debug variable is not less than num. proc ::pconnect::https::Debug {token level str} { variable debug if {$debug >= $level} { puts "[lindex [info level -1] 0] $token: $str" } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/iq.tcl000064400000000000000000000177401470446212700142420ustar00nobodynobody# iq.tcl -- # # This file is part of the XMPP library. It implements the IQ processing # for high level applications. If you want to use low level parsing, use # -packetCommand option for ::xmpp::new. # # Copyright (c) 2008-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package provide xmpp::iq 0.1 namespace eval ::xmpp::iq { namespace export registered register unregister process } # ::xmpp::iq::registered -- # # Return all registered XML namespaces. # # Arguments: # xlib XMPP token. # # Result: # A list of XMLNSs registered for the application. # # Side effects: # None. proc ::xmpp::iq::registered {xlib} { variable SupportedNS set ns {} foreach idx [array names SupportedNS] { if {[string match $idx $xlib]} { set ns [concat $ns $SupportedNS($idx)] } } return [lsort -unique $ns] } # ::xmpp::iq::register -- # # Register IQ. # # Arguments: # type IQ type to register. Must be either get or set. Types # error and result cannot be registered. # tag IQ XML tag pattern to register. # xmlns XMLNS pattern to register. # cmd Command to call when a registered IQ is received. This # command must return one of the following: {error, ...}, # {result, ...}, ignore. # # Result: # Empty string or error if IQ type isn't get or set. # # Side effects: # An IQ is registered, and its XMLNS is added to a list of supported # namespaces. proc ::xmpp::iq::register {type tag xmlns cmd} { RegisterIQ * $type $tag $xmlns $cmd } # ::xmpp::iq::unregister -- # # Unregister IQ. # # Arguments: # type IQ type to register. Must be either get or set. Types # error and result cannot be registered. # tag IQ XML tag pattern to register. # xmlns XMLNS pattern to register. # # Result: # Empty string. # # Side effects: # An IQ is unregistered, and its XMLNS is removed from a list of # supported namespaces. proc ::xmpp::iq::unregister {type tag xmlns} { UnregisterIQ * $type $tag $xmlns } # ::xmpp::iq::RegisterIQ -- # # Register IQ. # # Arguments: # xlib XMPP token. # type IQ type to register. Must be either get or set. Types # error and result cannot be registered. # tag IQ XML tag pattern to register. # xmlns XMLNS pattern to register. # cmd Command to call when a registered IQ is received. This # command must return one of the following: {error, ...}, # {result, ...}, ignore. # # Result: # Empty string or error if IQ type isn't get or set. # # Side effects: # An IQ is registered, and its XMLNS is added to a list of supported # namespaces. proc ::xmpp::iq::RegisterIQ {xlib type tag xmlns cmd} { variable IqCmd variable SupportedNS switch -- $type { get - set {} default { return -code error [::msgcat::mc "Illegal IQ type \"%s\"" $type] } } set IqCmd($xlib,$type,$tag,$xmlns) $cmd # TODO: Work with patterns if {[string equal $xmlns *]} return if {![info exists SupportedNS($xlib)]} { set SupportedNS($xlib) {} } set SupportedNS($xlib) \ [lsort -unique [linsert $SupportedNS($xlib) 0 $xmlns]] return } # ::xmpp::iq::UnregisterIQ -- # # Unregister IQ. # # Arguments: # xlib XMPP token. # type IQ type to register. Must be either get or set. Types # error and result cannot be registered. # tag IQ XML tag pattern to register. # xmlns XMLNS pattern to register. # # Result: # Empty string. # # Side effects: # An IQ is unregistered, and its XMLNS is removed from a list of # supported namespaces. proc ::xmpp::iq::UnregisterIQ {xlib type tag xmlns} { variable IqCmd variable SupportedNS if {![info exists IqCmd($xlib,$type,$tag,$xmlns)]} { return } unset IqCmd($xlib,$type,$tag,$xmlns) # TODO: Work with patterns if {[string equal $xmlns *]} return if {[llength [array names IqCmd $xlib,*,*,$xmlns]] > 0} return if {![info exists SupportedNS($xlib)]} return set idx [lsearch -exact $SupportedNS($xlib) $xmlns] if {$idx >= 0} { set SupportedNS($xlib) [lreplace $SupportedNS($xlib) $idx $idx] if {[llength $SupportedNS($xlib)] == 0} { unset SupportedNS($xlib) } } return } # ::xmpp::iq::process -- # # Process received IQ if it's registered. Otherwise reply with error. # # Arguments: # xlib XMPP token. # from JID from which the query is received. # type Query type (get or set). # xmlElement Query XML element. # # Result: # Empty string. # # Side effects: # A command corresponding to received IQ is called, and IQ reply is sent # back to a sending entity. proc ::xmpp::iq::process {xlib from type xmlElement args} { variable IqCmd ::xmpp::Debug $xlib 2 "$from $type $xmlElement $args" ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels if {[info exists IqCmd(*,$type,$tag,$xmlns)]} { set cmd $IqCmd(*,$type,$tag,$xmlns) } else { foreach idx [lsort [array names IqCmd \\*,$type,*]] { set fields [split $idx ,] set ptag [lindex $fields 2] set pxmlns [join [lrange $fields 3 end] ,] if {[string match $ptag $tag] && [string match $pxmlns $xmlns]} { set cmd $IqCmd($idx) break } } } if {[info exists IqCmd($xlib,$type,$tag,$xmlns)]} { set cmd $IqCmd($xlib,$type,$tag,$xmlns) } else { foreach idx [lsort [array names IqCmd $xlib,$type,*]] { set fields [split $idx ,] set ptag [lindex $fields 2] set pxmlns [join [lrange $fields 3 end] ,] if {[string match $ptag $tag] && [string match $pxmlns $xmlns]} { set cmd $IqCmd($idx) break } } } set id [::xmpp::xml::getAttr $args -id] set to [::xmpp::xml::getAttr $args -to] if {![info exists cmd]} { ::xmpp::Debug $xlib 2 "unsupported $from $id $xmlns" ::xmpp::sendIQ $xlib error \ -query $xmlElement \ -error [::xmpp::stanzaerror::error \ cancel service-unavailable] \ -to $from \ -from $to \ -id $id } else { set status [uplevel #0 $cmd [list $xlib $from $xmlElement] $args] switch -- [lindex $status 0] { result { ::xmpp::Debug $xlib 2 "result $from $id $xmlns" ::xmpp::sendIQ $xlib result \ -query [lindex $status 1] \ -to $from \ -from $to \ -id $id } error { ::xmpp::Debug $xlib 2 "error $from $id $xmlns" ::xmpp::sendIQ $xlib error \ -query $xmlElement \ -error [eval ::xmpp::stanzaerror::error \ [lrange $status 1 end]] \ -to $from \ -from $to \ -id $id } "" { ::xmpp::Debug $xlib 2 "do nothing $from $id $xmlns" # Do nothing, the request is supposed to be replied separately } } } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/jid.tcl000064400000000000000000000171131470446212700143710ustar00nobodynobody# jid.tcl -- # # This file is part of the XMPP library. It implements the routines to # work with JIDs # # Copyright (c) 2008-2012 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package provide xmpp::jid 0.1 namespace eval ::xmpp::jid { namespace export jid split node server resource replaceResource \ removeResource normalize equal if {![catch {package require stringprep 1.0.1}]} { variable Stringprep 1 ::stringprep::register Nameprep \ -mapping {B.1 B.2} \ -normalization KC \ -prohibited {A.1 C.1.2 C.2.2 C.3 C.4 C.5 C.6 C.7 C.8 C.9} \ -prohibitedBidi 1 ::stringprep::register Nodeprep \ -mapping {B.1 B.2} \ -normalization KC \ -prohibited {A.1 C.1.1 C.1.2 C.2.1 C.2.2 C.3 C.4 C.5 C.6 C.7 C.8 C.9} \ -prohibitedList {0x22 0x26 0x27 0x2f 0x3a 0x3c 0x3e 0x40} \ -prohibitedBidi 1 ::stringprep::register Resourceprep \ -mapping {B.1} \ -normalization KC \ -prohibited {A.1 C.1.2 C.2.1 C.2.2 C.3 C.4 C.5 C.6 C.7 C.8 C.9} \ -prohibitedBidi 1 } else { variable Stringprep 0 } } # ::xmpp::jid::jid -- # # Create JID from node, server and resource parts. # # Arguments: # node JID node. # server JID server. # resource (optional, defaults to "") JID resource. # # Result: # A constructed JID (arguments joined by @ and /). # # Side effects: # None. proc ::xmpp::jid::jid {node server {resource ""}} { set jid $server if {![string equal $node ""]} { set jid $node@$jid } if {![string equal $resource ""]} { set jid $jid/$resource } return $jid } # ::xmpp::jid::split -- # # Splits the given JID into 3 variables. # # Arguments: # jid JID. # nodeVar Variable for JID node. # serverVar Variable for JID server. # resourceVar Variable for JID resource. # # Result: # An empty string. # # Side effects: # Three variables are assigned. proc ::xmpp::jid::split {jid nodeVar serverVar resourceVar} { upvar 1 $nodeVar node $serverVar server $resourceVar resource set node [node $jid] set server [server $jid] set resource [resource $jid] return } # ::xmpp::jid::node -- # # Extract node part from JID. # # Arguments: # jid JID. # # Result: # An extracted node (part of JID before the first @ if it doesn't belong # to a resource, or empty string). # # Side effects: # None. proc ::xmpp::jid::node {jid} { set a [string first @ $jid] if {$a < 0} { return } else { set b [string first / $jid] if {$b >= 0 && $a > $b} { return } else { string range $jid 0 [incr a -1] } } } # ::xmpp::jid::server -- # # Extract server part from JID. # # Arguments: # jid JID. # # Result: # An extracted server (part of JID between the first @ and the first /). # # Side effects: # None. proc ::xmpp::jid::server {jid} { set a [string first @ $jid] set b [string first / $jid] if {$a < 0} { if {$b < 0} { return $jid } else { string range $jid 0 [incr b -1] } } else { if {$b < 0} { string range $jid [incr a] end } elseif {$a >= $b} { string range $jid 0 [incr b -1] } else { string range $jid [incr a] [incr b -1] } } } # ::xmpp::jid::resource -- # # Extract resource part from JID. # # Arguments: # jid JID. # # Result: # An extracted resource (part of JID after the first /). # # Side effects: # None. proc ::xmpp::jid::resource {jid} { set b [string first / $jid] if {$b < 0} { return } else { string range $jid [incr b] end } } # ::xmpp::jid::replaceResource -- # # Replace resource part for a given JID. # # Arguments: # jid JID. # resource A new JID resource. # # Result: # A JID constructed from node and server parts from the given JID and # the given resource part. # # Side effects: # None. proc ::xmpp::jid::replaceResource {jid resource} { split $jid node server res jid $node $server $resource } # ::xmpp::jid::removeResource -- # # Remove resource part from JID. # # Arguments: # jid JID. # # Result: # A JID constructed from node and server parts extracted from the # given JID. # # Side effects: # None. proc ::xmpp::jid::removeResource {jid} { replaceResource $jid "" } # ::xmpp::jid::stripResource -- # # The same as removeResource (for backward compatibility. # # Arguments: # jid JID. # # Result: # A JID constructed from node and server parts extracted from the # given JID. # # Side effects: # None. proc ::xmpp::jid::stripResource {jid} { removeResource $jid } # ::xmpp::jid::normalize -- # # Normalize JID for comparison. In case if stringprep package is loaded # it means applying the correspondent stringprep profiles to JID node, # server and resource. If stringprep isn'r available then JID node and # server parts are simply converted to lowercase. # # Arguments: # jid JID. # # Result: # A normalised JID with either all its parts stringprepped or with node # and server parts converted to lowercase. If JID is malformed then the # error is returned. # # Side effects: # If JID's node, server or resource is missing in the correspondent # cache it is added. proc ::xmpp::jid::normalize {jid} { variable Stringprep split $jid node server resource if {$Stringprep} { variable NodesCache variable ServersCache variable ResourcesCache if {[info exists NodesCache($node)]} { set node1 $NodesCache($node) } else { if {[catch {::stringprep::stringprep Nodeprep $node} node1]} { set node1 [string tolower $node] } set NodesCache($node) $node1 } if {[info exists ServersCache($server)]} { set server1 $ServersCache($server) } else { if {[catch {::stringprep::stringprep Nameprep $server} server1]} { set server1 [string tolower $server] } set ServersCache($server) $server1 } if {[info exists ResourcesCache($resource)]} { set resource1 $ResourcesCache($resource) } else { if {[catch {::stringprep::stringprep Resourceprep $resource} resource1]} { set resource1 $resource } set ResourcesCache($resource) $resource1 } } else { set node1 [string tolower $node] set server1 [string tolower $server] set resource1 $resource } jid $node1 $server1 $resource1 } # ::xmpp::jid::equal -- # # Compare two normalized JIDs. # # Arguments: # jid1 JID to compare. # jid1 JID to compare. # # Result: # 1 if normalized JIDs are equal, 0 otherwise. Error if some of the JIDs # is malformed. # # Side effects: # None. proc ::xmpp::jid::equal {jid1 jid2} { string equal [normalize $jid1] [normalize $jid2] } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/metacontacts.tcl000064400000000000000000000076261470446212700163200ustar00nobodynobody# metacontacts.tcl -- # # This file is a part of the XMPP library. It implements storing and # retieving metacontacts information (XEP-0209). # # Copyright (c) 2009-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp::private package provide xmpp::roster::metacontacts 0.1 namespace eval ::xmpp::roster::metacontacts { namespace export store retrieve serialize deserialize } proc ::xmpp::roster::metacontacts::retrieve {xlib args} { set commands {} set timeout 0 foreach {key val} $args { switch -- $key { -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } set id \ [::xmpp::private::retrieve \ $xlib \ [list [::xmpp::xml::create storage \ -xmlns storage:metacontacts]] \ -command [namespace code [list ProcessRetrieveAnswer $commands]] \ -timeout $timeout] return $id } proc ::xmpp::roster::metacontacts::ProcessRetrieveAnswer {commands status xml} { if {[llength $commands] == 0} return if {![string equal $status ok]} { uplevel #0 [lindex $commands 0] [list $status $xml] } uplevel #0 [lindex $commands 0] [list ok [deserialize $xml]] return } proc ::xmpp::roster::metacontacts::deserialize {xml} { foreach xmldata $xml { ::xmpp::xml::split $xmldata tag xmlns attrs cdata subels if {[string equal $xmlns storage:metacontacts]} { foreach meta $subels { ::xmpp::xml::split $meta stag sxmlns sattrs scdata ssubels set jid [::xmpp::xml::getAttr $sattrs jid] set tag [::xmpp::xml::getAttr $sattrs tag] set order [::xmpp::xml::getAttr $sattrs order] if {![string is integer -strict $order]} { set order 0 } lappend contacts($tag) [list $jid $order] } } } foreach tag [array names contacts] { foreach jo [lsort -integer -index 1 $contacts($tag)] { lappend result($tag) [lindex $jo 0] } } return [array get result] } proc ::xmpp::roster::metacontacts::serialize {contacts} { set tags {} foreach {tag jids} $contacts { set order 1 foreach jid $jids { set attrs [list jid $jid tag $tag order $order] lappend tags [::xmpp::xml::create meta -attrs $attrs] incr order } } return [::xmpp::xml::create storage \ -xmlns storage:metacontacts \ -subelements $tags] } proc ::xmpp::roster::metacontacts::store {xlib contacts args} { set commands {} set timeout 0 foreach {key val} $args { switch -- $key { -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } set id \ [::xmpp::private::store \ $xlib \ [list [serialize $contacts]] \ -command [namespace code [list ProcessStoreAnswer $commands]] \ -timeout $timeout] return $id } proc ::xmpp::roster::metacontacts::ProcessStoreAnswer {commands status xml} { if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/muc.tcl000064400000000000000000001101741470446212700144100ustar00nobodynobody# muc.tcl -- # # This file is a part of the XMPP library. It implements Multi # User Chat (XEP-0045). # # Copyright (c) 2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp package provide xmpp::muc 0.1 namespace eval ::xmpp::muc {} # ::xmpp::muc::new -- proc ::xmpp::muc::new {xlib room args} { variable id if {![string equal [::xmpp::jid::resource $room] ""]} { return -code error \ [::msgcat::mc "MUC room JID must have empty resource part.\ The specified JID was \"%s\"" $room] } if {[catch {set room [::xmpp::jid::normalize $room]}]} { return -code error \ [::msgcat::mc "MUC room JID \"%s\" is malformed" $room] } if {![info exists id]} { set id 0 } set token [namespace current]::[incr id] variable $token upvar 0 $token state set state(xlib) $xlib set state(room) $room set state(nick) "" set state(requestedNick) "" set state(users) {} set state(status) disconnected set state(args) {} set state(-eventcommand) [namespace code Noop] set state(-rostercommand) [namespace code Noop] set state(commands) {} catch {unset state(id)} foreach {key val} $args { switch -- $key { -eventcommand { set state($key) $val } -rostercommand { set state($key) $val } default { unset state return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } ::xmpp::presence::RegisterPresence $xlib $room * \ [namespace code [list ParsePresence $token]] return $token } # ::xmpp::muc::free -- proc ::xmpp::muc::free {token} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) set room $state(room) ::xmpp::presence::UnregisterPresence $xlib $room * \ [namespace code [list ParsePresence $token]] unset state return } # ::xmpp::muc::join -- proc ::xmpp::muc::join {token nickname args} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return # TODO: Add presence options to be able to change presence along with # nickname change. set commands {} set xlist {} set history {} set newXlist {} set state(args) {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } -xlist { set newXlist $val } -password { lappend xlist [::xmpp::xml::create password -cdata $val] } -maxchars { lappend history maxchars $val } -maxstanzas { lappend history maxstanzas $val } -seconds { lappend history seconds $val } -since { lappend history since $val } -from - -show - -status - -priority { lappend state(args) $key $val } default { return -code error [::msgcat::mc "Illegal option \"%s\"" $key] } } } if {[llength $history] > 0} { lappend xlist [::xmpp::xml::create history -attrs $history] } lappend newXlist [::xmpp::xml::create x \ -xmlns "http://jabber.org/protocol/muc" \ -subelements $xlist] if {[string equal $state(status) connected]} { after idle [namespace code \ [list CallBack $commands error \ [::xmpp::xml::create error \ -cdata [::msgcat::mc "Already joined"]]]] return } if {[string equal $state(status) connecting]} { after idle [namespace code \ [list CallBack $commands error \ [::xmpp::xml::create error \ -cdata [::msgcat::mc "Already joining"]]]] return } set xlib $state(xlib) set room $state(room) if {[catch {set jid [::xmpp::jid::normalize \ [::xmpp::jid::replaceResource $room \ $nickname]]}]} { after idle [namespace code \ [list CallBack $commands error \ [::xmpp::xml::create error \ -cdata [::msgcat::mc "Illegal nickname"]]]] return } set nickname [::xmpp::jid::resource $jid] if {[string equal $nickname ""]} { after idle [namespace code \ [list CallBack $commands error \ [::xmpp::xml::create error \ -cdata [::msgcat::mc "Empty nickname"]]]] return } set id [::xmpp::packetID $xlib] set state(id) $id set state(commands) $commands set state(status) connecting set state(nick) "" set state(requestedNick) $nickname set state(users) {} array unset state jid,* array unset state affiliation,* array unset state role,* eval [list ::xmpp::sendPresence $xlib \ -to [::xmpp::jid::replaceResource $room $nickname] \ -xlist $newXlist \ -id $id] $state(args) return } # ::xmpp::muc::leave -- proc ::xmpp::muc::leave {token args} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) set room $state(room) set nick $state(nick) set newArgs {} foreach {key val} $args { switch -- $key { -status { lappend newArgs -status $val } } } set state(status) disconnected set state(args) {} set commands $state(commands) set state(commands) {} if {[info exists state(id)]} { unset state(id) CallBack $commands error \ [::xmpp::xml::create error \ -cdata [::msgcat::mc "Leaving room"]] } set id [::xmpp::packetID $xlib] eval [list ::xmpp::sendPresence $xlib \ -type unavailable \ -to [::xmpp::jid::replaceResource $room $nick] \ -id $id] $newArgs } # ::xmpp::muc::reset -- proc ::xmpp::muc::reset {token} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set state(status) disconnected set state(args) {} catch {unset state(id)} set state(commands) {} } # ::xmpp::muc::setNick -- proc ::xmpp::muc::setNick {token nickname args} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set commands {} set newXlist {} array set Args $state(args) foreach {key val} $args { switch -- $key { -command { set commands [list $val] } -xlist { set newXlist $val } -maxchars { lappend history maxchars $val } -maxstanzas { lappend history maxstanzas $val } -seconds { lappend history seconds $val } -since { lappend history since $val } -from - -show - -status - -priority { set Args($key) $val } default { return -code error [::msgcat::mc "Illegal option \"%s\"" $key] } } } switch -- $state(status) { disconnected - connecting { after idle [namespace code \ [list CallBack $commands error \ [::xmpp::xml::create error \ -cdata [::msgcat::mc "The room isn't\ joined yet"]]]] return } } set xlib $state(xlib) set room $state(room) set nick $state(nick) if {[catch {set jid [::xmpp::jid::normalize \ [::xmpp::jid::replaceResource $room \ $nickname]]}]} { after idle [namespace code \ [list CallBack $commands error \ [::xmpp::xml::create error \ -cdata [::msgcat::mc "Illegal nickname"]]]] return } set nickname [::xmpp::jid::resource $jid] # Changing nickname to the equivalent one does nothing useful if {[::xmpp::jid::equal [::xmpp::jid::replaceResource $room $nick] \ [::xmpp::jid::replaceResource $room $nickname]]} { after idle [namespace code \ [list CallBack $commands error \ [::xmpp::xml::create error \ -cdata [::msgcat::mc "Nickname didn't\ change"]]]] return } # Can't change nickname when it is changing already. if {[info exists state(id)]} { after idle [namespace code \ [list CallBack $commands error \ [::xmpp::xml::create error \ -cdata [::msgcat::mc "Nickname is changing\ already"]]]] return } set xlib $state(xlib) set room $state(room) set nick $state(nick) set id [::xmpp::packetID $xlib] set state(id) $id set state(commands) $commands set state(args) [array get Args] eval [list ::xmpp::sendPresence $xlib \ -to [::xmpp::jid::replaceResource $room $nickname] \ -id $id] $state(args) } # ::xmpp::muc::ParsePresence -- proc ::xmpp::muc::ParsePresence {token from type xmlElements args} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set nick [::xmpp::jid::resource $from] switch -- $type { available - unavailable { foreach element $xmlElements { ::xmpp::xml::split $element tag xmlns attrs cdata subels if {[string equal $xmlns \ "http://jabber.org/protocol/muc#user"]} { ProcessMUCUser $token $nick $type $subels } } } error { set error [::xmpp::xml::create error -cdata [::msgcat::mc "Error"]] foreach {key val} $args { switch -- $key { -id { set id $val } -error { set error $val } } } if {[info exists state(id)]} { # We're waiting for some answer set match 0 if {[info exists id] && [string equal $state(id) $id]} { # If id matches then it's definitely an answer set match 1 } elseif {![info exists id]} { # If there's no id then it may be an answer if the room # doesn't respect XMPP rules switch -- $state(status) { connecting { set nickname $state(requestedNick) } default { set nickname $state(nick) } } if {[string equal $nick $nickname]} { # TODO: Should we also check for empty $nick? set match 1 } } if {$match} { unset state(id) switch -- $state(status) { connecting { set state(status) disconnected } } set commands $state(commands) set state(commands) {} CallBack $commands error $error return } } } } switch -- $type { unavailable - error { set status $type # Remove user from the room users list set idx [lsearch -exact $state(users) $nick] if {$idx >= 0} { set state(users) [lreplace $state(users) $idx $idx] } catch {unset state(jid,$nick)} catch {unset state(affiliation,$nick)} catch {unset state(role,$nick)} if {[info exists state(ignore_unavailable)] && \ [string equal $state(ignore_unavailable) $nick]} { unset state(ignore_unavailable) } else { uplevel #0 $state(-eventcommand) [list exit $nick] $args } if {[string equal $nick $state(nick)]} { # TODO: Check for $state(requestedNick)? set state(status) disconnected set state(args) {} set commands $state(commands) set state(commands) {} if {[info exists state(id)]} { unset state(id) CallBack $commands error \ [::xmpp::xml::create error \ -cdata [::msgcat::mc "Disconnected from the room"]] } uplevel #0 $state(-eventcommand) [list disconnect $nick] $args } } available { set status $type foreach {key val} $args { switch -- $key { -id { set id $val } -show { set status $val } } } if {[info exists state(id)]} { set match 0 if {[info exists id] && [string equal $id $state(id)]} { set match 1 } elseif {![info exists id]} { switch -- $state(status) { connecting { set nickname $state(requestedNick) } default { set nickname $state(nick) } } if {[string equal $nick $nickname]} { set match 1 } } if {$match} { unset state(id) set state(status) connected set state(nick) $nick set commands $state(commands) set state(commands) {} CallBack $commands ok $nick } } # Add user to the room users list set idx [lsearch -exact $state(users) $nick] if {![string equal $nick ""] && $idx < 0} { lappend state(users) $nick set action enter if {[string equal [set RealJID [realJid $token $nick]] ""]} { lappend args -jid $RealJID } if {[string equal [set aff [affiliation $token $nick]] ""]} { lappend args -affiliation $aff } if {[string equal [set role [role $token $nick]] ""]} { lappend args -role $role } } else { set action presence } if {[info exists state(ignore_available)] && \ [string equal $state(ignore_available) $nick]} { uplevel #0 $state(-eventcommand) nick $state(nick_args) unset state(nick_args) unset state(ignore_available) } else { uplevel #0 $state(-eventcommand) [list $action $nick] $args } } default { return } } if {![string equal $nick ""]} { # JID, Label, Status update only for non-empty nicknames, # otherwise it's a presence from the room itself, and it may # contain only auxiliary info like vcard-temp:x:update # (see https://chiselapp.com/user/sgolovan/repository/tkabber/tktview?name=f350ab6c7d # for details) uplevel #0 $state(-rostercommand) \ [list $from $nick $status \ -affiliation [affiliation $token $nick] \ -role [role $token $nick]] } return } # ::xmpp::muc::CallBack -- proc ::xmpp::muc::CallBack {commands status msg} { if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $msg] } return } # ::xmpp::muc::AttrChanged -- proc ::xmpp::muc::AttrChanged {token nick attr value} { variable $token upvar 0 $token state if {![string equal $value ""] && \ (![info exists state($attr,$nick)] || \ ![string equal $value $state($attr,$nick)])} { return 1 } else { return 0 } } # ::xmpp::muc::ProcessMUCUser -- proc ::xmpp::muc::ProcessMUCUser {token nick type xmlElements} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return foreach element $xmlElements { ::xmpp::xml::split $element tag xmlns attrs cdata subels switch -- $tag { item { switch -- $type { available { set args {} set callback 0 set jid [::xmpp::xml::getAttr $attrs jid] if {![string equal $jid ""]} { lappend args -jid $jid set state(jid,$nick) $jid } set affiliation \ [::xmpp::xml::getAttr $attrs affiliation] if {[AttrChanged $token $nick affiliation \ $affiliation]} { lappend args -affiliation $affiliation set state(affiliation,$nick) $affiliation set callback 1 } set role [::xmpp::xml::getAttr $attrs role] if {[AttrChanged $token $nick role $role]} { lappend args -role $role set state(role,$nick) $role set callback 1 } if {$callback && \ [lsearch -exact $state(users) $nick] >= 0} { uplevel #0 $state(-eventcommand) \ [list position $nick] $args } } unavailable { set new_nick [::xmpp::xml::getAttr $attrs nick] foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs \ scdata ssubels switch -- $stag { reason { set reason $scdata } actor { set actor \ [::xmpp::xml::getAttr $sattrs jid] } } } } } } destroy { set args {} foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { reason { lappend args -reason $scdata } } } set altjid [::xmpp::xml::getAttr $attrs jid] if {![string equal $altjid ""]} { lappend args -jid $altjid } uplevel #0 $state(-eventcommand) [list destroy $nick] $args } } } foreach element $xmlElements { ::xmpp::xml::split $element tag xmlns attrs cdata subels switch -- $tag { status { set code [::xmpp::xml::getAttr $attrs code] switch -- $code/$type { 110/available - 210/available { # 110: This present packet is our own # 210: The service has changed our nickname set state(nick) $nick switch -- $state(status) { connecting { catch {unset state(id)} set state(status) connected set commands $state(commands) set state(commands) {} CallBack $commands ok $nick } } } } } } } foreach element $xmlElements { ::xmpp::xml::split $element tag xmlns attrs cdata subels switch -- $tag { status { set code [::xmpp::xml::getAttr $attrs code] switch -- $code { 201 { uplevel #0 $state(-eventcommand) [list create $nick] } 301 - 307 - 321 - 322 { set args {} # 301: ban, 307: kick, 321: loosing membership # 322: room becomes members-only set RealJID [realJid $token $nick] if {![string equal $RealJID ""]} { lappend args -jid $RealJID } switch -- $code { 301 {set action ban} 307 {set action kick} 321 {set action demember} 322 {set action members-only} } if {[info exists actor] && ![string equal $actor ""]} { lappend args -actor $actor } if {[info exists reason] && \ ![string equal $reason ""]} { lappend args -reason $reason } uplevel #0 $state(-eventcommand) \ [list $action $nick] $args set state(ignore_unavailable) $nick } 303 { # 303: nickname change if {[info exists new_nick] && $new_nick != ""} { if {[string equal $nick $state(nick)]} { # It's our nickname change catch {unset state(id)} set state(nick) $new_nick set commands $state(commands) set state(commands) {} CallBack $commands ok $new_nick } set args [list -nick $new_nick] set RealJID [realJid $token $nick] if {![string equal $RealJID ""]} { lappend args -jid $RealJID } set state(ignore_available) $new_nick set state(nick_args) [linsert $args 0 $nick] set state(ignore_unavailable) $nick } } } } } } } # ::xmpp::muc::Noop -- proc ::xmpp::muc::Noop {args} { return } # ::xmpp::muc::realJid -- proc ::xmpp::muc::realJid {token nick} { UserAttr $token jid $nick } # ::xmpp::muc::affiliation -- proc ::xmpp::muc::affiliation {token nick} { UserAttr $token affiliation $nick } # ::xmpp::muc::role -- proc ::xmpp::muc::role {token nick} { UserAttr $token role $nick } # ::xmpp::muc::UserAttr -- proc ::xmpp::muc::UserAttr {token attr nick} { variable $token upvar 0 $token state if {[info exists state($attr,$nick)]} { return $state($attr,$nick) } else { return "" } } # ::xmpp::muc::nick -- proc ::xmpp::muc::nick {token} { Attr $token nick } # ::xmpp::muc::status -- proc ::xmpp::muc::status {token} { Attr $token status } # ::xmpp::muc::roster -- proc ::xmpp::muc::roster {token} { Attr $token users } # ::xmpp::muc::Attr -- proc ::xmpp::muc::Attr {token attr} { variable $token upvar 0 $token state return $state($attr) } # ::xmpp::muc::setAffiliation -- proc ::xmpp::muc::setAffiliation {xlib room affiliation args} { eval [list SetAttr $xlib $room affiliation $affiliation] $args } # ::xmpp::muc::setRole -- proc ::xmpp::muc::setRole {xlib room role args} { eval [list SetAttr $xlib $room role $role] $args } # ::xmpp::muc::SetAttr -- proc ::xmpp::muc::SetAttr {xlib room attr value args} { set commands {} foreach {key val} $args { switch -- $key { -nick { set nick $val } -jid { set jid $val } -reason { set reason $val } -command { set commands [list $val] } } } if {[info exists reason]} { set subels [list [::xmpp::xml::create reason -cdata $reason]] } else { set subels {} } if {[info exists nick]} { set attrs [list nick $nick $attr $value] } elseif {[info exists jid]} { set attrs [list jid $jid $attr $value] } else { return -code error \ [::msgcat::mc "Option \"-nick\" or \"-jid\" must be specified"] } set item [::xmpp::xml::create item \ -attrs $attrs \ -subelements $subels] ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create query \ -xmlns "http://jabber.org/protocol/muc#admin" \ -subelement $item] \ -to $room \ -command [namespace code [list CallBack $commands]] } # ::xmpp::muc::CompareAffiliations -- proc ::xmpp::muc::CompareAffiliations {affiliation1 affiliation2} { set affiliations {outcast none member admin owner} set idx1 [lsearch -exact $affiliations $affiliation1] set idx2 [lsearch -exact $affiliations $affiliation2] expr {$idx1 - $idx2} } # ::xmpp::muc::CompareRoles -- proc ::xmpp::muc::CompareRoles {role1 role2} { set roles {none visitor participant moderator} set idx1 [lsearch -exact $roles $role1] set idx2 [lsearch -exact $roles $role2] expr {$idx1 - $idx2} } # ::xmpp::muc::raiseAffiliation -- proc ::xmpp::muc::raiseAffiliation {token nick value args} { eval [list RaiseOrLowerAttr $token $nick affiliation $value 1] $args } # ::xmpp::muc::raiseRole -- proc ::xmpp::muc::raiseRole {token nick value args} { eval [list RaiseOrLowerAttr $token $nick role $value 1] $args } # ::xmpp::muc::lowerAffiliation -- proc ::xmpp::muc::lowerAffiliation {token nick value args} { eval [list RaiseOrLowerAttr $token $nick affiliation $value -1] $args } # ::xmpp::muc::lowerRole -- proc ::xmpp::muc::lowerRole {token nick value args} { eval [list RaiseOrLowerAttr $token $nick role $value -1] $args } # ::xmpp::muc::RaiseOrLowerAttr -- proc ::xmpp::muc::RaiseOrLowerAttr {token nick attr value dir args} { variable $token upvar 0 $token state set commands {} foreach {key val} $args { switch -- $key { -reason { set reason $val } -command { set commands [list $val] } } } if {![info exists state(xlib)]} { CallBack $commands error \ [::xmpp::xml::create error \ -cdata [::msgcat::mc "MUC token doesn't exist"]] return } set xlib $state(xlib) set room $state(room) switch -- $state(status) { disconnected { CallBack $commands error \ [::xmpp::xml::create error \ -cdata [::msgcat::mc "Must join room first"]] return } } switch -- $attr { affiliation { set value0 [affiliation $token $nick] set diff [CompareAffiliations $value0 $value] } role { set value0 [role $token $nick] set diff [CompareRoles $value0 $value] } } if {($dir > 0 && $diff >= 0) || ($dir < 0 && $diff <= 0)} { CallBack $commands error \ [::xmpp::xml::create error \ -cdata [::msgcat::mc "User already %s" $value0]] return } set attrs [list -nick $nick] switch -- $attr/$value { affiliation/outcast { # Banning request MUST be based on user's bare JID (which though # may be not known by admin) set RealJID [realJid $token $nick] if {![string equal $RealJID ""]} { set attrs [list -jid [::xmpp::jid::removeResource $RealJID]] } } } eval [list SetAttr $xlib $room $attr $value] $attrs $args } # ::xmpp::muc::requestAffiliations -- proc ::xmpp::muc::requestAffiliations {xlib room value args} { eval [list RequestList $xlib $room affiliation $value] $args } # ::xmpp::muc::requestRoles -- proc ::xmpp::muc::requestRoles {xlib room value args} { eval [list RequestList $xlib $room role $value] $args } # ::xmpp::muc::RequestList -- proc ::xmpp::muc::RequestList {xlib room attr value args} { set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create query \ -xmlns "http://jabber.org/protocol/muc#admin" \ -subelement [::xmpp::xml::create item \ -attrs [list $attr $value]]] \ -to $room \ -command [namespace code [list ParseRequestList $commands $attr]] } # ::xmpp::muc::ParseRequestList -- proc ::xmpp::muc::ParseRequestList {commands attr status xml} { if {![string equal $status ok]} { CallBack $commands $status $xml return } ::xmpp::xml::split $xml tag xmlns attrs cdata subels set items {} foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { item { set nick [::xmpp::xml::getAttr $sattrs nick] set jid [::xmpp::xml::getAttr $sattrs jid] switch -- $attr { affiliation { set attribute \ [::xmpp::xml::getAttr $sattrs affiliation] } role { set attribute [::xmpp::xml::getAttr $sattrs role] } } set reason "" foreach ssubel $ssubels { ::xmpp::xml::split $ssubel sstag ssxmlns ssattrs \ sscdata sssubels switch -- $sstag { reason { set reason $sscdata } } } lappend items [list $nick $jid $attribute $reason] } } } CallBack $commands ok $items return } # ::xmpp::muc::sendAffiliations -- proc ::xmpp::muc::sendAffiliations {xlib room items args} { eval [list SendList $xlib $room affiliation $items] $args } # ::xmpp::muc::sendRoles -- proc ::xmpp::muc::sendRoles {xlib room items args} { eval [list SendList $xlib $room role $items] $args } # ::xmpp::muc::SendList -- proc ::xmpp::muc::SendList {xlib room attr items args} { set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } set subels {} foreach item $items { foreach {nick jid attribute reason} $item break if {[string equal $nick ""] && [string equal $jid ""]} continue set attrs [list $attr $attribute] if {![string equal $nick ""]} { lappend attrs nick $nick } if {![string equal $jid ""]} { lappend attrs jid $jid } if {![string equal $reason ""]} { set ssubels [list [::xmpp::xml::create reason -cdata $reason]] } else { set ssubels {} } lappend subels [::xmpp::xml::create item \ -attrs $attrs \ -subelements $ssubels] } ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create query \ -xmlns "http://jabber.org/protocol/muc#admin" \ -subelements $subels] \ -to $room \ -command [namespace code [list CallBack $commands]] } # ::xmpp::muc::unsetOutcast -- proc ::xmpp::muc::unsetOutcast {xlib room jid args} { set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } RequestList $xlib $room affiliation outcast \ -command [namespace code [list ParseOutcastList \ $xlib $room $jid $commands]] } # ::xmpp::muc::ParseOutcastList -- proc ::xmpp::muc::ParseOutcastList {xlib room jid commands status items} { if {![string equal $status ok]} { CallBack $commands $status $items return } set bjid [xmpp::jid::normalize [::xmpp::jid::removeResource $jid]] set found 0 foreach item $items { foreach {nick jid affiliation reason} $item break if {[string equal $jid $bjid]} { set found 1 break } } if {!$found} { CallBack $commands error \ [::xmpp::xml::create error \ -cdata [::msgcat::mc "User is not banned"]] return } set item [::xmpp::xml::create item \ -attrs [list jid $bjid affiliation none]] ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create query \ -xmlns "http://jabber.org/protocol/muc#admin" \ -subelement $item] \ -to $room \ -command [namespace code [list CallBack $commands]] } # ::xmpp::muc::destroy -- proc ::xmpp::muc::destroy {xlib room args} { set commands {} foreach {key val} $args { switch -- $key { -jid { set jid $val } -reason { set reason $val } -command { set commands [list $val] } } } if {[info exists jid]} { set attrs [list jid $jid] } else { set attrs {} } if {[info exists reason]} { set subels [list [::xmpp::xml::create reason -cdata $reason]] } else { set subels {} } ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create query \ -xmlns "http://jabber.org/protocol/muc#owner" \ -subelement [::xmpp::xml::create destroy \ -attrs $attrs \ -subelements $subels]] \ -to $room \ -command [namespace code [list CallBack $commands]] } # vim:ft=tcl:ts=8:sw=4:sts=4:et tclxmpp/xmpp/negotiate.tcl000064400000000000000000000142421470446212700156020ustar00nobodynobody# negotiate.tcl -- # # This file is a part of the XMPP library. It implements support for # feature negotiation (XEP-0020). # # Copyright (c) 2008-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp package provide xmpp::negotiate 0.1 namespace eval ::xmpp::negotiate { ::xmpp::iq::register get feature http://jabber.org/protocol/feature-neg \ ::xmpp::negotiate::ParseQuery } # ::xmpp::negotiate::register -- proc ::xmpp::negotiate::register {feature command} { variable CallBack set CallBack($feature) $command } # ::xmpp::negotiate::unregister -- proc ::xmpp::negotiate::unregister {feature} { variable CallBack catch {unset CallBack($feature)} } # ::xmpp::negotiate::sendOptions -- proc ::xmpp::negotiate::sendOptions {xlib to feature options args} { set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } set opts {} foreach o $options { lappend opts "" $o } set fields [::xmpp::data::formField field -var $feature \ -type list-single \ -options $opts] ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create feature \ -xmlns http://jabber.org/protocol/feature-neg \ -subelement [::xmpp::data::form $fields]] \ -to $to \ -command [namespace code [list RecvOptionsResponse $xlib $to $commands]] } # ::xmpp::negotiate::RecvOptionsResponse -- proc ::xmpp::negotiate::RecvOptionsResponse {xlib jid commands status xml} { if {[llength $commands] == 0} { return } if {![string equal $status ok]} { uplevel #0 [lindex $commands 0] [list $status $xml] return } ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach {type form} [::xmpp::data::findForm $subels] break set fields [::xmpp::data::parseSubmit $form] uplevel #0 [lindex $commands 0] [list ok $fields] return } # ::xmpp::negotiate::sendRequest -- proc ::xmpp::negotiate::sendRequest {xlib to feature args} { set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } set fields [list $feature {}] ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create feature \ -xmlns http://jabber.org/protocol/feature-neg \ -subelement [::xmpp::data::submitForm $fields]] \ -to $to \ -command [namespace code [list RecvRequestResponse $xlib $to $commands]] } # ::xmpp::negotiate::RecvRequestResponse -- proc ::xmpp::negotiate::RecvRequestResponse {xlib jid commands status xml} { if {[llength $commands] == 0} { return } if {![string equal $status ok]} { uplevel #0 [lindex $commands 0] [list $status $xml] return } ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach {type form} [::xmpp::data::findForm $subels] break set fields [::xmpp::data::parseForm $form] uplevel #0 [lindex $commands 0] [list ok $fields] return } # ::xmpp::negotiate::ParseQuery -- proc ::xmpp::negotiate::ParseQuery {xlib from xml args} { variable CallBack ::xmpp::xml::split $xml tag xmlns attrs cdata subels set lang [::xmpp::xml::getAttr $args -lang en] foreach {type form} [::xmpp::data::findForm $subels] break switch -- $type { form { # Options offer set sfields {} set fields [::xmpp::data::parseForm $form] foreach {tag item} $fields { if {![string equal $tag field]} continue foreach {var type label desc required options values} $item { break } switch -- $type { hidden { lappend sfields $var $values } default { if {![info exists CallBack($var)]} continue set vals [eval $CallBack($var) \ [list $xlib $from $options] $args] if {[llength $vals] > 0} { lappend sfields $var $vals } } } } if {[llength $sfields] > 0} { return [list result \ [::xmpp::xml::create feature \ -xmlns \ http://jabber.org/protocol/feature-neg \ -subelement \ [::xmpp::data::submitForm $sfields]]] } } submit { # Options request set sfields {} set fields [::xmpp::data::parseSubmit $form] foreach {tag item} $fields { if {![string equal $tag field]} continue foreach {var type label values} $item break if {![info exists CallBack($var)]} continue set opts [eval $CallBack($var) [list $xlib $from {}] $args] if {[llength $opts] == 0} continue set oopts {} foreach o $opts { lappend oopts "" $o } lappend sfields [::xmpp::data::formField field \ -var $var \ -options $oopts] } if {[llength $sfields] > 0} { return [list result \ [::xmpp::xml::create feature \ -xmlns \ http://jabber.org/protocol/feature-neg \ -subelement [::xmpp::data::form $sfields]]] } } } return [list error cancel feature-not-implemented] } # vim:ft=tcl:ts=8:sw=4:sts=4:et tclxmpp/xmpp/pconnect.tcl000064400000000000000000000305551470446212700154410ustar00nobodynobody# pconnect.tcl --- # # Interface to socks4/5 or https to make usage of 'socket' transparent. # Can also be used as a wrapper for the 'socket' command without any # proxy configured. # # Copyright (c) 2008-2012 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require msgcat package provide pconnect 0.1 namespace eval ::pconnect { variable packs array set packs {} namespace export register proxies socket abort } # ::pconnect::register -- # # Register proxy for connecting using pconnect::socket. # # Arguments: # proxy the proxy identificator (socks4, socks5, https, # whatever) # connectCmd the command to call when connecting through proxy # abortCmd the command to call when aborting connection (before # connection succeded) # # Result: # An empty string. # # Side effects: # Proxy $proxy is registered and can be used in pconnect::socket calls. proc ::pconnect::register {proxy connectCmd abortCmd} { variable packs set packs($proxy) [list $connectCmd $abortCmd] return } # ::pconnect::proxies -- # # Return a registered proxies list (excluding an empty proxy, which is # assumed to be always available). # # Arguments: # None. # # Result: # A list of registered proxiy identificators (alphabetically sorted). # # Side effects: # None. proc ::pconnect::proxies {} { variable packs return [lsort [array names packs]] } # ::pconnect::socket -- # # Client side socket through a proxy. # # Arguments: # host the peer address, not SOCKS server # port the peer's port number # args # -proxyfilter A callback which takes host and port as its arguments # and returns a proxy to connect in form of a list # {type host port username password}. This option takes # precedence over -proxy, -host, -port, -usermname, and # -password options # -proxy "" (default) | socks4 | socks5 | https # -host proxy hostname (required if -proxy isn't "") # -port port number (required if -proxy isn't "") # -username user ID # -password password # -useragent user agent (for HTTP proxies) # -command tclProc {token status} # the 'status' is any of: ok, error, abort # Results: # A socket if -command is not specified or a token to make # possible to interrupt timed out connect. proc ::pconnect::socket {host port args} { variable packs array set Args {-proxyfilter "" -proxy "" -host "" -port "" -username "" -password "" -useragent "" -timeout 0 -command ""} array set Args $args set proxyfilter $Args(-proxyfilter) if {[string length $proxyfilter] > 0 && \ ![catch {eval $proxyfilter $host $port} answer]} { array set Args [list -proxy [lindex $answer 0] \ -host [lindex $answer 1] \ -port [lindex $answer 2] \ -username [lindex $answer 3] \ -password [lindex $answer 4]] } set proxy $Args(-proxy) if {[string length $proxy] > 0 && ![info exists packs($proxy)]} { return -code error [::msgcat::mc "Unsupported proxy \"%s\"" $proxy] } if {[string length $proxy] > 0} { if {[string length $Args(-host)] > 0 && \ [string length $Args(-port)] > 0} { set ahost $Args(-host) set aport $Args(-port) } else { return -code error [::msgcat::mc "Options \"-host\" and \"-port\"\ are required (or your proxy filter\ hasn't returned them)"] } } else { set ahost $host set aport $port } set sock [::socket -async $ahost $aport] set token [namespace current]::$sock fconfigure $sock -blocking 0 fileevent $sock writable [namespace code [list Writable $token \ $ahost $aport]] variable $token upvar 0 $token state array set state [array get Args] set state(ahost) $ahost set state(aport) $aport set state(host) $host set state(port) $port set state(sock) $sock # Setup timeout timer. if {$state(-timeout) > 0} { set state(timeoutid) \ [after $state(-timeout) [namespace code [list Timeout $token]]] } if {![string equal $state(-command) ""]} { return $token } else { vwait $token\(status) set status $state(status) set sock $state(sock) Free $token if {[string equal $status ok]} { return $sock } else { catch {close $sock} if {[string equal $status abort]} { return -code break $sock } else { return -code error $sock } } } } # ::pconnect::abort -- # # Abort connection which is in progress. If a connection is already # established or failed then return error. # # Arguments: # token A control token which is returned by pconnect::socket # # Result: # An empty string or error. # # Side effects: # A connection which is establising currently is aborted. If a callback # procedure was supplied then it is called with error. proc ::pconnect::abort {token} { variable packs variable $token upvar 0 $token state if {![info exists $token]} { return -code error "Connection either established or failed already" } set proxy $state(-proxy) if {[info exists state(ptoken)]} { uplevel #0 [lindex $packs($proxy) 1] [list $state(ptoken)] } else { if {[string length $proxy] > 0} { Finish $token abort [::msgcat::mc "Connection via proxy aborted"] } else { Finish $token abort [::msgcat::mc "Connection aborted"] } } return } # ::pconnect::Writable -- # # A helper procedure which checks if the connection is established and # if it is a connection to a proxy then call a corresponding connect # routine. This procedure is called when an opened socket becomes # writable. # # Arguments: # token A control token which is returned by pconnect::socket # # Result: # An empty string. # # Side effects: # None. proc ::pconnect::Writable {token ahost aport} { variable packs variable $token upvar 0 $token state set proxy $state(-proxy) set sock $state(sock) fileevent $sock writable {} if {[catch {fconfigure $sock -peername}]} { if {[string length $proxy] > 0} { Finish $token error [::msgcat::mc "Cannot connect to proxy %s:%s" \ $ahost $aport] return } else { Finish $token error [::msgcat::mc "Cannot connect to %s:%s" \ $ahost $aport] return } } else { if {[string length $proxy] > 0} { set state(ptoken) \ [uplevel #0 [lindex $packs($proxy) 0] \ [list $sock $state(host) $state(port) \ -command [namespace code [list ProxyCallback \ $token]]] \ [GetOpts $token]] return } else { Finish $token ok return } } return } # ::pconnect::GetOpts -- # # A helper procedure which returns additional options to pass them to # proxy connect command. # # Arguments: # token A control token which is returned by pconnect::socket # # Result: # A list of options -username, -password, -useragent which were supplied # to pconnect::socket earlier. # # Side effects: # None. proc ::pconnect::GetOpts {token} { variable $token upvar 0 $token state set opts {} if {[string length $state(-username)] > 0} { lappend opts -username $state(-username) } if {[string length $state(-password)] > 0} { lappend opts -password $state(-password) } if {[string length $state(-useragent)] > 0} { lappend opts -useragent $state(-useragent) } return $opts } # ::pconnect::ProxyCallback -- # # A helper procedure which is called as a callback by a proxy connect # procedure. # # Arguments: # token A control token which is returned by pconnect::socket # status Proxy connect status (ok or error) # sock A new TCP socket if $status equals ok or an error message # if $status equals error # # Result: # An empty string. # # Side effects: # A socket in state array is updated and connection procedure is finished # (either with ok or error status). proc ::pconnect::ProxyCallback {token status sock} { variable $token upvar 0 $token state if {[string equal $status ok]} { set state(sock) $sock Finish $token ok return } else { # If $status equals to error or abort then $sock contains error message Finish $token $status $sock return } return } # ::pconnect::Timeout -- # # Abort connection which is in progress with a timeout. # # Arguments: # token A control token which is returned by pconnect::socket # # Result: # An empty string or error. # # Side effects: # A connection which is establising currently is aborted. If a callback # procedure was supplied then it is called with error. proc ::pconnect::Timeout {token} { variable packs variable $token upvar 0 $token state set proxy $state(-proxy) if {[info exists state(ptoken)]} { uplevel #0 [lindex $packs($proxy) 1] [list $state(ptoken)] } else { if {[string length $proxy] > 0} { Finish $token timeout [::msgcat::mc "Connection via proxy timed out"] } else { Finish $token timeout [::msgcat::mc "Connection timed out"] } } return } # ::pconnect::Free -- # # Frees a connection token. # # Arguments: # token A connection token. # # Result: # An empty string. # # Side effects: # A connection token and its state informationa are destroyed. proc ::pconnect::Free {token} { variable $token upvar 0 $token state catch {after cancel $state(timeoutid)} catch {unset state} return } # ::pconnect::Finish -- # # A helper procedure which cleans up state and calls a callback command # (or sets traced status variable to return back to pconnect::socket). # # Arguments: # token A control token which is returned by pconnect::socket # status A connection status (ok, error, or abort). # errormsg An error message (is used if status is not ok). # # Result: # An empty string. # # Side effects: # If -command option was supplied to pconnect::socket then $token state # variable is destroyed and callback is invoked. Otherwise status # variable is set making vwaiting pconnect::socket continue. proc ::pconnect::Finish {token status {errormsg ""}} { variable $token upvar 0 $token state catch {after cancel $state(timeoutid)} if {[string length $state(-command)]} { set sock $state(sock) set cmd $state(-command) Free $token if {[string equal $status ok]} { uplevel #0 $cmd [list ok $sock] } else { catch {close $sock} uplevel #0 $cmd [list $status $errormsg] } } else { # Setting state(status) returns control to pconnect::socket if {[string equal $status ok]} { set state(status) ok } else { catch {close $state(sock)} set state(sock) $errormsg set state(status) $status } } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/pep.tcl000064400000000000000000000062261470446212700144120ustar00nobodynobody# pep.tcl -- # # This file is part of the XMPP library. It implements interface to # Personal Eventing Protocol (XEP-0163). # # Copyright (c) 2009-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp::pubsub package provide xmpp::pep 0.1 namespace eval ::xmpp::pep {} # # # PEP Creating a node (5) # -access_model (open, presence (default), roster, whitelist) # -roster_groups_allowed (roster group list if access is roster) proc ::xmpp::pep::createNode {xlib node args} { if {[string equal $node ""]} { return -code error "Node must not be empty" } set service [::xmpp::jid::stripResource [::xmpp::Set $xlib jid]] eval [list ::xmpp::pubsub::createNode $xlib $service $node] $args } # PEP Deleting a node proc ::xmpp::pep::deleteNode {xlib node args} { if {[string equal $node ""]} { return -code error "Node must not be empty" } set service [::xmpp::jid::stripResource [::xmpp::Set $xlib jid]] eval [list ::xmpp::pubsub::deleteNode $xlib $service $node] $args } # # # Publish item to PEP node "node" (8) # payload is a list of xml tags # node must not be empty # itemid may be empty proc ::xmpp::pep::publishItem {xlib node itemid args} { if {[string equal $node ""]} { return -code error "Node must not be empty" } set service [::xmpp::jid::stripResource [::xmpp::Set $xlib jid]] eval [list ::xmpp::pubsub::publishItem $xlib $service $node $itemid] $args } # # # Delete item from PEP node "node" # node must not be empty # itemid must not be empty proc ::xmpp::pep::deleteItem {xlib node itemid args} { if {[string equal $node ""]} { return -code error "Node must not be empty" } if {[string equal $itemid ""]} { return -code error "Item ID must not be empty" } set service [::xmpp::jid::stripResource [::xmpp::Set $xlib jid]] eval [list ::xmpp::pubsub::deleteItem $xlib $service $node $itemid] $args } # # # Subscribe to PEP node "node" at bare JID "to" (5.2) # node must not be empty # # -jid "jid" is optional (when it's present it's included to sub request) # # -resource "res" is optional (when it's present bare_jid/res is included # to sub request # # if both options are absent then user's bare JID is included to sub # request proc ::xmpp::pep::subscribe {xlib to node args} { if {[string equal $node ""]} { return -code error "Node must not be empty" } eval [list ::xmpp::pubsub::subscribe $xlib $to $node] $args } # # # Unsubscribe from PEP node "node" at bare JID "to" (undocumented?!) # node must not be empty # # -jid "jid" is optional (when it's present it's included to sub request) # # -resource "res" is optional (when it's present bare_jid/res is included # to sub request # # if both options are absent then user's bare JID is included to sub # request proc ::xmpp::pep::unsubscribe {xlib to node args} { if {[string equal $node ""]} { return -code error "Node must not be empty" } eval [list ::xmpp::pubsub::unsubscribe $xlib $to $node] $args } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/ping.tcl000064400000000000000000000120761470446212700145630ustar00nobodynobody# ping.tcl -- # # This file is part of the XMPP library. It implements interface to # XMPP Ping (XEP-0199) # # Copyright (c) 2009-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package provide xmpp::ping 0.1 namespace eval ::xmpp::ping { namespace export ping register unregister } # ::xmpp::ping::ping -- # # Send XMPP ping IQ request to a specified JID. # # Arguments: # xlib XMPP token. # -to jid (optional) JID to send ping request. If empty then # the request is sent without 'to' attribute which # means sending to own bare JID. # -timeout msecs (optional) Timeout in milliseconds of waiting for # answer. # -command cmd (optional) Command to call back on receiving reply. # # Result: # ID of outgoing IQ. # # Side effects: # A ping packet is sent over the XMPP connection $xlib. proc ::xmpp::ping::ping {xlib args} { set commands {} set newArgs {} foreach {key val} $args { switch -- $key { -to { lappend newArgs -to $val } -timeout { lappend newArgs -timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } eval [list ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create ping -xmlns urn:xmpp:ping] \ -command [namespace code [list ParseAnswer $commands]]] \ $newArgs } # ::xmpp::ping::ParseAnswer -- # # A helper procedure which is called upon XMPP ping answer is received. # It calls back the status and error message if any. # # Arguments: # commands A list of callbacks to call (only the first of them # is invoked. Status and error stanza are appended to # the called command. # status Ping request status (ok, error, abort, timeout). # xml Error message or result. # # Result: # Empty string. # # Side effects: # A callback is called if their list isn't empty. proc ::xmpp::ping::ParseAnswer {commands status xml} { if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } return } # ::xmpp::ping::register -- # # Register handler to answer XMPP ping IQ requests. # # Arguments: # -command cmd (optional) Command to call when ping request is # arrived. The result of the command is sent back. # It must be either {result {}}, or {error type condition}, # or empty string if the application will reply to the # request separately. # The command's arguments are xlib, from, xml, and # optional parameters -to, -id, -lang. # # Result: # Empty string. # # Side effects: # XMPP ping callback is registered. proc ::xmpp::ping::register {args} { set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } ::xmpp::iq::register get ping urn:xmpp:ping \ [namespace code [list ParseRequest $commands]] return } # ::xmpp::ping::ParseRequest -- # # A helper procedure which is called on any incoming XMPP ping request. # It either calls a command specified during registration or simply # returns result (if there weren't any command). # # Arguments: # commands A list of commands to call (only the first one # will be invoked). # xlib XMPP token where request was received. # from JID of user who sent the request. # xml Request XML element (in ping requests it is empty). # args optional arguments (-lang, -to, -id). # # Result: # Either {result, {}}, or {error type condition}, or empty string, if # the application desided to reply later. # # Side effects: # Side effects of the called command. proc ::xmpp::ping::ParseRequest {commands xlib from xml args} { if {[llength $commands] > 0} { return [uplevel #0 [lindex $commands 0] [list $xlib $from] $args] } else { return [list result {}] } } # ::xmpp::ping::unregister -- # # Unregister handler which used to answer XMPP ping IQ requests. # # Arguments: # None. # # Result: # Empty string. # # Side effects: # XMPP ping callback is registered. proc ::xmpp::ping::unregister {} { ::xmpp::iq::unregister get ping urn:xmpp:ping return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/pkgIndex.tcl000064400000000000000000000123401470446212700153710ustar00nobodynobody# pkgIndex.tcl -- # # This file is part of the XMPP library. It registeres XMPP packages # for Tcl. # # Copyright (c) 2008-2016 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package ifneeded pconnect 0.1 [list source [file join $dir pconnect.tcl]] package ifneeded pconnect::https 0.1 [list source [file join $dir https.tcl]] package ifneeded pconnect::socks4 0.1 [list source [file join $dir socks4.tcl]] package ifneeded pconnect::socks5 0.1 [list source [file join $dir socks5.tcl]] package ifneeded xmpp 0.3 [list source [file join $dir xmpp.tcl]] package ifneeded xmpp::auth 0.2 [list source [file join $dir auth.tcl]] package ifneeded xmpp::bob 0.1 [list source [file join $dir bob.tcl]] package ifneeded xmpp::component 0.2 [list source [file join $dir component.tcl]] package ifneeded xmpp::compress 0.1 [list source [file join $dir compress.tcl]] package ifneeded xmpp::data 0.1 [list source [file join $dir data.tcl]] package ifneeded xmpp::delay 0.1 [list source [file join $dir delay.tcl]] package ifneeded xmpp::disco 0.1 [list source [file join $dir disco.tcl]] package ifneeded xmpp::dns 0.1 [list source [file join $dir dns.tcl]] package ifneeded xmpp::hints 0.1 [list source [file join $dir hints.tcl]] package ifneeded xmpp::iq 0.1 [list source [file join $dir iq.tcl]] package ifneeded xmpp::jid 0.1 [list source [file join $dir jid.tcl]] package ifneeded xmpp::muc 0.1 [list source [file join $dir muc.tcl]] package ifneeded xmpp::negotiate 0.1 [list source [file join $dir negotiate.tcl]] package ifneeded xmpp::pep 0.1 [list source [file join $dir pep.tcl]] package ifneeded xmpp::ping 0.1 [list source [file join $dir ping.tcl]] package ifneeded xmpp::presence 0.1 [list source [file join $dir presence.tcl]] package ifneeded xmpp::privacy 0.1 [list source [file join $dir privacy.tcl]] package ifneeded xmpp::private 0.1 [list source [file join $dir private.tcl]] package ifneeded xmpp::pubsub 0.1 [list source [file join $dir pubsub.tcl]] package ifneeded xmpp::register 0.1 [list source [file join $dir register.tcl]] package ifneeded xmpp::roster 0.2 [list source [file join $dir roster.tcl]] package ifneeded xmpp::roster::annotations 0.1 [list source [file join $dir annotations.tcl]] package ifneeded xmpp::roster::bookmarks 0.1 [list source [file join $dir bookmarks.tcl]] package ifneeded xmpp::roster::delimiter 0.1 [list source [file join $dir delimiter.tcl]] package ifneeded xmpp::roster::metacontacts 0.1 [list source [file join $dir metacontacts.tcl]] package ifneeded xmpp::sasl 0.2 [list source [file join $dir sasl.tcl]] package ifneeded xmpp::search 0.1 [list source [file join $dir search.tcl]] package ifneeded xmpp::sm 0.1 [list source [file join $dir sm.tcl]] package ifneeded xmpp::stanzaerror 0.1 [list source [file join $dir stanzaerror.tcl]] package ifneeded xmpp::starttls 0.1 [list source [file join $dir starttls.tcl]] package ifneeded xmpp::streamerror 0.1 [list source [file join $dir streamerror.tcl]] package ifneeded xmpp::transport 0.2 [list source [file join $dir transport.tcl]] package ifneeded xmpp::transport::bosh 0.2 [list source [file join $dir bosh.tcl]] package ifneeded xmpp::transport::poll 0.2 [list source [file join $dir poll.tcl]] package ifneeded xmpp::transport::tcp 0.2 [list source [file join $dir tcp.tcl]] package ifneeded xmpp::transport::tls 0.2 [list source [file join $dir tls.tcl]] package ifneeded xmpp::transport::zlib 0.2 [list source [file join $dir zlib.tcl]] package ifneeded xmpp::xml 0.1 [list source [file join $dir xml.tcl]] package ifneeded xmpp::full 0.3 { package require pconnect::https 0.1 package require pconnect::socks4 0.1 package require pconnect::socks5 0.1 package require xmpp 0.3 package require xmpp::auth 0.2 package require xmpp::bob 0.1 package require xmpp::component 0.2 package require xmpp::compress 0.1 package require xmpp::delay 0.1 package require xmpp::disco 0.1 package require xmpp::dns 0.1 package require xmpp::hints 0.1 package require xmpp::muc 0.1 package require xmpp::pep 0.1 package require xmpp::ping 0.1 package require xmpp::privacy 0.1 package require xmpp::roster 0.2 package require xmpp::roster::annotations 0.1 package require xmpp::roster::bookmarks 0.1 package require xmpp::roster::delimiter 0.1 package require xmpp::roster::metacontacts 0.1 package require xmpp::sasl 0.2 package require xmpp::starttls 0.1 package require xmpp::transport::bosh 0.2 package require xmpp::transport::poll 0.2 package require xmpp::transport::tls 0.2 package require xmpp::transport::zlib 0.2 package provide xmpp::full 0.2 } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/poll.tcl000064400000000000000000000540761470446212700146020ustar00nobodynobody# poll.tcl -- # # This file is a part of the XMPP library. It implements HTTP-polling. # # Copyright (c) 2008-2015 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require sha1 package require http 2 package require xmpp::transport 0.2 package require xmpp::xml package provide xmpp::transport::poll 0.2 namespace eval ::xmpp::transport::poll { namespace export open abort close reset flush ip outXML outText \ openStream closeStream ::xmpp::transport::register poll \ -opencommand [namespace code open] \ -abortcommand [namespace code abort] \ -closecommand [namespace code close] \ -resetcommand [namespace code reset] \ -flushcommand [namespace code flush] \ -ipcommand [namespace code ip] \ -outxmlcommand [namespace code outXML] \ -outtextcommand [namespace code outText] \ -openstreamcommand [namespace code openStream] \ -reopenstreamcommand [namespace code openStream] \ -closestreamcommand [namespace code closeStream] if {![catch { package require tls 1.4 }]} { ::http::register https 443 [namespace code sock] } variable debug 0 } # ::xmpp::transport::poll::sock -- # # Wrapper over the tls::socket command which provides sane defaults. # # Arguments: # options Options for tls::socket # host Host to connect to. # port Port to connect to. # # Result: # A channel with performed TLS handshake. # # Side effects: # A new socket is created. proc ::xmpp::transport::poll::sock {args} { if {![catch ::tls::ciphers tls1.1]} { set args [linsert $args 0 -tls1.1 1] } if {![catch ::tls::ciphers tls1.2]} { set args [linsert $args 0 -tls1.2 1] } eval [linsert $args 0 ::tls::socket -ssl2 0 -ssl3 0 -tls1 1] } # ::xmpp::transport::poll::open -- # # Open connection to XMPP server. For HTTP-poll transport this means # "store poll parameters, create XML parser, and return or call back # with success. # # Arguments: # server (ignored, -url option is used) XMPP server # hostname. # port (ignored, -url option is used) XMPP server # port. # -url url (mandatory) HTTP-poll URL to request. # -streamheadercommand cmd Command to call when server stream header # is parsed. # -streamtrailercommand cmd Command to call when server stream trailer # is parsed. # -stanzacommand cmd Command to call when top-level stream # stanza is parsed. # -eofcommand cmd Command to call when server (or proxy) # breaks connection. # -command cmd Command to call upon a successfull or # failed connect (for this transport failing # during connect is impossible). # -timeout timeout Timeout for HTTP queries. # -min min Minimum interval between polls (in # milliseconds). # -max min Maximum interval between polls (in # milliseconds). # -usekeys usekeys (default true) Use poll keys which make # connection more secure. # -numkeys numkeys (default 100) Number of keys in a series. # -host proxyHost Proxy hostname. # -port proxyPort Proxy port. # -username proxyUsername Proxy username. # -password proxyPassword Proxy password. # -useragent proxyUseragent Proxy useragent. # # Result: # Transport token which is to be used for communication with XMPP server. # # Side effects: # A new variable is created where polling options are stored. Also, a new # XML parser is created. proc ::xmpp::transport::poll::open {server port args} { variable id if {![info exists id]} { set id 0 } set token [namespace current]::[incr id] variable $token upvar 0 $token state set state(transport) poll set state(streamHeaderCmd) # set state(streamTrailerCmd) # set state(stanzaCmd) # set state(eofCmd) # set state(-timeout) 0 set state(-min) 10000 set state(-max) 60000 set state(-url) "" set state(-usekeys) 1 set state(-numkeys) 100 foreach {key val} $args { switch -- $key { -streamheadercommand {set state(streamHeaderCmd) $val} -streamtrailercommand {set state(streamTrailerCmd) $val} -stanzacommand {set state(stanzaCmd) $val} -eofcommand {set state(eofCmd) $val} -command {set cmd $val} -timeout - -min - -max - -url - -usekeys - -numkeys {set state($key) $val} -proxyfilter {set proxyFilter $val} -host {set proxyHost $val} -port {set proxyPort $val} -username {set proxyUsername $val} -password {set proxyPassword $val} -useragent {set proxyUseragent $val} } } set state(int) $state(-min) set state(outdata) "" set state(sesskey) 0 set state(id) "" set state(keys) {} set state(proxyAuth) {} set state(wait) disconnected if {[info exists proxyUseragent]} { ::http::config -useragent $proxyUseragent } if {[info exists proxyFilter]} { # URLmatcher is borrowed from http package. set URLmatcher {(?x) # this is _expanded_ syntax ^ (?: (\w+) : ) ? # (?: // (?: ( [^@/\#?]+ # ) @ )? ( [^/:\#?]+ ) # (?: : (\d+) )? # )? ( / [^\#?]* (?: \? [^\#?]* )?)? # (including query) (?: \# (.*) )? # $ } if {[regexp -- $URLmatcher $state(-url) -> \ proto user host port srvurl]} { if {![catch {eval $proxyFilter $host} answer]} { foreach {phost pport proxyUsername proxyPassword} $answer { break } } } ::http::config -proxyfilter $proxyFilter } if {[info exists proxyHost] && [info exists proxyPort]} { ::http::config -proxyhost $proxyHost -proxyport $proxyPort } if {[info exists proxyUsername] && [info exists proxyPassword] && \ !([string equal $proxyUsername ""] && \ [string equal $proxyPassword ""])} { set auth \ [base64::encode \ [encoding convertto $proxyUsername:$proxyPassword]] set state(proxyAuth) [list Proxy-Authorization "Basic $auth"] } if {$state(-usekeys)} { Debug $token 2 "generating keys" set state(keys) [GenKeys $state(-numkeys)] } set state(parser) \ [::xmpp::xml::new \ [namespace code [list InXML $state(streamHeaderCmd)]] \ [namespace code [list InEmpty $state(streamTrailerCmd)]] \ [namespace code [list InXML $state(stanzaCmd)]]] SetWait $token connected if {[info exists cmd]} { # Asynchronous mode is almost synchronous after idle $cmd [list ok $token] } return $token } # ::xmpp::transport::poll::outText -- # # Send text to XMPP server. # # Arguments: # token Transport token. # text Text to send. # # Result: # Empty string. # # Side effects: # Sending text to the server is scheduled. proc ::xmpp::transport::poll::outText {token text} { variable $token upvar 0 $token state if {![info exists state(wait)]} { return -1 } switch -- $state(wait) { disconnected - waiting - disconnecting { # TODO return -1 } default { Poll $token $text } } # TODO return [string bytelength $text] } # ::xmpp::transport::poll::outXML -- # # Send XML element to XMPP server. # # Arguments: # token Transport token. # xml XML to send. # # Result: # Empty string. # # Side effects: # Sending XML to the server is scheduled. proc ::xmpp::transport::poll::outXML {token xml} { return [outText $token [::xmpp::xml::toText $xml]] } # ::xmpp::transport::poll::openStream -- # # Send XMPP stream header to XMPP server. # # Arguments: # token Transport token. # server XMPP server. # args Arguments for [::xmpp::xml::streamHeader]. # # Result: # Empty string. # # Side effects: # Sending string to the server is scheduled. proc ::xmpp::transport::poll::openStream {token server args} { return [outText $token \ [eval [list ::xmpp::xml::streamHeader $server] $args]] } # ::xmpp::transport::poll::closeStream -- # # Send XMPP stream trailer to XMPP server and start disconnecting # procedure. # # Arguments: # token Transport token. # -wait bool (optional, default 0) Wait for the server side to # close stream. # # Result: # Empty string. # # Side effects: # Sending stream trailer to the server is scheduled. proc ::xmpp::transport::poll::closeStream {token args} { variable $token upvar 0 $token state set len [outText $token [::xmpp::xml::streamTrailer]] switch -- $state(wait) { disconnected - waiting {} polling { SetWait $token waiting } default { SetWait $token disconnecting } } set wait 0 foreach {key val} $args { switch -- $key { -wait { set wait $val } } } if {$wait} { while {[info exists state(wait)] && \ ![string equal $state(wait) disconnected]} { vwait $token\(wait) } } return $len } # ::xmpp::transport::poll::flush -- # # Flush XMPP channel. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # Pending data is sent to the server. proc ::xmpp::transport::poll::flush {token} { # TODO } # ::xmpp::transport::poll::ip -- # # Return IP of an outgoing socket. # # Arguments: # token Transport token. # # Result: # Empty string (until really implemented). # # Side effects: # None. proc ::xmpp::transport::poll::ip {token} { variable $token upvar 0 $token state # TODO return "" } # ::xmpp::transport::poll::close -- # # Close XMPP channel. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # Transport token and XML parser are destroyed. proc ::xmpp::transport::poll::close {token} { variable $token upvar 0 $token state if {![info exists state(wait)]} { return } SetWait $token disconnected if {[info exists state(parser)]} { ::xmpp::xml::free $state(parser) } catch {unset state} return } # ::xmpp::transport::poll::reset -- # # Reset XMPP stream. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # XML parser is reset. proc ::xmpp::transport::poll::reset {token} { variable $token upvar 0 $token state ::xmpp::xml::reset $state(parser) return } # ::xmpp::transport::poll::InText -- # # A helper procedure which is called when a new portion of data is # received from XMPP server. It feeds XML parser with this data. # # Arguments: # token Transport token. # text Text to parse. # # Result: # Empty string. # # Side effects: # The text is parsed and if it completes top-level stanza then an # appropriate callback is invoked. proc ::xmpp::transport::poll::InText {token text} { variable $token upvar 0 $token state ::xmpp::xml::parser $state(parser) parse $text return } # ::xmpp::transport::poll::InXML -- # # A helper procedure which is called when a new XML stanza is parsed. # It then calls a specified command as an idle callback. # # Arguments: # cmd Command to call. # xml Stanza to pass to the command. # # Result: # Empty string. # # Side effects: # After entering event loop the specified command is called. proc ::xmpp::transport::poll::InXML {cmd xml} { after idle $cmd [list $xml] return } # ::xmpp::transport::poll::InEmpty -- # # A helper procedure which is called when XMPP stream is finished. # It then calls a specified command as an idle callback. # # Arguments: # cmd Command to call. # # Result: # Empty string. # # Side effects: # After entering event loop the specified command is called. proc ::xmpp::transport::poll::InEmpty {cmd} { after idle $cmd return } # ::xmpp::transport::poll::Poll -- # # Schedule HTTP-polling procedure to output given text. # # Arguments: # token Tranport token. # text Text to output. # # Result: # Empty string. # # Side effects: # If there's no request which is waited for then a new request is sent, # otherwise a new call to [Poll] is scheduled. proc ::xmpp::transport::poll::Poll {token text} { variable $token upvar 0 $token state Debug $token 2 '$text' if {![info exists state(wait)]} { # Trying to poll an already disconnected connection return } append state(outdata) $text switch -- $state(wait) { disconnected { Debug $token 2 DISCONNECTED return } disconnecting { Debug $token 2 DISCONNECTING if {[string equal $state(outdata) ""]} { SetWait $token disconnected return } } waiting - polling { Debug $token 2 RESCHEDULING after cancel $state(id) Debug $token 2 $state(int) set state(id) \ [after $state(int) [namespace code [list Poll $token ""]]] return } } if {$state(-usekeys)} { # regenerate set firstkey [lindex $state(keys) end] set secondkey "" if {[llength $state(keys)] == 1} { Debug $token 2 "regenerating keys" set state(keys) [GenKeys $state(-numkeys)] set secondkey [lindex $state(keys) end] } set l [llength $state(keys)] set state(keys) [lrange $state(keys) 0 end-1] if {[string length $firstkey]} { set firstkey ";$firstkey" } if {[string length $secondkey]} { set secondkey ";$secondkey" } set query "$state(sesskey)$firstkey$secondkey,$state(outdata)" } else { set query "$state(sesskey),$state(outdata)" } switch -- $state(wait) { disconnecting { SetWait $token waiting } default { SetWait $token polling } } Debug $token 2 "query: '$query'" GetURL $token 0 [encoding convertto utf-8 $query] set state(outdata) "" after cancel $state(id) Debug $token 2 $state(int) set state(id) \ [after $state(int) [namespace code [list Poll $token ""]]] return } # ::xmpp::transport::poll::ProcessReply -- # # Process HTTP-poll reply from the XMPP server. # # Arguments: # token Tranport token. # try Number of the previous requests of the same query. # query Query string. # httpToken HTTP token to get server answer. # # Result: # Empty string. # # Side effects: # If query failed then it is retried (not more than thrice), otherwise the # answer is received and pushed to XML parser. proc ::xmpp::transport::poll::ProcessReply {token try query httpToken} { variable $token upvar 0 $token state if {![info exists state(wait)]} { # A reply for an already disconnected connection return } upvar #0 $httpToken httpState if {[::http::ncode $httpToken] != 200} { Debug $token 1 "HTTP returned [::http::ncode $httpToken]\ $httpState(status)" if {$try < 3} { GetURL $token [incr try] $query } else { SetWait $token disconnected InEmpty $state(eofCmd) } ::http::cleanup $httpToken return } Debug $token 2 $httpState(meta) foreach {name value} $httpState(meta) { if {[string equal -nocase $name Set-Cookie] && \ [regexp {^ID=([^;]*);?} $value -> match]} { Debug $token 2 "Set-Cookie: $value -> $match" if {[string match *:0 $match] || [string match *%3A0 $match]} { Debug $token 1 "Cookie Error" SetWait $token disconnected InEmpty $state(eofCmd) ::http::cleanup $httpToken return } set state(sesskey) $match break } } set inmsg [encoding convertfrom utf-8 $httpState(body)] ::http::cleanup $httpToken Debug $token 2 '$inmsg' if {[string length $inmsg] > 5 } { set state(int) [expr {$state(int) / 2}] if {$state(int) < $state(-min)} { set state(int) $state(-min) } } else { set state(int) [expr {$state(int) * 6 / 5}] if {$state(int) > $state(-max)} { set state(int) $state(-max) } } InText $token $inmsg switch -- $state(wait) { waiting { SetWait $token disconnecting } polling { SetWait $token connected } } } # ::xmpp::transport::poll::GetURL -- # # Request HTTP-poll URL. # # Arguments: # token Transport token. # try Number of previous requests of the same query # (sometimes query fails because of proxy errors, so # it's better to try once more). # query Query to send to the server. # # Result: # Empty string. # # Side effects: # HTTP-poll request is sent. proc ::xmpp::transport::poll::GetURL {token try query} { variable $token upvar 0 $token state Debug $token 2 $try # Option -keepalive 1 (which reuse open sockets - a good thing) doesn't # work well if we do multiple requests in parallel (it's required for # multiuser support), so do open a separate socket for every request # (which creates a lot of overhead, but...) ::http::geturl $state(-url) \ -binary 1 \ -keepalive 0 \ -headers $state(proxyAuth) \ -query $query \ -timeout $state(-timeout) \ -command [namespace code [list ProcessReply $token \ $try \ $query]] return } # ::xmpp::transport::poll::SetWait -- # # Set polling state for a given connection (if it exists) and if the # state is "disconnected" then cancel future polling attempts. # # Arguments: # token Tranport token. # opt State name ("polling", "waiting", "connected", # "disconnecting", "disconnected"). # # Result: # Empty string. # # Side effects: # Polling state is changed. If it becomes "disconnected" then the next # polling attempt is canceled. proc ::xmpp::transport::poll::SetWait {token opt} { variable $token upvar 0 $token state if {![info exists state(wait)]} { return } set state(wait) $opt switch -- $opt { disconnected { after cancel $state(id) } } return } # ::xmpp::transport::poll::GenKeys -- # # Generate a sequence of security keys (see XEP-0025 for details). # # Arguments: # numKeys Number of keys to generate. # # Result: # List of keys. # # Side effects: # None. proc ::xmpp::transport::poll::GenKeys {numKeys} { set seed [expr {round(1000000000 * rand())}] set oldKey $seed set keys {} while {$numKeys > 0} { set nextKey [base64::encode [binary format H40 [sha1::sha1 $oldKey]]] # skip the initial seed lappend keys $nextKey set oldKey $nextKey incr numKeys -1 } return $keys } # ::xmpp::transport::poll::Debug -- # # Print debug information. # # Arguments: # token Transport token. # level Debug level. # str Debug message. # # Result: # An empty string. # # Side effects: # A debug message is printed to the console if the value of # ::xmpp::transport::poll::debug variable is not less than num. proc ::xmpp::transport::poll::Debug {token level str} { variable debug if {$debug >= $level} { puts "[lindex [info level -1] 0] $token: $str" } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/presence.tcl000064400000000000000000000140531470446212700154270ustar00nobodynobody# presence.tcl -- # # This file is part of the XMPP library. It implements the presence # processing for high level applications. If you want to use low level # parsing, use -packetCommand option for ::xmpp::new. # # Copyright (c) 2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package provide xmpp::presence 0.1 namespace eval ::xmpp::presence { namespace export register unregister process } # ::xmpp::presence::register -- # # Register presence callback. # # Arguments: # type Presence type to register. Must be one of known # presence types (available, error, probe, subscribe, # subscribed, unavailable, unsubscribe, unsubscribed) # or *. # cmd Command to call when a registered presence is received. # The return value of the command is ignored. # # Result: # Empty string or error if presence type isn't a valid type. # # Side effects: # A presence callback is registered. proc ::xmpp::presence::register {type cmd} { RegisterPresence * * $type $cmd } # ::xmpp::presence::unregister -- # # Unregister presence callback. # # Arguments: # type Presence type to unregister. Must be one of known # presence types (available, error, probe, subscribe, # subscribed, unavailable, unsubscribe, unsubscribed) # or *. # cmd Command to remove from registered commands. # # Result: # Empty string. # # Side effects: # A presence callback is unregistered. proc ::xmpp::presence::unregister {type cmd} { UnregisterPresence * * $type $cmd } # ::xmpp::presence::RegisterPresence -- # # Register presence callback. # # Arguments: # xlib XMPP token pattern. # jid Presence from address. # type Presence type to register. Must be one of known # presence types (available, error, probe, subscribe, # subscribed, unavailable, unsubscribe, unsubscribed) # or *. # cmd Command to call when a registered presence is received. # The return value of the command is ignored. # # Result: # Empty string or error if presence type isn't a valid type. # # Side effects: # A presence callback is registered. proc ::xmpp::presence::RegisterPresence {xlib jid type cmd} { variable PresenceCmd set jid [::xmpp::jid::normalize $jid] switch -- $type { available - error - probe - subscribe - subscribed - unavailable - unsubscribe - unsubscribed - * {} default { return -code error [::msgcat::mc "Illegal presence type \"%s\"" $type] } } if {![info exists PresenceCmd($xlib,$type,$jid)]} { set PresenceCmd($xlib,$type,$jid) {} } if {[lsearch -exact $PresenceCmd($xlib,$type,$jid) $cmd] < 0} { lappend PresenceCmd($xlib,$type,$jid) $cmd } return } # ::xmpp::presence::UnregisterPresence -- # # Unregister presence callback. # # Arguments: # xlib XMPP token pattern. # jid Presence from address. # type Presence type to unregister. Must be one of known # presence types (available, error, probe, subscribe, # subscribed, unavailable, unsubscribe, unsubscribed) # or *. # cmd Command to remove from registered commands. # # Result: # Empty string. # # Side effects: # A presence callback is unregistered. proc ::xmpp::presence::UnregisterPresence {xlib jid type cmd} { variable PresenceCmd set jid [::xmpp::jid::normalize $jid] if {![info exists PresenceCmd($xlib,$type,$jid)]} { return } if {[set idx [lsearch -exact $PresenceCmd($xlib,$type,$jid) $cmd]] >= 0} { set PresenceCmd($xlib,$type,$jid) \ [lreplace $PresenceCmd($xlib,$type,$jid) $idx $idx] if {[llength $PresenceCmd($xlib,$type,$jid)] == 0} { unset PresenceCmd($xlib,$type,$jid) } } return } # ::xmpp::presence::process -- # # Sequentially call all registered presence callbacks. # # Arguments: # xlib XMPP token. # from JID from which the presence is received. # type Presence type. # xmlElements XML elements included into the presence stanza. # The rest of args are optional. # -x xparams {key value} list of unspecified attributes. # -lang lang Stanza language (value of xml:lang attribute). # -to to Value of to attribute. # -id id Value of id attribute # -priority prio Presence priority. # -show show Presence status (chat, away, xa, dnd) # -status status Text status description. # -error xml Error subelement. # # Result: # Empty string. # # Side effects: # Commands corresponding to received presence are called. proc ::xmpp::presence::process {xlib from type xmlElements args} { variable PresenceCmd if {[string equal $type ""]} { set type available } ::xmpp::Debug $xlib 2 "$from $type $xmlElements $args" set jid [::xmpp::jid::normalize $from] set bjid [::xmpp::jid::removeResource $jid] set commands {} foreach xidx [list $xlib *] { foreach tidx [list $type *] { foreach jidx [list $jid $bjid *] { if {[info exists PresenceCmd($xidx,$tidx,$jidx)]} { set commands \ [concat $commands $PresenceCmd($xidx,$tidx,$jidx)] } } } } foreach cmd $commands { ::xmpp::Debug $xlib 2 "calling $cmd" uplevel #0 $cmd [list $from $type $xmlElements] $args } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/privacy.tcl000064400000000000000000000565071470446212700153120ustar00nobodynobody# privacy.tcl -- # # This file is part of the XMPP library. It provides support for the # Privacy Lists (XEP-0016). # # Copyright (c) 2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp package provide xmpp::privacy 0.1 namespace eval ::xmpp::privacy { namespace export register unregister requestLists requestItems sendItems \ setDefault setActive variable answer variable rid if {![info exists rid]} { set rid 0 } } # ::xmpp::privacy::requestLists -- # # Request privacy lists from the user's XMPP server # # Arguments: # xlib XMPP library token # -timeout timeout Return error after the specified timeout (in # milliseconds) # -command command Callback to call on server reply or timeout. It # must accept arguments {ok items} or # {status error_xml} where status is error, abort, or # timeout # # Result: # Sent XMPP IQ id. # # Side effects: # XMPP IQ stanza is sent. proc ::xmpp::privacy::requestLists {xlib args} { set commands {} set timeout 0 foreach {key val} $args { switch -- $key { -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } variable rid set lrid [incr rid] set id \ [::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create query \ -xmlns jabber:iq:privacy] \ -command [namespace code [list ParseListsReply $lrid $commands]] \ -timeout $timeout] if {[llength $commands] > 0} { # Asynchronous mode return $id } else { # Synchronous mode variable answer vwait [namespace current]::answer($lrid) foreach {status msg} $answer($lrid) break unset answer($lrid) switch -- $status { ok { return $msg } error { return -code error $msg } default { return -code break $msg } } } } # ::xmpp::privacy::ParseListsReply -- # # A helper procedure which parses server reply to a privacy lists # request and invokes callback. # # Arguments: # rid A request id (is used in synchronous mode) # commands A list of commands to call (it's either empty or # contains a single element) # status A status of the request (ok, error, abort, or timeout) # xml XML element with either error message or items list # # Result: # An empty string # # Side effects: # A callback is called if specified proc ::xmpp::privacy::ParseListsReply {rid commands status xml} { variable answer if {![string equal $status ok]} { if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } else { set answer($rid) [list $status $xml] } return } ::xmpp::xml::split $xml tag xmlns attrs cdata subels set res(items) {} foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { default { set res(default) [::xmpp::xml::getAttr $sattrs name] } active { set res(active) [::xmpp::xml::getAttr $sattrs name] } list { lappend res(items) [::xmpp::xml::getAttr $sattrs name] } } } if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list ok [array get res]] } else { set answer($rid) [list ok [array get res]] } return } # ::xmpp::privacy::requestItems -- # # Request privacy list with a specified name from the user's XMPP server # # Arguments: # xlib XMPP library token # name Privacy list name # -timeout timeout Return error after the specified timeout (in # milliseconds) # -command command Callback to call on server reply or timeout. It # must accept arguments {ok items} or # {status error_xml} where status is error, abort, or # timeout # # Result: # Sent XMPP IQ id. # # Side effects: # XMPP IQ stanza is sent. proc ::xmpp::privacy::requestItems {xlib name args} { set commands {} set timeout 0 foreach {key val} $args { switch -- $key { -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } variable rid set lrid [incr rid] set id \ [::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create query \ -xmlns jabber:iq:privacy \ -subelement [::xmpp::xml::create list \ -attrs [list name $name]]] \ -command [namespace code [list ParseItemsReply $lrid $commands]] \ -timeout $timeout] if {[llength $commands] > 0} { # Asynchronous mode return $id } else { # Synchronous mode variable answer vwait [namespace current]::answer($lrid) foreach {status msg} $answer($lrid) break unset answer($lrid) switch -- $status { ok { return $msg } error { return -code error $msg } default { return -code break $msg } } } } # ::xmpp::privacy::ParseItemsReply -- # # A helper procedure which parses server reply to a privacy list # request and invokes callback. # # Arguments: # rid A request id (is used in synchronous mode) # commands A list of commands to call (it's either empty or # contains a single element) # status A status of the request (ok, error, abort, or timeout) # xml XML element with either error message or items list # # Result: # An empty string # # Side effects: # A callback is called if specified. In case of success it is called # with ok and ordered items list without order attribute appended proc ::xmpp::privacy::ParseItemsReply {rid commands status xml} { variable answer if {![string equal $status ok]} { if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } else { set answer($rid) [list $status $xml] } return } ::xmpp::xml::split $xml tag xmlns attrs cdata subels set items {} foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { list { foreach ssubel $ssubels { ::xmpp::xml::split $ssubel \ sstag ssxmlns ssattrs sscdata sssubels switch -- $sstag { item { set item {} set order -1 foreach {attr val} $ssattrs { switch -- $attr { order { if {[string is integer -strict $val]} { set order $val } } default { lappend item $attr $val } } } set subitems {} foreach sssubel $sssubels { ::xmpp::xml::split $sssubel \ ssstag sssxmlns sssattrs \ ssscdata ssssubels switch -- $ssstag { message - presence-in - presence-out - iq { lappend subitems $ssstag } } } if {[llength $subitems] > 0} { lappend item stanzas $subitems } if {$order >= 0} { lappend items [list $order $item] } } } } break } } } set res {} foreach oi [lsort -index 0 -integer $items] { lappend res [lindex $oi 1] } if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list ok $res] } else { set answer($rid) [list ok $res] } return } # ::xmpp::privacy::sendItems -- # # Send privacy list items to the user's XMPP server # # Arguments: # xlib XMPP library token # name Privacy list name # items Items to send in format # {{type ... value ... action ... stanzas ...} ...} # -timeout timeout Return error after the specified timeout (in # milliseconds) # -command command Callback to call on server reply or timeout. It # must accept arguments {ok {}} or {status error_xml} # where status is error, abort, or timeout # # Result: # Sent XMPP IQ id. # # Side effects: # XMPP IQ stanza is sent. proc ::xmpp::privacy::sendItems {xlib name items args} { set commands {} set timeout 0 foreach {key val} $args { switch -- $key { -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } set subels {} set order 1 foreach item $items { set attrs {} set stanzas {} foreach {key val} $item { switch -- $key { type - value - action { lappend attrs $key $val } stanzas { foreach tag $val { switch -- $tag { message - presence-in - presence-out - iq { lappend stanzas [::xmpp::xml::create $tag] } } } } } } lappend attrs order $order lappend subels [::xmpp::xml::create item \ -attrs $attrs \ -subelements $stanzas] incr order } variable rid set lrid [incr rid] set id \ [::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create query \ -xmlns jabber:iq:privacy \ -subelement [::xmpp::xml::create list \ -attrs [list name $name] \ -subelements $subels]] \ -command [namespace code [list ParseSendItemsReply $lrid $commands]] \ -timeout $timeout] if {[llength $commands] > 0} { # Asynchronous mode return $id } else { # Synchronous mode variable answer vwait [namespace current]::answer($lrid) foreach {status msg} $answer($lrid) break unset answer($lrid) switch -- $status { ok { return $msg } error { return -code error $msg } default { return -code break $msg } } } } # ::xmpp::privacy::ParseSendItemsReply -- # # A helper procedure which parses server reply to a privacy list # set request and invokes callback. # # Arguments: # rid A request id (is used in synchronous mode) # commands A list of commands to call (it's either empty or # contains a single element) # status A status of the request (ok, error, abort, or timeout) # xml XML element with either error message or items list # # Result: # An empty string # # Side effects: # A callback is called if specified. proc ::xmpp::privacy::ParseSendItemsReply {rid commands status xml} { variable answer if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } else { set answer($rid) [list $status $xml] } return } # ::xmpp::privacy::setDefault -- # # Set default privacy list name. # # Arguments: # xlib XMPP library token # -name name Default privacy list name, if missing then no # default privacy list is set # -timeout timeout Return error after the specified timeout (in # milliseconds) # -command command Callback to call on server reply or timeout. It # must accept arguments {ok {}} or {status error_xml} # where status is error, abort, or timeout # # Result: # Sent XMPP IQ id. # # Side effects: # XMPP IQ stanza is sent. proc ::xmpp::privacy::setDefault {xlib args} { set commands {} set timeout 0 set attrs {} foreach {key val} $args { switch -- $key { -name { set attrs [list name $val] } -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } variable rid set lrid [incr rid] set id \ [::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create query \ -xmlns jabber:iq:privacy \ -subelement [::xmpp::xml::create default \ -attrs $attrs]] \ -command [namespace code [list ParseDefaultReply $lrid $commands]] \ -timeout $timeout] if {[llength $commands] > 0} { # Asynchronous mode return $id } else { # Synchronous mode variable answer vwait [namespace current]::answer($lrid) foreach {status msg} $answer($lrid) break unset answer($lrid) switch -- $status { ok { return $msg } error { return -code error $msg } default { return -code break $msg } } } } # ::xmpp::privacy::ParseDefaultReply -- # # A helper procedure which parses server reply to a default privacy list # set request and invokes callback. # # Arguments: # rid A request id (is used in synchronous mode) # commands A list of commands to call (it's either empty or # contains a single element) # status A status of the request (ok, error, abort, or timeout) # xml XML element with either error message or items list # # Result: # An empty string # # Side effects: # A callback is called if specified. proc ::xmpp::privacy::ParseDefaultReply {rid commands status xml} { variable answer if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } else { set answer($rid) [list $status $xml] } return } # ::xmpp::privacy::setActive -- # # Set active privacy list name. # # Arguments: # xlib XMPP library token # -name name Active privacy list name, if missing then no # active privacy list is set # -timeout timeout Return error after the specified timeout (in # milliseconds) # -command command Callback to call on server reply or timeout. It # must accept arguments {ok {}} or {status error_xml} # where status is error, abort, or timeout # # Result: # Sent XMPP IQ id. # # Side effects: # XMPP IQ stanza is sent. proc ::xmpp::privacy::setActive {xlib args} { set commands {} set timeout 0 set attrs {} foreach {key val} $args { switch -- $key { -name { set attrs [list name $val] } -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } variable rid set lrid [incr rid] set id \ [::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create query \ -xmlns jabber:iq:privacy \ -subelement [::xmpp::xml::create active \ -attrs $attrs]] \ -command [namespace code [list ParseActiveReply $lrid $commands]] \ -timeout $timeout] if {[llength $commands] > 0} { # Asynchronous mode return $id } else { # Synchronous mode variable answer vwait [namespace current]::answer($lrid) foreach {status msg} $answer($lrid) break unset answer($lrid) switch -- $status { ok { return $msg } error { return -code error $msg } default { return -code break $msg } } } } # ::xmpp::privacy::ParseActiveReply -- # # A helper procedure which parses server reply to an active privacy list # set request and invokes callback. # # Arguments: # rid A request id (is used in synchronous mode) # commands A list of commands to call (it's either empty or # contains a single element) # status A status of the request (ok, error, abort, or timeout) # xml XML element with either error message or items list # # Result: # An empty string # # Side effects: # A callback is called if specified. proc ::xmpp::privacy::ParseActiveReply {rid commands status xml} { variable answer if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } else { set answer($rid) [list $status $xml] } return } # ::xmpp::privacy::register -- # # Register handler to process privacy list pushes.. # # Arguments: # -command cmd (optional) Command to call when privacy list push is # arrived. The result of the command is sent back. # It must be either {result {}}, or {error type # condition}, or empty string if the application will # reply to the request separately. # The command's arguments are xlib, from, xml, and # optional parameters -to, -id, -lang. # # Result: # Empty string. # # Side effects: # XMPP privacy lists callback is registered. proc ::xmpp::privacy::register {args} { set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } ::xmpp::iq::register set query jabber:iq:privacy \ [namespace code [list ParseRequest $commands]] return } # ::xmpp::privacy::ParseRequest -- # # A helper procedure which is called on any incoming privacy list push. # It either calls a command specified during registration or simply # returns result (if there weren't any command). # # Arguments: # commands A list of commands to call (only the first one # will be invoked). # xlib XMPP token where request was received. # from JID of user who sent the request. # xml Request XML element. # args optional arguments (-lang, -to, -id). # # Result: # Either {result, {}}, or {error type condition}, or empty string, if # the application desided to reply later. # # Side effects: # Side effects of the called command. proc ::xmpp::privacy::ParseRequest {commands xlib from xml args} { # -to attribute contains the own JID, so check from JID to prevent # malicious users to pretend they perform roster push set to [::xmpp::xml::getAttr $args -to] if {![string equal $from ""] && \ ![::xmpp::jid::equal $from $to] && \ ![::xmpp::jid::equal $from [::xmpp::jid::stripResource $to]] && \ ![::xmpp::jid::equal $from [::xmpp::jid::server $to]]} { return [list error cancel service-unavailable] } if {[llength $commands] > 0} { ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { list { set name [::xmpp::xml::getAttr $sattrs name] break } } } if {[info exists name]} { return [uplevel #0 [lindex $commands 0] [list $xlib $from $name] \ $args] } else { return [list error modify bad-request] } } else { return [list result {}] } } # ::xmpp::privacy::unregister -- # # Unregister handler which used to answer XMPP privacy list pushes.. # # Arguments: # None. # # Result: # Empty string. # # Side effects: # XMPP privacy lists callback is unregistered. proc ::xmpp::privacy::unregister {} { ::xmpp::iq::unregister get query jabber:iq:privacy return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/private.tcl000064400000000000000000000051271470446212700152770ustar00nobodynobody# private.tcl -- # # This file is part of the XMPP library. It provides support for the # Private XML Storage (XEP-0049). # # Copyright (c) 2009-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp package provide xmpp::private 0.1 namespace eval ::xmpp::private {} proc ::xmpp::private::store {xlib query args} { set commands {} set timeout 0 foreach {key val} $args { switch -- $key { -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } set id \ [::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create query \ -xmlns jabber:iq:private \ -subelements $query] \ -command [namespace code [list ParseStoreAnswer $commands]] \ -timeout $timeout] return $id } proc ::xmpp::private::ParseStoreAnswer {commands status xml} { if {[llength $commands] > 0} { uplevel #0 [lindex $commands 0] [list $status $xml] } return } proc ::xmpp::private::retrieve {xlib query args} { set commands {} set timeout 0 foreach {key val} $args { switch -- $key { -timeout { set timeout $val } -command { set commands [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } set id \ [::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create query \ -xmlns jabber:iq:private \ -subelements $query] \ -command [namespace code [list ParseRetrieveAnswer $commands]] \ -timeout $timeout] return $id } proc ::xmpp::private::ParseRetrieveAnswer {commands status xml} { if {[llength $commands] == 0} return if {![string equal $status ok]} { uplevel #0 [lindex $commands 0] [list $status $xml] return } ::xmpp::xml::split $xml tag xmlns attrs cdata subels uplevel #0 [lindex $commands 0] [list ok $subels] return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/pubsub.tcl000064400000000000000000001144641470446212700151320ustar00nobodynobody# pubsub.tcl -- # # This file is part of the XMPP library. It implements interface to # Publish-Subscribe Support (XEP-0060). # # Copyright (c) 2009-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package provide xmpp::pubsub 0.1 namespace eval ::xmpp::pubsub { variable ns array set ns [list \ pubsub "http://jabber.org/protocol/pubsub" \ owner "http://jabber.org/protocol/pubsub#owner" \ collections "http://jabber.org/protocol/pubsub#collections" \ config-node "http://jabber.org/protocol/pubsub#config-node" \ create-and-configure "http://jabber.org/protocol/pubsub#create-and-configure" \ create-nodes "http://jabber.org/protocol/pubsub#create-nodes" \ delete-any "http://jabber.org/protocol/pubsub#delete-any" \ delete-nodes "http://jabber.org/protocol/pubsub#delete-nodes" \ get-pending "http://jabber.org/protocol/pubsub#get-pending" \ instant-nodes "http://jabber.org/protocol/pubsub#instant-nodes" \ item-ids "http://jabber.org/protocol/pubsub#item-ids" \ leased-subscription "http://jabber.org/protocol/pubsub#leased-subscription" \ meta-data "http://jabber.org/protocol/pubsub#meta-data" \ manage-subscription "http://jabber.org/protocol/pubsub#manage-subscription" \ modify-affiliations "http://jabber.org/protocol/pubsub#modify-affiliations" \ multi-collection "http://jabber.org/protocol/pubsub#multi-collection" \ multi-subscribe "http://jabber.org/protocol/pubsub#multi-subscribe" \ outcast-affiliation "http://jabber.org/protocol/pubsub#outcast-affiliation" \ persistent-items "http://jabber.org/protocol/pubsub#persistent-items" \ presence-notifications "http://jabber.org/protocol/pubsub#presence-notifications" \ publish "http://jabber.org/protocol/pubsub#publish" \ publisher-affiliation "http://jabber.org/protocol/pubsub#publisher-affiliation" \ purge-nodes "http://jabber.org/protocol/pubsub#purge-nodes" \ retract-items "http://jabber.org/protocol/pubsub#retract-items" \ retrieve-affiliations "http://jabber.org/protocol/pubsub#retrieve-affiliations" \ retrieve-default "http://jabber.org/protocol/pubsub#retrieve-default" \ retrieve-items "http://jabber.org/protocol/pubsub#retrieve-items" \ retrieve-subscriptions "http://jabber.org/protocol/pubsub#retrieve-subscriptions" \ subscribe "http://jabber.org/protocol/pubsub#subscribe" \ subscription-options "http://jabber.org/protocol/pubsub#subscription-options" \ subscription-notifications "http://jabber.org/protocol/pubsub#subscription-notifications" \ subscribe_authorization "http://jabber.org/protocol/pubsub#subscribe_authorization" \ subscribe_options "http://jabber.org/protocol/pubsub#subscribe_options" \ node_config "http://jabber.org/protocol/pubsub#node_config" \ event "http://jabber.org/protocol/pubsub#event"] } ########################################################################## # # Entity use cases (5) # ########################################################################## # # Discover features (5.1) is implemented in disco.tcl # Discover nodes (5.2) is implemented in disco.tcl # Discover node information (5.3) is implemented in disco.tcl # Discover node meta-data (5.4) is implemented in disco.tcl # ########################################################################## # # Discover items for a node (5.5) is NOT implemented in disco.tcl # TODO # ########################################################################## # # Retrieve subscriptions (5.6) # # Evaluates command for attribute lists # proc ::xmpp::pubsub::retrieveSubscriptions {xlib service args} { variable ns set attrs {} set commands {} foreach {key val} $args { switch -- $key { -node { set attrs [list node $val] } -command { set commands [list $val] } } } ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(pubsub) \ -subelement [::xmpp::xml::create subscriptions \ -attrs $attrs]] \ -to $service \ -command [namespace code [list RetrieveSubscriptionsResult $commands]] } proc ::xmpp::pubsub::RetrieveSubscriptionsResult {commands status xml} { if {![string equal $status ok]} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } return } set items {} ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { subscriptions { foreach item $ssubels { ::xmpp::xml::split \ $item sstag ssxmlns ssattrs sscdata sssubels if {[string equal $sstag subscription]} { lappend items $ssattrs } } } } } if {[llength $commands] > 0} { eval [lindex $commands 0] [list ok $items] } } ########################################################################## # # Retrieve affiliations (5.6) # # Evaluates command for attribute lists # proc ::xmpp::pubsub::retrieveAffiliations {xlib service args} { variable ns set attrs {} set commands {} foreach {key val} $args { switch -- $key { -node { set attrs [list node $val] } -command { set commands [list $val] } } } ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(pubsub) \ -subelement [::xmpp::xml::create affiliations \ -attrs $attrs]] \ -to $service \ -command [namespace code [list RetrieveAffiliationsResult $commands]] } proc ::xmpp::pubsub::RetrieveAffiliationsResult {commands status xml} { if {![string equal $status ok]} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } return } set items {} ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { affiliations { foreach item $ssubels { ::xmpp::xml::split \ $item sstag ssxmlns ssattrs sscdata sssubels if {[string equal $sstag affiliation]} { lappend items $ssattrs } } } } } if {[llength $commands] > 0} { eval [lindex $commands 0] [list ok $items] } } ########################################################################## # # Subscriber use cases (6) # ########################################################################## # # Subscribe to pubsub node "node" at service "service" (6.1) # # if node is empty then it's a subscription to root collection node (9.2) # # -jid "jid" is optional (when it's present it's included to sub request) # # -resource "res" is optional (when it's present bare_jid/res is included # to sub request # # if both options are absent then user's bare JID is included to sub # request # # Optional pubsub#subscribe_options parameters # -deliver # -digest # -expire # -include_body # -show-values # -subscription_type # -subscription_depth # proc ::xmpp::pubsub::subscribe {xlib service node args} { variable ns set commands {} set options [form_type $ns(subscribe_options)] foreach {key val} $args { switch -- $key { -jid { set jid $val } -resource { set resource $val } -command { set commands [list $val] } -deliver - -digest - -expire - -include_body - -show-values - -subscription_type - -subscription_depth { set par [string range $opt 1 end] set options [concat $options [field pubsub#$par $val]] } } } if {![info exists jid]} { set jid [::xmpp::jid::stripResource [::xmpp::Set $xlib jid]] } if {[info exists resource]} { append jid /$resource } set attrs [list jid $jid] if {$node != ""} { lappend attrs node $node } if {[llength $options] > 2} { set options \ [list [::xmpp::xml::create options \ -subelement [::xmpp::data::submitForm $options]]] } else { set options {} } ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(pubsub) \ -subelement [::xmpp::xml::create subscribe \ -attrs $attrs] \ -subelements $options] \ -to $service \ -command [namespace code [list SubscribeResult $commands]] } proc ::xmpp::pubsub::SubscribeResult {commands status xml} { variable ns if {![string equal $status ok]} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } return } ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { subscription { # TODO: subscription-options if {[llength $commands] > 0} { eval [lindex $commands 0] [list ok $sattrs] return } } } } # Something strange: OK without subscription details if {[llength $commands] > 0} { eval [lindex $commands 0] [list ok {}] } } ########################################################################## # # Unsubscribe from pubsub node "node" at service "service" (6.2) # # if node is empty then it's a unsubscription from root collection node (9.2) # # -jid "jid" is optional (when it's present it's included to sub request) # # -resource "res" is optional (when it's present bare_jid/res is included # to sub request # # if both options are absent then user's bare JID is included to sub # request # proc ::xmpp::pubsub::unsubscribe {xlib service node args} { variable ns debugmsg pubsub [info level 0] set commands {} foreach {key val} $args { switch -- $key { -jid { set jid $val } -subid { set subid $val } -resource { set resource $val } -command { set commands [list $val] } } } if {![info exists jid]} { set jid [::xmpp::jid::stripResource [::xmpp::Set $xlib jid]] } if {[info exists resource]} { append jid /$resource } set attrs [list jid $jid] if {$node != ""} { lappend attrs node $node } if {[info exists subid]} { lappend attrs subid $subid } ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(pubsub) \ -subelement [::xmpp::xml::create unsubscribe \ -attrs $attrs]] \ -to $service \ -command [namespace code [list UnsubscribeResult $commands]] } proc ::xmpp::pubsub::UnsubscribeResult {commands status xml} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } } ########################################################################## # # Configure subscription options (6.3) # proc ::xmpp::pubsub::requestSubscriptionOptions {xlib service node args} { variable ns set commands {} foreach {key val} $args { switch -- $key { -jid { set jid $val } -subid { set subid $val } -resource { set resource $val } -command { set commands [list $val] } } } if {[string equal $node ""]} { return -code error "Node must not be empty" } if {![info exists jid]} { set jid [::xmpp::jid::stripResource [::xmpp::Set $xlib jid]] } if {[info exists resource]} { append jid /$resource } if {[info exists subid]} { set attrs [list node $node subid $subid jid $jid] } else { set attrs [list node $node jid $jid] } ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(pubsub) \ -subelement [::xmpp::xml::create options \ -attrs $attrs]] \ -to $service \ -command [namespace code [list SubscriptionOptionsResult $commands]] } proc ::xmpp::pubsub::SubscriptionOptionsResult {commands status xml} { if {![string equal $status ok]} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } return } ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $tag { options { set form [::xmpp::data::findForm $ssubels] if {[llength $commands] > 0} { eval [lindex $commands 0] \ [list ok [list $sattrs [lindex $form 1]]] return } } } } if {[llength $commands] > 0} { eval [lindex $commands 0] [list ok {}] } } proc ::xmpp::pubsub::sendSubscriptionOptions {xlib service node restags args} { variable ns set commands {} foreach {key val} $args { switch -- $key { -jid { set jid $val } -subid { set subid $val } -resource { set resource $val } -command { set commands [list $val] } } } if {[string equal $node ""]} { return -code error "Node must not be empty" } if {![info exists jid]} { set jid [::xmpp::jid::stripResource [::xmpp::Set $xlib jid]] } if {[info exists resource]} { append jid /$resource } if {[info exists subid]} { set attrs [list node $node subid $subid jid $jid] } else { set attrs [list node $node jid $jid] } ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(pubsub) \ -subelement [::xmpp::xml::create options \ -attrs $attrs \ -subelements $restags]] \ -to $service \ -command [namespace code [list SendSubscriptionOptionsResult $commands]] } proc ::xmpp::pubsub::SendSubscriptionOptionsResult {commands status xml} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } } ########################################################################## # # Retrieve items for a node (6.4) # Node must not be empty # Evaluates command with list of items # # -max_items $number (request $number last items) # -items $item_id_list (request specific items) proc ::xmpp::pubsub::retrieveItems {xlib service node args} { variable ns set commands {} set items {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } -subid { set subid $val } -max_items { set max_items $val } -items { foreach id $val { lappend items [::xmpp::xml::create item \ -attrs [list id $id]] } } } } if {$node == ""} { return -code error "Node must not be empty" } if {[info exists subid]} { set attrs [list node $node subid $subid] } else { set attrs [list node $node] } if {[info exists max_items]} { lappend attrs max_items $max_items } ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(pubsub) \ -subelement [::xmpp::xml::create items \ -attrs $attrs \ -subelements $items]] \ -to $service \ -command [namespace code [list GetItemsResult $commands]] } proc ::xmpp::pubsub::GetItemsResult {commands status xml} { if {![string equal $status ok]} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } return } ::xmpp::xml::split $xml tag xmlns attrs cdata subels set items {} foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns attrs scdata ssubels switch -- $stag { items { foreach item $ssubels { ::xmpp::xml::split \ $item sstag ssxmlns ssattrs sscdata sssubels if {[string equal $sstag item]} { lappend items $item } } } } } if {[llength $commands] > 0} { eval [lindex $commands 0] [list ok $items] } } ########################################################################## # # Publisher use cases (7) # ########################################################################## # # Publish item "itemid" to pubsub node "node" at service "service" (7.1) # payload is a LIST of xml tags # node must not be empty proc ::xmpp::pubsub::publishItem {xlib service node itemid args} { variable ns debugmsg pubsub [info level 0] set commands {} set payload {} set transient 0 foreach {key val} $args { switch -- $key { -transient { set transient $val } -payload { set payload $val } -command { set commands [list $val] } } } if {[string equal $node ""]} { return -code error "Node must not be empty" } if {[string equal $itemid ""]} { set attrs {} } else { set attrs [list id $itemid] } if {$transient} { set item {} } else { set item [list [::xmpp::xml::create item \ -attrs $attrs \ -subelements $payload]] } ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(pubsub) \ -subelement [::xmpp::xml::create publish \ -attrs [list node $node] \ -subelements $item]] \ -to $service \ -command [namespace code [list PublishItemResult $commands]] } proc ::xmpp::pubsub::PublishItemResult {commands status xml} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } } ########################################################################## # # Delete item "itemid" from pubsub node "node" at service "service" (7.2) # node and itemid must not be empty # -notify is a boolean (true, false, 1, 0) proc ::xmpp::pubsub::deleteItem {xlib service node itemid args} { variable ns set commands {} set notify 0 foreach {key val} $args { switch -- $key { -notify { set notify $val } -command { set commands [list $val] } } } if {[string equal $node ""]} { return -code error "Node must not be empty" } if {[string equal $itemid ""]} { return -code error "Item ID must not be empty" } set attrs [list node $node] if {[string is true -strict $notify]} { lappend attrs notify true } ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(pubsub) \ -subelement [::xmpp::xml::create retract \ -attrs $attrs \ -subelement [::xmpp::xml::create item \ -attrs [list id $itemid]]]] \ -to $service \ -command [namespace code [list DeleteItemResult $commands]] } proc ::xmpp::pubsub::DeleteItemResult {commands status xml} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } } ########################################################################## # # Owner use cases (8) # ########################################################################## # # Create pubsub node "node" at service "service" (8.1) # # 8.1.2 create_node xlib service node -command callback # or create_node xlib service node -access_model model -command callback # # 8.1.3 create_node xlib service node -command callback \ # -title title \ # ........... \ # -body_xslt xslt # # Optional pubsub#node_config parameters # -access_model # -body_xslt # -collection # -dataform_xslt # -deliver_notifications # -deliver_payloads # -itemreply # -children_association_policy # -children_association_whitelist # -children # -children_max # -max_items # -max_payload_size # -node_type # -notify_config # -notify_delete # -notify_retract # -persist_items # -presence_based_delivery # -publish_model # -replyroom # -replyto # -roster_groups_allowed # -send_last_published_item # -subscribe # -title # -type proc ::xmpp::pubsub::createNode {xlib service node args} { variable ns debugmsg pubsub [info level 0] set commands {} set options {} set fields [form_type $ns(node_config)] foreach {key val} $args { switch -- $key { -command { set commands [list $val] } -access_model - -body_xslt - -collection - -dataform_xslt - -deliver_notifications - -deliver_payloads - -itemreply - -children_association_policy - -children_association_whitelist - -children - -children_max - -max_items - -max_payload_size - -node_type - -notify_config - -notify_delete - -notify_retract - -persist_items - -presence_based_delivery - -publish_model - -replyroom - -replyto - -roster_groups_allowed - -send_last_published_item - -subscribe - -title - -type { set par [string range $opt 1 end] set fields [concat $fields [field pubsub#$par $val]] } } } if {[string equal $node ""]} { set attrs {} } else { set attrs [list node $node] } if {[llength $fields] > 2} { set fields [list [::xmpp::data::submitForm $fields]] } else { set fields {} } ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(pubsub) \ -subelement [::xmpp::xml::create create \ -attrs $attrs] \ -subelement [::xmpp::xml::create configure \ -subelements $fields]] \ -to $service \ -command [namespace code [list CreateNodeResult $node $commands]] } proc ::xmpp::pubsub::form_type {value} { return [list FORM_TYPE [list $value]] } proc ::xmpp::pubsub::field {var value} { return [list $var [list $value]] } proc ::xmpp::pubsub::CreateNodeResult {node commands status xml} { if {![string equal $status ok]} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } return } if {[string equal $node ""]} { # Instant node: get node name from the answer ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels if {[string equal $stag create]} { set node [::xmpp::xml::getAttr $sattrs node] } } } if {[llength $commands] > 0} { eval [lindex $commands 0] [list ok $node] } } ########################################################################## # # Configure pubsub node "node" at service "service" (8.2) # node must not be empty # proc ::xmpp::pubsub::configureNode {xlib service node args} { variable ns set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } if {[string equal $node ""]} { return -code error "Node must not be empty" } ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(owner) \ -subelement [::xmpp::xml::create configure \ -attrs [list node $node]]] \ -to $service \ -command [namespace code [list ConfigureNodeResult $commands]] } proc ::xmpp::pubsub::ConfigureNodeResult {commands status xml} { if {![string equal $status ok]} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } return } ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { configure { set node [::xmpp::xml::getAttr $sattrs node] set form [::xmpp::data::findForm $ssubels] if {[llength $commands] > 0} { eval [lindex $commands 0] \ [list ok [list $node [lindex $form 1]]] return } } } } if {[llength $commands] > 0} { eval [lindex $commands 0] [list ok {}] } } proc ::xmpp::pubsub::sendConfigureNode {xlib service node restags args} { variable ns set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(owner) \ -subelement [::xmpp::xml::create configure \ -attrs [list node $node] \ -subelements $restags]] \ -to $service \ -command [namespace code [list SendConfigureNodeResult $commands]] } proc ::xmpp::pubsub::SendConfigureNodeResult {commands status xml} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } } ########################################################################## # # Request default configuration options (8.3) # proc ::xmpp::pubsub::requestDefaultConfig {xlib service args} { variable ns set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(owner) \ -subelement [::xmpp::xml::create default]] \ -to $service \ -command [namespace code [list RequestDefaultConfigResult $commands]] } proc ::xmpp::pubsub::RequestDefaultConfigResult {commands status xml} { if {![string equal $status ok]} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } return } ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { default { set form [::xmpp::data::findForm $ssubels] if {[llength $commands] > 0} { eval [lindex $commands 0] \ [list ok [lindex $form 1]] return } } } } if {[llength $commands] > 0} { eval [lindex $commands 0] [list ok {}] } } ########################################################################## # # Delete a node (8.4) # node must not be empty # proc ::xmpp::pubsub::deleteNode {xlib service node args} { variable ns set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } if {[string equal $node ""]} { return -code error "Node must not be empty" } ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(owner) \ -subelement [::xmpp::xml::create delete \ -attrs [list node $node]]] \ -to $service \ -command [namespace code [list DeleteNodeResult $commands]] } proc ::xmpp::pubsub::DeleteNodeResult {commands status xml} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } } ########################################################################## # # Purge all node items (8.5) # node must not be empty # proc ::xmpp::pubsub::purgeItems {xlib service node args} { variable ns set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } if {[string equal $node ""]} { return -code error "Node must not be empty" } ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(owner) \ -subelement [::xmpp::xml::create purge \ -attrs [list node $node]]] \ -to $service \ -command [namespace code [list PurgeItemsResult $commands]] } proc ::xmpp::pubsub::PurgeItemsResult {commands status xml} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } } ########################################################################## # # Manage subscription requests (8.6) # is done in messages.tcl # ########################################################################## # # Request all pending subscription requests (8.6.1) # TODO #proc ::xmpp::pubsub::requestPendingSubscription {xlib service} { # variable ns # # # Let xcommands.tcl do the job # xcommands::execute $xlib $service $ns(get-pending) #} ########################################################################## # # Manage subscriptions (8.7) # # Callback is called with list of entities: # {jid JID subscription SUB subid ID} # proc ::xmpp::pubsub::requestSubscriptions {xlib service node args} { variable ns set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } if {[string equal $node ""]} { return -code error "Node must not be empty" } ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(owner) \ -subelement [::xmpp::xml::create subscriptions \ -attrs [list node $node]]] \ -to $service \ -command [namespace code [list RequestSubscriptionsResult $commands]] } proc ::xmpp::pubsub::RequestSubscriptionsResult {commands status xml} { if {![string equal $status ok]} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } return } set entities {} ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { subscriptions { foreach entity $ssubels { ::xmpp::xml::split \ $entity sstag ssxmlns ssattrs sscdata sssubels if {[string equal $sstag subscription]} { lappend entities $ssattrs } } } } } if {[llength $commands] > 0} { eval [lindex $commands 0] [list ok $entities] } } ########################################################################## proc ::xmpp::pubsub::modifySubscriptions {xlib service node entities args} { variable ns set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } if {[string equal $node ""]} { return -code error "Node must not be empty" } set subscriptions {} foreach entity $entities { lappend subscriptions [::xmpp::xml::create subscription \ -attrs $entity] } ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(owner) \ -subelement [::xmpp::xml::create subscriptions \ -attrs [list node $node] \ -subelements $subscriptions]] \ -to $service \ -command [namespace code [list ModifySubscriptionsResult $commands]] } proc ::xmpp::pubsub::ModifySubscriptionsResult {commands status xml} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } } ########################################################################## # # Retrieve current affiliations (8.8) # Evaluates command with list of entity attributes lists # proc ::xmpp::pubsub::requestAffiliations {xlib service node args} { variable ns set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } if {[string equal $node ""]} { return -code error "Node must not be empty" } ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(owner) \ -subelement [::xmpp::xml::create affiliations]] \ -to $service \ -command [namespace code [list RequestAffiliationsResult $commands]] } proc ::xmpp::pubsub::RequestAffiliationsResult {commands status xml} { if {![string equal $status ok]} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } return } set entities {} ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { affiliations { foreach entity $ssubels { ::xmpp::xml::split \ $entity sstag ssxmlns sattrs sscdata sssubels if {[string equal $sstag affiliation]} { lappend entities $ssattrs } } } } } if {[llength $commands] > 0} { eval [lindex $commands 0] [list ok $entites] } } ########################################################################## proc ::xmpp::pubsub::modifyAffiliations {xlib service node entities args} { variable ns set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } if {[string equal $node ""]} { return -code error "Node must not be empty" } set affiliations {} foreach entity $entities { lappend affiliations [::xmpp::xml::create affiliation \ -attrs $entity] } ::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create pubsub \ -xmlns $ns(owner) \ -subelement [::xmpp::xml::create affiliations \ -attrs [list node $node] \ -subelements $affiliations]] \ -to $service \ -command [namespace code [list ModifyAffiliationsResult $commands]] } proc ::xmpp::pubsub::ModifyAffiliationsResult {commands status xml} { if {[llength $commands] > 0} { eval [lindex $commands 0] [list $status $xml] } } ########################################################################## # # Collection nodes (9) # ########################################################################## # # Subscribe to a collection node (9.1) # Implemented in # pubsub::subscribe xlib service node id \ # -subscription_type {nodes|items} \ # -subscription_depth {1|all} # ########################################################################## # # Root collection node (9.2) # Implemented in pubsub::subscribe and pubsub::unsubscribe with empty node # ########################################################################## # # Create collection node (9.3) # Implemented in # pubsub::create_node xlib service node \ # -node_type collection # ########################################################################## # # Create a node associated with a collection (9.4) # Implemented in # pubsub::create_node xlib service node \ # -collection collection # ########################################################################## # # Associate an existing node with a collection (9.5) # Implemented in TODO ########################################################################## # # Diassociate an node from a collection (9.6) # Implemented in TODO # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/register.tcl000064400000000000000000000152331470446212700154500ustar00nobodynobody# register.tcl -- # # This file is a part of the XMPP library. It implements support for # In-Band Registration (XEP-0077). # # Copyright (c) 2008-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp package provide xmpp::register 0.1 namespace eval ::xmpp::register { namespace export request submit # Register fields (see XEP-0077) array set labels [list username [::msgcat::mc "Username"] \ nick [::msgcat::mc "Nickname"] \ password [::msgcat::mc "Password"] \ name [::msgcat::mc "Full name"] \ first [::msgcat::mc "First name"] \ last [::msgcat::mc "Last name"] \ email [::msgcat::mc "E-mail"] \ address [::msgcat::mc "Address"] \ city [::msgcat::mc "City"] \ state [::msgcat::mc "State"] \ zip [::msgcat::mc "Zip"] \ phone [::msgcat::mc "Phone"] \ url [::msgcat::mc "URL"] \ date [::msgcat::mc "Date"] \ misc [::msgcat::mc "Misc"] \ text [::msgcat::mc "Text"] \ key [::msgcat::mc "Key"]] } # ::xmpp::register::request -- proc ::xmpp::register::request {xlib jid args} { set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } return [::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create query \ -xmlns jabber:iq:register] \ -to $jid \ -command [namespace code [list ParseForm $commands]]] } # ::xmpp::register::submit -- proc ::xmpp::register::submit {xlib jid fields args} { set old 0 set commands {} foreach {key val} $args { switch -- $key { -old { set old $val } -command { set commands [list $val] } } } if {!$old} { set subels [list [::xmpp::data::submitForm $fields]] } else { set subels [FillFields $fields] } return [::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create query \ -xmlns jabber:iq:register \ -subelements $subels] \ -to $jid \ -command [namespace code [list SubmitResult $commands]]] } # ::xmpp::register::remove -- proc ::xmpp::register::remove {xlib jid args} { set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } return [::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create query \ -xmlns jabber:iq:register \ -subelement [::xmpp::xml::create remove]] \ -to $jid \ -command [namespace code [list SubmitResult $commands]]] } # ::xmpp::register::password -- proc ::xmpp::register::password {xlib username password args} { set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } set subels [list [::xmpp::xml::create username -cdata $username] \ [::xmpp::xml::create password -cdata $password]] return [::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create query \ -xmlns jabber:iq:register \ -subelements $subels] \ -command [namespace code [list SubmitResult $commands]]] } # ::xmpp::register::ParseForm -- proc ::xmpp::register::ParseForm {commands status xml} { if {[llength $commands] == 0} { return } if {![string equal $status ok]} { uplevel #0 [lindex $commands 0] [list $status $xml] return } ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach {type form} [::xmpp::data::findForm $subels] break if {[string equal $type form]} { set fields [::xmpp::data::parseForm $form] set old 0 } else { set fields [ParseFields $subels] set old 1 } uplevel #0 [lindex $commands 0] [list $status $fields -old $old] return } # ::xmpp::register::ParseFields -- proc ::xmpp::register::ParseFields {xmlElements} { variable labels set res {} foreach xml $xmlElements { ::xmpp::xml::split $xml tag xmlns attrs cdata subels switch -- $tag { instructions { set res [linsert $res 0 instructions $cdata] } x {} default { switch -- $tag { key - registered { set type hidden } password { set type text-private } default { set type text-single } } if {[info exists labels($tag)]} { set label $labels($tag) } else { set label "" } lappend res field \ [list $tag $type $label "" 0 {} [list $cdata] {}] } } } return $res } # ::xmpp::register::FillFields -- proc ::xmpp::register::FillFields {fields} { set res {} foreach {var values} $fields { lappend res [::xmpp::xml::create $var -cdata [lindex $values 0]] } return $res } # ::xmpp::register::SubmitResult -- proc ::xmpp::register::SubmitResult {commands status xml} { if {[llength $commands] == 0} { return } if {![string equal $status error]} { uplevel #0 [lindex $commands 0] [list $status $xml] return } ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach {type form} [::xmpp::data::findForm $subels] break if {[string equal $type form]} { set status continue set fields [::xmpp::data::parseForm $form] } else { set fields $xml } uplevel #0 [lindex $commands 0] [list $status $fields] return } # vim:ft=tcl:ts=8:sw=4:sts=4:et tclxmpp/xmpp/roster.tcl000064400000000000000000000300371470446212700151410ustar00nobodynobody# roster.tcl -- # # This file is a part of the XMPP library. It implements basic # roster routines (RFC-3921 and RFC-6121). # # Copyright (c) 2008-2015 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp package provide xmpp::roster 0.2 namespace eval ::xmpp::roster {} # ::xmpp::roster::features -- # # Return roster features list it can be empty or include 'ver' string # which means that roster versioning is supported (XEP-0237 and later # RFC-6121, section 2.6) proc ::xmpp::roster::features {xlib} { set features {} foreach f [::xmpp::streamFeatures $xlib] { ::xmpp::xml::split $f tag xmlns attrs cdata subels if {[string equal $tag ver] && [string equal $xmlns urn:xmpp:features:rosterver]} { lappend features ver } } set features } # ::xmpp::roster::new -- proc ::xmpp::roster::new {xlib args} { variable id if {![info exists id]} { set id 0 } set token [namespace current]::[incr id] variable $token upvar 0 $token state set state(xlib) $xlib set state(rid) 0 set state(items) {} set state(-version) "" set state(-cache) {} foreach {key val} $args { switch -- $key { -version - -cache - -itemcommand { set state($key) $val } default { unset state return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } ::xmpp::iq::RegisterIQ $xlib set * jabber:iq:roster \ [namespace code [list ParsePush $token]] set token } # ::xmpp::roster::free -- proc ::xmpp::roster::free {token} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) set version $state(-version) set cache $state(-cache) ::xmpp::iq::UnregisterIQ $xlib set * jabber:iq:roster unset state list $version $cache } # ::xmpp::roster::items -- proc ::xmpp::roster::items {token args} { variable $token upvar 0 $token state set normalized 0 foreach {key val} $args { switch -- $key { -normalized { set normalized $val } } } if {$normalized} { return $state(items) } else { set items {} foreach njid $state(items) { lappend items [::xmpp::xml::getAttr $state(roster,$njid) jid] } return $items } } # ::xmpp::roster::item -- proc ::xmpp::roster::item {token jid {key -all}} { variable $token upvar 0 $token state set njid [::xmpp::jid::normalize $jid] switch -- $key { -all { if {![info exists state(roster,$njid)]} { return {} } else { return $state(roster,$njid) } } -jid - -name - -subscription - -ask - -groups { if {![info exists state(roster,$njid)]} { return "" } else { return [::xmpp::xml::getAttr $state(roster,$njid) $key] } } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } # ::xmpp::roster::remove -- proc ::xmpp::roster::remove {token jid args} { eval [list send $token -jid $jid -subscription remove] $args } # ::xmpp::roster::send -- proc ::xmpp::roster::send {token args} { variable $token upvar 0 $token state set xlib $state(xlib) set timeout 0 set cmd {} set attrs {} set groups {} foreach {key val} $args { switch -- $key { -timeout { set timeout $val } -command { set cmd [list -command $val] } -jid { lappend attrs jid $val } -name { lappend attrs name $val } -subscription { lappend attrs subscription $val } -ask { lappend attrs ask $val } -groups { foreach group $val { lappend groups [::xmpp::xml::create group -cdata $group] } } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } set query [::xmpp::xml::create query \ -xmlns jabber:iq:roster \ -subelements [list [::xmpp::xml::create item \ -attrs $attrs \ -subelements $groups]]] eval [list ::xmpp::sendIQ $xlib set \ -query $query \ -timeout $timeout] $cmd } # ::xmpp::roster::get -- proc ::xmpp::roster::get {token args} { variable $token upvar 0 $token state set xlib $state(xlib) set timeout 0 set attrs {} set cmd {} foreach {key val} $args { switch -- $key { -timeout { set timeout $val } -command { set cmd [list $val] } default { return -code error \ [::msgcat::mc "Illegal option \"%s\"" $key] } } } if {[lsearch -exact [features $xlib] ver] >= 0} { lappend attrs ver $state(-version) } set rid [incr state(rid)] set state(items) {} array unset state roster,* ::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create query \ -xmlns jabber:iq:roster \ -attrs $attrs] \ -command [namespace code [list ParseAnswer $token \ $rid \ $cmd]] \ -timeout $timeout if {[llength $cmd] > 0} { # Asynchronous mode return $token } else { # Synchronous mode vwait $token\(status,$rid) foreach {status msg} $state(status,$rid) break unset state(status,$rid) if {[string equal $status ok]} { return $msg } else { if {[string equal $status abort]} { return -code break $msg } else { return -code error $msg } } } } # ::xmpp::roster::ParsePush -- proc ::xmpp::roster::ParsePush {token xlib from xmlElement args} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return # -to attribute contains the own JID, so check from JID to prevent # malicious users to pretend they perform roster push set to [::xmpp::xml::getAttr $args -to] if {![string equal $from ""] && \ ![::xmpp::jid::equal $from $to] && \ ![::xmpp::jid::equal $from [::xmpp::jid::stripResource $to]] && \ ![::xmpp::jid::equal $from [::xmpp::jid::server $to]]} { return [list error cancel service-unavailable] } ParseItems $token push $xmlElement return [list result {}] } # ::xmpp::roster::ParseAnswer -- proc ::xmpp::roster::ParseAnswer {token rid cmd status xmlElement} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token $rid '$cmd' $status" if {[string equal $status ok]} { ParseItems $token fetch $xmlElement set xmlElement "" } if {[llength $cmd] > 0} { uplevel #0 [lindex $cmd 0] [list $status $xmlElement] } else { # Trigger vwait in [roster] set state(status,$rid) [list $status $xmlElement] } return } # ::xmpp::roster::ParseItems -- proc ::xmpp::roster::ParseItems {token mode xmlElement} { variable $token upvar 0 $token state if {$xmlElement == {}} { # Empty result, so use the cached roster set items {} foreach item $state(-cache) { foreach {njid jid name subsc ask groups} $item break lappend items $njid set state(roster,$njid) [list jid $jid \ name $name \ subscription $subsc \ ask $ask \ groups $groups] if {[info exists state(-itemcommand)]} { uplevel #0 $state(-itemcommand) [list $njid \ -jid $jid \ -name $name \ -subscription $subsc \ -ask $ask \ -groups $groups] } } set state(items) [lsort -unique $items] return } ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels # Get the new roster version set state(-version) [::xmpp::xml::getAttr $attrs ver ""] # Empty cache but not while roster push if {[string equal $mode fetch]} { set state(-cache) {} } foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels set groups {} set jid [::xmpp::xml::getAttr $sattrs jid] set name [::xmpp::xml::getAttr $sattrs name] set subsc [::xmpp::xml::getAttr $sattrs subscription] set ask [::xmpp::xml::getAttr $sattrs ask] foreach ssubel $ssubels { ::xmpp::xml::split $ssubel sstag ssxmlns ssattrs sscdata sssubels switch -- $sstag { group { lappend groups $sscdata } } } set njid [::xmpp::jid::normalize $jid] switch -- $subsc { remove { # Removing roster item set idx [lsearch -exact $state(items) $njid] if {$idx >= 0} { set state(items) [lreplace $state(items) $idx $idx] } set idx -1 set i -1 foreach item $state(-cache) { incr i if {[string equal [lindex $item 0] $njid]} { set idx $i break } } if {$idx >= 0} { set state(-cache) [lreplace $state(-cache) $idx $idx] } catch {unset state(roster,$njid)} } default { # Updating or adding roster item set state(items) \ [lsort -unique [linsert $state(items) 0 $njid]] set state(roster,$njid) [list jid $jid \ name $name \ subscription $subsc \ ask $ask \ groups $groups] lappend state(-cache) \ [list $njid $jid $name $subsc $ask $groups] } } if {[info exists state(-itemcommand)]} { uplevel #0 $state(-itemcommand) [list $njid \ -jid $jid \ -name $name \ -subscription $subsc \ -ask $ask \ -groups $groups] } } return } # vim:ft=tcl:ts=8:sw=4:sts=4:et tclxmpp/xmpp/sasl.tcl000064400000000000000000001016071470446212700145670ustar00nobodynobody# sasl.tcl -- # # This file is part of the XMPP library. It provides support for the # SASL authentication layer via the tclsasl or tcllib SASL package. # Also, it binds resource and opens XMPP session. # # Copyright (c) 2008-2016 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require base64 package require xmpp::stanzaerror package provide xmpp::sasl 0.2 namespace eval ::xmpp::sasl { namespace export auth abort variable saslpack variable encodeToUTF8 if {![catch {package require sasl 1.0}]} { set saslpack tclsasl } elseif {![catch {package require SASL 1.0} v]} { catch {package require SASL::NTLM} catch {package require SASL::XGoogleToken} if {![catch {package require SASL::SCRAM}]} { # Provide more secure SCRAM-SHA-256 mechanism package require sha256 proc ::SASL::SCRAM::SHA-256:hash {str} { sha2::sha256 -bin $str } proc ::SASL::SCRAM::SHA-256:hmac {key str} { sha2::hmac -bin -key $key $str } proc ::SASL::SCRAM::SHA-256:client {context challenge args} { client ::SASL::SCRAM::SHA-256:hash ::SASL::SCRAM::SHA-256:hmac $context $challenge } proc ::SASL::SCRAM::SHA-256:server {context clientrsp args} { server ::SASL::SCRAM::SHA-256:hash ::SASL::SCRAM::SHA-256:hmac $context $clientrsp } # Register the SCRAM-SHA-256 SASL mechanism with the Tcllib SASL package ::SASL::register SCRAM-SHA-256 55 ::SASL::SCRAM::SHA-256:client ::SASL::SCRAM::SHA-256:server } set saslpack tcllib if {[package vcompare $v 1.3.2] >= 0} { set encodeToUTF8 0 } else { set encodeToUTF8 1 } } else { return -code error [::msgcat::mc "No SASL package found"] } switch -- $saslpack { tclsasl { sasl::client_init -callbacks {} } tcllib { if {[lsearch -exact [::SASL::mechanisms] EXTERNAL] < 0} { # Register the EXTERNAL SASL authentication mechanism namespace eval ::SASL::EXTERNAL { proc client {context challenge args} { upvar #0 $context ctx incr ctx(step) set username [eval $ctx(callback) [list $context username]] set realm [eval $ctx(callback) [list $context realm]] set ctx(response) $username@$realm return 0 } ::SASL::register EXTERNAL 100 [namespace current]::client } } } default { # empty } } # SASL error messages ::xmpp::stanzaerror::registerType sasl [::msgcat::mc "Authentication error"] foreach {lcode type cond description} [list \ 401 sasl aborted [::msgcat::mc "Aborted"] \ 401 sasl incorrect-encoding [::msgcat::mc "Incorrect encoding"] \ 401 sasl invalid-authzid [::msgcat::mc "Invalid authzid"] \ 401 sasl invalid-mechanism [::msgcat::mc "Invalid mechanism"] \ 401 sasl mechanism-too-weak [::msgcat::mc "Mechanism too weak"] \ 401 sasl not-authorized [::msgcat::mc "Not authorized"] \ 401 sasl temporary-auth-failure [::msgcat::mc "Temporary auth\ failure"]] \ { ::xmpp::stanzaerror::registerError $lcode $type $cond $description } } # ::xmpp::sasl::auth -- # # Authenticate an existing XMPP stream using SASL method described # either in RFC-6120 (for clients) or in XEP-0225 (for components). # # Arguments: # xlib XMPP token. It must be connected and XMPP # stream must be opened. # -username username Username to authenticate (clients only). # -password password Password to use in authentication (clients # only). # -resource resource XMPP resource to bind to the stream after # successful authentication (clients only). # -domain domain Domain name to bind to (components only). # -secret secret Secret to use in authentication (components # only). # -disable mechlist List of SASL mechanisms which are explicitly # forbidden to use. # -digest digest (optional, defaults to "yes") Boolean value # which specifies if a digest authentication # method should be used. A special value "auto" # allows to select digest authentication if it's # available and fallback to plaintext if the # digest method isn't provided by server. Note # that Tclsasl doesn't allow one to disable # digest authentication mechanisms. # -timeout timeout (optional, defaults to 0 which means infinity) # Timeout (in milliseconds) for authentication # queries. # -command callback (optional) If present, it turns on asynchronous # mode. After successful or failed authentication # "callback" is invoked with two appended # arguments: status ("ok", "error", "abort" or # "timeout") and either authenticated JID if # status is "ok", or error stanza otherwise. # # Result: # Empty string. # # Side effects: # In state of waiting for reply from server terminates waiting process. proc ::xmpp::sasl::auth {xlib args} { variable saslpack variable id if {![info exists id]} { set id 0 } set token [namespace current]::[incr id] variable $token upvar 0 $token state ::xmpp::Debug $xlib 2 $token ::xmpp::Set $xlib abortCommand [namespace code [abort $token]] set state(xlib) $xlib set state(-server) [::xmpp::Set $xlib server] set state(-digest) 1 set state(-disable) {} set state(-sm) disable set timeout 0 catch {unset state(mechanisms)} foreach {key val} $args { switch -- $key { -domain - -secret - -username - -resource - -password - -disable - -sm - -command { set state($key) $val } -timeout { set timeout $val } -digest { if {[string is true -strict $val]} { set state(-digest) 1 } elseif {[string is false -strict $val]} { set state(-digest) 0 } elseif {[string equal $val auto]} { set state(-digest) 0.5 } else { unset state return -code error \ [::msgcat::mc "Illegal value \"%s\" for\ option \"%s\"" $val $key] } } default { unset state return -code error [::msgcat::mc "Illegal option \"%s\"" $key] } } } set count 0 foreach key {-username -domain} { if {[info exists state($key)]} { incr count } } if {$count >= 2} { unset state return -code error [::msgcat::mc "Only one option \"-username\"\ or \"-domain\" is allowed"] } if {[info exists state(-username)]} { foreach key {-resource -password} { if {![info exists state($key)]} { unset state return -code error [::msgcat::mc "Missing option \"%s\"" $key] } } } elseif {[info exists state(-domain)]} { foreach key {-secret} { if {![info exists state($key)]} { unset state return -code error [::msgcat::mc "Missing option \"%s\"" $key] } } } else { unset state return -code error [::msgcat::mc "Missing option \"-username\"\ or \"-domain\""] } ::xmpp::RegisterElement $xlib * urn:ietf:params:xml:ns:xmpp-sasl \ [namespace code [list Parse $token]] # Resource binding and session establishing use IQ ::xmpp::RegisterElement $xlib iq * [list ::xmpp::ParseIQ $xlib] switch -- $saslpack { tclsasl { if {[info exists state(-username)]} { set callback TclsaslCallbackUser } else { set callback TclsaslCallbackComponent } foreach key {authname pass getrealm cnonce} { lappend callbacks \ [list $key [namespace code [list $callback $token]]] } set state(token) \ [sasl::client_new -service xmpp \ -serverFQDN $state(-server) \ -callbacks $callbacks \ -flags success_data] if {$state(-digest) == 1} { set flags {noplaintext} } elseif {$state(-digest) > 0} { set flags {} } else { unset state return -code error [::msgcat::mc "Cannot forbid digest\ mechanisms"] } $state(token) -operation setprop \ -property sec_props \ -value [list min_ssf 0 \ max_ssf 0 \ flags $flags] } tcllib { if {[info exists state(-username)]} { set callback TcllibCallbackUser } else { set callback TcllibCallbackComponent } set state(token) \ [SASL::new -service xmpp \ -type client \ -server $state(-server) \ -callback [namespace code [list $callback $token]]] # Workaround a bug 1545306 in Tcllib SASL module set ::SASL::digest_md5_noncecount 0 } } if {$timeout > 0} { set state(afterid) \ [after $timeout \ [namespace code \ [list AbortAuth $token timeout \ [::msgcat::mc "SASL authentication\ timed out"]]]] } ::xmpp::TraceStreamFeatures $xlib \ [namespace code [list AuthContinue $token]] if {[info exists state(-command)]} { # Asynchronous mode return $token } else { # Synchronous mode vwait $token\(status) foreach {status msg} $state(status) break unset state if {[string equal $status ok]} { return $msg } else { if {[string equal $status abort]} { return -code break $msg } else { return -code error $msg } } } } # ::xmpp::sasl::abort -- # # Abort an existing authentication procedure, or do nothing if it's # already finished. # # Arguments: # token Authentication control token which is returned by # ::xmpp::sasl::auth procedure. # # Result: # Empty string. # # Side effects: # In state of waiting for reply from server terminates waiting process. proc ::xmpp::sasl::abort {token} { AbortAuth $token abort [::msgcat::mc "SASL authentication aborted"] } # ::xmpp::sasl::AbortAuth -- # # Abort an existing authentication procedure, or do nothing if it's # already finished. # # Arguments: # token Authentication control token which is returned by # ::xmpp::sasl::auth procedure. # status (error, abort or timeout) Status code of the abortion. # msg Error message. # # Result: # Empty string. # # Side effects: # In state of waiting for reply from server terminates waiting process. proc ::xmpp::sasl::AbortAuth {token status msg} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" ::xmpp::RemoveTraceStreamFeatures $xlib \ [namespace code [list AuthContinue $token]] if {[info exists state(reopenStream)]} { ::xmpp::GotStream $xlib abort {} return } set error [::xmpp::xml::create error -cdata $msg] if {[info exists state(id)]} { ::xmpp::abortIQ $xlib $state(id) $status $error } else { Finish $token $status $error } return } ########################################################################## proc ::xmpp::sasl::Parse {token xmlElement} { variable $token upvar 0 $token state ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels switch -- $tag { challenge { Step $token $cdata } success { Success $token } failure { Failure $token $subels } } } ########################################################################## proc ::xmpp::sasl::AuthContinue {token featuresList} { variable saslpack variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token $featuresList" if {[catch {FindMechanisms $featuresList} mechanisms]} { Finish $token error \ [::xmpp::stanzaerror::error modify not-acceptable -text \ [::msgcat::mc "Server hasn't provided SASL\ authentication feature"]] return } ::xmpp::Debug $xlib 2 "$token mechs: $mechanisms" switch -- $saslpack { tclsasl { set code [catch { $state(token) \ -operation start \ -mechanisms $mechanisms \ -interact [namespace code [list Interact $token]] } result] } tcllib { set code [catch {ChooseMech $token $mechanisms} result] if {!$code} { set state(mech) $result SASL::configure $state(token) -mech $state(mech) switch -glob -- $state(mech) { SCRAM-* - PLAIN - EXTERNAL - X-GOOGLE-TOKEN { # Initial responce set code [catch {SASL::step $state(token) ""} result] if {!$code} { set output [SASL::response $state(token)] } } default { set output "" } } if {!$code} { set result [list mechanism $state(mech) output $output] } } } } ::xmpp::Debug $xlib 2 "$token SASL code $code: $result" switch -- $code { 0 - 4 { array set resarray $result set data [::xmpp::xml::create auth \ -xmlns urn:ietf:params:xml:ns:xmpp-sasl \ -attrs [list mechanism $resarray(mechanism)] \ -cdata [base64::encode -maxlen 0 $resarray(output)]] ::xmpp::outXML $xlib $data } default { set str [::msgcat::mc "SASL auth error:\n%s" $result] Finish $token error \ [::xmpp::stanzaerror::error sasl undefined-condition \ -text $str] } } } proc ::xmpp::sasl::FindMechanisms {featuresList} { set saslFeature 0 set mechanisms {} foreach feature $featuresList { ::xmpp::xml::split $feature tag xmlns attrs cdata subels if {[string equal $xmlns urn:ietf:params:xml:ns:xmpp-sasl] && \ [string equal $tag mechanisms]} { set saslFeature 1 foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels if {[string equal $stag mechanism]} { lappend mechanisms $scdata } } } } if {$saslFeature} { return $mechanisms } else { return -code error } } ########################################################################## proc ::xmpp::sasl::ChooseMech {token mechanisms} { variable $token upvar 0 $token state set forbiddenMechs $state(-disable) if {$state(-digest) == 1} { lappend forbiddenMechs PLAIN LOGIN } elseif {$state(-digest) == 0} { foreach m [SASL::mechanisms] { switch -- $m { PLAIN - LOGIN {} default {lappend forbiddenMechs $m} } } } foreach m [SASL::mechanisms] { if {[lsearch -exact $mechanisms $m] >= 0 && \ [lsearch -exact $forbiddenMechs $m] < 0} { return $m } } if {[llength $mechanisms] == 0} { return -code error [::msgcat::mc "Server provided no SASL mechanisms"] } elseif {[llength $mechanisms] == 1} { return -code error [::msgcat::mc "Server provided mechanism\ %s. It is forbidden" \ [lindex $mechanisms 0]] } else { return -code error [::msgcat::mc "Server provided mechanisms\ %s. They are forbidden" \ [join $mechanisms ", "]] } } ########################################################################## proc ::xmpp::sasl::Step {token serverin64} { variable saslpack variable $token upvar 0 $token state set xlib $state(xlib) set serverin [base64::decode $serverin64] ::xmpp::Debug $xlib 2 "$token SASL challenge: $serverin" switch -- $saslpack { tclsasl { set code [catch { $state(token) \ -operation step \ -input $serverin \ -interact [namespace code [list Interact $token]] } result] } tcllib { set code [catch {SASL::step $state(token) $serverin} result] if {!$code} { set result [SASL::response $state(token)] } } } ::xmpp::Debug $xlib 2 "$token SASL code $code: $result" switch -- $code { 0 - 4 { set data [::xmpp::xml::create response \ -xmlns urn:ietf:params:xml:ns:xmpp-sasl \ -cdata [base64::encode -maxlen 0 $result]] ::xmpp::outXML $xlib $data } default { Finish $token error \ [::xmpp::stanzaerror::error sasl undefined-condition \ -text [::msgcat::mc "SASL step error: %s" $result]] } } } ########################################################################## proc ::xmpp::sasl::TclsaslCallbackUser {token data} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token $data" array set params $data switch -- $params(id) { user { # authzid return "" } authname { #username return [encoding convertto utf-8 $state(-username)] } pass { return [encoding convertto utf-8 $state(-password)] } getrealm { return [encoding convertto utf-8 $state(-server)] } default { return -code error \ [::msgcat::mc "SASL callback error: client needs to\ write \"%s\"" $params(id)] } } } proc ::xmpp::sasl::TclsaslCallbackComponent {token data} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token $data" array set params $data switch -- $params(id) { user { # authzid return "" } authname { #username return [encoding convertto utf-8 $state(-domain)] } pass { return [encoding convertto utf-8 $state(-secret)] } getrealm { return [encoding convertto utf-8 $state(-server)] } default { return -code error \ [::msgcat::mc "SASL callback error: client needs to\ write \"%s\"" $params(id)] } } } ########################################################################## proc ::xmpp::sasl::TcllibCallbackUser {token stoken command args} { variable encodeToUTF8 variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token $stoken $command" switch -- $command { login { # authzid return "" } username { switch -glob -- $state(mech)/$encodeToUTF8 { SCRAM-*/* - DIGEST-MD5/0 { return $state(-username) } default { return [encoding convertto utf-8 $state(-username)] } } } password { switch -glob -- $state(mech)/$encodeToUTF8 { SCRAM-*/* - DIGEST-MD5/0 { return $state(-password) } default { return [encoding convertto utf-8 $state(-password)] } } } realm { return [encoding convertto utf-8 $state(-server)] } hostname { return [info host] } default { return -code error \ [::msgcat::mc "SASL callback error: client needs to\ write \"%s\"" $command] } } } proc ::xmpp::sasl::TcllibCallbackComponent {token stoken command args} { variable encodeToUTF8 variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token $stoken $command" switch -- $command { login { # authzid return "" } username { switch -glob -- $state(mech)/$encodeToUTF8 { SCRAM-*/* - DIGEST-MD5/0 { return $state(-domain) } default { return [encoding convertto utf-8 $state(-domain)] } } } password { switch -glob -- $state(mech)/$encodeToUTF8 { SCRAM-*/* - DIGEST-MD5/0 { return $state(-secret) } default { return [encoding convertto utf-8 $state(-secret)] } } } realm { return [encoding convertto utf-8 $state(-server)] } hostname { return [info host] } default { return -code error \ [::msgcat::mc "SASL callback error: client needs to\ write \"%s\"" $command] } } } ########################################################################## proc ::xmpp::sasl::Interact {token data} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token $data" # empty } ########################################################################## proc ::xmpp::sasl::Failure {token xmlElements} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" set error [lindex $xmlElements 0] if {$error == ""} { set err not-authorized } else { ::xmpp::xml::split $error tag xmlns attrs cdata subels set err $tag } Finish $token error [::xmpp::stanzaerror::error sasl $err] } ########################################################################## proc ::xmpp::sasl::Success {token} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" # XMPP core section 6.2: # Upon receiving the element, # the initiating entity MUST initiate a new stream by sending an # opening XML stream header to the receiving entity (it is not # necessary to send a closing tag first... # Moreover, some servers (ejabberd) won't work if stream is closed. set state(reopenStream) \ [::xmpp::ReopenStream $xlib \ -command [namespace code [list Reopened $token]]] return } ########################################################################## proc ::xmpp::sasl::Reopened {token status sessionid} { variable $token upvar 0 $token state set xlib $state(xlib) unset state(reopenStream) ::xmpp::Debug $xlib 2 "$token $status $sessionid" if {![string equal $status ok]} { Finish $token $status [::xmpp::xml::create error -cdata $sessionid] return } ::xmpp::TraceStreamFeatures $xlib \ [namespace code [list ResumeSM $token]] return } proc ::xmpp::sasl::ResumeSM {token featuresList} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token $featuresList" if {![string equal $state(-sm) resume]} { ::xmpp::sm::reset [::xmpp::Set $xlib sm] ResourceBind $token $featuresList } else { ::xmpp::sm::resume [::xmpp::Set $xlib sm] \ -command [namespace code [list Finish \ $token]] } } proc ::xmpp::sasl::ResourceBind {token featuresList} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token $featuresList" if {[info exists state(-username)]} { foreach feature $featuresList { ::xmpp::xml::split $feature tag xmlns attrs cdata subels if {[string equal $xmlns urn:ietf:params:xml:ns:xmpp-bind] && \ [string equal $tag bind]} { if {[string equal $state(-resource) ""]} { set subelements {} } else { set subelements [list [::xmpp::xml::create resource \ -cdata $state(-resource)]] } set data [::xmpp::xml::create bind \ -xmlns $xmlns \ -subelements $subelements] set state(id) \ [::xmpp::sendIQ $xlib set \ -query $data \ -command [namespace code [list EnableSMClient \ $token \ $featuresList]]] return } } Finish $token abort "Can't bind resource" return } else { foreach feature $featuresList { ::xmpp::xml::split $feature tag xmlns attrs cdata subels if {[string equal $xmlns urn:xmpp:component] && \ [string equal $tag bind]} { set subelements [list [::xmpp::xml::create hostname \ -cdata $state(-domain)]] set data [::xmpp::xml::create bind \ -xmlns $xmlns \ -subelements $subelements] set state(id) \ [::xmpp::sendIQ $xlib set \ -query $data \ -command [namespace code [list EnableSMComponent \ $token \ $featuresList]]] return } } Finish $token abort "Can't bind hostname" return } } proc ::xmpp::sasl::EnableSMClient {token featuresList status xmlData} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$xmlData" if {![string equal $state(-sm) enable]} { SendSession $token $featuresList $status $xmlData } else { ::xmpp::sm::enable [::xmpp::Set $xlib sm] \ -resume 0 \ -command [namespace code [list SendSession \ $token \ $featuresList]] } } proc ::xmpp::sasl::EnableSMComponent {token featuresList status xmlData} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$xmlData" if {![string equal $state(-sm) enable]} { Finish $token $status $xmlData } else { ::xmpp::sm::enable [::xmpp::Set $xlib sm] \ -resume 0 \ -command [namespace code [list Finish $token]] } } proc ::xmpp::sasl::SendSession {token featuresList status xmlData} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$xmlData" switch -- $status { ok { # Store returned JID ::xmpp::xml::split $xmlData tag xmlns attrs cdata subels foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { jid { set state(jid) $scdata } } } foreach feature $featuresList { ::xmpp::xml::split $feature tag xmlns attrs cdata subels if {[string equal $xmlns urn:ietf:params:xml:ns:xmpp-session] && [string equal $tag session]} { # Establish the session. set data [::xmpp::xml::create session \ -xmlns urn:ietf:params:xml:ns:xmpp-session] set state(id) \ [::xmpp::sendIQ $xlib set \ -query $data \ -command [namespace code [list Finish $token]]] return } } Finish $token ok $xmlData } default { Finish $token $status $xmlData } } } ########################################################################## proc ::xmpp::sasl::Finish {token status xmlData} { variable saslpack variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) if {[info exists state(afterid)]} { after cancel $state(afterid) } ::xmpp::Unset $xlib abortCommand if {[string equal $status ok]} { if {[info exists state(jid)]} { set jid $state(jid) } elseif {[info exists state(-username)]} { set jid [::xmpp::jid::jid $state(-username) \ $state(-server) \ $state(-resource)] } else { set jid $state(-domain) } ::xmpp::Set $xlib jid $jid } ::xmpp::Debug $xlib 2 "$status" ::xmpp::UnregisterElement $xlib * urn:ietf:params:xml:ns:xmpp-sasl ::xmpp::UnregisterElement $xlib iq * if {[info exists state(token)]} { switch -- $saslpack { tclsasl { rename $state(token) "" } tcllib { SASL::cleanup $state(token) } } } # Cleanup in asynchronous mode if {[info exists state(-command)]} { set cmd $state(-command) unset state } if {[string equal $status ok]} { set msg $jid ::xmpp::CallBack $xlib status [::msgcat::mc "Authentication succeeded"] } else { set msg $xmlData ::xmpp::CallBack $xlib status [::msgcat::mc "Authentication failed"] } if {[info exists cmd]} { # Asynchronous mode uplevel #0 $cmd [list $status $msg] } else { # Synchronous mode # Trigger vwait in [auth] set state(status) [list $status $msg] } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/search.tcl000064400000000000000000000122271470446212700150710ustar00nobodynobody# search.tcl -- # # This file is a part of the XMPP library. It implements support for # Jabber search (XEP-0055). # # Copyright (c) 2008-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp package provide xmpp::search 0.1 namespace eval ::xmpp::search { namespace export request submit # Search fields (see XEP-0055) array set labels [list jid [::msgcat::mc "Jabber ID"] \ first [::msgcat::mc "First name"] \ last [::msgcat::mc "Last name"] \ nick [::msgcat::mc "Nickname"] \ email [::msgcat::mc "E-mail"]] } # ::xmpp::search::request -- proc ::xmpp::search::request {xlib jid args} { set commands {} foreach {key val} $args { switch -- $key { -command { set commands [list $val] } } } return [::xmpp::sendIQ $xlib get \ -query [::xmpp::xml::create query \ -xmlns jabber:iq:search] \ -to $jid \ -command [namespace code [list ParseForm $commands]]] } # ::xmpp::search::submit -- proc ::xmpp::search::submit {xlib jid fields args} { set old 0 set commands {} foreach {key val} $args { switch -- $key { -old { set old $val } -command { set commands [list $val] } } } if {!$old} { set subels [list [::xmpp::data::submitForm $fields]] } else { set subels [FillFields $fields] } return [::xmpp::sendIQ $xlib set \ -query [::xmpp::xml::create query \ -xmlns jabber:iq:search \ -subelements $subels] \ -to $jid \ -command [namespace code [list ParseResult $commands]]] } # ::xmpp::search::ParseForm -- proc ::xmpp::search::ParseForm {commands status xml} { if {[llength $commands] == 0} { return } if {![string equal $status ok]} { uplevel #0 [lindex $commands 0] [list $status $xml] return } ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach {type form} [::xmpp::data::findForm $subels] break if {[string equal $type form]} { set fields [::xmpp::data::parseForm $form] set old 0 } else { set fields [ParseFields $subels] set old 1 } uplevel #0 [lindex $commands 0] [list $status $fields -old $old] return } # ::xmpp::search::ParseFields -- proc ::xmpp::search::ParseFields {xmlElements} { variable labels set res {} foreach xml $xmlElements { ::xmpp::xml::split $xml tag xmlns attrs cdata subels switch -- $tag { instructions { set res [linsert $res 0 instructions $cdata] } x {} default { if {[info exists labels($tag)]} { set label $labels($tag) } else { set label "" } lappend res field \ [list $tag text-single $label "" 0 {} [list $cdata] {}] } } } return $res } # ::xmpp::search::FillFields -- proc ::xmpp::search::FillFields {fields} { set res {} foreach {var values} $fields { lappend res [::xmpp::xml::create $var -cdata [lindex $values 0]] } return $res } # ::xmpp::search::ParseResult -- proc ::xmpp::search::ParseResult {commands status xml} { if {[llength $commands] == 0} { return } if {![string equal $status ok]} { uplevel #0 [lindex $commands 0] [list $status $xml] return } ::xmpp::xml::split $xml tag xmlns attrs cdata subels foreach {type form} [::xmpp::data::findForm $subels] break if {[string equal $type result]} { set fields [::xmpp::data::parseResult $form] } else { set fields [ParseLegacyItems $subels] } uplevel #0 [lindex $commands 0] [list $status $fields] return } # ::xmpp::search::ParseLegacyItems -- proc ::xmpp::search::ParseLegacyItems {items} { variable labels set res {} set reported(jid) $labels(jid) foreach item $items { ::xmpp::xml::split $item tag xmlns attrs cdata subels switch -- $tag { item { set itemjid [::xmpp::xml::getAttr $attrs jid] set fields [list jid $itemjid] foreach field $subels { ::xmpp::xml::split $field stag sxmlns sattrs scdata ssubels lappend fields $stag $scdata if {[info exists labels($stag)]} { set reported($stag) $labels($stag) } else { set reported($stag) "" } } } } lappend res item $fields } return [linsert $res 0 reported [array get reported]] } # vim:ft=tcl:ts=8:sw=4:sts=4:et tclxmpp/xmpp/sm.tcl000064400000000000000000000402431470446212700142420ustar00nobodynobody# sm.tcl -- # # This file is part of the XMPP library. It provides support for the # Stream Management (XEP-0198) protocol. # # Copyright (c) 2015 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp::stanzaerror package provide xmpp::sm 0.1 namespace eval ::xmpp::sm {} # ::xmpp::sm::new -- # # Arguments: # xlib XMPP token. It must be connected and XMPP # stream must be opened. # # Result: # A control token is returned. # # Side effects: # A variable in ::xmpp::sm namespace is created and stream management # state is stored in it. proc ::xmpp::sm::new {xlib} { variable id if {![info exists id]} { set id 0 } set token [namespace current]::[incr id] variable $token upvar 0 $token state ::xmpp::Debug $xlib 2 "$token" set state(xlib) $xlib reset $token ::xmpp::RegisterElement $xlib * urn:xmpp:sm:3 \ [namespace code [list Parse $token]] return $token } proc ::xmpp::sm::reset {token} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" set state(count-in) 0 ; # Number of received stanzas set state(count-out) 0 ; # Number of acknowledged sent stanzas set state(queue) {} ; # Queue of unacknowledged yet sent stanzas set state(location) "" ; # Preferred resume location set state(id) "" ; # Stream ID for resumption set state(resume) 0 ; # Whether the server agree to resume the stream set state(max) 0 ; # Maximum resumption time (0 for infinity) set state(enabled) 0 ; # Whether the SM is enabled return } proc ::xmpp::sm::free {token} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" ::xmpp::UnregisterElement $xlib * urn:xmpp:sm:3 array unset state return } # ::xmpp::sm::enable -- # # Enable stream management for the specified connection. # # Arguments: # token SM token. The associated with it XMPP # stream must be opened and authenticated. # -command callback After successful or failed authentication # "callback" is invoked with two appended # arguments: status ("ok", "error", "abort" or # "timeout") and empty string if # status is "ok", or error stanza otherwise. # -resume boolean (optional, defaults to false) Whether to enable # stream resumption. # -timeout timeout (optional, defaults to 0 which means infinity) # Timeout (in milliseconds) for stream management # negotiation. # # Result: # Empty string. # # Side effects: # A continuation procedure is scheduled. proc ::xmpp::sm::enable {token args} { eval [list EnableResume $token enable] $args } # ::xmpp::sm::resume -- # # Resume XMPP stream using the stream management protocol for the # specified connection. # # Arguments: # token SM token. The associated with it XMPP # stream must be opened and authenticated. # -command callback After successful or failed authentication # "callback" is invoked with two appended # arguments: status ("ok", "error", "abort" or # "timeout") and empty string if # status is "ok", or error stanza otherwise. # -timeout timeout (optional, defaults to 0 which means infinity) # Timeout (in milliseconds) for stream management # negotiation. # # Result: # Empty string. # # Side effects: # A continuation procedure is scheduled. proc ::xmpp::sm::resume {token args} { eval [list EnableResume $token resume] $args } # ::xmpp::sm::EnableResume -- # # Enable or resume stream management for the specified connection. # # Arguments: # token SM token. The associated with it XMPP # stream must be opened and authenticated. # -command callback After successful or failed authentication # "callback" is invoked with two appended # arguments: status ("ok", "error", "abort" or # "timeout") and empty string if # status is "ok", or error stanza otherwise. # -resume boolean (optional, makes sense for enabling only, # defaults to false) Whether to enable # stream resumption. # -timeout timeout (optional, defaults to 0 which means infinity) # Timeout (in milliseconds) for stream management # negotiation. # # Result: # Empty string. # # Side effects: # A continuation procedure is scheduled. proc ::xmpp::sm::EnableResume {token mode args} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" ::xmpp::Set $xlib abortCommand [namespace code [list abort $token]] set state(mode) $mode catch {unset state(-command)} if {[string equal $mode enable]} { set state(-resume) 0 } set timeout 0 foreach {key val} $args { switch -- $key { -resume { if {[string equal $mode enable]} { set state(-resume) [string is true $val] } } -command { set state($key) $val } -timeout { set timeout $val } default { return -code error [::msgcat::mc "Illegal option \"%s\"" $key] } } } if {![info exists state(-command)]} { return -code error [::msgcat::mc "Option -command is mandatory"] } if {$timeout > 0} { set state(afterid) \ [after $timeout \ [namespace code \ [list AbortEnable $token timeout \ [::msgcat::mc "Stream management\ negotiation timed out"]]]] } ::xmpp::TraceStreamFeatures $xlib \ [namespace code [list Continue $token]] return } # ::xmpp::sm::abort -- # # Abort an existing stream management negotiation procedure, or do # nothing if it's already finished. # # Arguments: # token SM token. # # Result: # Empty string. # # Side effects: # In state of waiting for reply from server terminates waiting process. proc ::xmpp::sm::abort {token} { variable $token upvar 0 $token state AbortEnable $token abort [::msgcat::mc "Stream management\ negotiation aborted"] } # ::xmpp::sm::AbortEnable -- # # Abort an existing stream management negotiation procedure, or do # nothing if it's already finished. # # Arguments: # token Stream management control token which is returned by # ::xmpp::sm::new procedure. # status (error, abort or timeout) Status code of the abortion. # msg Error message. # # Result: # Empty string. # # Side effects: # In state of waiting for reply from server terminates waiting process. proc ::xmpp::sm::AbortEnable {token status msg} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" ::xmpp::RemoveTraceStreamFeatures $xlib \ [namespace code [list Continue $token]] Finish $token $status [::xmpp::xml::create error -cdata $msg] } # ::xmpp::sm::Continue -- # # A helper procedure which checks if there is a stream management feature # in a features list provided by server and continues or finishes the # negotiation. # # Arguments: # token SM control token. # featuresList XMPP features list from server. # # Result: # Empty string. # # Side effects: # Either a SM request is sent to server or negotiation is # finished with error. proc ::xmpp::sm::Continue {token featuresList} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" set smFeature 0 foreach feature $featuresList { ::xmpp::xml::split $feature tag xmlns attrs cdata subels switch -- $tag/$xmlns { sm/urn:xmpp:sm:3 { set smFeature 1 break } } } if {!$smFeature} { Finish $token error \ [::xmpp::stanzaerror::error modify not-acceptable -text \ [::msgcat::mc "Server hasn't provided stream management feature"]] return } if {[string equal $state(mode) enable]} { set state(count-in) 0 set state(count-out) 0 set state(queue) {} set state(location) "" set state(id) "" set state(max) 0 set state(resume) 0 set state(enabled) 0 set attrs {} if {$state(-resume)} { lappend attrs resume true } ::xmpp::outXML $xlib [::xmpp::xml::create enable \ -xmlns urn:xmpp:sm:3 \ -attrs $attrs] } else { set state(enabled) 0 if {!$state(resume)} { Finish $token error \ [::xmpp::stanzaerror::error cancel item-not-found] return } ::xmpp::outXML $xlib [::xmpp::xml::create resume \ -xmlns urn:xmpp:sm:3 \ -attrs [list h $state(count-in) \ previd $state(id)]] } } # ::xmpp::sm::Parse -- # # Parse XML elemens in urn:xmpp:sm:3 namespace. They # indicate the result of negotiation procedure (success or failure). # # Arguments: # token SM control token. # xmlElement Top-level XML stanza. # # Result: # Empty string. # # Side effects: # A corresponding procedure is called in cases of successful or failed # sm negotiation. proc ::xmpp::sm::Parse {token xmlElement} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels switch -- $tag { enabled { set state(enabled) 1 foreach {attr val} $attrs { switch -- $attr { id - max - location { set state($attr) $val } resume { set state(resume) [string is true $val] } } } Finish $token ok $xmlElement } resumed { set state(enabled) 1 foreach {attr val} $attrs { switch -- $attr { h { set qc [PullFromQueue $xlib \ $state(queue) \ $state(count-out) \ $val] set state(queue) [lindex $qc 0] set state(count-out) [lindex $qc 1] } previd { # TODO: Check if IDs match set state(id) $val } } } Finish $token ok $xmlElement } failed { set state(enabled) 0 Failed $token $subels } a { set qc [PullFromQueue $xlib \ $state(queue) \ $state(count-out) \ [::xmpp::xml::getAttr $attrs h]] set state(queue) [lindex $qc 0] set state(count-out) [lindex $qc 1] } r { ::xmpp::outXML $xlib \ [::xmpp::xml::create a \ -xmlns urn:xmpp:sm:3 \ -attrs [list h $state(count-in)]] } } } proc ::xmpp::sm::PullFromQueue {xlib queue countold countnew} { set countnew [expr {$countnew % (1<<32)}] if {$countnew < $countold} { set countold [expr {$countold - (1<<32)}] } for {set i $countold} {$i < $countnew} {incr i} { set xmlElement [lindex $queue 0] ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels set id [::xmpp::xml::getAttr $attrs id] if {[string equal $tag message] && ![string equal $id ""]} { # TODO: Should we call back for presence and IQ as well? ::xmpp::CallBack $xlib sm ack $id } set queue [lreplace $queue 0 0] } list $queue $countnew } proc ::xmpp::sm::count {token mode xmlElement} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" if {!$state(enabled)} return ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels switch -- $tag { iq - presence - message { if {[string equal $mode in]} { set state(count-in) [expr {($state(count-in) + 1) % (1<<32)}] } else { # TODO: Add a delay subelement lappend state(queue) $xmlElement ::xmpp::outXML $xlib [::xmpp::xml::create r \ -xmlns urn:xmpp:sm:3] } } } } # ::xmpp::sm::Failed -- # # A helper procedure which is called if SM negotiations failed. It # finishes SM procedure with error. # # Arguments: # token SM control token. # xmlElements Subelements of element which include error. # # Result: # Empty string. # # Side effects: # SM negotiation is finished with error. proc ::xmpp::sm::Failed {token xmlElements} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" set error [lindex $xmlElements 0] if {[string equal $error ""]} { set err [::xmpp::stanzaerror::error modify undefined-condition \ -text [::msgcat::mc "Stream management negotiation failed"]] } else { ::xmpp::xml::split $error tag xmlns attrs cdata subels set err [::xmpp::stanzaerror::error modify $tag] } Finish $token error $err } # ::xmpp::sm::Finish -- # # A hepler procedure which finishes negotiation process. # # Arguments: # token SM control token. # status Status of the negotiations ("ok" means success). # xmlData Either a returned enabled stanza if status is ok or # error stanza. # # Result: # Empty string. # # Side effects: # A callback is called. proc ::xmpp::sm::Finish {token status xmlData} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) if {[info exists state(afterid)]} { after cancel $state(afterid) unset state(afterid) } ::xmpp::Unset $xlib abortCommand ::xmpp::Debug $xlib 2 "$token $status" if {[string equal $status ok]} { ::xmpp::CallBack $xlib status [::msgcat::mc "Stream management negotiation successful"] } else { ::xmpp::CallBack $xlib status [::msgcat::mc "Stream management negotiation failed"] } if {[info exists state(-command)]} { uplevel #0 $state(-command) [list $status $xmlData] unset state(-command) } } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/socks4.tcl000064400000000000000000000211101470446212700150210ustar00nobodynobody# socks4.tcl --- # # Package for using the SOCKS4a method for connecting TCP sockets. # Only client side. # # Copyright (c) 2007 Mats Bengtsson # Copyright (c) 2007-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require pconnect package require msgcat package provide pconnect::socks4 0.1 namespace eval ::pconnect::socks4 { namespace export connect variable const array set const { ver \x04 cmd_connect \x01 cmd_bind \x02 rsp_granted \x5a rsp_failure \x5b rsp_errconnect \x5c rsp_erruserid \x5d } variable msg array set msg [list \ 91 [::msgcat::mc "Request rejected or failed"] \ 92 [::msgcat::mc "Server cannot reach client's identd"] \ 93 [::msgcat::mc "Client's identd could not confirm the userid"]] variable debug 0 ::pconnect::register socks4 \ [namespace current]::connect \ [namespace current]::abort } # ::pconnect::socks4::connect -- # # Negotiates with a SOCKS server. # # Arguments: # sock an open socket to the SOCKS server # addr the peer address, not SOCKS server # port the peer's port number # args # -command tclProc {token status} # -username userid # -timeout millisecs (default 60000) # # Results: # The connect socket or error if no -command, else a connection token. # # Side effects: # Socket is prepared for data transfer. # If -command specified, the callback tclProc is called with # status ok and socket or error and error message. proc ::pconnect::socks4::connect {sock addr port args} { variable const set token [namespace current]::$sock variable $token upvar 0 $token state array set state { -command "" -timeout 60000 -username "" async 0 bnd_addr "" bnd_port "" status "" } array set state [list addr $addr \ port $port \ sock $sock] array set state $args if {![string equal $state(-command) ""]} { set state(async) 1 } # Network byte-ordered port (2 binary-bytes, short) set bport [binary format S $port] # This corresponds to IP address 0.0.0.x, with x nonzero. set bip \x00\x00\x00\x01 set bdata "$const(ver)$const(cmd_connect)$bport$bip" append bdata "$state(-username)\x00$addr\x00" fconfigure $sock -translation binary -blocking 0 fileevent $sock writable {} if {[catch { puts -nonewline $sock $bdata flush $sock } err]} { catch {close $sock} if {$state(async)} { after idle $state(-command) \ [list error [::msgcat::mc "Failed to send SOCKS4a request"]] Free $token return } else { Free $token return -code error [::msgcat::mc "Failed to send SOCKS4a request"] } } # Setup timeout timer. if {$state(-timeout) > 0} { set state(timeoutid) \ [after $state(-timeout) [namespace code [list Timeout $token]]] } fileevent $sock readable \ [namespace code [list Response $token]] if {$state(async)} { return $token } else { # We should not return from this proc until finished! vwait $token\(status) set status $state(status) set sock $state(sock) Free $token if {[string equal $status ok]} { return $sock } else { catch {close $sock} if {[string equal $status abort]} { return -code break $sock } else { return -code error $sock } } } } # ::pconnect::socks4::abort -- # # Abort proxy negotiation. # # Arguments: # token A connection token. # # Result: # An empty string. # # Side effects: # A proxy negotiation is finished with error. proc ::pconnect::socks4::abort {token} { Finish $token abort [::msgcat::mc "SOCKS4a proxy negotiation aborted"] return } # ::pconnect::socks4::Response -- # # Receive the reply from a proxy and finish the negotiations. # # Arguments: # token A connection token. # # Result: # An empty string. # # Side effects: # The negotiation is finished with either success or error. proc ::pconnect::socks4::Response {token} { variable $token upvar 0 $token state variable const variable msg Debug $token 2 "" set sock $state(sock) fileevent $sock readable {} # Read and parse status. if {[catch {read $sock 2} data] || [eof $sock]} { Finish $token error [::msgcat::mc "Failed to read SOCKS4a response"] return } binary scan $data cc null status if {![string equal $null 0]} { Finish $token error [::msgcat::mc "Incorrect SOCKS4a server version"] return } if {$status == 90} { # ok } elseif {[info exists msg($status)]} { Finish $token error $msg($status) return } else { Finish $token error [::msgcat::mc "Unknown SOCKS4a server error"] return } # Read and parse port (2 bytes) and ip (4 bytes). if {[catch {read $sock 6} data] || [eof $sock]} { Finish $token error [::msgcat::mc "Failed to read SOCKS4a\ destination address"] return } binary scan $data ccccS i0 i1 i2 i3 port set addr {} foreach n [list $i0 $i1 $i2 $i3] { # Translate to unsigned! lappend addr [expr {$n & 0xff}] } # Translate to unsigned! set port [expr {$port & 0xffff}] set state(bnd_addr) [join $addr .] set state(bnd_port) $port Finish $token ok return } # ::pconnect::socks4::Timeout -- # # This proc is called in case of timeout. # # Arguments: # token A connection token. # # Result: # An empty string. # # Side effects: # A proxy negotiation is finished with error. proc ::pconnect::socks4::Timeout {token} { Finish $token timeout [::msgcat::mc "SOCKS4a proxy negotiation timed out"] return } # ::pconnect::socks4::Free -- # # Frees a connection token. # # Arguments: # token A connection token. # # Result: # An empty string. # # Side effects: # A connection token and its state informationa are destroyed. proc ::pconnect::socks4::Free {token} { variable $token upvar 0 $token state catch {after cancel $state(timeoutid)} catch {unset state} return } # ::pconnect::socks4::Finish -- # # Finishes a negotiation process. # # Arguments: # token A connection token. # errormsg (optional) error message. # # Result: # An empty string. # # Side effects: # If connection is asynchronous then a callback is executed. # Otherwise state(status) is set to allow ::pconnect::socks4::connect # to return with either success or error. proc ::pconnect::socks4::Finish {token status {errormsg ""}} { variable $token upvar 0 $token state catch {after cancel $state(timeoutid)} Debug $token 2 "status=$status, errormsg=$errormsg" if {$state(async)} { # In case of asynchronous connection we do the cleanup. set command $state(-command) set sock $state(sock) Free $token if {[string equal $status ok]} { uplevel #0 $command [list ok $sock] } else { catch {close $sock} uplevel #0 $command [list $status $errormsg] } } else { # Otherwise we trigger state(status). if {[string equal $status ok]} { set state(status) ok } else { catch {close $state(sock)} set state(sock) $errormsg set state(status) $status } } return } # ::pconnect::socks4::Debug -- # # Prints debug information. # # Arguments: # token Token. # num Debug level. # str Debug message. # # Result: # An empty string. # # Side effects: # A debug message is printed to the console if the value of # ::pconnect::socks4::debug variable is not less than num. proc ::pconnect::socks4::Debug {token level str} { variable debug if {$debug >= $level} { puts "[lindex [info level -1] 0] $token: $str" } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/socks5.tcl000064400000000000000000000451601470446212700150350ustar00nobodynobody# socks5.tcl --- # # Package for using the SOCKS5 method for connecting TCP sockets. # Some code plus idee from Kerem 'Waster_' Hadimli. # Made from RFC 1928. # # Copyright (c) 2000 Kerem Hadimli # Copyright (c) 2003-2007 Mats Bengtsson # Copyright (c) 2007-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require pconnect package require ip package require msgcat package provide pconnect::socks5 0.1 namespace eval ::pconnect::socks5 { namespace export connect # Constants: # ver: Socks version # nomatchingmethod: No matching methods # cmd_connect: Connect command # rsv: Reserved # atyp_*: Address type # auth_*: Authorication version variable const array set const { ver \x05 auth_no \x00 auth_gssapi \x01 auth_userpass \x02 nomatchingmethod \xFF cmd_connect \x01 cmd_bind \x02 rsv \x00 atyp_ipv4 \x01 atyp_domainname \x03 atyp_ipv6 \x04 } variable msg array set msg [list \ 1 [::msgcat::mc "General SOCKS server failure"] \ 2 [::msgcat::mc "Connection not allowed by ruleset"] \ 3 [::msgcat::mc "Network unreachable"] \ 4 [::msgcat::mc "Host unreachable"] \ 5 [::msgcat::mc "Connection refused by destination host"] \ 6 [::msgcat::mc "TTL expired"] \ 7 [::msgcat::mc "Command not supported"] \ 8 [::msgcat::mc "Address type not supported"]] variable debug 0 ::pconnect::register socks5 \ [namespace current]::connect \ [namespace current]::abort } # ::pconnect::socks5::connect -- # # Negotiates with a SOCKS server. # # Arguments: # sock an open socket to the SOCKS5 server # addr the peer address, not SOCKS5 server # port the peer's port number # args # -command tclProc {status socket} # -username username # -password password # -timeout millisecs (default 60000) # # Results: # The connect socket or error if no -command, else a connection token. # # Side effects: # Socket is prepared for data transfer. # If -command specified, the callback tclProc is called with # status ok and socket or error and error message. proc ::pconnect::socks5::connect {sock addr port args} { variable msg variable const # Initialize the state variable, an array. We'll return the # name of this array as the token for the transaction. set token [namespace current]::$sock variable $token upvar 0 $token state Debug $token 2 "$addr $port $args" array set state { -password "" -timeout 60000 -username "" -command "" async 0 auth 0 bnd_addr "" bnd_port "" state "" status "" } array set state [list addr $addr \ port $port \ sock $sock] array set state $args if {[string length $state(-username)] || \ [string length $state(-password)]} { set state(auth) 1 } if {![string equal $state(-command) ""]} { set state(async) 1 } if {$state(auth)} { set methods "$const(auth_no)$const(auth_userpass)" } else { set methods "$const(auth_no)" } set nmethods [binary format c [string length $methods]] fconfigure $sock -translation {binary binary} -blocking 0 fileevent $sock writable {} Debug $token 2 "send: ver nmethods methods" # Request authorization methods if {[catch { puts -nonewline $sock "$const(ver)$nmethods$methods" flush $sock } err]} { catch {close $sock} if {$state(async)} { after idle $state(-command) \ [list error [::msgcat::mc "Failed to send SOCKS5\ authorization methods request"]] Free $token return } else { Free $token return -code error [::msgcat::mc "Failed to send SOCKS5\ authorization methods request"] } } # Setup timeout timer. if {$state(-timeout) > 0} { set state(timeoutid) \ [after $state(-timeout) [namespace code [list Timeout $token]]] } fileevent $sock readable \ [namespace code [list ResponseMethod $token]] if {$state(async)} { return $token } else { # We should not return from this proc until finished! vwait $token\(status) set status $state(status) set sock $state(sock) Free $token if {[string equal $status ok]} { return $sock } else { catch {close $sock} if {[string equal $status abort]} { return -code break $sock } else { return -code error $sock } } } } # ::pconnect::socks5::abort -- # # Abort proxy negotiation. # # Arguments: # token A connection token. # # Result: # An empty string. # # Side effects: # A proxy negotiation is finished with error. proc ::pconnect::socks5::abort {token} { Finish $token abort [::msgcat::mc "SOCKS5 proxy negotiation aborted"] return } # ::pconnect::socks5::ResponseMethod -- # # Receive the reply from a proxy and choose authorization method. # # Arguments: # token A connection token. # # Result: # An empty string. # # Side effects: # The negotiation is finished with error or continues with chosen # method. proc ::pconnect::socks5::ResponseMethod {token} { variable $token variable const upvar 0 $token state Debug $token 2 "" set sock $state(sock) if {[catch {read $sock 2} data] || [eof $sock]} { Finish $token error [::msgcat::mc "Failed to read SOCKS5\ authorization methods response"] return } set serv_ver "" set method $const(nomatchingmethod) binary scan $data cc serv_ver smethod Debug $token 2 "serv_ver=$serv_ver, smethod=$smethod" if {![string equal $serv_ver 5]} { Finish $token error [::msgcat::mc "Incorrect SOCKS5 server version"] return } if {[string equal $smethod 0]} { # Now, request address and port. Request $token } elseif {[string equal $smethod 2]} { # User/Pass authorization required if {$state(auth) == 0} { Finish $token error [::msgcat::mc "SOCKS5 server authorization required"] return } # Username & Password length (binary 1 byte) set ulen [binary format c [string length $state(-username)]] set plen [binary format c [string length $state(-password)]] Debug $token 2 "send: auth_userpass ulen -username plen -password" if {[catch { puts -nonewline $sock \ "$const(auth_userpass)$ulen$state(-username)$plen$state(-password)" flush $sock } err]} { Finish $token error [::msgcat::mc "Failed to send SOCKS5\ authorization request"] return } fileevent $sock readable \ [namespace code [list ResponseAuth $token]] } else { Finish $token error [::msgcat::mc "Unsupported SOCKS5 authorization method"] return } return } # ::pconnect::socks5::ResponseAuth -- # # Receive the authorization reply from a proxy. # # Arguments: # token A connection token. # # Result: # An empty string. # # Side effects: # The negotiation is finished with error or continues with address and # port request. proc ::pconnect::socks5::ResponseAuth {token} { variable $token upvar 0 $token state Debug $token 2 "" set sock $state(sock) if {[catch {read $sock 2} data] || [eof $sock]} { Finish $token error [::msgcat::mc "Failed to read SOCKS5\ authorization response"] return } set auth_ver -1 set status -1 binary scan $data cc auth_ver status Debug $token 2 "auth_ver=$auth_ver, status=$status" if {![string equal $auth_ver 1]} { Finish $token error [::msgcat::mc "Unsupported SOCKS5 authorization method"] return } if {![string equal $status 0]} { Finish $token error [::msgcat::mc "SOCKS5 server authorization failed"] return } # Now, request address and port. Request $token return } # ::pconnect::socks5::Request -- # # Request connect to specified address and port. # # Arguments: # token A connection token. # # Result: # An empty string. # # Side effects: # The negotiation is finished with error or continues with address and # port request. proc ::pconnect::socks5::Request {token} { variable $token variable const upvar 0 $token state Debug $token 2 "" set sock $state(sock) # Network byte-ordered port (2 binary-bytes, short) set bport [binary format S $state(port)] # Figure out type of address given to us. if {[ip::version $state(addr)] == 4} { Debug $token 2 "ipv4" # IPv4 numerical address. set atyp_addr_port $const(atyp_ipv4) foreach i [split [ip::normalize $state(addr)] .] { append atyp_addr_port [binary format c $i] } append atyp_addr_port $bport } elseif {[ip::version $state(addr)] == 6} { Debug $token 2 "ipv6" # IPv6 numerical address. set atyp_addr_port $const(atyp_ipv6) foreach i [split [ip::normalize $state(addr)] :] { append atyp_addr_port [binary format S 0x$i] } append atyp_addr_port $bport } else { Debug $token 2 "domainname" # Domain name. # Domain length (binary 1 byte) set dlen [binary format c [string length $state(addr)]] set atyp_addr_port "$const(atyp_domainname)$dlen$state(addr)$bport" } # We send request for connect Debug $token 2 "send: ver cmd_connect rsv atyp_domainname dlen addr port" set aconst "$const(ver)$const(cmd_connect)$const(rsv)" if {[catch { puts -nonewline $sock "$aconst$atyp_addr_port" flush $sock } err]} { Finish $token error [::msgcat::mc "Failed to send SOCKS5 connection request"] return } fileevent $sock readable \ [namespace code [list Response $token]] return } # ::pconnect::socks5::Response -- # # Receive the final reply from a proxy and finish the negotiations. # # Arguments: # token A connection token. # # Result: # An empty string. # # Side effects: # The negotiation is finished with either success or error. proc ::pconnect::socks5::Response {token} { variable msg variable $token upvar 0 $token state Debug $token 2 "" set sock $state(sock) fileevent $sock readable {} # Start by reading ver+cmd+rsv. if {[catch {read $sock 3} data] || [eof $sock]} { Finish $token error [::msgcat::mc "Failed to read SOCKS5 connection response"] return } set serv_ver "" set rep "" binary scan $data ccc serv_ver rep rsv if {![string equal $serv_ver 5]} { Finish $token error [::msgcat::mc "Incorrect SOCKS5 server version"] return } if {$rep == 0} { # ok } elseif {[info exists msg($rep)]} { Finish $token error $msg($rep) return } else { Finish $token error [::msgcat::msg "Unknown SOCKS5 server error"] return } # Now parse the variable length atyp+addr+host. if {[catch {ParseAtypAddr $token addr port} err]} { Finish $token error $err return } # Store in our state array. set state(bnd_addr) $addr set state(bnd_port) $port # And finally let the client know that the bytestream is set up. Finish $token ok return } # ::pconnect::socks5::ParseAtypAddr -- # # Receive and parse destination address type and IP or name. # # Arguments: # token A connection token. # addrVar A variable for destination address. # portVar A variable for destination port. # # Result: # An empty string or error if address and port can't be parsed. # # Side effects: # The address type and IP or name is read from the socket. proc ::pconnect::socks5::ParseAtypAddr {token addrVar portVar} { variable $token variable const upvar 0 $token state upvar 1 $addrVar addr upvar 1 $portVar port Debug $token 2 "" set sock $state(sock) # Start by reading atyp. if {[catch {read $sock 1} data] || [eof $sock]} { return -code error [::msgcat::mc "Failed to read SOCKS5\ destination address type"] } set atyp "" binary scan $data c atyp Debug $token 2 "atyp=$atyp" # Treat the three address types in order. switch -- $atyp { 1 { # IPv4 if {[catch {read $sock 6} data] || [eof $sock]} { return -code error [::msgcat::mc "Failed to read SOCKS5\ destination IPv4 address\ and port"] } binary scan $data ccccS i0 i1 i2 i3 port set addr {} foreach n [list $i0 $i1 $i2 $i3] { # Translate to unsigned! lappend addr [expr {$n & 0xff}] } set addr [join $addr .] # Translate to unsigned! set port [expr {$port & 0xffff}] } 3 { # Domain if {[catch {read $sock 1} data] || [eof $sock]} { return -code error [::msgcat::mc "Failed to read SOCKS5\ destination domain\ length"] } binary scan $data c len Debug $token 2 "len=$len" set len [expr {$len & 0xff}] if {[catch {read $sock $len} data] || [eof $sock]} { return -code error [::msgcat::mc "Failed to read SOCKS5\ destination domain"] } set addr $data Debug $token 2 "addr=$addr" if {[catch {read $sock 2} data] || [eof $sock]} { return -code error [::msgcat::mc "Failed to read SOCKS5\ destination port"] } binary scan $data S port # Translate to unsigned! set port [expr {$port & 0xffff}] Debug $token 2 "port=$port" } 4 { # IPv6 if {[catch {read $sock 18} data] || [eof $sock]} { return -code error [::msgcat::mc "Failed to read SOCKS5\ destination IPv6 address\ and port"] } binary scan $data SSSSSSSSS s0 s1 s2 s3 s4 s5 s6 s7 s8 port set addr {} foreach n [list $s0 $s1 $s2 $s3 $s4 $s5 $s6 $s7 $s8] { # Translate to unsigned! lappend addr [format %x [expr {$n & 0xffff}]] } set addr [join $addr :] # Translate to unsigned! set port [expr {$port & 0xffff}] } default { return -code error [::msgcat::mc "Unknown SOCKS5 destination\ address type"] } } } proc ::pconnect::socks5::GetIpAndPort {token} { variable $token upvar 0 $token state return [list $state(bnd_addr) $state(bnd_port)] } # ::pconnect::socks5::Timeout -- # # This proc is called in case of timeout. # # Arguments: # token A connection token. # # Result: # An empty string. # # Side effects: # A proxy negotiation is finished with error. proc ::pconnect::socks5::Timeout {token} { Finish $token timeout [::msgcat::mc "SOCKS5 negotiation timed out"] return } # ::pconnect::socks5::Free -- # # Frees a connection token. # # Arguments: # token A connection token. # # Result: # An empty string. # # Side effects: # A connection token and its state informationa are destroyed. proc ::pconnect::socks5::Free {token} { variable $token upvar 0 $token state catch {after cancel $state(timeoutid)} catch {unset state} } # ::pconnect::socks5::Finish -- # # Finishes a negotiation process. # # Arguments: # token A connection token. # errormsg (optional) error message. # # Result: # An empty string. # # Side effects: # If connection is asynchronous then a callback is executed. # Otherwise state(status) is set to allow ::pconnect::socks5::connect # to return with either success or error. proc ::pconnect::socks5::Finish {token status {errormsg ""}} { variable $token upvar 0 $token state catch {after cancel $state(timeoutid)} Debug $token 2 "status=$status, errormsg=$errormsg" if {$state(async)} { # In case of asynchronous connection we do the cleanup. set command $state(-command) set sock $state(sock) Free $token if {[string equal $status ok]} { uplevel #0 $command [list ok $sock] } else { catch {close $sock} uplevel #0 $command [list $status $errormsg] } } else { # Otherwise we trigger state(status). if {[string equal $status ok]} { set state(status) ok } else { catch {close $state(sock)} set state(sock) $errormsg set state(status) $status } } return } # ::pconnect::socks5::Debug -- # # Prints debug information. # # Arguments: # token Token. # level Debug level. # str Debug message. # # Result: # An empty string. # # Side effects: # A debug message is printed to the console if the value of # ::pconnect::socks5::debug variable is not less than num. proc ::pconnect::socks5::Debug {token level str} { variable debug if {$debug >= $level} { puts "[lindex [info level -1] 0] $token: $str" } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/stanzaerror.tcl000064400000000000000000000314661470446212700162040ustar00nobodynobody# stanzaerror.tcl -- # # This file is part of the XMPP library. It provides routines for # parsing and generating XMPP stanza errors. For legacy errors XEP-0086 # rules are used. # # Copyright (c) 2008-2011 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package provide xmpp::stanzaerror 0.1 namespace eval ::xmpp::stanzaerror { namespace export registerType registerError type condition message error # Defined error types (see XMPP core, section 9.3.2) array set Type [list \ cancel [::msgcat::mc "Unrecoverable error"] \ continue [::msgcat::mc "Warning"] \ modify [::msgcat::mc "Request error"] \ auth [::msgcat::mc "Authorization error"] \ wait [::msgcat::mc "Temporary error"]] set DefinedConditions {} # Defined error conditions (see XMPP core, section 9.3.3, and XEP-0086). foreach {clist lcode type cond description} [list \ {400} 400 modify bad-request [::msgcat::mc "Bad request"] \ {409} 409 cancel conflict [::msgcat::mc "Conflict"] \ {501} 501 cancel feature-not-implemented [::msgcat::mc "Feature not\ implemented"] \ {403} 403 auth forbidden [::msgcat::mc "Forbidden"] \ {302} 302 modify gone [::msgcat::mc "Gone"] \ {500} 500 wait internal-server-error [::msgcat::mc "Internal server\ error"] \ {404} 404 cancel item-not-found [::msgcat::mc "Item not\ found"] \ {} 400 modify jid-malformed [::msgcat::mc "JID\ malformed"] \ {406} 406 modify not-acceptable [::msgcat::mc "Not\ acceptable"] \ {405} 405 cancel not-allowed [::msgcat::mc "Not allowed"] \ {401} 401 auth not-authorized [::msgcat::mc "Not\ authorized"] \ {402} 402 auth payment-required [::msgcat::mc "Payment\ required"] \ {} 404 wait recipient-unavailable [::msgcat::mc "Recipient\ unavailable"] \ {} 302 modify redirect [::msgcat::mc "Redirect"] \ {407} 407 auth registration-required [::msgcat::mc "Registration\ required"] \ {} 404 cancel remote-server-not-found [::msgcat::mc "Remote server\ not found"] \ {408 504} \ 504 wait remote-server-timeout [::msgcat::mc "Remote server\ timeout"] \ {} 500 wait resource-constraint [::msgcat::mc "Resource\ constraint"] \ {502 503 510} \ 503 cancel service-unavailable [::msgcat::mc "Service\ unavailable"] \ {} 407 auth subscription-required [::msgcat::mc "Subscription\ required"] \ {} 500 any undefined-condition [::msgcat::mc "Undefined\ condition"] \ {} 400 wait unexpected-request [::msgcat::mc "Unexpected\ request"]] \ { lappend DefinedConditions $cond set Description($type,$cond) $description # XEP-0086 foreach code $clist { set TypeDescelem($code) [list $type $cond] } set LegacyCodes($cond) $lcode } # Error messages from jabberd14 # [::msgcat::mc "Access Error"] # [::msgcat::mc "Address Error"] # [::msgcat::mc "Application Error"] # [::msgcat::mc "Format Error"] # [::msgcat::mc "Not Found"] # [::msgcat::mc "Not Implemented"] # [::msgcat::mc "Recipient Error"] # [::msgcat::mc "Remote Server Error"] # [::msgcat::mc "Request Timeout"] # [::msgcat::mc "Server Error"] # [::msgcat::mc "Unauthorized"] # [::msgcat::mc "Username Not Available"] } # ::xmpp::stanzaerror::registerType -- # # Register additional stanza error type (e.g. for SASL errors). # # Arguments: # type Error type. # description Error type human-readable description. # # Result: # Empty string. # # Side effects: # A new error type and description are stored. proc ::xmpp::stanzaerror::registerType {type description} { variable Type set Type($type) $description return } # ::xmpp::stanzaerror::registerError -- # # Register additional stanza error (pair type-condition). # # Arguments: # lcode Legacy code for the error. If zero then [error] will # not add the code to error stanza. # type Error type. # cond Error condition. # description Error human-readable description. # # Result: # Empty string. # # Side effects: # A new error type, condition and description are stored. Also, a legacy # error code is assigned to the specified error. proc ::xmpp::stanzaerror::registerError {lcode type cond description} { variable DefinedConditions variable Description lappend DefinedConditions $cond set Description($type,$cond) $description set LegacyCodes($cond) $lcode return } # ::xmpp::stanzaerror::type -- # # Return XMPP stanza error type. # # Arguments: # xmlElement Stanza error XML element. # # Result: # Error type. # # Side effects: # None. proc ::xmpp::stanzaerror::type {xmlElement} { return [lindex [ToList $xmlElement] 0] } # ::xmpp::stanzaerror::condition -- # # Return XMPP stanza error condition. # # Arguments: # xmlElement Stanza error XML element. # # Result: # Error condition. # # Side effects: # None. proc ::xmpp::stanzaerror::condition {xmlElement} { return [lindex [ToList $xmlElement] 1] } # ::xmpp::stanzaerror::message -- # # Return XMPP stanza error human-readable message. # # Arguments: # xmlElement Stanza error XML element. # # Result: # Error message. # # Side effects: # None. proc ::xmpp::stanzaerror::message {xmlElement} { return [lindex [ToList $xmlElement] 2] } # ::xmpp::stanzaerror::ToList -- # # Convert XMPP stanza error to a list of error type, condition and # readable message. # # Arguments: # xmlElement Stanza error XML element. # # Result: # A tuple {type, condition, message}. # # Side effects: # None. proc ::xmpp::stanzaerror::ToList {xmlElement} { variable Type variable DefinedConditions variable Description variable TypeDescelem ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels if {[::xmpp::xml::isAttr $attrs type]} { # XMPP error set type [::xmpp::xml::getAttr $attrs type] set cond undefined-condition set description "" set textdescription "" foreach subel $subels { ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { text { if {[string equal $sxmlns \ urn:ietf:params:xml:ns:xmpp-stanzas]} { set textdescription ": $scdata" } } undefined-condition { # TODO set description $Description(any,undefined-condition) } default { if {[lsearch -exact $DefinedConditions $stag] >= 0} { set cond $stag if {[info exists Description($type,$stag)] && \ [string equal $description ""]} { set description $Description($type,$stag) } } else { # TODO } } } } if {[info exists Type($type)]} { set typedesc $Type($type) } set res "" if {![string equal $description ""]} { set res $description } if {[info exists typedesc] && ![string equal $typedesc ""]} { if {[string equal $res ""]} { set res $typedesc } else { set res "$typedesc ($res)" } } return [list $type $cond "$res$textdescription"] } elseif {[::xmpp::xml::isAttr $attrs code]} { # Legacy error. Description is in $cdata set code [::xmpp::xml::getAttr $attrs code] if {[string is integer -strict $code]} { if {[info exists TypeDescelem($code)]} { set type [lindex $TypeDescelem($code) 0] set desc [lindex $TypeDescelem($code) 1] } else { set type none set desc none } return [list $type $desc "$code ([::msgcat::mc $cdata])"] } else { return [list none none [::msgcat::mc $cdata]] } } else { return [list none none [::msgcat::mc $cdata]] } } # ::xmpp::stanzaerror::error -- # # Create error stanza. # # Arguments: # type Error type. # cond Error condition. # -old boolean Create legacy error if true. # -text text Human readable description. # -application-specific xml Application-specific error condition. # # Result: # Generated error XML element. # # Side effects: # None. proc ::xmpp::stanzaerror::error {type cond args} { set old 0 foreach {key val} $args { switch -- $key { -old { set old $val } } } if {$old} { return [eval [list LegacyError $type $cond] $args] } else { return [eval [list XMPPError $type $cond] $args] } } # ::xmpp::stanzaerror::LegacyError -- # # Create legacy (pre-XMPP) error stanza. # # Arguments: # type Error type. # cond Error condition. # -text text Human readable description. # # Result: # Generated pre-XMPP error XML element which corresponds to specified # XMPP error type and condition. # # Side effects: # None. proc ::xmpp::stanzaerror::LegacyError {type cond args} { variable LegacyCodes variable Description if {[info exists LegacyCodes($cond)] && $LegacyCodes($cond) > 0} { set code $LegacyCodes($cond) } else { set code 503 } if {[info exists Description($type,$cond)]} { set description $Description($type,$cond) } else { set description "" } foreach {opt val} $args { switch -- $opt { -text { set description $val } } } return [::xmpp::xml::create error -attrs [list code $code] \ -cdata $description] } # ::xmpp::stanzaerror::XMPPError -- # # Create XMPP error stanza. # # Arguments: # type Error type. # cond Error condition. # -text text Human readable description. # -application-specific xml Application-specific error condition. # # Result: # Generated XMPP error XML element. # # Side effects: # None. proc ::xmpp::stanzaerror::XMPPError {type cond args} { variable LegacyCodes set subels [list [::xmpp::xml::create $cond \ -xmlns urn:ietf:params:xml:ns:xmpp-stanzas]] foreach {key val} $args { switch -- $key { -text { lappend subels \ [::xmpp::xml::create text \ -xmlns urn:ietf:params:xml:ns:xmpp-stanzas \ -cdata $val] } -application-specific { lappend subels $val } } } set attrs [list type $type] if {[info exists LegacyCodes($cond)] && $LegacyCodes($cond) > 0} { lappend attrs code $LegacyCodes($cond) } return [::xmpp::xml::create error -attrs $attrs -subelements $subels] } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/starttls.tcl000064400000000000000000000332601470446212700155040ustar00nobodynobody# starttls.tcl -- # # This file is part of the XMPP library. It provides support for the # tls network socket security layer. # # Copyright (c) 2008-2015 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require xmpp::stanzaerror package require xmpp::transport::tls package provide xmpp::starttls 0.1 namespace eval ::xmpp::starttls {} # ::xmpp::starttls::starttls -- # # Negotiate STARTTLS procedure and switch to an encrypted stream. # # Arguments: # xlib XMPP token. It must be connected and XMPP # stream must be opened. # -timeout timeout (optional, defaults to 0 which means infinity) # Timeout (in milliseconds) for STARTTLS # negotiation. # -command callback (optional) If present, it turns on asynchronous # mode. After successful or failed authentication # "callback" is invoked with two appended # arguments: status ("ok", "error", "abort" or # "timeout") and either new stream session ID if # status is "ok", or error stanza otherwise. # -verifycommand TLS callback (it turns into -command option # for ::tls::import). # -infocommand Callback to get status of an established # TLS connection. It is calles wit a list of # key-value pairs returned from tls::status. # -castore If this option points to a file then it's # equivalent to -cafile, if it points to a # directory then it's equivalent to -cadir. # # -cadir Options for ::tls::import procedure (see # -cafile tls package manual for details). # -certfile # -keyfile # -ssl2 # -ssl3 # -tls1 # -tls1.1 (supported by tls 1.6 and newer) # -tls1.2 (supported by tls 1.6 and newer) # -request # -require # -password # # Result: # In asynchronous mode a control token is returned (it allows to abort # STARTTLS process). In synchronous mode either new stream session ID is # returned (if STARTTLS succeded) or IQ error (with return code # error in case of error, or break in case of abortion). # # Side effects: # A variable in ::xmpp::starttls namespace is created and STARTTLS state # is stored in it in asynchronous mode. In synchronous mode the Tcl event # loop is entered and processing until return. proc ::xmpp::starttls::starttls {xlib args} { variable id if {![info exists id]} { set id 0 } set token [namespace current]::[incr id] variable $token upvar 0 $token state ::xmpp::Debug $xlib 2 "$token" ::xmpp::Set $xlib abortCommand [namespace code [abort $token]] set state(xlib) $xlib set state(tlsArgs) {} set timeout 0 foreach {key val} $args { switch -- $key { -castore - -cadir - -cafile - -certfile - -keyfile - -ssl2 - -ssl3 - -tls1 - -tls1.1 - -tls1.2 - -request - -require - -password - -verifycommand - -infocommand { lappend state(tlsArgs) $key $val } -command { set state($key) $val } -timeout { set timeout $val } default { unset state return -code error [::msgcat::mc "Illegal option \"%s\"" $key] } } } # Append default TLS options which may differ from the tls::import defaults if {![::xmpp::xml::isAttr $state(tlsArgs) -ssl2]} { lappend state(tlsArgs) -ssl2 0 } if {![::xmpp::xml::isAttr $state(tlsArgs) -ssl3]} { lappend state(tlsArgs) -ssl3 0 } if {![::xmpp::xml::isAttr $state(tlsArgs) -tls1]} { lappend state(tlsArgs) -tls1 1 } if {![::xmpp::xml::isAttr $state(tlsArgs) -tls1.1] && \ ![catch ::tls::ciphers tls1.1]} { lappend state(tlsArgs) -tls1.1 1 } if {![::xmpp::xml::isAttr $state(tlsArgs) -tls1.2] && \ ![catch ::tls::ciphers tls1.2]} { lappend state(tlsArgs) -tls1.2 1 } ::xmpp::RegisterElement $xlib * urn:ietf:params:xml:ns:xmpp-tls \ [namespace code [list Parse $token]] if {$timeout > 0} { set state(afterid) \ [after $timeout \ [namespace code \ [list AbortStarttls $token timeout \ [::msgcat::mc "STARTTLS timed out"]]]] } ::xmpp::TraceStreamFeatures $xlib \ [namespace code [list Continue $token]] if {[info exists state(-command)]} { # Asynchronous mode return $token } else { # Synchronous mode vwait $token\(status) foreach {status msg} $state(status) break unset state if {[string equal $status ok]} { return $msg } else { if {[string equal $status abort]} { return -code break $msg } else { return -code error $msg } } } } # ::xmpp::starttls::abort -- # # Abort an existing STARTTLS procedure, or do nothing if it's # already finished. # # Arguments: # token STARTTLS control token which is returned by # ::xmpp::starttls::starttls procedure. # # Result: # Empty string. # # Side effects: # In state of waiting for reply from server terminates waiting process. proc ::xmpp::starttls::abort {token} { AbortStarttls $token abort [::msgcat::mc "STARTTLS aborted"] } # ::xmpp::starttls::AbortStarttls -- # # Abort an existing STARTTLS procedure, or do nothing if it's # already finished. # # Arguments: # token STARTTLS control token which is returned by # ::xmpp::starttls::starttls procedure. # status (error, abort or timeout) Status code of the abortion. # msg Error message. # # Result: # Empty string. # # Side effects: # In state of waiting for reply from server terminates waiting process. proc ::xmpp::starttls::AbortStarttls {token status msg} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" ::xmpp::RemoveTraceStreamFeatures $xlib \ [namespace code [list Continue $token]] if {[info exists state(reopenStream)]} { ::xmpp::GotStream $xlib abort {} return } Finish $token $status [::xmpp::xml::create error -cdata $msg] } # ::xmpp::starttls::Continue -- # # A helper procedure which checks if there is a STARTTLS feature in a # features list provided by server and continues or finishes STARTTLS # negotiation. # # Arguments: # token STARTTLS control token. # featuresList XMPP features list from server. # # Result: # Empty string. # # Side effects: # Either a STARTTLS request is sent to server or negotiation is # finished with error. proc ::xmpp::starttls::Continue {token featuresList} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" set starttlsFeature 0 foreach feature $featuresList { ::xmpp::xml::split $feature tag xmlns attrs cdata subels switch -- $tag/$xmlns { starttls/urn:ietf:params:xml:ns:xmpp-tls { set starttlsFeature 1 break } } } if {!$starttlsFeature} { Finish $token error \ [::xmpp::stanzaerror::error modify not-acceptable -text \ [::msgcat::mc "Server hasn't provided STARTTLS feature"]] return } ::xmpp::outXML $xlib [::xmpp::xml::create starttls \ -xmlns urn:ietf:params:xml:ns:xmpp-tls] } # ::xmpp::starttls::Parse -- # # Parse XML elemens in urn:ietf:params:xml:ns:xmpp-tls namespace. They # indicate the result of negotiation procedure (success or failure). # # Arguments: # token STARTTLS control token. # xmlElement Top-level XML stanza. # # Result: # Empty string. # # Side effects: # A corresponding procedure is called in cases of successful or failed # STARTTLS negotiation. proc ::xmpp::starttls::Parse {token xmlElement} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels switch -- $tag { proceed { Proceed $token } failure { Failure $token $subels } } } # ::xmpp::starttls::Proceed -- # # A helper procedure which is called if STARTTLS negotiations succeeded. # It switches transport to tls and reopens XMPP stream. # # Arguments: # token STARTTLS control token. # # Result: # Empty string. # # Side effects: # In case of success XMPP channel becomes encrypted, XMPP stream is # reopened. proc ::xmpp::starttls::Proceed {token} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" if {[catch {eval [list ::xmpp::SwitchTransport $xlib tls] \ $state(tlsArgs)} msg]} { set err [::xmpp::stanzaerror::error modify undefined-condition \ -text $msg] Finish $token error $err return } set state(reopenStream) \ [::xmpp::ReopenStream $xlib \ -command [namespace code [list Reopened $token]]] return } # ::xmpp::starttls::Reopened -- # # A callback which is invoked when the XMPP server responds to stream # reopening. It finishes STARTTLS procedure with error or success. # # Arguments: # token STARTTLS control token. # status "ok", "error", "abort", or "timeout". # sessionid Stream session ID in case of success, or error message # otherwise. # # Result: # Empty string. # # Side effects: # STARTTLS negotiation is finished. proc ::xmpp::starttls::Reopened {token status sessionid} { variable $token upvar 0 $token state set xlib $state(xlib) unset state(reopenStream) ::xmpp::Debug $xlib 2 "$token $status $sessionid" if {[string equal $status ok]} { Finish $token ok $sessionid } else { Finish $token $status [::xmpp::xml::create error -cdata $sessionid] } } # ::xmpp::starttls::Failure -- # # A helper procedure which is called if STARTTLS negotiations failed. It # finishes STARTTLS procedure with error. # # Arguments: # token STARTTLS control token. # xmlElements Subelements of element which include error. # # Result: # Empty string. # # Side effects: # STARTTLS negotiation is finished with error. proc ::xmpp::starttls::Failure {token xmlElements} { variable $token upvar 0 $token state set xlib $state(xlib) ::xmpp::Debug $xlib 2 "$token" set error [lindex $xmlElements 0] if {[string equal $error ""]} { set err [::xmpp::stanzaerror::error modify undefined-condition \ -text [::msgcat::mc "STARTTLS failed"]] } else { ::xmpp::xml::split $error tag xmlns attrs cdata subels set err [::xmpp::stanzaerror::error modify $tag] } Finish $token error $err } # ::xmpp::starttls::Finish -- # # A hepler procedure which finishes negotiation process and destroys # STARTTLS control token (or returns to [starttls]). # # Arguments: # token STARTTLS control token. # status Status of the negotiations ("ok" means success). # xmlData Either a new stream session ID if status is ok or # error stanza. # # Result: # Empty string. # # Side effects: # In asynchronous mode a control token is destroyed and a callback is # called. In synchronous mode vwait in [starttls] is triggered. proc ::xmpp::starttls::Finish {token status xmlData} { variable $token upvar 0 $token state if {![info exists state(xlib)]} return set xlib $state(xlib) if {[info exists state(afterid)]} { after cancel $state(afterid) } ::xmpp::Unset $xlib abortCommand ::xmpp::Debug $xlib 2 "$token $status" ::xmpp::UnregisterElement $xlib * urn:ietf:params:xml:ns:xmpp-tls # Cleanup in asynchronous mode if {[info exists state(-command)]} { set cmd $state(-command) unset state } if {[string equal $status ok]} { ::xmpp::CallBack $xlib status [::msgcat::mc "STARTTLS successful"] } else { ::xmpp::CallBack $xlib status [::msgcat::mc "STARTTLS failed"] } if {[info exists cmd]} { # Asynchronous mode uplevel #0 $cmd [list $status $xmlData] } else { # Synchronous mode # Trigger vwait in [starttls] set state(status) [list $status $xmlData] } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/streamerror.tcl000064400000000000000000000137451470446212700161770ustar00nobodynobody# streamerror.tcl -- # # This file is part of the XMPP library. It provides routines for # parsing XMPP stream errors. # # Copyright (c) 2008-2010 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package provide xmpp::streamerror 0.1 namespace eval ::xmpp::streamerror { namespace export condition message error # Defined error conditions (see XMPP core, section 4.7.3) foreach {cond message} [list \ bad-format [::msgcat::mc "Bad format"] \ bad-namespace-prefix [::msgcat::mc "Bad namespace prefix"] \ conflict [::msgcat::mc "Conflict"] \ connection-timeout [::msgcat::mc "Connection timeout"] \ host-gone [::msgcat::mc "Host gone"] \ host-unknown [::msgcat::mc "Host unknown"] \ improper-addressing [::msgcat::mc "Improper addressing"] \ internal-server-error [::msgcat::mc "Internal server error"] \ invalid-from [::msgcat::mc "Invalid from"] \ invalid-id [::msgcat::mc "Invalid ID"] \ invalid-namespace [::msgcat::mc "Invalid namespace"] \ invalid-xml [::msgcat::mc "Invalid XML"] \ not-authorized [::msgcat::mc "Not authorized"] \ policy-violation [::msgcat::mc "Policy violation"] \ remote-connection-failed [::msgcat::mc "Remote connection failed"] \ resource-constraint [::msgcat::mc "Resource constraint"] \ restricted-xml [::msgcat::mc "Restricted XML"] \ see-other-host [::msgcat::mc "See other host"] \ system-shutdown [::msgcat::mc "System shutdown"] \ undefined-condition [::msgcat::mc "Undefined condition"] \ unsupported-encoding [::msgcat::mc "Unsupported encoding"] \ unsupported-stanza-type [::msgcat::mc "Unsupported stanza type"] \ unsupported-version [::msgcat::mc "Unsupported version"] \ xml-not-well-formed [::msgcat::mc "XML not well-formed"]] \ { set StreamerrorDesc($cond) $message } } # ::xmpp::streamerror::condition -- # # Return XMPP stream error condition. # # Arguments: # xmlElement Stanza error XML element. # # Result: # Error condition. # # Side effects: # None. proc ::xmpp::streamerror::condition {xmlElement} { return [lindex [ToList $xmlElement] 0] } # ::xmpp::streamerror::message -- # # Return XMPP stream error human-readable message. # # Arguments: # xmlElement Stanza error XML element. # # Result: # Error message. # # Side effects: # None. proc ::xmpp::streamerror::message {xmlElement} { return [lindex [ToList $xmlElement] 1] } # ::xmpp::streamerror::ToList -- # # Convert XMPP stream error to a list of error condition and readable # message. # # Arguments: # xmlElement Stanza error XML element. # # Result: # A tuple {type, condition, message}. # # Side effects: # None. proc ::xmpp::streamerror::ToList {xmlElement} { variable StreamerrorDesc ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels if {[llength $subels] == 0} { # Legacy error set cdata [string trim $cdata] if {[string length $cdata] > 0} { return [list legacy [::msgcat::mc "Stream error (%s)" $cdata]] } else { return [list legacy [::msgcat::mc "Stream error"]] } } else { # XMPP error set condition undefined-condition set desc "" set text "" foreach errelem $subels { ::xmpp::xml::split $errelem stag sxmlns sattrs scdata ssubels switch -- $stag { text { if {[string equal $xmlns \ urn:ietf:params:xml:ns:xmpp-streams]} { set text $scdata } } undefined-condition { # TODO } default { if {[info exists StreamerrorDesc($stag)]} { set condition $stag set desc $StreamerrorDesc($stag) } } } } switch -glob -- [string length $desc]/[string length $text] { 0/0 { return [list $condition [::msgcat::mc "Stream error"]] } 0/* { return [list $condition [::msgcat::mc "Stream error: %s" \ $text]] } */0 { return [list $condition [::msgcat::mc "Stream error (%s)" \ $desc]] } default { return [list $condition [::msgcat::mc "Stream error (%s): %s" \ $desc $text]] } } } } # ::xmpp::streamerror::error -- # # Create XMPP stream error stanza. # # Arguments: # cond Error condition. # -text text Human readable description. # # Result: # Generated XMPP stream error XML element. # # Side effects: # None. proc ::xmpp::streamerror::error {cond args} { set subels [list [::xmpp::xml::create $cond \ -xmlns urn:ietf:params:xml:ns:xmpp-streams]] foreach {key val} $args { switch -- $key { -text { lappend subels \ [::xmpp::xml::create text \ -xmlns urn:ietf:params:xml:ns:xmpp-streams \ -cdata $val] } } } return [::xmpp::xml::create error \ -xmlns http://etherx.jabber.org/streams \ -subelements $subels] } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/tcp.tcl000064400000000000000000000325371470446212700144200ustar00nobodynobody# tcp.tcl -- # # This file is part of the XMPP library. It provides support for the # XMPP stream over TCP sockets. # # Copyright (c) 2008-2013 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require pconnect package require xmpp::transport 0.2 package require xmpp::xml package provide xmpp::transport::tcp 0.2 namespace eval ::xmpp::transport::tcp { namespace export open abort close reset flush ip outXML outText \ openStream closeStream ::xmpp::transport::register tcp \ -opencommand [namespace code open] \ -abortcommand [namespace code abort] \ -closecommand [namespace code close] \ -resetcommand [namespace code reset] \ -flushcommand [namespace code flush] \ -ipcommand [namespace code ip] \ -outxmlcommand [namespace code outXML] \ -outtextcommand [namespace code outText] \ -openstreamcommand [namespace code openStream] \ -reopenstreamcommand [namespace code openStream] \ -closestreamcommand [namespace code closeStream] } # ::xmpp::transport::tcp::open -- # # Open TCP socket (using ::pconnect::socket), create XML parser and # link them together. # # Arguments: # host Host to connect. # port Port to connect. # -command cmd0 (optional) Callback to call when TCP # connection to server (directly or through # proxy) is established. If missing then a # synchronous mode is set and function # doesn't return until connect succeded or # failed. # -streamheadercommand cmd1 Command to call when XMPP stream header # () is received. # -streamtrailercommand cmd2 Command to call when XMPP stream trailer # () is received. # -stanzacommand cmd3 Command to call when XMPP stanza is # received. # -eofcommand cmd4 End-of-file callback. # (other arguments are passed to [::pconnect::socket]) # -proxy string Proxy type "" (default), "socks4", # "socks5", or "https" # -host string Proxy hostname (required if -proxy # isn't empty) # -port integer Proxy port number (required if -proxy # isn't empty) # -username string Proxy user ID # -password string Proxy password # -useragent string Proxy user agent (for HTTP proxies) # # Result: # Transport token is returned to allow to abort connection process in # asynchronous mode. In synchronous mode token is returned in case of # success or error is raised if the connection is failed. # # Side effects: # In synchronous mode in case of success a new TCP socket and XML parser # are created, in case of failure none. In asynchronous mode a call to # ::pconnect::socket is executed. proc ::xmpp::transport::tcp::open {host port args} { variable id if {![info exists id]} { set id 0 } set token [namespace current]::[incr id] variable $token upvar 0 $token state set state(transport) tcp set state(streamHeaderCmd) # set state(streamTrailerCmd) # set state(stanzaCmd) # set state(eofCmd) # set newArgs {} foreach {key val} $args { switch -- $key { -command {set cmd $val} -streamheadercommand {set state(streamHeaderCmd) $val} -streamtrailercommand {set state(streamTrailerCmd) $val} -stanzacommand {set state(stanzaCmd) $val} -eofcommand {set state(eofCmd) $val} default {lappend newArgs $key $val} } } if {![info exists cmd]} { # Synchronous mode set state(sock) [eval [list ::pconnect::socket $host $port] $newArgs] Configure $token } else { # Asynchronous mode if {[catch { set state(pconnect) \ [eval [list ::pconnect::socket $host $port] $newArgs \ [list -command [namespace code [list OpenAux $token \ $cmd]]]] } msg]} { # We can't even open a socket after idle [namespace code [list OpenAux $token $cmd error $msg]] } } return $token } # ::xmpp::transport::tcp::OpenAux -- # # A helper procedure which is passed as a callback to ::pconnect::socket # call and in turn invokes a callback for [open] procedure. # # Arguments: # token Transport token created in [open] # cmd Procedure to call with status ok or error. # status Connection status (ok means success). # sock TCP socket if status is ok, or error message if # status is error, timeout, or abort. # # Result: # Empty string. # # Side effects: # If status is ok then a new XML parser is created. In all cases a # callback procedure is executed. proc ::xmpp::transport::tcp::OpenAux {token cmd status sock} { variable $token upvar 0 $token state catch {unset state(pconnect)} if {[string equal $status ok]} { set state(sock) $sock Configure $token } else { # Here $sock contains error message set token $sock } uplevel #0 $cmd [list $status $token] return } # ::xmpp::transport::tcp::Configure -- # # A helper procedure which creates a new XML parser and configures TCP # socket. # # Arguments: # token Transport token created in [open] # # Result: # Empty string. # # Side effects: # Socket is put in non-buffering nonblocking mode with encoding UTF-8. # XML parser is created. proc ::xmpp::transport::tcp::Configure {token} { variable $token upvar 0 $token state set state(parser) \ [::xmpp::xml::new \ [namespace code [list InXML $state(streamHeaderCmd)]] \ [namespace code [list InEmpty $state(streamTrailerCmd)]] \ [namespace code [list InXML $state(stanzaCmd)]]] fconfigure $state(sock) -blocking 0 \ -buffering none \ -translation auto \ -encoding utf-8 fileevent $state(sock) readable [namespace code [list InText $token]] return } # ::xmpp::transport::tcp::abort -- # # Abort connection which isn't fully opened yet. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # Connection token is destroyed and the connection is aborted. proc ::xmpp::transport::tcp::abort {token} { variable $token upvar 0 $token state if {[info exists state(pconnect)]} { # If ::pconnect::abort returns error then propagate it to the caller ::pconnect::abort $state(pconnect) } if {[info exists state(parser)]} { ::xmpp::xml::free $state(parser) } unset state return } # ::xmpp::transport::tcp::outText -- # # Send text to XMPP server. # # Arguments: # token Transport token. # text Text to send. # # Result: # Bytelength of a sent text. # # Side effects: # Text is sent to the server. proc ::xmpp::transport::tcp::outText {token text} { variable $token upvar 0 $token state if {[catch {puts -nonewline $state(sock) $text} err]} { return -1 } else { # TODO return [string bytelength $text] } } # ::xmpp::transport::tcp::outXML -- # # Send XML element to XMPP server. # # Arguments: # token Transport token. # xml XML to send. # # Result: # Bytelength of a textual representation of a sent XML. # # Side effects: # Text is sent to the server. proc ::xmpp::transport::tcp::outXML {token xml} { return [outText $token [::xmpp::xml::toText $xml]] } # ::xmpp::transport::tcp::openStream -- # # Send XMPP stream header to XMPP server. # # Arguments: # token Transport token. # server XMPP server. # args Arguments for [::xmpp::xml::streamHeader]. # # Result: # Bytelength of a textual representation of a sent header. # # Side effects: # Text is sent to the server. proc ::xmpp::transport::tcp::openStream {token server args} { return [outText $token \ [eval [list ::xmpp::xml::streamHeader $server] $args]] } # ::xmpp::transport::tcp::closeStream -- # # Send XMPP stream trailer to XMPP server and start disconnecting # procedure. # # Arguments: # token Transport token. # -wait bool (optional, default 0) Wait for the server side to # close stream. # # Result: # Bytelength of a textual representation of a sent header. # # Side effects: # Text is sent to the server. proc ::xmpp::transport::tcp::closeStream {token args} { variable $token upvar 0 $token state set len [outText $token [::xmpp::xml::streamTrailer]] set wait 0 foreach {key val} $args { switch -- $key { -wait { set wait $val } } } if {!$wait} { ::flush $state(sock) } else { fconfigure $state(sock) -blocking 1 ::flush $state(sock) # TODO #vwait $token\(sock) } return $len } # ::xmpp::transport::tcp::flush -- # # Flush XMPP channel. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # Pending data is sent to the server. proc ::xmpp::transport::tcp::flush {token} { variable $token upvar 0 $token state ::flush $state(sock) return } # ::xmpp::transport::tcp::ip -- # # Return IP of an outgoing socket. # # Arguments: # token Transport token. # # Result: # IP address. # # Side effects: # None. proc ::xmpp::transport::tcp::ip {token} { variable $token upvar 0 $token state return [lindex [fconfigure $state(sock) -sockname] 0] } # ::xmpp::transport::tcp::close -- # # Close XMPP channel. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # Transport token and XML parser are destroyed. proc ::xmpp::transport::tcp::close {token} { variable $token upvar 0 $token state catch {fileevent $state(sock) readable {}} catch {::close $state(sock)} if {[info exists state(parser)]} { ::xmpp::xml::free $state(parser) } catch {unset state} return } # ::xmpp::transport::tcp::reset -- # # Reset XMPP stream. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # XML parser is reset. proc ::xmpp::transport::tcp::reset {token} { variable $token upvar 0 $token state ::xmpp::xml::reset $state(parser) return } # ::xmpp::transport::tcp::InText -- # # A helper procedure which is called when a new portion of data is # received from XMPP server. It receives the data from a socket and # feeds XML parser with them. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # The text is parsed and if it completes top-level stanza then an # appropriate callback is invoked. proc ::xmpp::transport::tcp::InText {token} { variable $token upvar 0 $token state if {[catch {read $state(sock)} msg]} { fileevent $state(sock) readable {} ::close $state(sock) InEmpty $state(eofCmd) return } ::xmpp::xml::parser $state(parser) parse $msg if {[eof $state(sock)]} { fileevent $state(sock) readable {} ::close $state(sock) InEmpty $state(eofCmd) } } # ::xmpp::transport::tcp::InXML -- # # A helper procedure which is called when a new XML stanza is parsed. # It then calls a specified command as an idle callback. # # Arguments: # cmd Command to call. # xml Stanza to pass to the command. # # Result: # Empty string. # # Side effects: # After entering event loop the specified command is called. proc ::xmpp::transport::tcp::InXML {cmd xml} { after idle $cmd [list $xml] } # ::xmpp::transport::tcp::InEmpty -- # # A helper procedure which is called when XMPP stream is finished. # It then calls a specified command as an idle callback. # # Arguments: # cmd Command to call. # # Result: # Empty string. # # Side effects: # After entering event loop the specified command is called. proc ::xmpp::transport::tcp::InEmpty {cmd} { after idle $cmd } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/tls.tcl000064400000000000000000000454141470446212700144320ustar00nobodynobody# tls.tcl -- # # This file is part of the XMPP library. It provides support for the # XMPP stream over TLS encrypted TCP sockets. # # Copyright (c) 2008-2015 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require tls 1.4 package require pconnect package require xmpp::transport 0.2 package require xmpp::xml package provide xmpp::transport::tls 0.2 namespace eval ::xmpp::transport::tls { namespace export open abort close reset flush ip outXML outText \ openStream closeStream import ::xmpp::transport::register tls \ -opencommand [namespace code open] \ -abortcommand [namespace code abort] \ -closecommand [namespace code close] \ -resetcommand [namespace code reset] \ -flushcommand [namespace code flush] \ -ipcommand [namespace code ip] \ -outxmlcommand [namespace code outXML] \ -outtextcommand [namespace code outText] \ -openstreamcommand [namespace code openStream] \ -reopenstreamcommand [namespace code openStream] \ -closestreamcommand [namespace code closeStream] \ -importcommand [namespace code import] } # ::xmpp::transport::tls::open -- # # Open TCP socket (using ::pconnect::socket), create XML parser and # link them together. # # Arguments: # host Host to connect. # port Port to connect. # -command cmd0 (optional) Callback to call when TCP # connection to server (directly or through # proxy) is established. If missing then a # synchronous mode is set and function # doesn't return until connect succeded or # failed. # -streamheadercommand cmd1 Command to call when XMPP stream header # () is received. # -streamtrailercommand cmd2 Command to call when XMPP stream trailer # () is received. # -stanzacommand cmd3 Command to call when XMPP stanza is # received. # -eofcommand cmd4 End-of-file callback. # -verifycommand TLS callback (it turns into -command option # for ::tls::import). # -passwordcommand cmd5 TLS password callback (it turns into # -password option for ::tls::import). # -infocommand Callback to get status of an established # TLS connection. It is calles wit a list of # key-value pairs returned from tls::status. # -castore If this option points to a file then it's # equivalent to -cafile, if it points to a # directory then it's equivalent to -cadir. # # -cadir Options for ::tls::import procedure (see # -cafile tls package manual for details). # -certfile # -keyfile # -ssl2 # -ssl3 # -tls1 # -tls1.1 (supported for tls 1.6 and newer) # -tls1.2 (supported for tls 1.6 and newer) # -request # -require # (other arguments are passed to [::pconnect::socket]) # -proxy string Proxy type "" (default), "socks4", # "socks5", or "https" # -host string Proxy hostname (required if -proxy # isn't empty) # -port integer Proxy port number (required if -proxy # isn't empty) # -username string Proxy user ID # -password string Proxy password # -useragent string Proxy user agent (for HTTP proxies) # # Result: # Transport token is returned to allow to abort connection process in # asynchronous mode. In synchronous mode token is returned in case of # success or error is raised if the connection is failed. # # Side effects: # In synchronous mode in case of success a new encrypted TCP socket and # XML parser are created, in case of failure none. In asynchronous mode # a call to ::pconnect::socket is executed. proc ::xmpp::transport::tls::open {host port args} { variable id if {![info exists id]} { set id 0 } set token [namespace current]::[incr id] variable $token upvar 0 $token state set state(transport) tls set state(streamHeaderCmd) # set state(streamTrailerCmd) # set state(stanzaCmd) # set state(eofCmd) # set tlsArgs {} set newArgs {} foreach {key val} $args { switch -- $key { -command {set cmd $val} -streamheadercommand {set state(streamHeaderCmd) $val} -streamtrailercommand {set state(streamTrailerCmd) $val} -stanzacommand {set state(stanzaCmd) $val} -eofcommand {set state(eofCmd) $val} -castore - -cadir - -cafile - -certfile - -keyfile - -ssl2 - -ssl3 - -tls1 - -tls1.1 - -tls1.2 - -request - -require - -passwordcommand - -verifycommand - -infocommand {lappend tlsArgs $key $val} default {lappend newArgs $key $val} } } # Append default TLS options which may differ from the tls::import defaults if {![::xmpp::xml::isAttr $tlsArgs -ssl2]} { lappend tlsArgs -ssl2 0 } if {![::xmpp::xml::isAttr $tlsArgs -ssl3]} { lappend tlsArgs -ssl3 0 } if {![::xmpp::xml::isAttr $tlsArgs -tls1]} { lappend tlsArgs -tls1 1 } if {![::xmpp::xml::isAttr $tlsArgs -tls1.1] && \ ![catch ::tls::ciphers tls1.1]} { lappend tlsArgs -tls1.1 1 } if {![::xmpp::xml::isAttr $tlsArgs -tls1.2] && \ ![catch ::tls::ciphers tls1.2]} { lappend tlsArgs -tls1.2 1 } if {![info exists cmd]} { # Synchronous mode set state(sock) [eval [list ::pconnect::socket $host $port] $newArgs] Configure $token $tlsArgs } else { # Asynchronous mode if {[catch { set state(pconnect) \ [eval [list ::pconnect::socket $host $port] $newArgs \ [list -command [namespace code [list OpenAux $token \ $cmd \ $tlsArgs]]]] } msg]} { # We can't even open a socket after idle [namespace code [list OpenAux $token $cmd $tlsArgs \ error $msg]] } } return $token } # ::xmpp::transport::tls::OpenAux -- # # A helper procedure which is passed as a callback to ::pconnect::socket # call and in turn invokes a callback for [open] procedure. # # Arguments: # token Transport token created in [open]. # cmd Procedure to call with status ok or error. # tlsArgs TLS-specific arguments. # status Connection status (ok means success). # sock TCP socket if status is ok, or error message if # status is error, timeout, or abort. # # Result: # Empty string. # # Side effects: # If status is ok then a new XML parser is created. In all cases a # callback procedure is executed. proc ::xmpp::transport::tls::OpenAux {token cmd tlsArgs status sock} { variable $token upvar 0 $token state catch {unset state(pconnect)} if {[string equal $status ok]} { set state(sock) $sock if {[catch {Configure $token $tlsArgs} msg]} { set status error set token $msg # TODO: Cleanup } } else { # Here $sock contains error message set token $sock } uplevel #0 $cmd [list $status $token] return } # ::xmpp::transport::tls::Configure -- # # A helper procedure which creates a new XML parser and configures TCP # socket. # # Arguments: # token Transport token created in [open] # tlsArgs TLS-specific options. # # Result: # Empty string. # # Side effects: # Socket is put in non-buffering nonblocking mode with encoding UTF-8. # XML parser is created. proc ::xmpp::transport::tls::Configure {token tlsArgs} { variable $token upvar 0 $token state set state(parser) \ [::xmpp::xml::new \ [namespace code [list InXML $state(streamHeaderCmd)]] \ [namespace code [list InEmpty $state(streamTrailerCmd)]] \ [namespace code [list InXML $state(stanzaCmd)]]] eval [list import $token] $tlsArgs return } # ::xmpp::transport::tls::import -- # # Turn TCP socket into a TLS socket. # # Arguments: # token Transport control token. # -passwordcommand TLS password callback (it turns into -password # option for ::tls::import). # -verifycommand TLS callback (it turns into -command option # for ::tls::import). # -infocommand Callback to get status of an established # TLS connection. It is calles wit a list of # key-value pairs returned from tls::status. # -castore If this option points to a file then it's # equivalent to -cafile, if it points to a # directory then it's equivalent to -cadir. # # -cadir Options for ::tls::import procedure (see # -cafile tls package manual for details). # -certfile # -keyfile # -ssl2 # -ssl3 # -tls1 # -tls1.1 (supported for tls 1.6 and newer) # -tls1.2 (supported for tls 1.6 and newer) # -request # -require # # Result: # Empty string. # # Side effects: # TCP socket which corresponds to the given token becomes TLS-encrypted. proc ::xmpp::transport::tls::import {token args} { variable $token upvar 0 $token state set newArgs {} foreach {key val} $args { switch -- $key { -castore { if {[file isdirectory $val]} { lappend newArgs -cadir $val } else { lappend newArgs -cafile $val } } -passwordcommand { lappend newArgs -password $val } -verifycommand { lappend newArgs -command $val } -infocommand { set infoCmd $val } default {lappend newArgs $key $val} } } fileevent $state(sock) readable {} fileevent $state(sock) writable {} fconfigure $state(sock) -blocking true eval [list ::tls::import $state(sock)] $newArgs if {[catch {::tls::handshake $state(sock)} result]} { catch {::close $state(sock)} # TODO: Cleanup. return -code error [::msgcat::mc "TLS handshake failed: %s" $result] } fconfigure $state(sock) -blocking false \ -buffering none \ -translation auto \ -encoding utf-8 fileevent $state(sock) readable [namespace code [list InText $token]] set state(transport) tls if {[info exists infoCmd]} { eval $infoCmd [::tls::status $state(sock)] } return $token } # ::xmpp::transport::tls::abort -- # # Abort connection which isn't fully opened yet. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # Connection token is destroyed and the connection is aborted. proc ::xmpp::transport::tls::abort {token} { variable $token upvar 0 $token state if {[info exists state(pconnect)]} { # If ::pconnect::abort returns error then propagate it to the caller ::pconnect::abort $state(pconnect) } if {[info exists state(parser)]} { ::xmpp::xml::free $state(parser) } unset state return } # ::xmpp::transport::tls::outText -- # # Send text to XMPP server. # # Arguments: # token Transport token. # text Text to send. # # Result: # Bytelength of a sent text. # # Side effects: # Text is sent to the server. proc ::xmpp::transport::tls::outText {token text} { variable $token upvar 0 $token state if {[catch {puts -nonewline $state(sock) $text} err]} { return -1 } else { ::flush $state(sock) # TODO return [string bytelength $text] } } # ::xmpp::transport::tls::outXML -- # # Send XML element to XMPP server. # # Arguments: # token Transport token. # xml XML to send. # # Result: # Bytelength of a textual representation of a sent XML. # # Side effects: # Text is sent to the server. proc ::xmpp::transport::tls::outXML {token xml} { return [outText $token [::xmpp::xml::toText $xml]] } # ::xmpp::transport::tls::openStream -- # # Send XMPP stream header to XMPP server. # # Arguments: # token Transport token. # server XMPP server. # args Arguments for [::xmpp::xml::streamHeader]. # # Result: # Bytelength of a textual representation of a sent header. # # Side effects: # Text is sent to the server. proc ::xmpp::transport::tls::openStream {token server args} { return [outText $token \ [eval [list ::xmpp::xml::streamHeader $server] $args]] } # ::xmpp::transport::tls::closeStream -- # # Send XMPP stream trailer to XMPP server and start disconnecting # procedure. # # Arguments: # token Transport token. # -wait bool (optional, default 0) Wait for the server side to # close stream. # # Result: # Bytelength of a textual representation of a sent header. # # Side effects: # Text is sent to the server. proc ::xmpp::transport::tls::closeStream {token args} { variable $token upvar 0 $token state set len [outText $token [::xmpp::xml::streamTrailer]] set wait 0 foreach {key val} $args { switch -- $key { -wait { set wait $val } } } if {!$wait} { ::flush $state(sock) } else { fconfigure $state(sock) -blocking 1 ::flush $state(sock) # TODO #vwait $token\(sock) } return $len } # ::xmpp::transport::tls::flush -- # # Flush XMPP channel. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # Pending data is sent to the server. proc ::xmpp::transport::tls::flush {token} { variable $token upvar 0 $token state ::flush $state(sock) } # ::xmpp::transport::tls::ip -- # # Return IP of an outgoing socket. # # Arguments: # token Transport token. # # Result: # IP address. # # Side effects: # None. proc ::xmpp::transport::tls::ip {token} { variable $token upvar 0 $token state return [lindex [fconfigure $state(sock) -sockname] 0] } # ::xmpp::transport::tls::close -- # # Close XMPP channel. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # Transport token and XML parser are destroyed. proc ::xmpp::transport::tls::close {token} { variable $token upvar 0 $token state catch {fileevent $state(sock) readable {}} catch {::close $state(sock)} if {[info exists state(parser)]} { ::xmpp::xml::free $state(parser) } catch {unset state} return } # ::xmpp::transport::tls::reset -- # # Reset XMPP stream. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # XML parser is reset. proc ::xmpp::transport::tls::reset {token} { variable $token upvar 0 $token state ::xmpp::xml::reset $state(parser) } # ::xmpp::transport::tls::InText -- # # A helper procedure which is called when a new portion of data is # received from XMPP server. It receives the data from a socket and # feeds XML parser with them. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # The text is parsed and if it completes top-level stanza then an # appropriate callback is invoked. proc ::xmpp::transport::tls::InText {token} { variable $token upvar 0 $token state if {[catch {read $state(sock)} msg]} { fileevent $state(sock) readable {} ::close $state(sock) InEmpty $state(eofCmd) return } ::xmpp::xml::parser $state(parser) parse $msg if {[eof $state(sock)]} { fileevent $state(sock) readable {} ::close $state(sock) InEmpty $state(eofCmd) } } # ::xmpp::transport::tls::InXML -- # # A helper procedure which is called when a new XML stanza is parsed. # It then calls a specified command as an idle callback. # # Arguments: # cmd Command to call. # xml Stanza to pass to the command. # # Result: # Empty string. # # Side effects: # After entering event loop the specified command is called. proc ::xmpp::transport::tls::InXML {cmd xml} { after idle $cmd [list $xml] } # ::xmpp::transport::tls::InEmpty -- # # A helper procedure which is called when XMPP stream is finished. # It then calls a specified command as an idle callback. # # Arguments: # cmd Command to call. # # Result: # Empty string. # # Side effects: # After entering event loop the specified command is called. proc ::xmpp::transport::tls::InEmpty {cmd} { after idle $cmd } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/transport.tcl000064400000000000000000000203531470446212700156570ustar00nobodynobody# transport.tcl -- # # This file is part of the XMPP library. It implements the XMPP # transports infrastructure. # # Copyright (c) 2008-2013 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require msgcat package provide xmpp::transport 0.2 namespace eval ::xmpp::transport { namespace export list register unregister use switch # A list of registered XMPP transports (tcp, tls etc.) variable TransportsList {} } # ::xmpp::transport::list -- # # Return list of registered XMPP transports. # # Arguments: # None. # # Result: # A list of names of already registered transports. # # Side effects: # None. proc ::xmpp::transport::list {} { variable TransportsList return $TransportsList } # ::xmpp::transport::register -- # # Register new XMPP transport. # # Arguments: # transport Transport name. # -opencommand cmd0 Command to call when opening connection # (e.g. TCP socket). # -abortcommand cmd1 Command to call when aborting connection if # opening is asynchronous. # -closecommand cmd2 Command to call when closing an opened # connection. # -resetcommand cmd3 Command to call when resetting an opened # connection (usually it resets XML parser). # -flushcommand cmd4 Command to flush buffer (if any) to a # connection. # -outxmlcommand cmd5 Command which converts XML (e.g. returned # by ::xmpp::xml::create) to text and sends # it to a connection. # -outtextcommand cmd6 Command which sends raw text to a # connection. # -openstreamcommand cmd7 Command which opens XMPP stream over a # connection. # -reopenstreamcommand cmd8 Command which reopens XMPP stream over a # connection. # -closestreamcommand cmd9 Command which closes XMPP stream over a # connection. # -importcommand icmd (optional) Import command # # Result: # Transport name in case of success or error if the specified transport # is already registered or some command argument is missing. # # Side effects: # Transport is registered. proc ::xmpp::transport::register {transport args} { variable TransportsList variable Transports if {[lsearch -exact $TransportsList $transport] >= 0} { return -code error [::msgcat::mc "Transport \"%s\" already\ registered" $transport] } foreach {key val} $args { ::switch -- $key { -opencommand - -abortcommand - -closecommand - -resetcommand - -flushcommand - -ipcommand - -outxmlcommand - -outtextcommand - -openstreamcommand - -reopenstreamcommand - -closestreamcommand - -importcommand { set attrs($key) $val } default { return -code error [::msgcat::mc "Illegal option \"%s\"" $key] } } } set Transports($transport) {} foreach key {-opencommand -abortcommand -closecommand -resetcommand -flushcommand -ipcommand -outxmlcommand -outtextcommand -openstreamcommand -reopenstreamcommand -closestreamcommand} { if {![info exists attrs($key)]} { unset Transports($transport) return -code error [::msgcat::mc "Missing option \"%s\"" $key] } else { lappend Transports($transport) $key $attrs($key) } } foreach key {-importcommand} { if {[info exists attrs($key)]} { lappend Transports($transport) $key $attrs($key) } } lappend TransportsList $transport return $transport } # ::xmpp::transport::unregister -- # # Remove transport from registered transport list. # # Arguments: # transport XMPP Transport name. # # Result: # Transport name in case of success or error if the transport isn't # registered. # # Side effects: # Transport is unregistered and cannot be used anymore. proc ::xmpp::transport::unregister {transport} { variable TransportsList variable Transports if {[set idx [lsearch -exact $TransportsList $transport]] < 0} { return -code error [::msgcat::mc "Unknown transport \"%s\"" $transport] } else { set TransportsList [lreplace $TransportsList $idx $idx] unset $Transports($transport) } return $transport } proc ::xmpp::transport::open {transport args} { variable TransportsList variable Transports if {[lsearch -exact $TransportsList $transport] < 0} { return -code error [::msgcat::mc "Unknown transport \"%s\"" $transport] } array set attrs $Transports($transport) return [uplevel #0 $attrs(-opencommand) $args] } # ::xmpp::transport::use -- # # Use transport for transferring XMPP data (call a registered command). # # Arguments: # token XMPP transport token. # command One of open, abort, close, flush, outXML, # outText, openStream, reopenStream closeStream # (corresponding to ::xmpp::transport::register # options). # args Arguments depending on command. # # Result: # The result of corresponding called command or error if the specified # transport isn't registered or command doesn't belong to the commands # list. # # Side effects: # The side effects of corresponding called command. proc ::xmpp::transport::use {token command args} { variable TransportsList variable Transports variable $token upvar 0 $token state set transport $state(transport) if {[lsearch -exact $TransportsList $transport] < 0} { return -code error [::msgcat::mc "Unknown transport \"%s\"" $transport] } ::switch -- $command { abort {set key -abortcommand} close {set key -closecommand} reset {set key -resetcommand} flush {set key -flushcommand} ip {set key -ipcommand} outXML {set key -outxmlcommand} outText {set key -outtextcommand} openStream {set key -openstreamcommand} reopenStream {set key -reopenstreamcommand} closeStream {set key -closestreamcommand} default { return -code error [::msgcat::mc "Illegal command \"%s\"" $command] } } array set attrs $Transports($transport) return [uplevel #0 $attrs($key) $token $args] } # ::xmpp::transport::switch -- # # Switch XMPP transport. # # Arguments: # token XMPP transport token. # transport XMPP transport name to switch. # args Arguments for import procedure. See also # ::xmpp::tls::import and ::xmpp::zlib::import. # # Result: # A new XMPP token to use. # # Side effects: # Transport for XMPP connection is changed. proc ::xmpp::transport::switch {token transport args} { variable TransportsList variable Transports if {[lsearch -exact $TransportsList $transport] < 0} { return -code error [::msgcat::mc "Unknown transport \"%s\"" $transport] } array set attrs $Transports($transport) if {[catch { uplevel #0 $attrs(-importcommand) [::list $token] $args } token2]} { return -code error \ [::msgcat::mc "Can't switch transport to \"%s\": %s" \ $transport $token2] } else { return $token2 } } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/xml.tcl000064400000000000000000000676131470446212700144350ustar00nobodynobody# xml.tcl -- # # This file is part of the XMPP library. It defines procedures which # wrap XML parser. These procedures are called by functions in XMPP # library, and they in turn call the TclXML or tDOM library functions. # # Copyright (c) 2008-2013 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require msgcat namespace eval ::xmpp::xml { variable implementation tcl } if {[catch {package require tdom 0.8}]} { package require -exact xml 2.0 } else { set ::xmpp::xml::implementation tdom } package provide xmpp::xml 0.1 namespace eval ::xmpp::xml { namespace export new free parser reset toText create split merge \ isAttr getAttr getCdata getFirstCdata getNextCdata \ streamHeader streamTrailer parseData lang } # ::xmpp::xml::new -- # # Creates new wrapper over an XML parser. # # Arguments: # streamHeaderCmd A command which is to be called when XMPP stream # header is received. # streamTrailerCmd A command which is to be called when XMPP stream # trailer is receoved. # stanzaCmd A command which is to be called when XMPP stream # stanza is received. # Results: # A new parser token (a state array name). # # Side effects: # A new XML parser is created. proc ::xmpp::xml::new {streamHeaderCmd streamTrailerCmd stanzaCmd} { variable id if {![info exists id]} { set id 0 } else { incr id } set token [namespace current]::parser#$id variable $token upvar 0 $token state set state(streamHeaderCmd) $streamHeaderCmd set state(streamTrailerCmd) $streamTrailerCmd set state(stanzaCmd) $stanzaCmd set state(parser) \ [::xml::parser parser#$id \ -final 0 \ -elementstartcommand [namespace code [list ElementStart $token]] \ -elementendcommand [namespace code [list ElementEnd $token]] \ -characterdatacommand [namespace code [list ElementCdata $token]]] if {[llength [info commands ::$state(parser)]] == 0} { set state(parser) [namespace current]::$state(parser) } set state(stack) {} set state(namespace) {{{} {} xml xml}} return $token } # ::xmpp::xml::free -- # # Frees a previously created wrapper over an XML parser. # # Arguments: # token A previously created wrapper token. # # Results: # An empty string. # # Side effects: # An existing XML parser is destroyed. proc ::xmpp::xml::free {token} { variable $token upvar 0 $token state if {![info exists state(parser)]} { return -code error [::msgcat::mc "Parser \"%s\" doesn't exist" $token] } $state(parser) free unset state return } # ::xmpp::xml::parser -- # # Calls wrapped XML parser. # # Arguments: # token A wrapper token. # command An XML parser command (configure, parse, etc.). # args Arguments for a given command. # # Results: # An empty string. # # Side effects: # An XML parser invokes a series of callbacks. proc ::xmpp::xml::parser {token command args} { variable $token upvar 0 $token state variable implementation if {![info exists state(parser)]} { return -code error [::msgcat::mc "Parser \"%s\" doesn't exist" $token] } # TODO: catch and process errors if {$implementation eq "tdom" && $command eq "parse"} { # $args here contains only the XML data return [uplevel 1 [list $state(parser) parse [encoding convertto utf-8 [lindex $args 0]]]] } else { return [uplevel 1 [list $state(parser) $command] $args] } } # ::xmpp::xml::reset -- # # Resets wrapped XML parser and internal stack. # # Arguments: # token A wrapper token. # # Results: # An empty string. # # Side effects: # A wrapped parser is reset. proc ::xmpp::xml::reset {token} { variable $token upvar 0 $token state if {![info exists state(parser)]} { return -code error [::msgcat::mc "Parser \"%s\" doesn't exist" $token] } $state(parser) reset catch {$state(parser) configure -namespace 0} $state(parser) configure \ -final 0 \ -elementstartcommand [namespace code [list ElementStart $token]] \ -elementendcommand [namespace code [list ElementEnd $token]] \ -characterdatacommand [namespace code [list ElementCdata $token]] set state(stack) {} set state(namespace) {{{} {} xml xml}} return } # ::xmpp::xml::toText -- # # Creates textual representation from XML data. # # Arguments: # xmldata A parsed (or created by create) XML element. # pxmlns Optional. XMLNS of a parent XML element. # prefixes Optional. List of defined XMLNS prefixes. # Pairs (XMLNS, prefix) # # Results: # A converted raw XML data. # # Side effects: # None. proc ::xmpp::xml::toText {xmldata {pxmlns ""} {prefixes {xml xml http://etherx.jabber.org/streams stream}}} { set retext "" set tag [lindex $xmldata 0] set xmlns [lindex $xmldata 1] set attrs [lindex $xmldata 2] set subels [lindex $xmldata 3] set cdata [lindex $xmldata 4] array set p $prefixes set ps {} foreach ns [array names p] { lappend ps $p($ns) } # Parsimoniously adding new prefixes (only when XMLNS is prepended # to an attribute). set newattrs {} foreach {attr value} $attrs { set l [::split $attr :] if {[llength $l] > 1} { set axmlns [join [lrange $l 0 end-1] :] set aattr [lindex $l end] if {[string equal $axmlns $xmlns]} { lappend newattrs $aattr $value } elseif {[info exists p($axmlns)]} { lappend newattrs $p($axmlns):$aattr $value } else { set p($axmlns) [FindNewPrefix $ps] lappend newattrs xmlns:$p($axmlns) $axmlns $p($axmlns):$aattr $value } } else { lappend newattrs $attr $value } } if {![string equal $xmlns ""] && ![string equal $xmlns $pxmlns]} { if {![info exists p($xmlns)]} { lappend newattrs xmlns $xmlns set pxmlns $xmlns } else { set tag "$p($xmlns):$tag" } } append retext "<$tag" foreach {attr value} $newattrs { append retext " $attr='[Escape $value]'" } if {[string equal $cdata ""] && [llength $subels] == 0} { append retext "/>" return $retext } else { append retext ">" } append retext [Escape $cdata] foreach subdata $subels { append retext [toText $subdata $pxmlns [array get p]] append retext [Escape [lindex $subdata 5]] } append retext "" return $retext } # ::xmpp::xml::toTabbedText -- # # Creates pretty-printed textual representation from XML data. The XML # must satisfy the following condition: it must contain either a single # CDATA element or a list of subelements. Mixing CDATA and subelements # is not allowed. This procedure may be useful for saving XML into # files. # # Arguments: # xmldata A parsed (or created by create) XML element. # pxmlns Optional. XMLNS of a parent XML element. # # Results: # A converted raw XML data. # # Side effects: # None. proc ::xmpp::xml::toTabbedText {xmldata {pxmlns ""}} { return [toText [ReplaceCdata $xmldata 0] $pxmlns] } # ::xmpp::xml::ReplaceCdata -- # # Replace character data in XML element to a mix of tabs and linefeeds # to make its textual representation look pretty. This procedure distorts # XML element if it has subelements and CDATA simultaneously. # # Arguments: # xmldata A parsed (or created by create) XML element. # level number of tabulation characters to add before the element. # # Result: # XML element with CDATA sections replaced by tabs (except if CDATA is # a unique subelement). # # Side effects: # None. proc ::xmpp::xml::ReplaceCdata {xmldata level} { set tag [lindex $xmldata 0] set xmlns [lindex $xmldata 1] set attrs [lindex $xmldata 2] set subels [lindex $xmldata 3] set cdata1 [lindex $xmldata 4] set cdata2 [lindex $xmldata 5] set s1 \n[string repeat \t $level] incr level set s2 \n[string repeat \t $level] if {[llength $subels] == 0} { return [lreplace $xmldata 5 5 $s1] } else { set cdata1 $s2 set cdata2 $s1 set newsubels {} foreach subel [lrange $subels 0 end-1] { lappend newsubels [ReplaceCdata $subel $level] } set newsubel [ReplaceCdata [lindex $subels end] $level] lappend newsubels [lreplace $newsubel 5 5 $s1] return [list $tag $xmlns $attrs $newsubels $cdata1 $cdata2] } } # ::xmpp::xml::create -- # # Creates XML data for an element. # # Arguments: # tag An XML element name. # -xmlns xmlns An element XMLNS (optional, default is empty which # means inherited from a parent element). # -attrs attrlist A list {attr1 value1 attr2 value2 ...} of # attribute/value pairs (optional, default is no # attributes). Attribute list must not contain xmlns. # -cdata cdata CData of an element. It is appended after # the latest subelement (optional, defaoult is empty # CData). # -subelement el A subelement to add after the latest CData or # already added subelement (optional, default is no # subelements). # -subelements ellist A list of subelements to add (optional, default is # no subelements). # # Results: # A created XML element data. # # Side effects: # None. proc ::xmpp::xml::create {tag args} { set xmlns "" set attrs {} set cdata "" set subels {} foreach {key val} $args { switch -- $key { -xmlns {set xmlns $val} } } foreach {key val} $args { switch -- $key { -xmlns {} -attrs { foreach {attr value} $val { if {[string equal $attr xmlns]} { return -code error \ [::msgcat::mc "Illegal attribute \"xmlns\".\ Use -xmlns option"] } lappend attrs $attr $value } } -cdata { if {[llength $subels] == 0} { append cdata $val } else { set tail [lindex $subels end] set ncdata [lindex $tail 5]$val set subels \ [lreplace $subels end end [lreplace $tail 5 5 $ncdata]] } } -subelement { if {[llength $val] > 0} { if {[string equal [lindex $val 1] ""]} { lappend subels [lreplace $val 1 1 $xmlns] } else { lappend subels $val } } } -subelements { foreach subel $val { if {[llength $subel] > 0} { if {[string equal [lindex $subel 1] ""]} { lappend subels [lreplace $subel 1 1 $xmlns] } else { lappend subels $subel } } } } default { return -code error [::msgcat::mc "Invalid option \"%s\"" $key] } } } set retext [list $tag $xmlns $attrs $subels $cdata ""] return $retext } # ::xmpp::xml::split -- # # Splits the given xmldata into 5 variables. # # Arguments: # xmldata A parsed XML element. # tagVar A variable for element name. # xmlnsVar A variable for element XMLNS. # attrsVar A variable for element attributes. # cdataVar A variable for element CDATA. # subelsVar A variable for subelements. # nextCdataVar (optional) A variable for CDATA just after XML element. # This variable will always be empty for an outmost # element. # # Results: # An empty string. # # Side effects: # Five or six variables are assigned. proc ::xmpp::xml::split {xmldata tagVar xmlnsVar attrsVar cdataVar \ subelsVar {nextCdataVar ""}} { upvar 1 $tagVar tag $xmlnsVar xmlns $attrsVar attrs $cdataVar cdata \ $subelsVar subels set tag [lindex $xmldata 0] set xmlns [lindex $xmldata 1] set attrs [lindex $xmldata 2] set subels [lindex $xmldata 3] set cdata [lindex $xmldata 4] if {![string equal $nextCdataVar ""]} { upvar 1 $nextCdataVar nextCdata set nextCdata [lindex $xmldata 5] } return } # ::xmpp::xml::merge -- # # Merges the given data from 5 variables to XML element. The correctness # of data isn't checked. Since it's very easy to get inconsistent cdata # this procedure is mainly useful if one wants to change XMLNS or # attributes. # # Arguments: # tag An element name. # xmlns An element XMLNS. # attrs An element attributes. # cdata An element CDATA. # subels Subelements. # nextCdata (optional) A next CDATA. # # Results: # A merged XML element. # # Side effects: # None. proc ::xmpp::xml::merge {tag xmlns attrs cdata subels {nextCdata ""}} { return [list $tag $xmlns $attrs $subels $cdata $nextCdata] } # ::xmpp::xml::isAttr -- # # Returns 1, or 0, depending on if the attribute exists in attribute # list or not. # # Arguments: # attrList A list of attribute-value pairs. # attrName A name of attribute to check. # # Results: # 1 if the list contains a requested attribute, or 0 otherwise. # # Side effects: # None. proc ::xmpp::xml::isAttr {attrList attrName} { foreach {attr val} $attrList { if {[string equal $attr $attrName]} { return 1 } } return 0 } # ::xmpp::xml::getAttr -- # # Returns the value of the last given attribute from attribute list. # # Arguments: # attrList A list of attribute-value pairs. # attrName A name of attribute to get. # fallback (optional, defaults to "") A returned value in case # when attribute is missing # # Results: # An attribute value or a fallback value if the list doesn't # contain a requested attribute. # # Side effects: # None. proc ::xmpp::xml::getAttr {attrList attrName {fallback ""}} { set res $fallback foreach {attr val} $attrList { if {[string equal $attr $attrName]} { set res $val } } return $res } # ::xmpp::xml::getCdata -- # # Returns all element's CDATA chunks concatenated. # # Arguments: # xmldata A parsed XML element. # # Results: # An element CDATA. # # Side effects: # None. proc ::xmpp::xml::getCdata {xmldata} { set cdata [lindex $xmldata 4] foreach subel [lindex $xmldata 3] { append cdata [lindex $subel 5] } return $cdata } # ::xmpp::xml::getFirstCdata -- # # Returns element's CDATA chunk which is located before the first # subelement. # # Arguments: # xmldata A parsed XML element. # # Results: # A CDATA chunk which goes before the first subelement. # # Side effects: # None. proc ::xmpp::xml::getFirstCdata {xmldata} { return [lindex $xmldata 4] } # ::xmpp::xml::getNextCdata -- # # Returns parent's CDATA chunk which is located after the given XML # element. # # Arguments: # xmldata A parsed XML element. # # Results: # A parent's CDATA chunk which goes after the specified XML element. # # Side effects: # None. proc ::xmpp::xml::getNextCdata {xmldata} { return [lindex $xmldata 5] } # ::xmpp::xml::streamHeader -- # # Returns XMPP stream header. # # Arguments: # to A peer's (server's) JID. # -xmlns:stream uri xmlns:stream attribute # -xmlns uri xmlns attribute # -from jid from attribute (optional) # -xml:lang lang xml:lang attribute (optional) # -version ver XMPP version attribute (optional) # # Results: # An XMPP stream header. # # Side effects: # None. proc ::xmpp::xml::streamHeader {to args} { if {[isAttr $args -xmlns:stream]} { set xmlns_stream [getAttr $args -xmlns:stream] } else { return -code error [::msgcat::mc "Missing option \"%s\"" -xmlns:stream] } if {[isAttr $args -xmlns]} { set xmlns [getAttr $args -xmlns] } else { return -code error [::msgcat::mc "Missing option \"%s\"" -xmlns] } set retext "" return $retext } # ::xmpp::xml::streamTrailer -- # # Returns XMPP stream trailer. # # Arguments: # None. # # Results: # An XMPP stream trailer. # # Side effects: # None. proc ::xmpp::xml::streamTrailer {} { return "" } # ::xmpp::xml::parseData -- # Parse XML data. # # Arguments: # data XML data to parse. # stanzaCmd (optional) Callback to invoke on every outmost XML # stanza. If empty then list of all parsed XML stanzas # is returned. # # Result: # Empty string or parsed XML. # # Side effects: # Side effects from stanzaCmd. proc ::xmpp::xml::parseData {data {stanzaCmd ""}} { set token [new # # $stanzaCmd] variable $token upvar 0 $token state # HACK if {[string equal $stanzaCmd ""]} { set state(stanzaCmd) [namespace code [list ParseDataAux $token]] } set state(XML) {} # HACK to move declaration out from file tag regexp {(^\s*<\?([^?]|\?[^>])*\?>)?(.*)$} $data -> header _ data parser $token parse "$header\n$data" set xml $state(XML) free $token return $xml } proc ::xmpp:::xml::ParseDataAux {token xmlElement} { variable $token upvar 0 $token state lappend state(XML) $xmlElement } # ::xmpp::xml::lang -- # # Construct xml:lang attribute from msgcat preferences. # # Arguments: # None. # # Result: # Either language code (en, ru, es etc.) or language code joined with # country code (en-US, ru-RU, uk-UA etc.) depending on msgcat # preferences. # # Side effects: # None. proc ::xmpp::xml::lang {} { set prefs [::msgcat::mcpreferences] while {[string equal [lindex $prefs end] ""]} { set prefs [lreplace $prefs end end] } set lang [lindex $prefs end] switch -- $lang { "" - c - posix { return en } } set lang2 [lindex $prefs end-1] if {[regexp {^([A-Za-z]+)_([0-9A-Za-z]+)} $lang2 -> l1 l2]} { return [string tolower $l1]-[string toupper $l2] } else { return $lang } } # ::xmpp::xml::FindNewPrefix -- # # Find new XMLNS prefix. # # Arguments: # prefixes A list of defined prefixes. # # Results: # A string which isn't contained in the prefixes list. # # Side effects: # None. proc ::xmpp::xml::FindNewPrefix {prefixes} { set l0 {a b c d e f g h i j k l m n o p q r s t u v w x y z} set l1 $l0 while {1} { foreach p $l1 { if {[lsearch -exact $prefixes $p] < 0} { return $p } } set l1 [DescartesProduct $l1 $l0] } } # ::xmpp::xml::DescartesProduct -- # # Returns a sort of Descartes product of two lists of strings - the list # of appended strings from the first and the second list. # # Arguments: # prefixes The list of prefixes. # suffixes The lsit of suffixes. # # Results: # The list of strings, where prefixes from the first list are joined with # suffixes from the second one. # # Side effects: # None. proc ::xmpp::xml::DescartesProduct {prefixes suffixes} { set res {} foreach p $prefixes { foreach s $suffixes { lappend res $p$s } } } # ::xmpp::xml::Escape -- # # Escapes predefined XML entities and forbidden space characters. # # Arguments: # text Unescaped text. # # Results: # A string where forbidden space characters are replaced by spaces # and symbols which correspond to predefined XML entities are # replaced by them. # # Side effects: # None. proc ::xmpp::xml::Escape {text} { return [string map {& & < < > > \" " ' ' \x00 " " \x01 " " \x02 " " \x03 " " \x04 " " \x05 " " \x06 " " \x07 " " \x08 " " \x0B " " \x0C " " \x0E " " \x0F " " \x10 " " \x11 " " \x12 " " \x13 " " \x14 " " \x15 " " \x16 " " \x17 " " \x18 " " \x19 " " \x1A " " \x1B " " \x1C " " \x1D " " \x1E " " \x1F " " \x80 " " \x81 " " \x82 " " \x83 " " \x84 " " \x85 " " \x86 " " \x87 " " \x88 " " \x89 " " \x8A " " \x8B " " \x8C " " \x8D " " \x8E " " \x8F " " \x90 " " \x91 " " \x92 " " \x93 " " \x94 " " \x95 " " \x96 " " \x97 " " \x98 " " \x99 " " \x9A " " \x9B " " \x9C " " \x9D " " \x9E " " \x9F " "} $text] } # ::xmpp::xml::ElementStart -- # # A callback procedure which is called by a SAX parser when it finds # an XML element start. # # Arguments: # token A wrapper token. # tag A name of the current element. If tDOM is used then # it contains XMLNS prepended. # attrs Attributes list. # -namespace xmlns An XMLNS if TclXML tclparser is used. # # Results: # An empty string. # # Side effects: # If the current element is a outmost one then stream start command is # called. The current element is added to an XML elements stack. proc ::xmpp::xml::ElementStart {token tag attrs args} { variable $token upvar 0 $token state variable implementation if {![info exists state(parser)]} { return -code error [::msgcat::mc "Parser \"%s\" doesn't exist" $token] } if {$implementation eq "tdom"} { set tag [encoding convertfrom utf-8 $tag] set newattrs {} foreach attr $attrs { lappend newattrs [encoding convertfrom utf-8 $attr] } set attrs $newattrs } array set namespace [lindex $state(namespace) end] set newattrs {} foreach {attr val} $attrs { set l [::split $attr :] set prefix [lindex $l 0] set local [lindex $l 1] if {[string equal $prefix xmlns]} { set namespace($local) $val } else { lappend newattrs $attr $val } } set l [::split $tag :] if {[llength $l] > 1} { set prefix [lindex $l 0] set tag [lindex $l 1] if {![info exists namespace($prefix)]} { set xmlns undefined } else { set xmlns $namespace($prefix) } } else { set xmlns $namespace() } set attrs {} foreach {attr val} $newattrs { set l [::split $attr :] if {[llength $l] > 1} { set prefix [lindex $l 0] set attr [lindex $l 1] if {![info exists namespace($prefix)]} { if {![string equal $xmlns undefined]} { set attr undefined:$attr } } elseif {![string equal $xmlns $namespace($prefix)]} { set attr $namespace($prefix):$attr } } lappend attrs $attr $val } lappend state(namespace) [array get namespace] set state(stack) \ [linsert $state(stack) 0 [list $tag $xmlns $attrs {} "" ""]] if {[llength $state(stack)] == 1} { uplevel #0 $state(streamHeaderCmd) [list $attrs] } return } # ::xmpp::xml::ElementEnd -- # # A callback procedure which is called by a SAX parser when it finds # an XML element end. # # Arguments: # token A wrapper token. # tag A name of the current element. # # Results: # An empty string. # # Side effects: # If the current element is a outmost one then stream end command is # called. If the current element is level one element then stanza # command is called. In both cases the element removed from the stack. # Otherwise the current element is inserted into its parent. proc ::xmpp::xml::ElementEnd {token tag args} { variable $token upvar 0 $token state variable implementation if {![info exists state(parser)]} { return -code error [::msgcat::mc "Parser \"%s\" doesn't exist" $token] } if {$implementation eq "tdom"} { set tag [encoding convertfrom utf-8 $tag] } set state(namespace) [lreplace $state(namespace) end end] set newEl [lindex $state(stack) 0] set tail [lrange $state(stack) 1 end] set len [llength $tail] if {$len > 1} { set head [lindex $tail 0] set els [linsert [lindex $head 3] end $newEl] set state(stack) [lreplace $tail 0 0 [lreplace $head 3 3 $els]] } elseif {$len == 1} { set state(stack) $tail uplevel #0 $state(stanzaCmd) [list $newEl] } else { set state(stack) $tail uplevel #0 $state(streamTrailerCmd) } return } # ::xmpp::xml::ElementCdata -- # # A callback procedure which is called by a SAX parser when it finds # an XML element CData. # # Arguments: # token A wrapper token. # cdata Character data. # # Results: # An empty string. # # Side effects: # A given CData is added to a current XML element. proc ::xmpp::xml::ElementCdata {token cdata} { variable $token upvar 0 $token state variable implementation if {![info exists state(parser)]} { return -code error [::msgcat::mc "Parser \"%s\" doesn't exist" $token] } if {$implementation eq "tdom"} { set cdata [encoding convertfrom utf-8 $cdata] } set newEl [lindex $state(stack) 0] set els [lindex $newEl 3] if {[llength $els] == 0} { set newEl [lreplace $newEl 4 4 [lindex $newEl 4]$cdata] } else { set els [lindex $newEl 3] set lastEl [lindex $els end] set lastEl [lreplace $lastEl 5 5 [lindex $lastEl 5]$cdata] set els [lreplace $els end end $lastEl] set newEl [lreplace $newEl 3 3 $els] } set state(stack) [lreplace $state(stack) 0 0 $newEl] return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/xmpp.tcl000064400000000000000000001566221470446212700146200ustar00nobodynobody# xmpp.tcl -- # # This file is part of the XMPP library. It implements the main library # routines. # # Copyright (c) 2008-2016 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. package require msgcat package require xmpp::jid package require xmpp::xml package require xmpp::transport::tcp 0.2 package require xmpp::streamerror package require xmpp::stanzaerror package require xmpp::iq package require xmpp::presence package require xmpp::sm package provide xmpp 0.3 namespace eval ::xmpp { # Default debug level (0: no debug, 1: light debug, 2: heavy debug). variable debug 0 } # ::xmpp::new -- # # Create a new XMPP token and assigns client callbacks for XMPP events. # # Arguments: # token (optional, if missing then token is created # automatically, if present then it must be a # fully namespaced nonexistent variable) XMPP # token to create. # -packetcommand cmd (optional) Command to call on every incoming # XMPP packet except stream errors. # -messagecommand cmd (optional) Command to call on every XMPP # message packet (overrides -packetcommand). # -presencecommand cmd (optional) Command to call on every XMPP # presence packet (overrides -packetcommand). # -disconnectcommand cmd (optional) Command to call on forced disconnect # from XMPP server. # -statuscommand cmd (optional) Command to call when XMPP connection # status is changed (e.g. after successful # authentication). # -errorcommand cmd (optional) Command to call on XMPP stream error # packet. # -logcommand cmd (optional) Command to call when text or XML has # come or about to be sent. Its purpose is to # log outgoing or incoming traffic. # -smcommand cmd (optional) Command to call on Stream Management # (XEP-0198) stanza acknowledgement events. # # Result: # XMPP token name or error if the supplied variable exists or illegal # option is listed. # # Side effects: # A new variable is created. proc ::xmpp::new {args} { variable id if {![info exists id]} { set id 0 } if {[llength $args] > 0 && ![string match -* [lindex $args 0]]} { set xlib [lindex $args 0] set args [lrange $args 1 end] if {[info exists $xlib]} { return -code error \ [::msgcat::mc "An existing variable \"%s\" cannot be used\ as an XMPP token" $xlib] } } else { set xlib [namespace current]::[incr id] # Variable id always grows but user may occupy some values while {[info exists $xlib]} { set xlib [namespace current]::[incr id] } } foreach {key val} $args { switch -- $key { -packetcommand - -messagecommand - -presencecommand - -iqcommand - -disconnectcommand - -statuscommand - -errorcommand - -logcommand - -smcommand { set attrs($key) $val } default { return -code error [::msgcat::mc "Illegal option \"%s\"" $key] } } } variable $xlib upvar 0 $xlib state array unset state set state(status) disconnected # A sequence of IQ ids set state(id) 0 array set state [array get attrs] if {[info exists state(-messagecommand)]} { RegisterElement $xlib message * \ [namespace code [list ParseMessage $xlib]] } if {[info exists state(-presencecommand)]} { RegisterElement $xlib presence * \ [namespace code [list ParsePresence $xlib]] } if {![info exists state(-packetcommand)] || \ [info exists state(-iqcommand)]} { RegisterElement $xlib iq * \ [namespace code [list ParseIQ $xlib]] } RegisterElement $xlib error http://etherx.jabber.org/streams \ [namespace code [list ParseStreamError $xlib]] RegisterElement $xlib features http://etherx.jabber.org/streams \ [namespace code [list ParseStreamFeatures $xlib]] set state(sm) [::xmpp::sm::new $xlib] Debug $xlib 2 "" return $xlib } # ::xmpp::free -- # # Destroy an existing XMPP token. # # Arguments: # xlib XMPP token to destroy. # # Result: # Empty string or error if the token is still connected. # # Side effects: # The variable which contains token state is destroyed. proc ::xmpp::free {xlib} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "" if {![string equal $state(status) disconnected]} { return -code error [::msgcat::mc "Free without disconnect"] } ::xmpp::sm::free $state(sm) if {[info exists state(-messagecommand)]} { UnregisterElement $xlib message * } if {[info exists state(-presencecommand)]} { UnregisterElement $xlib presence * } if {![info exists state(-packetcommand)]} { UnregisterElement $xlib iq * } UnregisterElement $xlib error http://etherx.jabber.org/streams UnregisterElement $xlib features http://etherx.jabber.org/streams unset state return } # ::xmpp::connect -- # # Connect to XMPP server. # # Arguments: # xlib XMPP token. # host (optional, defaults to "localhost") Server name # to connect. It isn't used when transport is # "poll". # port (optional, defaults to 5222) Port to connect. # It isn't used for "poll" transport. # -transport transport (optional, defaults to "tcp") Transport to use # when connecting to an XMPP server. May be one # of "tcp", "tls", "poll", "zlib" (though none of # the servers support zlib compressed sockets # without prior negotiating). # -command cmd (optional) If present then the connection # becomes asynchronous and the command is called # upon connection success or failure. Otherwise # the connection is in synchronous mode. # Other arguments are passed unchanged to corresponding transport open # routine. # # Result: # Empty string on success or error on failure in synchronous mode. # Connection token to make it possible to abort connection in # asynchronous mode. # # Side effects: # A new connection to an XMPP server is started (or is opened). In # synchronous mode connection status is set to "connected". In # asynchronous mode an abort command is stored to be called if a user # will decide to abort connection procedure. proc ::xmpp::connect {xlib args} { variable $xlib upvar 0 $xlib state if {![string equal $state(status) disconnected]} { # TODO: Should we use ForcedDisconnect or call back? disconnect $xlib } set transport tcp set host localhost set port 5222 set argList {} if {![string match -* [lindex $args 0]]} { set host [lindex $args 0] set args [lrange $args 1 end] } if {![string match -* [lindex $args 0]]} { set port [lindex $args 0] set args [lrange $args 1 end] } foreach {key val} $args { switch -- $key { -transport {set transport $val} -command {set cmd $val} default {lappend argList $key $val} } } Debug $xlib 2 "$host $port $transport" if {![info exists cmd]} { # TODO: Allow abortions in synchronous mode too. # Propagate error (if any) up. set state(transport) \ [eval [list transport::open $transport $host $port \ -streamheadercommand \ [namespace code [list GotStream $xlib ok]] \ -streamtrailercommand \ [namespace code [list EndOfParse $xlib]] \ -stanzacommand \ [namespace code [list Parse $xlib]] \ -eofcommand \ [namespace code [list EndOfFile $xlib]]] \ $argList] set state(status) connected return } else { set token \ [eval [list transport::open $transport $host $port \ -streamheadercommand \ [namespace code [list GotStream $xlib ok]] \ -streamtrailercommand \ [namespace code [list EndOfParse $xlib]] \ -stanzacommand \ [namespace code [list Parse $xlib]] \ -eofcommand \ [namespace code [list EndOfFile $xlib]] \ -command \ [namespace code [list ConnectAux $xlib $cmd]]] \ $argList] set state(abortCommand) \ [namespace code [list transport::use $token abort]] return $token } } # ::xmpp::ConnectAux -- # # A helper procedure which calls back with connection to XMPP server # result. # # Arguments: # xlib XMPP token. # cmd Callback to call. # status "ok", "error", "abort", or "timeout". # msg Transport token in case of success or error message in # case of failure. # # Result: # Empty string. # # Side effects: # A callback is called and a stored abort command is emptied (it is no # longer needed as the connect procedure is finished). proc ::xmpp::ConnectAux {xlib cmd status msg} { variable $xlib upvar 0 $xlib state catch {unset state(abortCommand)} if {[string equal $status ok]} { set state(transport) $msg set state(status) connected uplevel #0 $cmd [list ok ""] } else { uplevel #0 $cmd [list $status $msg] } return } # ::xmpp::openStream -- # # Open XMPP stream over the already opened connection. # # Arguments: # xlib XMPP token. # server XMPP server to which the stream is opened. # -xmlns:stream ns (optional, defaults to # http://etherx.jabber.org/streams, if present must be # http://etherx.jabber.org/streams). XMLNS for stream # prefix. # -xmlns xmlns (optional, defaults to jabber:client) Stream default # XMLNS. # -xml:lang lang (optional, defaults to language from msgcat # preferences) Stream default xml:lang attribute. # -version ver (optional) Stream XMPP version. Must be "1.0" if any # XMPP feature is used (SASL, STARTTLS, stream # compression). # -timeout num (optional, defaults to 0 which means infinity) Timeout # after which the operation is finished with failure. # -command cmd (optional) If present then the stream opens in # asynchronous mode and the command "cmd" is called upon # success or failure. Otherwise the mode is synchronous. # # Result: # The same as in [OpenStreamAux]. # # Side effects: # The same as in [OpenStreamAux]. Also, server state variable is set. proc ::xmpp::openStream {xlib server args} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "$server $args" set state(server) $server eval [list OpenStreamAux $xlib open] $args } # ::xmpp::ReopenStream -- # # Reset underlying XML parser and reopen XMPP stream. This procedure # is useful when changing transport (from tcp to tls or zlib) and # when resetting stream after SASL authentication. It's never called # by user directly. # # Arguments: # xlib XMPP token. # args Additional arguments to pass to OpenStreamAux. They are # the same as for [openStream]. But usually the only # useful options are -command and -timeout. # # Result: # The same as in [OpenStreamAux]. # # Side effects: # In addition to [OpenStreamAux] side effects, an XML parser in transport # is reset. proc ::xmpp::ReopenStream {xlib args} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "$args" transport::use $state(transport) reset # Unset features variable to remove possible trace. array unset state features if {[info exists state(-version)]} { set vargs [list -version $state(-version)] } else { set vargs {} } eval [list OpenStreamAux $xlib reopen \ -xmlns:stream $state(-xmlns:stream) \ -xmlns $state(-xmlns) \ -xml:lang $state(-xml:lang)] $vargs $args } # ::xmpp::OpenStreamAux -- # # A helper procedure which contains common code for opening and # reopening XMPP streams. # # Arguments: # mode 'open' or 'reopen'. # The others are the same as for openStream (except server which is # taken from state variable). # # Result: # Empty string in asynchronous mode, session id or error in synchronous # mode. # # Side effects: # Stream header is sent to an open channel. An abort command is stored # to be called if a user will decide to abort stream opening procedure. # # Bugs: # Only stream XMLNS http://etherx.jabber.org/streams is supported. # On the other hand there's no other defined stream XMLNS currently. proc ::xmpp::OpenStreamAux {xlib mode args} { variable $xlib upvar 0 $xlib state array set params [list -xmlns:stream http://etherx.jabber.org/streams \ -xmlns jabber:client \ -xml:lang [xml::lang]] array set state [array get params] set timeout 0 foreach {key val} $args { switch -- $key { -xmlns:stream { if {![string equal $val http://etherx.jabber.org/streams]} { return -code error \ [::msgcat::mc "Unsupported stream XMLNS \"%s\"" \ $val] } } -xmlns - -xml:lang - -from - -version { set state($key) $val set params($key) $val } -timeout { set timeout $val } -command { set state(openStreamCommand) $val } default { return -code error [::msgcat::mc "Illegal option \"%s\"" $key] } } } if {$timeout > 0} { set state(streamAfterId) \ [after $timeout [namespace code [list GotStream $xlib timeout {}]]] } # Stream may be reopened inside STARTTLS, or compression, or SASL # procedure, so set abort command only if it isn't defined already. if {![info exists state(abortCommand)]} { set state(abortCommand) \ [namespace code [list GotStream $xlib abort {}]] } eval [list transport::use $state(transport) ${mode}Stream $state(server)] \ [array get params] if {[info exists state(openStreamCommand)]} { # Asynchronous mode return "" } else { # Synchronous mode vwait $xlib\(openStatus) if {![string equal $state(openStatus) timeout]} { return $state(sessionID) } else { return -code error $state(sessionID) } } } # ::xmpp::GotStream -- # # A helper procedure which is invoked when an incoming XMPP stream # header is parsed by a transport. It finishes headers exchange. # # Arguments: # xlib XMPP token. # status "ok", "abort", or "timeout". # attrs List of XMPP stream attributes. # # Result: # Empty string. # # Side effects: # A callback is called in asynchronous mode or [vwait] is triggered # in synchronous mode. Also, a stored abort command is emptied (it is no # longer needed as the connect procedure is finished). proc ::xmpp::GotStream {xlib status attrs} { variable $xlib upvar 0 $xlib state if {![info exists state(abortCommand)]} { # state(abortCommand) must exist, otherwise it's a stale stream Debug $xlib 2 "Stale stream: $status $attrs" return } Debug $xlib 2 "$status $attrs" if {[string equal $status ok]} { set msg "" CallBack $xlib log input text $msg } if {[info exists state(openStreamCommand)]} { set cmd $state(openStreamCommand) unset state(openStreamCommand) } if {[info exists state(streamAfterId)]} { after cancel $state(streamAfterId) unset state(streamAfterId) } # Stream may be reopened inside STARTTLS, or compression, or SASL # procedure, so unset abort command only if it was set in [openStream] if {[string equal $state(abortCommand) \ [namespace code [list GotStream $xlib abort {}]]]} { catch {unset state(abortCommand)} } switch -- $status { timeout { set state(sessionID) [::msgcat::mc "Opening stream timed out"] # Trigger vwait in [openStream] in synchronous mode set state(openStatus) $status if {[info exists cmd]} { # Invoke callback in asynchronous mode uplevel #0 $cmd [list $status $state(sessionID)] } return } abort { set state(sessionID) [::msgcat::mc "Opening stream aborted"] # Trigger vwait in [openStream] in synchronous mode set state(openStatus) $status if {[info exists cmd]} { # Invoke callback in asynchronous mode uplevel #0 $cmd [list $status $state(sessionID)] } return } } if {[xml::isAttr $attrs from]} { # Sometimes server (ejabberd is known to) returns 'from' # attribute which differs from 'to' attribute sent to the server. # If XMLNS is 'jabber:component:accept' then the address in 'from' # attribute is ignored. if {![string equal $state(-xmlns) jabber:component:accept]} { set state(server) [xml::getAttr $attrs from] } } set version [xml::getAttr $attrs version] if {![string is double -strict $version]} { set version 0.0 } set sessionID [xml::getAttr $attrs id] Debug $xlib 2 "server = $state(server), sessionID = $sessionID,\ version = $version" if {$version < 1.0} { # Register iq-auth and iq-register namespaces to allow # authenticate and register in-band on pre-XMPP server ParseStreamFeatures $xlib \ [xml::create features \ -xmlns http://etherx.jabber.org/streams \ -subelement \ [xml::create auth \ -xmlns http://jabber.org/features/iq-auth] \ -subelement \ [xml::create register \ -xmlns http://jabber.org/features/iq-register]] } set state(status) streamOpened set state(sessionID) $sessionID # Trigger vwait in [openStream] in synchronous mode set state(openStatus) $status if {[info exists cmd]} { # Invoke callback in asynchronous mode uplevel #0 $cmd [list $status $sessionID] } return } # ::xmpp::streamFeatures -- # # Return the current stream features list. # # Arguments: # xlib XMPP token. # # Result: # Features list. # # Side effects: # Features list is taken from the state variable. proc ::xmpp::streamFeatures {xlib} { variable $xlib upvar 0 $xlib state if {[info exists state(features)]} { return $state(features) } else { return {} } } # ::xmpp::ParseStreamFeatures -- # # A helper procedure which is called when stream features are received. # It stores features list (as a list of XML elements, because it may be # a deep list) in a variable. This procedure is registered as a handler # for features element in http://etherx.jabber.org/streams XMLNS in # [new]. # # Arguments: # xlib XMPP token. # xmlElement Features XML element to store. # # Result: # Empty string. # # Side effects: # Features list is stored in a state variable. proc ::xmpp::ParseStreamFeatures {xlib xmlElement} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "$xmlElement" xml::split $xmlElement tag xmlns attrs cdata subels set state(features) $subels return } # ::xmpp::TraceStreamFeatures -- # # Call the specified command back if stream features are already # received, or set a trace to call the command upon receiving them. # Trace syntax is old-style to make it work in Tcl 8.3. # # Arguments: # xlib XMPP token. # cmd Command to call. # # Result: # Empty string. # # Side effects: # If stream features aren't received yet then a trace is added for # variable state(features). proc ::xmpp::TraceStreamFeatures {xlib cmd} { variable $xlib upvar 0 $xlib state if {[info exists state(features)]} { after idle $cmd [list $state(features)] } else { # Variable state(features) must not be set outside ParseStreamFeatures, # to prevent spurious trace callback triggering. trace variable $xlib\(features) w \ [namespace code [list TraceStreamFeaturesAux $xlib $cmd]] } return } # ::xmpp::TraceStreamFeaturesAux -- # # A helper procedure which is called by a trace of state(features) # variable. It in turn removes trace and calls a specified command back. # Trace syntax is old-style to make it work in Tcl 8.3. # # Arguments: # xlib XMPP token. # cmd Command to call. # args Arguments, added by trace. # # Result: # Empty string. # # Side effects: # Trace of state(features) variable is removed. proc ::xmpp::TraceStreamFeaturesAux {xlib cmd args} { variable $xlib upvar 0 $xlib state RemoveTraceStreamFeatures $xlib $cmd uplevel #0 $cmd [list $state(features)] return } # ::xmpp::RemoveTraceStreamFeatures -- # # Remove trace of state(features) variable if it's set. This procedure # may be called in case if it's needed to abort connection process, or # in case when stream features are received (see # [TraceStreamFeaturesAux]). # # Arguments: # xlib XMPP token. # cmd Command that was to be called. # # Result: # Empty string. # # Side effects: # Trace of state(features) is removed if it was set. proc ::xmpp::RemoveTraceStreamFeatures {xlib cmd} { variable $xlib upvar 0 $xlib state trace vdelete $xlib\(features) w \ [namespace code [list TraceStreamFeaturesAux $xlib $cmd]] return } # ::xmpp::ParseStreamError -- # # A helper procedure which is called when stream error is received. # It calls back error command (-errorcommand option in [new]) with # appended error message. This procedure is registered as a handler # for error element in http://etherx.jabber.org/streams XMLNS in [new]. # # Arguments: # xlib XMPP token. # xmlElement Stream error XML element. # # Result: # Empty string. # # Side effects: # A client error callback is invoked. proc ::xmpp::ParseStreamError {xlib xmlElement} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "$xmlElement" CallBack $xlib error [streamerror::condition $xmlElement] \ [streamerror::message $xmlElement] return } # ::xmpp::SwitchTransport -- # # Switch XMPP transport. This procedure is helpful if STARTTLS or # stream compression over TCP is used. # # Arguments: # xlib XMPP token. # transport Transport name to switch to. # # Result: # Empty string or error. # # Side effects: # Transport is changed if it's possible. proc ::xmpp::SwitchTransport {xlib transport args} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "$transport" set state(transport) \ [eval [list transport::switch $state(transport) $transport] $args] return } # ::xmpp::outXML -- # # Output XML element to an XMPP channel. # # Arguments: # xlib XMPP token. # xmlElement XML element to send. # # Result: # Length of the sent textual XML representation. # # Side effects: # XML element is sent to the server. proc ::xmpp::outXML {xlib xmlElement} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "[xml::toText $xmlElement]" CallBack $xlib log output xml $xmlElement after idle [list ::xmpp::sm::count $state(sm) out $xmlElement] transport::use $state(transport) outXML $xmlElement } # ::xmpp::outText -- # # Output text string to an XMPP channel. If the text doesn't represent # valid XML then server will likely disconnect the XMPP session. # # Arguments: # xlib XMPP token. # text Text to send. # # Result: # Length of the sent XML textual representation. # # Side effects: # XML element is sent to the server. proc ::xmpp::outText {xlib text} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "$text" CallBack $xlib log output text $text transport::use $state(transport) outText $text } # ::xmpp::closeStream -- # # Close XMPP stream (usually by sending ). # # Arguments: # xlib XMPP token. # -wait bool (optional, default 0) Wait for the server side. # # Result: # Length of the sent stream trailer. # # Side effects: # XMPP stream trailer is sent to the server. proc ::xmpp::closeStream {xlib args} { variable $xlib upvar 0 $xlib state set msg [xml::streamTrailer] Debug $xlib 2 "$msg" CallBack $xlib log output text $msg eval [list transport::use $state(transport) closeStream] $args } # ::xmpp::EndOfParse -- # # A callback procedure which is called if end of stream is received from # an XMPP server. If it's intentional (XMPP token is in disconnecting # state) then do nothing, otherwise disconnect. # # Arguments: # xlib XMPP token. # # Result: # Empty string. # # Side effects: # In disconnected or disconnecting state none, otherwise ForcedDisconnect # procedure is called. proc ::xmpp::EndOfParse {xlib} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "" CallBack $xlib log input text "" switch -- $state(status) { disconnecting - disconnected {} default { ForcedDisconnect $xlib } } return } # ::xmpp::EndOfFile -- # # A callback procedure which is called if an XMPP server has closed # connection. If it's intentional (XMPP token is in disconnecting # state) then do nothing, otherwise disconnect. # # Arguments: # xlib XMPP token. # # Result: # Empty string. # # Side effects: # In disconnected or disconnecting state none, otherwise ForcedDisconnect # procedure is called. proc ::xmpp::EndOfFile {xlib} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "" switch -- $state(status) { disconnecting - disconnected {} default { ForcedDisconnect $xlib } } return } # ::xmpp::ForcedDisconnect -- # # Disconnect from an XMPP server if this disconnect id forced by the # server itself. # # Arguments: # xlib XMPP token. # # Result: # Empty string. # # Side effects: # In disconnected or disconnecting state none, otherwise this procedure # aborts any pending operation, closes the XMPP channel, calls back # "disconnect" client function and clears the token state. proc ::xmpp::ForcedDisconnect {xlib} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "" switch -- $state(status) { disconnecting - disconnected {} default { set state(status) disconnecting if {[info exists state(abortCommand)]} { uplevel #0 $state(abortCommand) catch {unset state(abortCommand)} } if {[catch {transport::use $state(transport) close} msg]} { Debug $xlib 1 "Closing connection failed: $msg" } catch {unset state(transport)} CallBack $xlib disconnect ClearState $xlib } } return } # ::xmpp::disconnect -- # # Disconnect from an XMPP server. # # Arguments: # xlib XMPP token. # -wait bool (optional, default 0) Wait for the server side when # closing XMPP stream. # # Result: # Empty string. # # Side effects: # In disconnected or disconnecting state none, otherwise this procedure # aborts any pending operation, closes the XMPP stream and channel, and # clears the token state. proc ::xmpp::disconnect {xlib args} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "" switch -- $state(status) { disconnecting - disconnected {} default { set state(status) disconnecting if {[info exists state(abortCommand)]} { uplevel #0 $state(abortCommand) catch {unset state(abortCommand)} } if {[catch {eval [list closeStream $xlib] $args} msg]} { Debug $xlib 1 "Closing stream failed: $msg" } if {[catch {transport::use $state(transport) close} msg]} { Debug $xlib 1 "Closing connection failed: $msg" } catch {unset state(transport)} ClearState $xlib } } } # ::xmpp::ClearState -- # # Clean XMPP token state. # # Arguments: # xlib XMPP token. # # Result: # Empty string. # # Side effects: # All pending IQ callbacks are called and state array is cleaned up. proc ::xmpp::ClearState {xlib} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "" foreach idx [array names state iq,*] { set cmd $state($idx) unset state($idx) uplevel #0 $cmd [list abort \ [xml::create error \ -cdata [::msgcat::mc "Disconnected"]]] } # Don't reset ID counter because the higher level application may # still use the old values. #set state(id) 0 set state(status) disconnected # connect # This variable is unset in [disconnect] or [ForcedDisconnect] #array unset state transport # openStream array unset state server array unset state -xmlns:stream array unset state -xmlns array unset state -xml:lang array unset state -version array unset state openStreamCommand array unset state streamAfterId array unset state openStatus array unset state sessionID # TraceStreamFeatures array unset state features # various array unset state abortCommand return } # ::xmpp::RegisterElement -- # # Register callback for XMPP top-level stanza in a stream. # # Arguments: # xlib XMPP token. # tag XML element tag pattern. # xmlns XMLNS pattern. # cmd Command to call when the top-level stanza in XMPP # stream matches tag ans XMLNS patterns. # # Result: # Empty string. # # Side effects: # Command is pushed to a stack of registered commands for given tag and # XMLNS patterns. proc ::xmpp::RegisterElement {xlib tag xmlns cmd} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "$tag $xmlns $cmd" lappend state(registered,$tag,$xmlns) $cmd return } # ::xmpp::UnregisterElement -- # # Unregister the last callback for XMPP top-level stanza in a stream. # # Arguments: # xlib XMPP token. # tag XML element tag pattern. # xmlns XMLNS pattern. # # Result: # Empty string. Error is raised if there wasn't a registered command for # specified tag ans XMLNS patterns. # # Side effects: # The last registered command is popped from a stack of registered # commands for given tag and XMLNS patterns. proc ::xmpp::UnregisterElement {xlib tag xmlns} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "$tag $xmlns" set state(registered,$tag,$xmlns) \ [lreplace $state(registered,$tag,$xmlns) end end] return } # ::xmpp::ElementCommand -- # # Return the last registerd command for XMPP top-level stanza. # # Arguments: # xlib XMPP token. # tag XML element tag. # xmlns XMLNS. # # Result: # Command which was registered for specified tag and XMLNS if any. # Otherwise a command which was registered for patterns which match tag # and XMLNS if any. Otherwise an empty string. # # Side effects: # None. proc ::xmpp::ElementCommand {xlib tag xmlns} { variable $xlib upvar 0 $xlib state # If there's an exact match, return it if {[info exists state(registered,$tag,$xmlns)]} { return [lindex $state(registered,$tag,$xmlns) end] } # Otherwise find matching indices foreach idx [lsort [array names state registered,*]] { set fields [split $idx ,] set ptag [lindex $fields 1] set pxmlns [join [lrange $fields 2 end] ,] if {[string match $ptag $tag] && [string match $pxmlns $xmlns]} { return [lindex $state($idx) end] } } # There's no matches return } # ::xmpp::Parse -- # # A callback procedure which is called when a top-level XMPP stanza is # received. It in turn calls a procedure which parses and processes the # stanza. # # Arguments: # xlib XMPP token # xmlElement Top-level XML stanza. # # Result: # Empty string. # # Side effects: # A registered command for the xmlElement tag and XMLNS is called if any, # or general "packet" callback is invoked. proc ::xmpp::Parse {xlib xmlElement} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "$xmlElement" CallBack $xlib log input xml $xmlElement if {![info exists state(transport)]} { Debug $xlib 1 "Connection doesn't exist" return -1 } ::xmpp::sm::count $state(sm) in $xmlElement xml::split $xmlElement tag xmlns attrs cdata subels set cmd [ElementCommand $xlib $tag $xmlns] if {![string equal $cmd ""]} { uplevel #0 $cmd [list $xmlElement] return } CallBack $xlib packet $xmlElement return } # ::xmpp::ParseMessage -- # # Parse XMPP message and invoke "message" client callback. The callback # must take the following arguments: # (Mandatory) # xlib XMPP token. # from From JID. # type Message type ("", "error", "normal", "chat", # "groupchat", "headline"). # x Extra subelements (attachments). # (Optional) # -x keypairs Key-valus pairs of extra attributes. # -lang lang xml:lang # -to to To JID (usually own JID). # -id id Stanza ID (string). # -subject subject Message subject (string). # -thread thread Message thread (string). # -body body Message body (string). # -error error Error stanza (XML element). # # Arguments: # xlib XMPP token # xmlElement XMPP stanza. # # Result: # Empty string. # # Side effects: # A message callback is called if defined. proc ::xmpp::ParseMessage {xlib xmlElement} { variable $xlib upvar 0 $xlib state xml::split $xmlElement tag xmlns attrs cdata subels set from "" set type "" set x {} set params {} set xparam {} foreach {key val} $attrs { switch -- $key { from {set from $val} type { switch -- $val { chat - error - groupchat - headline - normal { set type $val } default { Debug $xlib 1 \ [::msgcat::mc "Unknown message type %s" $val] } } } xml:lang {lappend params -lang $val} to {lappend params -to $val} id {lappend params -id $val} default {lappend xparam $key $val} } } foreach subel $subels { xml::split $subel stag sxmlns sattrs scdata ssubels switch -- $stag { subject {lappend params -subject $scdata} thread {lappend params -thread $scdata} body {lappend params -body $scdata} error {lappend params -error $subel} default {lappend x $subel} } } eval [list CallBack $xlib message $from $type $x -x $xparam] $params return } # ::xmpp::ParsePresence -- # # Parse XMPP presence and invoke "presence" client callback. The callback # must take the following arguments: # (Mandatory) # xlib XMPP token. # from From JID. # type Presence type ("", "error", "unavailable", # "probe", "subscribe", "subscribed", # "unsubscribe", "unsubscribed"). # x Extra subelements (attachments). # (Optional) # -x keypairs Key-valus pairs of extra attributes. # -lang lang xml:lang # -to to To JID (usually own JID). # -id id Stanza ID (string). # -priority priority Presence priority (number). # -show show Presence status (missing, "away", "chat", # "dnd", "xa"). # -status status Presence extended status (string). # -error error Error stanza (XML element). # # Arguments: # xlib XMPP token # xmlElement XMPP stanza. # # Result: # Empty string. # # Side effects: # A presence callback is called if defined. proc ::xmpp::ParsePresence {xlib xmlElement} { variable $xlib upvar 0 $xlib state xml::split $xmlElement tag xmlns attrs cdata subels set from "" set type "" set x {} set params {} set xparam {} foreach {key val} $attrs { switch -- $key { from {set from $val} type {set type $val} xml:lang {lappend params -lang $val} to {lappend params -to $val} id {lappend params -id $val} default {lappend xparam $key $val} } } foreach subel $subels { xml::split $subel stag sxmlns sattrs scdata ssubels switch $stag { priority { if {[string is integer -strict $scdata]} { lappend params -priority $scdata } } show { switch -- $scdata { away - chat - dnd - xa { lappend params -show $scdata } } } status {lappend params -status $scdata} error {lappend params -error $subel} default {lappend x $subel} } } # Evaluate client callback eval [list CallBack $xlib presence $from $type $x -x $xparam] $params # Evaluate internal (or otherwise registered) callbacks eval [list presence::process $xlib $from $type $x -x $xparam] $params return } # ::xmpp::ParseIQ -- # # Parse XMPP IQ. For get or set IQ type invoke [iq::process] command # which will find and invoke the corresponding handler. For result or # error IQ type find and call the callback stored in [sendIQ]. # # Arguments: # xlib XMPP token # xmlElement XMPP stanza. # # Result: # Empty string. # # Side effects: # An IQ handler or the callback specified when IQ was sent is called if # defined. proc ::xmpp::ParseIQ {xlib xmlElement} { variable $xlib upvar 0 $xlib state Debug $xlib 2 $xmlElement xml::split $xmlElement tag xmlns attrs cdata subels set to "" set from "" set type "" set id "" set x {} set params {} set xparam {} foreach {key val} $attrs { switch -- $key { from {set from $val} type {set type $val} xml:lang {lappend params -lang $val} to { set to $val lappend params -to $val } id { set id $val lappend params -id $val } default {lappend xparam $key $val} } } # Any IQ. eval [list CallBack $xlib iq $from $type $subels -x $xparam] $params switch -- $type { get - set { # Registered IQ. eval [list iq::process $xlib $from $type \ [lindex $subels 0]] $params return } result { if {[info exists state(iq,$id)]} { set cmd $state(iq,$id) unset state(iq,$id) uplevel #0 $cmd [list ok [lindex $subels 0]] } else { Debug $xlib 1 \ [::msgcat::mc "IQ id %s doesn't exist in memory" $id] } return } error { if {[info exists state(iq,$id)]} { set cmd $state(iq,$id) unset state(iq,$id) set error {} foreach subel $subels { xml::split $subel stag sxmlns sattrs scdata ssubels if {[string equal $stag error]} { set error $subel break } } uplevel #0 $cmd [list error $error] } else { Debug $xlib 1 \ [::msgcat::mc "IQ id %s doesn't exist in memory" $id] } return } default { Debug $xlib 1 [::msgcat::mc "Unknown IQ type \"%s\"" $type] return } } } # ::xmpp::sendMessage -- # # Send XMPP message. # # Arguments: # xlib XMPP token. # to JID to send message to. # -from from From attribute (it's usually overwritten by server) # -type type Message type ("", "normal", "chat", "groupchat", # "headline", "error"). # -id id Stanza ID. # -subject subj Message subject. # -thread thread Message thread. # -body body Message body. # -error error Error stanza. # -xlist elements List of attachments. # # Result: # Length of sent textual representation of message stanza. If negative # then the operation is failed. # # Side effects: # Presence stanza is set to a server. proc ::xmpp::sendMessage {xlib to args} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "$to $args" if {![info exists state(transport)]} { Debug $xlib 1 "Connection doesn't exist" return -1 } set attrs(to) $to set attrs(xml:lang) [xml::lang] set subelements {} foreach {key val} $args { switch -- $key { -from {set attrs(from) $val} -type {set attrs(type) $val} -id {set attrs(id) $val} -subject {lappend subelements [xml::create subject -cdata $val]} -thread {lappend subelements [xml::create thread -cdata $val]} -body {lappend subelements [xml::create body -cdata $val]} -error {lappend subelements $val} -xlist { foreach x $val { lappend subelements $x } } } } set data [xml::create message -attrs [array get attrs] \ -subelements $subelements] return [outXML $xlib $data] } # ::xmpp::sendPresence -- # # Send XMPP presence. # # Arguments: # xlib XMPP token. # -from from From attribute (it's usually overwritten by server) # -to to JID to send message to. # -type type Presence type (missing, "unavailable", "probe", # "subscribe", "subscribed", "unsubscribe", # "unsubscribed", "error"). # -id id Stanza ID. # -show show Presence status (missing, "chat", "away", "xa", "dnd"). # -status status Presence extended status. # -priority prio Presence priority (-128 <= prio <= 127). # -error error Error stanza. # -xlist elements List of attachments. # # Result: # Length of sent textual representation of presence stanza. If negative # then the operation is failed. # # Side effects: # Presence stanza is set to a server. proc ::xmpp::sendPresence {xlib args} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "$args" if {![info exists state(transport)]} { Debug $xlib 1 "Connection doesn't exist" return -1 } set attrs(xml:lang) [xml::lang] set subelements {} foreach {key val} $args { switch -- $key { -from {set attrs(from) $val} -to {set attrs(to) $val} -type {set attrs(type) $val} -id {set attrs(id) $val} -show {lappend subelements [xml::create show -cdata $val]} -status {lappend subelements [xml::create status -cdata $val]} -priority {lappend subelements [xml::create priority -cdata $val]} -error {lappend subelements $val} -xlist { foreach x $val { lappend subelements $x } } } } set data [xml::create presence -attrs [array get attrs] \ -subelements $subelements] return [outXML $xlib $data] } # ::xmpp::sendIQ -- # # Send XMPP IQ. # # Arguments: # xlib XMPP token. # type IQ type ("get", "set", "result", "error"). # -from from From attribute (it's usually overwritten by server) # -to to JID to send message to. # -id id Stanza ID. # -command Command to call when the result IQ will be received. # This option is allowed for "get" and "set" types only. # -timeout num Timeout for waiting an answer (in milliseconds). # -query query Query stanza. # -error error Error stanza. # # Result: # Id of the sent stanza. # # Side effects: # IQ stanza is set to a server. If it's a "get" or "set" stanza then # depending on -command and -timeout options the command is stored for # calling it back later, and the IQ abortion is scheduled. proc ::xmpp::sendIQ {xlib type args} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "$type $args" switch -- $type { get - set { set attrs(type) $type set getset 1 } result - error { set attrs(type) $type set getset 0 } default { set attrs(type) get set getset 1 } } set attrs(xml:lang) [xml::lang] set subelements {} set timeout 0 foreach {key val} $args { switch -- $key { -from {set attrs(from) $val} -to { if {![string equal $val ""]} { set attrs(to) $val } } -id { # Option -command takes precedence over -id if {![info exists attrs(id)] || ![info exists cmd]} { set attrs(id) $val } } -command { # Option -command makes sense for get or set IQs only if {!$getset} { return -code error \ [::msgcat::mc "Option \"-command\" is illegal for\ IQ type \"%s\"" $attrs(type)] } # Only the last -command takes effect if {![info exists attrs(id)] || ![info exists cmd]} { set attrs(id) [packetID $xlib] } set cmd $val } -timeout { if {$val > 0} { set timeout $val } } -query - -error {lappend subelements $val} } } if {![info exists state(transport)]} { Debug $xlib 1 "Connection doesn't exist" if {[info exists cmd]} { uplevel #0 $cmd [list abort \ [xml::create error \ -cdata [::msgcat::mc "Disconnected"]]] } return } if {[info exists cmd]} { set state(iq,$attrs(id)) $cmd if {$timeout > 0} { after $timeout \ [namespace code [list abortIQ $xlib $attrs(id) timeout \ [xml::create error \ -cdata [::msgcat::mc "IQ %s timed out" \ $attrs(id)]]]] } } if {$getset && ![info exists attrs(id)]} { # The id attribute is mandatory set attrs(id) [packetID $xlib] } set data [xml::create iq -attrs [array get attrs] \ -subelements $subelements] set res [outXML $xlib $data] if {[info exists cmd] && $res < 0} { after idle \ [namespace code [list abortIQ $xlib $attrs(id) abort \ [xml::create error \ -cdata [::msgcat::mc \ "Disconnected"]]]] } if {$getset && [info exists attrs(id)]} { return $attrs(id) } else { return } } # ::xmpp::abortIQ -- # # Abort a pending IQ request and call its pending command with a # specified status. # # Arguments: # xlib XMPP token. # id IQ identity attribute. # status "ok", "abort", "timeout", or "error". # error Error XML stanza. (If status is "ok" then error must be # a result stanza). # # Result: # Empty string. # # Side effects: # Side effects from the called command. proc ::xmpp::abortIQ {xlib id status error} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "$id" if {[info exists state(iq,$id)]} { set cmd $state(iq,$id) unset state(iq,$id) uplevel #0 $cmd [list $status $error] } else { Debug $xlib 1 [::msgcat::mc "IQ id %s doesn't exist in memory" $id] } return } # ::xmpp::packetID -- # # Return the next free packet ID. # # Arguments: # xlib XMPP token. # # Result: # Packet ID. # # Side effects: # The next ID value is increased by one. proc ::xmpp::packetID {xlib} { variable $xlib upvar 0 $xlib state return [incr state(id)]:[expr {round(rand()*1000000)}] } # ::xmpp::CallBack -- # # Call a client callback procedure if it was defined in [new]. # # Arguments: # xlib XMPP token. # command Callback type. # args Arguments for callback. # # Result: # Callback return code and value: # # Side effects: # Side effects from the callback. proc ::xmpp::CallBack {xlib command args} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "$command" set cmd -${command}command if {[info exists state($cmd)]} { set code [catch {uplevel #0 $state($cmd) [list $xlib] $args} msg] return -code $code -errorinfo $::errorInfo $msg } else { return } } # ::xmpp::Set -- # # Set the specified XMPP token property or get it value. # # Arguments: # xlib XMPP token. # property Property to set or get. # value (optional) If present then state variable is set. # If missing then its value is returned. # # Result: # Value of a corresponding state variable. # # Side effects: # If value is present then variable state($property) is set. proc ::xmpp::Set {xlib property args} { variable $xlib upvar 0 $xlib state switch -- [llength $args] { 0 { return $state($property) } 1 { return [set state($property) [lindex $args 0]] } default { return -code error \ [::msgcat::mc "Usage: ::xmpp::Set xlib property ?value?"] } } } # ::xmpp::Unset -- # # Unset the specified XMPP token property. # # Arguments: # xlib XMPP token. # property Property to unset. # # Result: # Empty string. # # Side effects: # Variable state($property) is unset. proc ::xmpp::Unset {xlib property} { variable $xlib upvar 0 $xlib state catch {unset state($property)} return } # ::xmpp::ip -- # # Return IP of low level TCP socket. # # Arguments: # xlib XMPP token. # # Result: # Socket IP or empty string. # # Side effects: # None. proc ::xmpp::ip {xlib} { variable $xlib upvar 0 $xlib state Debug $xlib 2 "" return [transport::use $state(transport) ip] } # ::xmpp::Debug -- # # Prints debug information. # # Arguments: # xlib XMPP token. # level A debug level. # str A debug message. # # Result: # An empty string. # # Side effects: # A debug message is printed to the console if the value of # ::xmpp::debug variable is not less than num. proc ::xmpp::Debug {xlib level str} { variable debug if {$debug >= $level} { puts "[clock format [clock seconds] -format %T]\ [lindex [info level -1] 0] $xlib $str" } return } # vim:ts=8:sw=4:sts=4:et tclxmpp/xmpp/zlib.tcl000064400000000000000000000423101470446212700145600ustar00nobodynobody# zlib.tcl -- # # This file is part of the XMPP library. It provides support for the # XMPP stream over Zlib compressed TCP sockets. # # Copyright (c) 2008-2013 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAMER OF ALL WARRANTIES. namespace eval ::xmpp::transport::zlib { variable zlibpack if {[llength [info commands ::zlib]] == 0} { # No zlib at all at the moment package require zlib 1.0 if {[catch {::zlib info version}]} { return -code error "Package zlib from Ztcl cannot be found" } set zlibpack ztcl rename ::zlib [namespace current]::zlib package forget zlib } elseif {![catch {::zlib info version}]} { # zlib from Ztcl package is loaded already set zlibpack ztcl proc zlib {args} { eval ::zlib $args } } elseif {[catch {zlib push} msg] && \ [string first "wrong # args" $msg] >= 0} { # Tcl 8.6 set zlibpack tcl } else { # zlib package rename ::zlib ::zlib:saved if {[catch {package require zlib 1.0} msg]} { rename ::zlib:saved ::zlib return -code error $msg } elseif {[catch {::zlib info version}]} { rename ::zlib:saved ::zlib return -code error "Package zlib from Ztcl cannot be found" } set zlibpack ztcl rename ::zlib [namespace current]::zlib rename ::zlib:saved ::zlib } } package require pconnect package require xmpp::transport 0.2 package require xmpp::xml package provide xmpp::transport::zlib 0.2 namespace eval ::xmpp::transport::zlib { namespace export open abort close reset flush ip outXML outText \ openStream closeStream import ::xmpp::transport::register zlib \ -opencommand [namespace code open] \ -abortcommand [namespace code abort] \ -closecommand [namespace code close] \ -resetcommand [namespace code reset] \ -flushcommand [namespace code flush] \ -ipcommand [namespace code ip] \ -outxmlcommand [namespace code outXML] \ -outtextcommand [namespace code outText] \ -openstreamcommand [namespace code openStream] \ -reopenstreamcommand [namespace code openStream] \ -closestreamcommand [namespace code closeStream] \ -importcommand [namespace code import] } # ::xmpp::transport::zlib::open -- # # Open TCP socket (using ::pconnect::socket), create XML parser and # link them together. # # Arguments: # host Host to connect. # port Port to connect. # -command cmd0 (optional) Callback to call when TCP # connection to server (directly or through # proxy) is established. If missing then a # synchronous mode is set and function # doesn't return until connect succeded or # failed. # -streamheadercommand cmd1 Command to call when XMPP stream header # () is received. # -streamtrailercommand cmd2 Command to call when XMPP stream trailer # () is received. # -stanzacommand cmd3 Command to call when XMPP stanza is # received. # -eofcommand cmd4 End-of-file callback. # -level integer Compression level. # (other arguments are passed to [::pconnect::socket]) # -proxy string Proxy type "" (default), "socks4", # "socks5", or "https" # -host string Proxy hostname (required if -proxy # isn't empty) # -port integer Proxy port number (required if -proxy # isn't empty) # -username string Proxy user ID # -password string Proxy password # -useragent string Proxy user agent (for HTTP proxies) # # Result: # Transport token is returned to allow to abort connection process in # asynchronous mode. In synchronous mode token is returned in case of # success or error is raised if the connection is failed. # # Side effects: # In synchronous mode in case of success a new compressed TCP socket and # XML parser are created, in case of failure none. In asynchronous mode # a call to ::pconnect::socket is executed. proc ::xmpp::transport::zlib::open {host port args} { variable id if {![info exists id]} { set id 0 } set token [namespace current]::[incr id] variable $token upvar 0 $token state set state(transport) zlib set state(streamHeaderCmd) # set state(streamTrailerCmd) # set state(stanzaCmd) # set state(eofCmd) # set zlibArgs {} set newArgs {} foreach {key val} $args { switch -- $key { -command {set cmd $val} -streamheadercommand {set state(streamHeaderCmd) $val} -streamtrailercommand {set state(streamTrailerCmd) $val} -stanzacommand {set state(stanzaCmd) $val} -eofcommand {set state(eofCmd) $val} -level {lappend zlibArgs $key $val} default {lappend newArgs $key $val} } } if {![info exists cmd]} { # Synchronous mode set state(sock) [eval [list ::pconnect::socket $host $port] $newArgs] Configure $token $zlibArgs } else { # Asynchronous mode if {[catch { set state(pconnect) \ [eval [list ::pconnect::socket $host $port] $newArgs \ [list -command [namespace code [list OpenAux $token \ $cmd \ $zlibArgs]]]] } msg]} { # We can't even open a socket after idle [namespace code [list OpenAux $token $cmd $zlibArgs \ error $msg]] } } return $token } # ::xmpp::transport::zlib::OpenAux -- # # A helper procedure which is passed as a callback to ::pconnect::socket # call and in turn invokes a callback for [open] procedure. # # Arguments: # token Transport token created in [open] # cmd Procedure to call with status ok or error. # zlibArgs zlib-specific options. # status Connection status (ok means success). # sock TCP socket if status is ok, or error message if # status is error, timeout, or abort. # # Result: # Empty string. # # Side effects: # If status is ok then a new XML parser is created. In all cases a # callback procedure is executed. proc ::xmpp::transport::zlib::OpenAux {token cmd zlibArgs status sock} { variable $token upvar 0 $token state catch {unset state(pconnect)} if {[string equal $status ok]} { set state(sock) $sock if {[catch {Configure $token $zlibArgs} msg]} { set status error set token $msg # TODO: Cleanup } } else { # Here $sock contains error message set token $sock } uplevel #0 $cmd [list $status $token] return } # ::xmpp::transport::zlib::Configure -- # # A helper procedure which creates a new XML parser and configures TCP # socket. # # Arguments: # token Transport token created in [open] # zlibArgs zlib-specific options. # # Result: # An XML parser identifier. # # Side effects: # Socket is put in non-buffering nonblocking mode with encoding UTF-8. # XML parser is created. proc ::xmpp::transport::zlib::Configure {token zlibArgs} { variable $token upvar 0 $token state set state(parser) \ [::xmpp::xml::new \ [namespace code [list InXML $state(streamHeaderCmd)]] \ [namespace code [list InEmpty $state(streamTrailerCmd)]] \ [namespace code [list InXML $state(stanzaCmd)]]] eval [list import $token] $zlibArgs return } # ::xmpp::transport::zlib::import -- # # Turn TCP socket into a compressed socket. # # Arguments: # token Transport control token. # -level integer Compression level. # # Result: # Empty string. # # Side effects: # TCP socket which corresponds to the given token becomes compressed. proc ::xmpp::transport::zlib::import {token args} { variable zlibpack variable $token upvar 0 $token state fconfigure $state(sock) -blocking 0 \ -buffering none \ -translation auto \ -encoding utf-8 switch -- $zlibpack { ztcl { eval [list zlib stream $state(sock) RDWR \ -output compress \ -input decompress] $args } tcl { zlib push decompress $state(sock) eval [list zlib push compress $state(sock)] $args } default { return -code error "Unsupported zlib package" } } fileevent $state(sock) readable [namespace code [list InText $token]] set state(transport) zlib return $token } # ::xmpp::transport::zlib::abort -- # # Abort connection which isn't fully opened yet. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # Connection token is destroyed and the connection is aborted. proc ::xmpp::transport::zlib::abort {token} { variable $token upvar 0 $token state if {[info exists state(pconnect)]} { # If ::pconnect::abort returns error then propagate it to the caller ::pconnect::abort $state(pconnect) } if {[info exists state(parser)]} { ::xmpp::xml::free $state(parser) } unset state return } # ::xmpp::transport::zlib::outText -- # # Send text to XMPP server. # # Arguments: # token Transport token. # text Text to send. # # Result: # Bytelength of a sent text. # # Side effects: # Text is sent to the server. proc ::xmpp::transport::zlib::outText {token text} { variable zlibpack variable $token upvar 0 $token state if {[catch {puts -nonewline $state(sock) $text} err]} { return -1 } else { ::flush $state(sock) switch -- $zlibpack { ztcl { fconfigure $state(sock) -flush output } tcl { fconfigure $state(sock) -flush sync } } # TODO return [string bytelength $text] } } # ::xmpp::transport::zlib::outXML -- # # Send XML element to XMPP server. # # Arguments: # token Transport token. # xml XML to send. # # Result: # Bytelength of a textual representation of a sent XML. # # Side effects: # Text is sent to the server. proc ::xmpp::transport::zlib::outXML {token xml} { return [outText $token [::xmpp::xml::toText $xml]] } # ::xmpp::transport::zlib::openStream -- # # Send XMPP stream header to XMPP server. # # Arguments: # token Transport token. # server XMPP server. # args Arguments for [::xmpp::xml::streamHeader]. # # Result: # Bytelength of a textual representation of a sent header. # # Side effects: # Text is sent to the server. proc ::xmpp::transport::zlib::openStream {token server args} { return [outText $token \ [eval [list ::xmpp::xml::streamHeader $server] $args]] } # ::xmpp::transport::zlib::closeStream -- # # Send XMPP stream trailer to XMPP server and start disconnecting # procedure. # # Arguments: # token Transport token. # -wait bool (optional, default 0) Wait for the server side to # close stream. # # Result: # Bytelength of a textual representation of a sent header. # # Side effects: # Text is sent to the server. proc ::xmpp::transport::zlib::closeStream {token args} { variable zlibpack variable $token upvar 0 $token state set len [outText $token [::xmpp::xml::streamTrailer]] set wait 0 foreach {key val} $args { switch -- $key { -wait { set wait $val } } } if {!$wait} { ::flush $state(sock) switch -- $zlibpack { ztcl { fconfigure $state(sock) -finish output } tcl { fconfigure $state(sock) -flush full } } } else { fconfigure $state(sock) -blocking 1 ::flush $state(sock) switch -- $zlibpack { ztcl { fconfigure $state(sock) -finish output } tcl { fconfigure $state(sock) -flush full } } # TODO #vwait $token\(sock) } return $len } # ::xmpp::transport::zlib::flush -- # # Flush XMPP channel. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # Pending data is sent to the server. proc ::xmpp::transport::zlib::flush {token} { variable zlibpack variable $token upvar 0 $token state ::flush $state(sock) switch -- $zlibpack { ztcl { fconfigure $state(sock) -flush output } tcl { fconfigure $state(sock) -flush sync } } } # ::xmpp::transport::zlib::ip -- # # Return IP of an outgoing socket. # # Arguments: # token Transport token. # # Result: # IP address. # # Side effects: # None. proc ::xmpp::transport::zlib::ip {token} { variable $token upvar 0 $token state return [lindex [fconfigure $state(sock) -sockname] 0] } # ::xmpp::transport::zlib::close -- # # Close XMPP channel. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # Transport token and XML parser are destroyed. proc ::xmpp::transport::zlib::close {token} { variable $token upvar 0 $token state catch {fileevent $state(sock) readable {}} catch {::close $state(sock)} if {[info exists state(parser)]} { ::xmpp::xml::free $state(parser) } catch {unset state} return } # ::xmpp::transport::zlib::reset -- # # Reset XMPP stream. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # XML parser is reset. proc ::xmpp::transport::zlib::reset {token} { variable $token upvar 0 $token state ::xmpp::xml::reset $state(parser) } # ::xmpp::transport::zlib::InText -- # # A helper procedure which is called when a new portion of data is # received from XMPP server. It receives the data from a socket and # feeds XML parser with them. # # Arguments: # token Transport token. # # Result: # Empty string. # # Side effects: # The text is parsed and if it completes top-level stanza then an # appropriate callback is invoked. proc ::xmpp::transport::zlib::InText {token} { variable zlibpack variable $token upvar 0 $token state switch -- $zlibpack { ztcl { catch {fconfigure $state(sock) -flush input} } } if {[catch {read $state(sock)} msg]} { fileevent $state(sock) readable {} ::close $state(sock) InEmpty $state(eofCmd) return } ::xmpp::xml::parser $state(parser) parse $msg if {[eof $state(sock)]} { fileevent $state(sock) readable {} ::close $state(sock) InEmpty $state(eofCmd) } } # ::xmpp::transport::zlib::InXML -- # # A helper procedure which is called when a new XML stanza is parsed. # It then calls a specified command as an idle callback. # # Arguments: # cmd Command to call. # xml Stanza to pass to the command. # # Result: # Empty string. # # Side effects: # After entering event loop the specified command is called. proc ::xmpp::transport::zlib::InXML {cmd xml} { after idle $cmd [list $xml] } # ::xmpp::transport::zlib::InEmpty -- # # A helper procedure which is called when XMPP stream is finished. # It then calls a specified command as an idle callback. # # Arguments: # cmd Command to call. # # Result: # Empty string. # # Side effects: # After entering event loop the specified command is called. proc ::xmpp::transport::zlib::InEmpty {cmd} { after idle $cmd } # vim:ts=8:sw=4:sts=4:et