[Tkabber-dev] r1244 - in trunk/tkabber: . ifacetk jabberlib plugins/general plugins/roster tclxml

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Sat Oct 6 11:53:05 MSD 2007


Author: sergei
Date: 2007-10-06 11:53:04 +0400 (Sat, 06 Oct 2007)
New Revision: 1244

Added:
   trunk/tkabber/jabberlib/
   trunk/tkabber/jabberlib/autoconnect.tcl
   trunk/tkabber/jabberlib/https.tcl
   trunk/tkabber/jabberlib/idna.tcl
   trunk/tkabber/jabberlib/jabberlib.tcl
   trunk/tkabber/jabberlib/jlibauth.tcl
   trunk/tkabber/jabberlib/jlibcomponent.tcl
   trunk/tkabber/jabberlib/jlibcompress.tcl
   trunk/tkabber/jabberlib/jlibdns.tcl
   trunk/tkabber/jabberlib/jlibsasl.tcl
   trunk/tkabber/jabberlib/jlibtls.tcl
   trunk/tkabber/jabberlib/namespaces.tcl
   trunk/tkabber/jabberlib/ntlm.tcl
   trunk/tkabber/jabberlib/pkgIndex.tcl
   trunk/tkabber/jabberlib/socks4.tcl
   trunk/tkabber/jabberlib/socks5.tcl
   trunk/tkabber/jabberlib/stanzaerror.tcl
   trunk/tkabber/jabberlib/streamerror.tcl
   trunk/tkabber/jabberlib/transports.tcl
   trunk/tkabber/jabberlib/wrapper.tcl
Removed:
   trunk/tkabber/jabberlib-tclxml/
   trunk/tkabber/jabberlib/autoconnect.tcl
   trunk/tkabber/jabberlib/https.tcl
   trunk/tkabber/jabberlib/idna.tcl
   trunk/tkabber/jabberlib/jabberlib.tcl
   trunk/tkabber/jabberlib/jlibauth.tcl
   trunk/tkabber/jabberlib/jlibcomponent.tcl
   trunk/tkabber/jabberlib/jlibcompress.tcl
   trunk/tkabber/jabberlib/jlibdns.tcl
   trunk/tkabber/jabberlib/jlibsasl.tcl
   trunk/tkabber/jabberlib/jlibtls.tcl
   trunk/tkabber/jabberlib/namespaces.tcl
   trunk/tkabber/jabberlib/ntlm.tcl
   trunk/tkabber/jabberlib/pkgIndex.tcl
   trunk/tkabber/jabberlib/socks4.tcl
   trunk/tkabber/jabberlib/socks5.tcl
   trunk/tkabber/jabberlib/stanzaerror.tcl
   trunk/tkabber/jabberlib/streamerror.tcl
   trunk/tkabber/jabberlib/tclxml/
   trunk/tkabber/jabberlib/transports.tcl
   trunk/tkabber/jabberlib/wrapper.tcl
   trunk/tkabber/tclxml/xmldep.tcl
   trunk/tkabber/tclxml/xpath.tcl
Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/Makefile
   trunk/tkabber/disco.tcl
   trunk/tkabber/ifacetk/iface.tcl
   trunk/tkabber/ifacetk/iroster.tcl
   trunk/tkabber/plugins/general/avatars.tcl
   trunk/tkabber/plugins/general/subscribe_gateway.tcl
   trunk/tkabber/plugins/general/xcommands.tcl
   trunk/tkabber/plugins/roster/conferences.tcl
   trunk/tkabber/privacy.tcl
   trunk/tkabber/pubsub.tcl
   trunk/tkabber/splash.tcl
   trunk/tkabber/tclxml/pkgIndex.tcl
   trunk/tkabber/tclxml/sgmlparser.tcl
   trunk/tkabber/tclxml/tclparser-8.1.tcl
   trunk/tkabber/tclxml/xml__tcl.tcl
   trunk/tkabber/tkabber.tcl
Log:
	* jabberlib-tclxml/: Renamed to jabberlib/ directory.

	* tclxml/*: Code cleanup, removed xmldep.tcl and xpath.tcl since they
	  are not necessary for jabberlib.

	* Makefile: Adopted to recent changes in directories list.

	* disco.tcl, ifacetk/iface.tcl, ifacetk/iroster.tcl,
	  plugins/general/avatars.tcl, plugins/general/subscribe_gateway.tcl,
	  plugins/roster/conferences.tcl,
	  plugins/general/xcommands.tcl, privacy.tcl, pubsub.tcl: Got rid of
	  ::jlib::route.

	* tkabber.tcl: Require jabberlib 0.10.1

	* splash.tcl: Fixed label flicker during loading package indices.


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/ChangeLog	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,3 +1,22 @@
+2007-10-06  Sergei Golovan  <sgolovan at nes.ru>
+
+	* jabberlib-tclxml/: Renamed to jabberlib/ directory.
+
+	* tclxml/*: Code cleanup, removed xmldep.tcl and xpath.tcl since they
+	  are not necessary for jabberlib.
+
+	* Makefile: Adopted to recent changes in directories list.
+
+	* disco.tcl, ifacetk/iface.tcl, ifacetk/iroster.tcl,
+	  plugins/general/avatars.tcl, plugins/general/subscribe_gateway.tcl,
+	  plugins/roster/conferences.tcl,
+	  plugins/general/xcommands.tcl, privacy.tcl, pubsub.tcl: Got rid of
+	  ::jlib::route.
+
+	* tkabber.tcl: Require jabberlib 0.10.1
+
+	* splash.tcl: Fixed label flicker during loading package indices.
+
 2007-10-05  Sergei Golovan  <sgolovan at nes.ru>
 
 	* jabberlib-tclxml/jabberlib.tcl, doc/tkabber.xml: Removed keep-alive

Modified: trunk/tkabber/Makefile
===================================================================
--- trunk/tkabber/Makefile	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/Makefile	2007-10-06 07:53:04 UTC (rev 1244)
@@ -5,14 +5,15 @@
 DOCDIR = $(PREFIX)/share/doc/tkabber
 BINDIR = $(PREFIX)/bin
 
-SUBDIRS = emoticons       \
-	  ifacetk         \
-	  jabberlib-tclxml\
-	  mclistbox       \
-	  msgs            \
-	  pixmaps         \
-	  plugins         \
-	  sounds          \
+SUBDIRS = emoticons \
+	  ifacetk   \
+	  jabberlib \
+	  mclistbox \
+	  msgs      \
+	  pixmaps   \
+	  plugins   \
+	  sounds    \
+	  tclxml    \
 	  trans
 
 install: install-bin install-doc install-examples

Modified: trunk/tkabber/disco.tcl
===================================================================
--- trunk/tkabber/disco.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/disco.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -469,7 +469,7 @@
 	}
     }
     if {![info exists connid]} {
-	set connid [jlib::route $jid]
+	set connid [lindex [jlib::connections] 0]
     }
 
     if {$jid == ""} {

Modified: trunk/tkabber/ifacetk/iface.tcl
===================================================================
--- trunk/tkabber/ifacetk/iface.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/ifacetk/iface.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -301,8 +301,8 @@
 		       -command {change_password_dialog}] \
 		  [list command [::msgcat::mc "Edit my info..."] {} {} {} \
 		       -command {
-			    if {![lempty [jlib::connections]]} {
-				set connid [jlib::route ""]
+			    if {[llength [jlib::connections]] > 0} {
+				set connid [lindex [jlib::connections] 0]
 				userinfo::open [jlib::connection_bare_jid $connid] \
 				    -editable 1 -connection $connid
 			    }}] \
@@ -451,9 +451,9 @@
 ###############################################################################
 
 proc ifacetk::send_announce_message {resource} {
-    if {[lempty [jlib::connections]]} return
+    if {[llength [jlib::connections]] == 0} return
 
-    set server [jlib::connection_server [jlib::route ""]]
+    set server [jlib::connection_server [lindex [jlib::connections] 0]]
 
     if {$resource == "announce/motd/delete"} {
 	message::send_msg "$server/$resource" -type normal

Modified: trunk/tkabber/ifacetk/iroster.tcl
===================================================================
--- trunk/tkabber/ifacetk/iroster.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/ifacetk/iroster.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1315,8 +1315,11 @@
 	    set connid $gr
 	    set gr {}
 	}
+    } elseif {![cequal $tags ""]} {
+	lassign [tag_to_jid [crange [lindex $tags 1] 5 end]] connid
+	set gr {}
     } else {
-	set connid [jlib::route ""]
+	set connid [lindex [jlib::connections] 0]
 	set gr {}
     }
     if {$options(nested)} {

Copied: trunk/tkabber/jabberlib (from rev 1219, trunk/tkabber/jabberlib-tclxml)

Deleted: trunk/tkabber/jabberlib/autoconnect.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/autoconnect.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/autoconnect.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,229 +0,0 @@
-#  autoconnect.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) 2007  Mats Bengtsson
-#  Modifications Copyright (c) Sergei Golovan <sgolovan at nes.ru>
-#
-#  This source file is distributed under the BSD license.
-#
-# $Id$
-
-package provide autoconnect 0.1
-
-namespace eval autoconnect {
-    variable options
-    array set options {
-	-proxy          ""
-	-proxyhost      ""
-	-proxyport      ""
-	-proxyusername  ""
-	-proxypassword  ""
-	-proxyuseragent ""
-	-proxyno        ""
-	-proxyfilter    autoconnect::filter
-    }
-
-    variable packs
-    foreach name {socks4 socks5 https} {
-	if {![catch {package require $name}]} {
-	    set packs($name) 1
-	}
-    }
-}
-
-# autoconnect::configure --
-#
-#       Get or set configuration options for the proxy.
-#
-# Arguments:
-#       args:
-#           -proxy            ""|socks4|socks5|https
-#           -proxyhost        hostname
-#           -proxyport        port number
-#           -proxyusername    user ID
-#           -proxypassword    (socks5) password
-#           -proxyno          glob list of hosts to not use proxy
-#           -proxyfilter      tclProc {host}
-#
-# Results:
-#       one or many option values depending on arguments.
-
-proc autoconnect::configure {args} {
-    variable options
-    variable packs
-    if {[llength $args] == 0} {
-	return [array get options]
-    } elseif {[llength $args] == 1} {
-	return $options($args)
-    } else {
-	set idx [lsearch $args -proxy]
-	if {$idx >= 0} {
-	    set proxy [lindex $args [incr idx]]
-	    if {[string length $proxy] && ![info exists packs($proxy)]} {
-		return -code error "unsupported proxy \"$proxy\""
-	    }
-	}
-	array set options $args
-    }
-}
-
-proc autoconnect::init {} {
-    # @@@ Here we should get default settings from some system API.
-}
-
-# autoconnect::socket --
-#
-#       Subclassing the 'socket' command. Only client side.
-#       We use -command tclProc instead of -async + fileevent writable.
-#
-# Arguments:
-#       host:       the peer address, not SOCKS server
-#       port:       the peer's port number
-#       args:
-#           -command    tclProc {token status}
-#                       the 'status' is any of:
-#                       ok, error, timeout, network-failure,
-#                       rsp_*, err_* (see socks4/5)
-# Results:
-#	A socket if -command is not specified or an empty string.
-
-proc autoconnect::socket {host port args} {
-    variable options
-
-    set argsA(-command) ""
-    array set argsA $args
-    set proxy $options(-proxy)
-
-    set hostport [$options(-proxyfilter) $host]
-    if {[llength $hostport]} {
-	set ahost [lindex $hostport 0]
-	set aport [lindex $hostport 1]
-    } else {
-	set ahost $host
-	set aport $port
-    }
-
-    # Connect ahost + aport.
-    set sock [::socket -async $ahost $aport]
-    set token [namespace current]::$sock
-    variable $token
-    upvar 0 $token state
-
-    set state(host) $host
-    set state(port) $port
-    set state(sock) $sock
-    set state(cmd)  $argsA(-command)
-
-    fconfigure $sock -blocking 0
-    fileevent $sock writable [namespace code [list writable $token]]
-
-    if {[string length $state(cmd)]} {
-	return
-    } else {
-	vwait $token\(status)
-
-	set status $state(status)
-	set sock $state(sock)
-	catch {unset state}
-
-	if {[string equal $status OK]} {
-	    return $sock
-	} else {
-	    return -code error $sock
-	}
-    }
-}
-
-proc autoconnect::get_opts {} {
-    variable options
-
-    set opts [list]
-    if {[string length $options(-proxyusername)]} {
-	lappend opts -username $options(-proxyusername)
-    }
-    if {[string length $options(-proxypassword)]} {
-	lappend opts -password $options(-proxypassword)
-    }
-    if {[string length $options(-proxyuseragent)]} {
-	lappend opts -useragent $options(-proxyuseragent)
-    }
-    return $opts
-}
-
-proc autoconnect::writable {token} {
-    variable $token
-    upvar 0 $token state
-    variable options
-
-    set proxy $options(-proxy)
-    set sock $state(sock)
-    fileevent $sock writable {}
-
-    if {[catch {eof $sock} iseof] || $iseof} {
-	Finish $token network-failure
-    } else {
-	if {[string length $proxy]} {
-	    eval {${proxy}::connect $sock $state(host) $state(port) \
-		      -command [namespace code [list SocksCb $token]]
-		} [get_opts]
-	} else {
-	    Finish $token
-	}
-    }
-    return
-}
-
-proc autoconnect::SocksCb {token status sock} {
-    variable $token
-    upvar 0 $token state
-
-    if {[string equal $status OK]} {
-	set state(sock) $sock
-	Finish $token
-    } else {
-	Finish $token $sock
-    }
-    return
-}
-
-proc autoconnect::Finish {token {errormsg ""}} {
-    variable $token
-    upvar 0 $token state
-    variable options
-
-    if {[string length $state(cmd)]} {
-	if {[string length $errormsg]} {
-	    catch {close $state(sock)}
-	    uplevel #0 $state(cmd) [list ERROR $errormsg]
-	} else {
-	    uplevel #0 $state(cmd) [list OK $state(sock)]
-	}
-	catch {unset state}
-    } else {
-	if {[string length $errormsg]} {
-	    catch {close $state(sock)}
-	    set state(sock) $errormsg
-	    set state(status) ERROR
-	} else {
-	    set state(status) OK
-	}
-    }
-    return
-}
-
-proc autoconnect::filter {host} {
-    variable options
-    if {[llength $options(-proxy)]} {
-	foreach domain $options(-proxyno) {
-	    if {[string match $domain $host]} {
-		return [list]
-	    }
-	}
-	return [list $options(-proxyhost) $options(-proxyport)]
-    } else {
-	return [list]
-    }
-}

Copied: trunk/tkabber/jabberlib/autoconnect.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/autoconnect.tcl)
===================================================================
--- trunk/tkabber/jabberlib/autoconnect.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/autoconnect.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,229 @@
+#  autoconnect.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) 2007  Mats Bengtsson
+#  Modifications Copyright (c) Sergei Golovan <sgolovan at nes.ru>
+#
+#  This source file is distributed under the BSD license.
+#
+# $Id$
+
+package provide autoconnect 0.1
+
+namespace eval autoconnect {
+    variable options
+    array set options {
+	-proxy          ""
+	-proxyhost      ""
+	-proxyport      ""
+	-proxyusername  ""
+	-proxypassword  ""
+	-proxyuseragent ""
+	-proxyno        ""
+	-proxyfilter    autoconnect::filter
+    }
+
+    variable packs
+    foreach name {socks4 socks5 https} {
+	if {![catch {package require $name}]} {
+	    set packs($name) 1
+	}
+    }
+}
+
+# autoconnect::configure --
+#
+#       Get or set configuration options for the proxy.
+#
+# Arguments:
+#       args:
+#           -proxy            ""|socks4|socks5|https
+#           -proxyhost        hostname
+#           -proxyport        port number
+#           -proxyusername    user ID
+#           -proxypassword    (socks5) password
+#           -proxyno          glob list of hosts to not use proxy
+#           -proxyfilter      tclProc {host}
+#
+# Results:
+#       one or many option values depending on arguments.
+
+proc autoconnect::configure {args} {
+    variable options
+    variable packs
+    if {[llength $args] == 0} {
+	return [array get options]
+    } elseif {[llength $args] == 1} {
+	return $options($args)
+    } else {
+	set idx [lsearch $args -proxy]
+	if {$idx >= 0} {
+	    set proxy [lindex $args [incr idx]]
+	    if {[string length $proxy] && ![info exists packs($proxy)]} {
+		return -code error "unsupported proxy \"$proxy\""
+	    }
+	}
+	array set options $args
+    }
+}
+
+proc autoconnect::init {} {
+    # @@@ Here we should get default settings from some system API.
+}
+
+# autoconnect::socket --
+#
+#       Subclassing the 'socket' command. Only client side.
+#       We use -command tclProc instead of -async + fileevent writable.
+#
+# Arguments:
+#       host:       the peer address, not SOCKS server
+#       port:       the peer's port number
+#       args:
+#           -command    tclProc {token status}
+#                       the 'status' is any of:
+#                       ok, error, timeout, network-failure,
+#                       rsp_*, err_* (see socks4/5)
+# Results:
+#	A socket if -command is not specified or an empty string.
+
+proc autoconnect::socket {host port args} {
+    variable options
+
+    set argsA(-command) ""
+    array set argsA $args
+    set proxy $options(-proxy)
+
+    set hostport [$options(-proxyfilter) $host]
+    if {[llength $hostport]} {
+	set ahost [lindex $hostport 0]
+	set aport [lindex $hostport 1]
+    } else {
+	set ahost $host
+	set aport $port
+    }
+
+    # Connect ahost + aport.
+    set sock [::socket -async $ahost $aport]
+    set token [namespace current]::$sock
+    variable $token
+    upvar 0 $token state
+
+    set state(host) $host
+    set state(port) $port
+    set state(sock) $sock
+    set state(cmd)  $argsA(-command)
+
+    fconfigure $sock -blocking 0
+    fileevent $sock writable [namespace code [list writable $token]]
+
+    if {[string length $state(cmd)]} {
+	return
+    } else {
+	vwait $token\(status)
+
+	set status $state(status)
+	set sock $state(sock)
+	catch {unset state}
+
+	if {[string equal $status OK]} {
+	    return $sock
+	} else {
+	    return -code error $sock
+	}
+    }
+}
+
+proc autoconnect::get_opts {} {
+    variable options
+
+    set opts [list]
+    if {[string length $options(-proxyusername)]} {
+	lappend opts -username $options(-proxyusername)
+    }
+    if {[string length $options(-proxypassword)]} {
+	lappend opts -password $options(-proxypassword)
+    }
+    if {[string length $options(-proxyuseragent)]} {
+	lappend opts -useragent $options(-proxyuseragent)
+    }
+    return $opts
+}
+
+proc autoconnect::writable {token} {
+    variable $token
+    upvar 0 $token state
+    variable options
+
+    set proxy $options(-proxy)
+    set sock $state(sock)
+    fileevent $sock writable {}
+
+    if {[catch {eof $sock} iseof] || $iseof} {
+	Finish $token network-failure
+    } else {
+	if {[string length $proxy]} {
+	    eval {${proxy}::connect $sock $state(host) $state(port) \
+		      -command [namespace code [list SocksCb $token]]
+		} [get_opts]
+	} else {
+	    Finish $token
+	}
+    }
+    return
+}
+
+proc autoconnect::SocksCb {token status sock} {
+    variable $token
+    upvar 0 $token state
+
+    if {[string equal $status OK]} {
+	set state(sock) $sock
+	Finish $token
+    } else {
+	Finish $token $sock
+    }
+    return
+}
+
+proc autoconnect::Finish {token {errormsg ""}} {
+    variable $token
+    upvar 0 $token state
+    variable options
+
+    if {[string length $state(cmd)]} {
+	if {[string length $errormsg]} {
+	    catch {close $state(sock)}
+	    uplevel #0 $state(cmd) [list ERROR $errormsg]
+	} else {
+	    uplevel #0 $state(cmd) [list OK $state(sock)]
+	}
+	catch {unset state}
+    } else {
+	if {[string length $errormsg]} {
+	    catch {close $state(sock)}
+	    set state(sock) $errormsg
+	    set state(status) ERROR
+	} else {
+	    set state(status) OK
+	}
+    }
+    return
+}
+
+proc autoconnect::filter {host} {
+    variable options
+    if {[llength $options(-proxy)]} {
+	foreach domain $options(-proxyno) {
+	    if {[string match $domain $host]} {
+		return [list]
+	    }
+	}
+	return [list $options(-proxyhost) $options(-proxyport)]
+    } else {
+	return [list]
+    }
+}

Deleted: trunk/tkabber/jabberlib/https.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/https.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/https.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,672 +0,0 @@
-# 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 Sergei Golovan <sgolovan at nes.ru>
-#
-#  This source file is distributed under the BSD license.
-#
-# $Id$
-
-package require base64
-package require ntlm 1.0
-
-package provide https 1.0
-
-namespace eval https {
-    namespace export connect
-
-    variable debug 0
-}
-
-# 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 empty string.
-#
-# 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 https::connect {sock addr port args} {
-    variable auth
-
-    set token [namespace current]::$sock
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "https::connect token=$token, 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)]} {
-	set state(async) 1
-    }
-
-    if {[catch {set state(peer) [fconfigure $sock -peername]}]} {
-	if {$state(async)} {
-	    after idle [list $state(-command) ERROR network-failure]
-	    Free $token
-	    return
-	} else {
-	    Free $token
-	    return -code error network-failure
-	}
-    }
-
-    PutsConnectQuery $token
-
-    fileevent $sock readable  \
-	[list [namespace current]::Readable $token]
-
-    # Setup timeout timer.
-    set state(timeoutid) \
-	[after $state(-timeout) [namespace current]::Timeout $token]
-
-    if {$state(async)} {
-	return
-    } 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 {
-	    return -code error $sock
-	}
-    }
-}
-
-# 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 https::Readable {token} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "https::Readable token=$token"
-
-    fileevent $state(sock) readable {}
-    set code [ReadProxyAnswer $token]
-
-    if {$code >= 200 && $code < 300} {
-	# Success
-	while {[string length [gets $state(sock)]]} {}
-	Finish $token
-    } elseif {$code != 407} {
-	# Failure
-	Finish $token $state(result)
-    } else {
-	# Authorization required
-	set content_length -1
-	set method basic
-	while {[string length [set header [gets $state(sock)]]]} {
-	    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 \
-	    [list [namespace current]::Authorize $token $method]
-    }
-
-    return
-}
-
-# 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 https::Authorize {token method} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "https::Authorize token=$token, method=$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 https::AuthorizeBasicStep1 {token} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "https::AuthorizeBasicStep1 token=$token"
-
-    set auth \
-	[string map {\n {}} \
-	     [base64::encode \
-		  [encoding convertto "$state(-username):$state(-$password)"]]]
-
-    PutsConnectQuery $token "Basic $auth"
-
-    fileevent $state(sock) readable \
-	[list [namespace current]::AuthorizeBasicStep2 $token]
-
-    return
-}
-
-# 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 https::AuthorizeBasicStep2 {token} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "https::AuthorizeBasicStep2 token=$token"
-
-    fileevent $state(sock) readable {}
-
-    set code [ReadProxyAnswer $token]
-
-    if {$code >= 200 && $code < 300} {
-	# Success
-	while {[string length [gets $sock]]} { }
-	Finish $token
-    } else {
-	# Failure
-	Finish $token $state(result)
-    }
-    return
-}
-
-# 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 https::AuthorizeNtlmStep1 {token} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "https::AuthorizeNtlmStep1 token=$token"
-
-    set domain ""
-    set host [info hostname]
-
-    # if username is domain/username or domain\username
-    # then set domain and username
-    set username $state(-username)
-    regexp {(\w+)[\\/](.*)} $username -> domain username
-
-    set ntlmtok [NTLM::new -domain $domain \
-			   -host $host \
-			   -username $username \
-			   -password $state(-password)]
-    set message1 [$ntlmtok type1Message]
-    set state(ntlmtok) $ntlmtok
-
-    PutsConnectQuery $token "NTLM $message1"
-
-    fileevent $state(sock) readable \
-	[list [namespace current]::AuthorizeNtlmStep2 $token]
-
-    return
-}
-
-# 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 https::AuthorizeNtlmStep2 {token} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "https::AuthorizeNtlmStep2 token=$token"
-
-    fileevent $state(sock) readable {}
-
-    set code [ReadProxyAnswer $token]
-
-    if {$code >= 200 && $code < 300} {
-	# Success
-	while {[string length [gets $state(sock)]]} { }
-	Finish $token
-	return
-    } elseif {$code != 407} {
-	# Failure
-	Finish $token $state(result)
-	return
-    }
-
-    set content_length -1
-    set message2 ""
-    while {![string equal [set header [gets $state(sock)]] ""]} {
-	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
-
-    $state(ntlmtok) parseType2Message -message $message2
-    set message3 [$state(ntlmtok) type3Message]
-    $state(ntlmtok) free
-
-    PutsConnectQuery $token "NTLM $message3"
-
-    fileevent $state(sock) readable \
-	[list [namespace current]::AuthorizeNtlmStep3 $token]
-
-    return
-}
-
-# 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 https::AuthorizeNtlmStep3 {token} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "https::AuthorizeNtlmStep3 token=$token"
-
-    fileevent $state(sock) readable {}
-
-    set code [ReadProxyAnswer $token]
-
-    if {$code >= 200 && $code < 300} {
-	# Success
-	while {[string length [gets $state(sock)]]} { }
-	Finish $token
-    } else {
-	# Failure
-	Finish $token $state(result)
-    }
-    return
-}
-
-# 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 https::PutsConnectQuery {token {auth ""}} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "https::PutsConnectQuery token=$token auth=$auth"
-
-    fconfigure $state(sock) -buffering line -translation auto
-
-    puts $state(sock) "CONNECT $state(addr):$state(port) HTTP/1.1"
-    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
-}
-
-# 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 https::ReadProxyAnswer {token} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "https::ReadProxyAnswer token=$token"
-
-    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
-    }
-}
-
-# 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 https::ReadProxyJunk {token length} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "https::ReadProxyJunk token=$token, length=$length"
-
-    fconfigure $state(sock) -buffering none -translation binary
-    if {$length != -1} {
-	read $state(sock) $length
-    } else {
-	read $state(sock)
-    }
-    return
-}
-
-# https::HttpHeaderName --
-#
-#	Returns HTTP header name (converted to lowercase).
-#
-# Arguments:
-#	header	    A HTTP header.
-#
-# Result:
-#	A header name.
-#
-# Side effects
-#	None.
-
-proc https::HttpHeaderName {header} {
-    set hlist [split $header ":"]
-    return [string tolower [lindex $hlist 0]]
-}
-
-# https::HttpHeaderBody --
-#
-#	Returns HTTP header body.
-#
-# Arguments:
-#	header	    A HTTP header.
-#
-# Result:
-#	A header body.
-#
-# Side effects
-#	None.
-
-proc https::HttpHeaderBody {header} {
-    set hlist [split $header ":"]
-    set body [join [lrange $hlist 1 end] ":"]
-    return [string trim $body]
-}
-
-# 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 https::Timeout {token} {
-    Finish $token timeout
-    return
-}
-
-# 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 https::Free {token} {
-    variable $token
-    upvar 0 $token state
-
-    catch {after cancel $state(timeoutid)}
-    catch {unset state}
-    return
-}
-
-# https::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 https::connect to return
-#	with either success or error.
-
-proc https::Finish {token {errormsg ""}} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "https::Finish token=$token, errormsg=$errormsg"
-
-    catch {after cancel $state(timeoutid)}
-
-    if {$state(async)} {
-	if {[string length $errormsg]} {
-	    catch {close $state(sock)}
-	    uplevel #0 $state(-command) [list ERROR $errormsg]
-	} else {
-	    uplevel #0 $state(-command) [list OK $state(sock)]
-	}
-	Free $token
-    } else {
-	if {[string length $errormsg]} {
-	    catch {close $state(sock)}
-	    set state(sock) $errormsg
-	    set state(status) ERROR
-	} else {
-	    set state(status) OK
-	}
-    }
-    return
-}
-
-# https::Debug --
-#
-#	Prints debug information.
-#
-# Arguments:
-#	num	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
-#	https::debug variable is not less than num.
-
-proc https::Debug {num str} {
-    variable debug
-
-    if {$num <= $debug} {
-	puts $str
-    }
-
-    return
-}
-
-# Test
-if {0} {
-    set s [socket 192.168.0.1 3128]
-    set t [https::connect $s google.com 443]
-    puts $t
-    close $t
-
-    set s [socket 192.168.0.1 3128]
-    set t [https::connect $s google.com 80]
-    puts $t
-    close $t
-}
-

Copied: trunk/tkabber/jabberlib/https.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/https.tcl)
===================================================================
--- trunk/tkabber/jabberlib/https.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/https.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,672 @@
+# 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 Sergei Golovan <sgolovan at nes.ru>
+#
+#  This source file is distributed under the BSD license.
+#
+# $Id$
+
+package require base64
+package require ntlm 1.0
+
+package provide https 1.0
+
+namespace eval https {
+    namespace export connect
+
+    variable debug 0
+}
+
+# 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 empty string.
+#
+# 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 https::connect {sock addr port args} {
+    variable auth
+
+    set token [namespace current]::$sock
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::connect token=$token, 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)]} {
+	set state(async) 1
+    }
+
+    if {[catch {set state(peer) [fconfigure $sock -peername]}]} {
+	if {$state(async)} {
+	    after idle [list $state(-command) ERROR network-failure]
+	    Free $token
+	    return
+	} else {
+	    Free $token
+	    return -code error network-failure
+	}
+    }
+
+    PutsConnectQuery $token
+
+    fileevent $sock readable  \
+	[list [namespace current]::Readable $token]
+
+    # Setup timeout timer.
+    set state(timeoutid) \
+	[after $state(-timeout) [namespace current]::Timeout $token]
+
+    if {$state(async)} {
+	return
+    } 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 {
+	    return -code error $sock
+	}
+    }
+}
+
+# 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 https::Readable {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::Readable token=$token"
+
+    fileevent $state(sock) readable {}
+    set code [ReadProxyAnswer $token]
+
+    if {$code >= 200 && $code < 300} {
+	# Success
+	while {[string length [gets $state(sock)]]} {}
+	Finish $token
+    } elseif {$code != 407} {
+	# Failure
+	Finish $token $state(result)
+    } else {
+	# Authorization required
+	set content_length -1
+	set method basic
+	while {[string length [set header [gets $state(sock)]]]} {
+	    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 \
+	    [list [namespace current]::Authorize $token $method]
+    }
+
+    return
+}
+
+# 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 https::Authorize {token method} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::Authorize token=$token, method=$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 https::AuthorizeBasicStep1 {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::AuthorizeBasicStep1 token=$token"
+
+    set auth \
+	[string map {\n {}} \
+	     [base64::encode \
+		  [encoding convertto "$state(-username):$state(-$password)"]]]
+
+    PutsConnectQuery $token "Basic $auth"
+
+    fileevent $state(sock) readable \
+	[list [namespace current]::AuthorizeBasicStep2 $token]
+
+    return
+}
+
+# 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 https::AuthorizeBasicStep2 {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::AuthorizeBasicStep2 token=$token"
+
+    fileevent $state(sock) readable {}
+
+    set code [ReadProxyAnswer $token]
+
+    if {$code >= 200 && $code < 300} {
+	# Success
+	while {[string length [gets $sock]]} { }
+	Finish $token
+    } else {
+	# Failure
+	Finish $token $state(result)
+    }
+    return
+}
+
+# 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 https::AuthorizeNtlmStep1 {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::AuthorizeNtlmStep1 token=$token"
+
+    set domain ""
+    set host [info hostname]
+
+    # if username is domain/username or domain\username
+    # then set domain and username
+    set username $state(-username)
+    regexp {(\w+)[\\/](.*)} $username -> domain username
+
+    set ntlmtok [NTLM::new -domain $domain \
+			   -host $host \
+			   -username $username \
+			   -password $state(-password)]
+    set message1 [$ntlmtok type1Message]
+    set state(ntlmtok) $ntlmtok
+
+    PutsConnectQuery $token "NTLM $message1"
+
+    fileevent $state(sock) readable \
+	[list [namespace current]::AuthorizeNtlmStep2 $token]
+
+    return
+}
+
+# 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 https::AuthorizeNtlmStep2 {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::AuthorizeNtlmStep2 token=$token"
+
+    fileevent $state(sock) readable {}
+
+    set code [ReadProxyAnswer $token]
+
+    if {$code >= 200 && $code < 300} {
+	# Success
+	while {[string length [gets $state(sock)]]} { }
+	Finish $token
+	return
+    } elseif {$code != 407} {
+	# Failure
+	Finish $token $state(result)
+	return
+    }
+
+    set content_length -1
+    set message2 ""
+    while {![string equal [set header [gets $state(sock)]] ""]} {
+	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
+
+    $state(ntlmtok) parseType2Message -message $message2
+    set message3 [$state(ntlmtok) type3Message]
+    $state(ntlmtok) free
+
+    PutsConnectQuery $token "NTLM $message3"
+
+    fileevent $state(sock) readable \
+	[list [namespace current]::AuthorizeNtlmStep3 $token]
+
+    return
+}
+
+# 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 https::AuthorizeNtlmStep3 {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::AuthorizeNtlmStep3 token=$token"
+
+    fileevent $state(sock) readable {}
+
+    set code [ReadProxyAnswer $token]
+
+    if {$code >= 200 && $code < 300} {
+	# Success
+	while {[string length [gets $state(sock)]]} { }
+	Finish $token
+    } else {
+	# Failure
+	Finish $token $state(result)
+    }
+    return
+}
+
+# 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 https::PutsConnectQuery {token {auth ""}} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::PutsConnectQuery token=$token auth=$auth"
+
+    fconfigure $state(sock) -buffering line -translation auto
+
+    puts $state(sock) "CONNECT $state(addr):$state(port) HTTP/1.1"
+    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
+}
+
+# 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 https::ReadProxyAnswer {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::ReadProxyAnswer token=$token"
+
+    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
+    }
+}
+
+# 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 https::ReadProxyJunk {token length} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::ReadProxyJunk token=$token, length=$length"
+
+    fconfigure $state(sock) -buffering none -translation binary
+    if {$length != -1} {
+	read $state(sock) $length
+    } else {
+	read $state(sock)
+    }
+    return
+}
+
+# https::HttpHeaderName --
+#
+#	Returns HTTP header name (converted to lowercase).
+#
+# Arguments:
+#	header	    A HTTP header.
+#
+# Result:
+#	A header name.
+#
+# Side effects
+#	None.
+
+proc https::HttpHeaderName {header} {
+    set hlist [split $header ":"]
+    return [string tolower [lindex $hlist 0]]
+}
+
+# https::HttpHeaderBody --
+#
+#	Returns HTTP header body.
+#
+# Arguments:
+#	header	    A HTTP header.
+#
+# Result:
+#	A header body.
+#
+# Side effects
+#	None.
+
+proc https::HttpHeaderBody {header} {
+    set hlist [split $header ":"]
+    set body [join [lrange $hlist 1 end] ":"]
+    return [string trim $body]
+}
+
+# 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 https::Timeout {token} {
+    Finish $token timeout
+    return
+}
+
+# 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 https::Free {token} {
+    variable $token
+    upvar 0 $token state
+
+    catch {after cancel $state(timeoutid)}
+    catch {unset state}
+    return
+}
+
+# https::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 https::connect to return
+#	with either success or error.
+
+proc https::Finish {token {errormsg ""}} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::Finish token=$token, errormsg=$errormsg"
+
+    catch {after cancel $state(timeoutid)}
+
+    if {$state(async)} {
+	if {[string length $errormsg]} {
+	    catch {close $state(sock)}
+	    uplevel #0 $state(-command) [list ERROR $errormsg]
+	} else {
+	    uplevel #0 $state(-command) [list OK $state(sock)]
+	}
+	Free $token
+    } else {
+	if {[string length $errormsg]} {
+	    catch {close $state(sock)}
+	    set state(sock) $errormsg
+	    set state(status) ERROR
+	} else {
+	    set state(status) OK
+	}
+    }
+    return
+}
+
+# https::Debug --
+#
+#	Prints debug information.
+#
+# Arguments:
+#	num	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
+#	https::debug variable is not less than num.
+
+proc https::Debug {num str} {
+    variable debug
+
+    if {$num <= $debug} {
+	puts $str
+    }
+
+    return
+}
+
+# Test
+if {0} {
+    set s [socket 192.168.0.1 3128]
+    set t [https::connect $s google.com 443]
+    puts $t
+    close $t
+
+    set s [socket 192.168.0.1 3128]
+    set t [https::connect $s google.com 80]
+    puts $t
+    close $t
+}
+

Deleted: trunk/tkabber/jabberlib/idna.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/idna.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/idna.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,147 +0,0 @@
-#  idna.tcl --
-#  
-#      This file is part of the jabberlib. It provides support for
-#      Internationalizing Domain Names in Applications (IDNA, RFC 3490).
-#      
-#  Copyright (c) 2005 Alexey Shchepin <alexey at sevcom.net>
-#  
-# $Id$
-#
-#  SYNOPSIS
-#      idna::domain_toascii domain
-#
-
-##########################################################################
-
-package provide idna 1.0
-
-##########################################################################
-
-namespace eval idna {}
-
-##########################################################################
-
-proc idna::domain_toascii {domain} {
-    set domain [string tolower $domain]
-    set parts [split $domain "\u002E\u3002\uFF0E\uFF61"]
-    set res {}
-    foreach p $parts {
-	set r [toascii $p]
-	lappend res $r
-    }
-    return [join $res .]
-}
-
-##########################################################################
-
-proc idna::toascii {name} {
-    # TODO: Steps 2, 3 and 5 from RFC3490
-
-    if {![string is ascii $name]} {
-	set name [punycode_encode $name]
-	set name "xn--$name"
-    }
-    return $name
-}
-
-##########################################################################
-
-proc idna::punycode_encode {input} {
-    set base 36
-    set tmin 1
-    set tmax 26
-    set skew 38
-    set damp 700
-    set initial_bias 72
-    set initial_n 0x80
-
-    set n $initial_n
-    set delta 0
-    set out 0
-    set bias $initial_bias
-    set output ""
-    set input_length [string length $input]
-    set nonbasic {}
-
-    for {set j 0} {$j < $input_length} {incr j} {
-	set c [string index $input $j]
-	if {[string is ascii $c]} {
-	    append output $c
-	} else {
-	    lappend nonbasic $c
-	}
-    }
-
-    set nonbasic [lsort -unique $nonbasic]
-
-    set h [set b [string length $output]];
-
-    if {$b > 0} {
-	append output -
-    }
-
-    while {$h < $input_length} {
-	set m [scan [string index $nonbasic 0] %c]
-	set nonbasic [lrange $nonbasic 1 end]
-
-	incr delta [expr {($m - $n) * ($h + 1)}]
-	set n $m
-
-	for {set j 0} {$j < $input_length} {incr j} {
-	    set c [scan [string index $input $j] %c]
-
-	    if {$c < $n} {
-		incr delta
-	    } elseif {$c == $n} {
-		for {set q $delta; set k $base} {1} {incr k $base} {
-		    set t [expr {$k <= $bias ? $tmin :
-				 $k >= $bias + $tmax ? $tmax : $k - $bias}]
-		    if {$q < $t} break;
-		    append output \
-			[punycode_encode_digit \
-			     [expr {$t + ($q - $t) % ($base - $t)}]]
-		    set q [expr {($q - $t) / ($base - $t)}]
-		}
-
-		append output [punycode_encode_digit $q]
-		set bias [punycode_adapt \
-			      $delta [expr {$h + 1}] [expr {$h == $b}]]
-		set delta 0
-		incr h
-	    }
-	}
-	
-	incr delta
-	incr n
-    }
-
-    return $output;
-}
-
-##########################################################################
-
-proc idna::punycode_adapt {delta numpoints firsttime} {
-    set base 36
-    set tmin 1
-    set tmax 26
-    set skew 38
-    set damp 700
-
-    set delta [expr {$firsttime ? $delta / $damp : $delta >> 1}]
-    incr delta [expr {$delta / $numpoints}]
-
-    for {set k 0} {$delta > (($base - $tmin) * $tmax) / 2}  {incr k $base} {
-	set delta [expr {$delta / ($base - $tmin)}];
-    }
-
-    return [expr {$k + ($base - $tmin + 1) * $delta / ($delta + $skew)}]
-}
-
-##########################################################################
-
-proc idna::punycode_encode_digit {d} {
-    return [format %c [expr {$d + 22 + 75 * ($d < 26)}]]
-}
-
-##########################################################################
-

Copied: trunk/tkabber/jabberlib/idna.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/idna.tcl)
===================================================================
--- trunk/tkabber/jabberlib/idna.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/idna.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,147 @@
+#  idna.tcl --
+#  
+#      This file is part of the jabberlib. It provides support for
+#      Internationalizing Domain Names in Applications (IDNA, RFC 3490).
+#      
+#  Copyright (c) 2005 Alexey Shchepin <alexey at sevcom.net>
+#  
+# $Id$
+#
+#  SYNOPSIS
+#      idna::domain_toascii domain
+#
+
+##########################################################################
+
+package provide idna 1.0
+
+##########################################################################
+
+namespace eval idna {}
+
+##########################################################################
+
+proc idna::domain_toascii {domain} {
+    set domain [string tolower $domain]
+    set parts [split $domain "\u002E\u3002\uFF0E\uFF61"]
+    set res {}
+    foreach p $parts {
+	set r [toascii $p]
+	lappend res $r
+    }
+    return [join $res .]
+}
+
+##########################################################################
+
+proc idna::toascii {name} {
+    # TODO: Steps 2, 3 and 5 from RFC3490
+
+    if {![string is ascii $name]} {
+	set name [punycode_encode $name]
+	set name "xn--$name"
+    }
+    return $name
+}
+
+##########################################################################
+
+proc idna::punycode_encode {input} {
+    set base 36
+    set tmin 1
+    set tmax 26
+    set skew 38
+    set damp 700
+    set initial_bias 72
+    set initial_n 0x80
+
+    set n $initial_n
+    set delta 0
+    set out 0
+    set bias $initial_bias
+    set output ""
+    set input_length [string length $input]
+    set nonbasic {}
+
+    for {set j 0} {$j < $input_length} {incr j} {
+	set c [string index $input $j]
+	if {[string is ascii $c]} {
+	    append output $c
+	} else {
+	    lappend nonbasic $c
+	}
+    }
+
+    set nonbasic [lsort -unique $nonbasic]
+
+    set h [set b [string length $output]];
+
+    if {$b > 0} {
+	append output -
+    }
+
+    while {$h < $input_length} {
+	set m [scan [string index $nonbasic 0] %c]
+	set nonbasic [lrange $nonbasic 1 end]
+
+	incr delta [expr {($m - $n) * ($h + 1)}]
+	set n $m
+
+	for {set j 0} {$j < $input_length} {incr j} {
+	    set c [scan [string index $input $j] %c]
+
+	    if {$c < $n} {
+		incr delta
+	    } elseif {$c == $n} {
+		for {set q $delta; set k $base} {1} {incr k $base} {
+		    set t [expr {$k <= $bias ? $tmin :
+				 $k >= $bias + $tmax ? $tmax : $k - $bias}]
+		    if {$q < $t} break;
+		    append output \
+			[punycode_encode_digit \
+			     [expr {$t + ($q - $t) % ($base - $t)}]]
+		    set q [expr {($q - $t) / ($base - $t)}]
+		}
+
+		append output [punycode_encode_digit $q]
+		set bias [punycode_adapt \
+			      $delta [expr {$h + 1}] [expr {$h == $b}]]
+		set delta 0
+		incr h
+	    }
+	}
+	
+	incr delta
+	incr n
+    }
+
+    return $output;
+}
+
+##########################################################################
+
+proc idna::punycode_adapt {delta numpoints firsttime} {
+    set base 36
+    set tmin 1
+    set tmax 26
+    set skew 38
+    set damp 700
+
+    set delta [expr {$firsttime ? $delta / $damp : $delta >> 1}]
+    incr delta [expr {$delta / $numpoints}]
+
+    for {set k 0} {$delta > (($base - $tmin) * $tmax) / 2}  {incr k $base} {
+	set delta [expr {$delta / ($base - $tmin)}];
+    }
+
+    return [expr {$k + ($base - $tmin + 1) * $delta / ($delta + $skew)}]
+}
+
+##########################################################################
+
+proc idna::punycode_encode_digit {d} {
+    return [format %c [expr {$d + 22 + 75 * ($d < 26)}]]
+}
+
+##########################################################################
+

Deleted: trunk/tkabber/jabberlib/jabberlib.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/jabberlib.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/jabberlib.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,1851 +0,0 @@
-######################################################################
-#
-# $Header$
-#
-# This is JabberLib (abbreviated jlib), the Tcl library for
-# use in making Jabber clients.
-#
-#
-# Variables used in JabberLib :
-#	roster(users)                : Users currently in roster
-#
-#	roster(group,$username)      : Groups $username is in.
-#
-#	roster(name,$username)       : Name of $username.
-#
-#	roster(subsc,$username)      : Subscription of $username
-#                                  ("to" | "from" | "both" | "")
-#
-#	roster(ask,$username)        : "Ask" of $username
-#                                  ("subscribe" | "unsubscribe" | "")
-#
-#	lib(wrap)                    : Wrap ID
-#
-#	lib(sck)                     : SocketName
-#
-#	lib(sckstats)                : Socket status, "on" or "off"
-#
-#	lib(disconnect)              : disconnect procedure
-#
-#	iq(num)                      : Next iq id-number. Sent in
-#                                  "id" attributes of <iq> packets.
-#
-#	iq($id)                      : Callback to run when result packet
-#                                  of $id is received.
-#
-#
-######################################################################
-#
-# Procedures defined in this library
-#
-if {0} {
-proc jlib::connect {sck server}
-proc jlib::disconnect {}
-proc jlib::got_stream {vars}
-proc jlib::end_of_parse {}
-proc jlib::outmsg {msg}
-proc jlib::inmsg {}
-proc jlib::clear_vars {}
-proc jlib::clear_iqs {}
-proc jlib::parse {xmldata}
-proc jlib::parse_send_auth {cmd type data}
-proc jlib::parse_send_create {cmd type data}
-proc jlib::parse_roster_get {connid ispush cmd type data}
-proc jlib::parse_roster_set {item cmd groups name type data}
-proc jlib::parse_roster_del {item cmd type data}
-proc jlib::send_iq {type xmldata args}
-proc jlib::send_auth {user pass res cmd}
-proc jlib::send_create {user pass name mail cmd}
-proc jlib::send_msg {to args}
-proc jlib::send_presence {args}
-proc jlib::roster_get {args}
-proc jlib::roster_set {item args}
-proc jlib::roster_del {item args}
-proc ::LOG text
-proc jlib::noop args
-}
-
-lappend auto_path [file dirname [info script]]
-if {![info exists use_external_tclxml] || $use_external_tclxml == 0} {
-    package require -exact xml 2.0
-} else {
-    package require xml 2.0
-}
-package require sha1
-package require msgcat
-
-package require namespaces 1.0
-package require streamerror 1.0
-package require stanzaerror 1.0
-package require idna 1.0
-package require jlibauth 1.0
-package require jlibdns 1.0
-
-package require autoconnect 0.1
-
-######################################################################
-
-namespace eval jlib {
-
-    # Load XML:Wrapper
-    source [file join [file dirname [info script]] wrapper.tcl]
-
-    set lib(capabilities,auth) {non_sasl}
-
-    # Load connection transports
-    source [file join [file dirname [info script]] transports.tcl]
-
-    catch { package require jlibtls 1.0 }
-    catch { package require jlibcompress 1.0 }
-
-    if {![catch { package require jlibsasl 1.0 }]} {
-	lappend lib(capabilities,auth) sasl
-    }
-
-    set lib(connections) {}
-    set lib(connid) 0
-    set iq(num) 1
-
-    # Export procedures.
-    #
-    namespace export \
-	wrapper:splitxml wrapper:createtag \
-	wrapper:createxml wrapper:xmlcrypt \
-	wrapper:isattr wrapper:getattr
-}
-
-######################################################################
-
-if {![info exists keep_alive]} {
-    set keep_alive 0
-}
-if {![info exists keep_alive_interval]} {
-    set keep_alive_interval 10
-}
-
-######################################################################
-
-proc jlib::capabilities {type} {
-    variable lib
-
-    set res {}
-    switch -- $type {
-	proxy {
-	    set res [transport::proxy::capabilities]
-	}
-	transport {
-	    set res [transport::capabilities]
-	}
-	auth {
-	    set res $lib(capabilities,$type)
-	}
-    }
-    return $res
-}
-
-######################################################################
-
-# TODO register callbacks in jlib::new
-proc jlib::client {callback args} {
-    uplevel #0 [list client:$callback] $args
-}
-
-######################################################################
-
-proc jlib::new {args} {
-    variable lib
-    variable connjid
-    variable connhist
-
-    foreach {attr val} $args {
-	switch -- $attr {
-	    -user          {set user $val}
-	    -server        {set server $val}
-	    -resource      {set resource $val}
-	}
-    }
-
-    if {![info exists user] || ![info exists server] || \
-	    ![info exists resource]} {
-	return -code error "Usage: jlib::new -user username\
-			    -server servername -resource resourcename"
-    }
-
-    set jid $user@$server/$resource
-    if {[info exists connhist($jid)]} {
-	set connid $connhist($jid)
-	if {[lsearch -exact $lib(connections) $connid] >= 0} {
-	    set connid [incr lib(connid)]
-	}
-    } else {
-	set connid [incr lib(connid)]
-	set connhist($jid) $connid
-    }
-
-    set connjid($connid,user) $user
-    set connjid($connid,server) $server
-    set connjid($connid,resource) $resource
-
-    ::LOG "(jlib::new) JID:'$jid' ConnectionID:'$connid'"
-    return $connid
-}
-
-######################################################################
-
-proc jlib::connect {connid args} {
-    variable lib
-    variable connjid
-
-    set user $connjid($connid,user)
-    set server $connjid($connid,server)
-    set resource $connjid($connid,resource)
-
-    set transport tcp
-    set host $server
-    set port 5222
-    set hosts {}
-    set xmlns jabber:client
-    set use_sasl 0
-    set allow_auth_plain 0
-    set use_starttls 0
-    set use_compression 0
-    set cacertstore ""
-    set certfile ""
-    set keyfile ""
-
-    foreach {attr val} $args {
-	switch -- $attr {
-	    -password       {set password $val}
-	    -transport      {set transport $val}
-	    -host           {set host $val}
-	    -hosts          {set hosts $val}
-	    -port           {set port $val}
-	    -xmlns          {set xmlns $val}
-	    -usesasl        {set use_sasl $val}
-	    -allowauthplain {set allow_auth_plain $val}
-	    -usestarttls    {set use_starttls $val}
-	    -usecompression {set use_compression $val}
-	    -cacertstore    {set cacertstore $val}
-	    -certfile       {set certfile $val}
-	    -keyfile        {set keyfile $val}
-	}
-    }
-
-    if {$hosts == {}} {
-	set hosts [list [list [idna::domain_toascii $host] $port]]
-    }
-
-    ::LOG "(jlib::connect) Server:'$server' ConnectionID:'$connid'"
-
-    # TODO: do not change autoconnect options on every login.
-    eval autoconnect::configure $args
-
-    foreach hp $hosts {
-	if {[catch {
-		eval [list transport::${transport}::connect \
-			   $connid \
-			   [lindex $hp 0] \
-			   [lindex $hp 1]] $args
-	    } sock]} {
-	    set error 1
-	} else {
-	    set lib($connid,sck) $sock
-	    set error 0
-	    break
-	}
-    }
-    if {$error} {
-	::LOG "error (jlib::connect) Can't connect to the server: $sock"
-	return -code error $sock
-    }
-
-    lappend lib(connections) $connid
-
-    set lib($connid,xmlns) $xmlns
-    set lib($connid,password) $password
-    set lib($connid,transport) $transport
-    add_connection_route $connid $server
-    set lib($connid,disconnect) reconnect
-    set lib($connid,parse_end) 0
-    set lib($connid,use_sasl) $use_sasl
-    set lib($connid,allow_auth_plain) $allow_auth_plain
-    set lib($connid,use_starttls) $use_starttls
-    set lib($connid,use_compression) $use_compression
-    set lib($connid,cacertstore) $cacertstore
-    set lib($connid,certfile) $certfile
-    set lib($connid,keyfile) $keyfile
-    set lib($connid,disconnecting) 0
-    set lib($connid,bytes_counter) 0
-
-    catch { unset lib($connid,features) }
-    set lib($connid,version) 0.0
-
-    set lib($connid,wrap) \
-	[wrapper:new [list [namespace current]::got_stream $connid] \
-		     [list [namespace current]::end_of_parse $connid] \
-		     [list [namespace current]::parse $connid]]
-
-    set lib($connid,authtoken) \
-	[::jlibauth::new $connid -username $user \
-				 -server $server \
-				 -resource $resource \
-				 -password $password \
-				 -allow_plain $allow_auth_plain]
-
-    if {[info commands ::jlibtls::new] != ""} {
-	set lib($connid,tlstoken) \
-	    [::jlibtls::new $connid -certfile $certfile \
-				    -cacertstore $cacertstore \
-				    -keyfile $keyfile]
-    }
-
-    if {[info commands ::jlibcompress::new] != ""} {
-	set lib($connid,compresstoken) \
-	    [::jlibcompress::new $connid]
-    }
-
-    if {[info commands ::jlibsasl::new] != ""} {
-	set lib($connid,sasltoken) \
-	    [::jlibsasl::new $connid -username $user \
-				     -server $server \
-				     -resource $resource \
-				     -password $password \
-				     -allow_plain $allow_auth_plain]
-    }
-
-    set params [list -xmlns $xmlns -xml:lang [get_lang]]
-    if {$use_sasl || $use_starttls || $use_compression} {
-	lappend params -version "1.0"
-    }
-
-    outmsg [eval [list wrapper:streamheader $server] $params] \
-	-connection $connid
-
-    return $connid
-}
-
-######################################################################
-
-proc jlib::socket_ip {connid} {
-    variable lib
-
-    if {[info exists lib($connid,sck)] && \
-	![catch {fconfigure $lib($connid,sck) -sockname} sock]} {
-	return [lindex $sock 0]
-    } else {
-	return ""
-    }
-}
-
-######################################################################
-
-proc jlib::reset {connid} {
-    variable lib
-
-    wrapper:reset $lib($connid,wrap)
-    catch { unset lib($connid,features) }
-    catch { unset lib($connid,sessionid) }
-}
-
-######################################################################
-
-proc jlib::login {connid cmd} {
-    ::LOG "(jlib::login) $connid"
-
-    wait_for_stream $connid \
-	[list [namespace current]::login_aux $connid $cmd]
-}
-
-proc jlib::login_aux {connid cmd} {
-    variable lib
-
-    ::LOG "(jlib::login_aux) $connid"
-
-    if {$lib($connid,use_starttls)} {
-	$lib($connid,tlstoken) starttls \
-	    -command [list [namespace current]::login_aux2 $connid $cmd]
-    } else {
-	login_aux1 $connid $cmd
-    }
-}
-
-proc jlib::login_aux1 {connid cmd} {
-    variable lib
-
-    ::LOG "(jlib::login_aux1) $connid"
-
-    if {$lib($connid,use_compression)} {
-	$lib($connid,compresstoken) start \
-	    -command [list [namespace current]::login_aux2 $connid $cmd]
-    } else {
-	login_aux3 $connid $cmd
-    }
-}
-
-proc jlib::login_aux2 {connid cmd res xmldata} {
-    ::LOG "(jlib::login_aux2) $connid"
-
-    if {$res == "ERR"} {
-	login_aux5 $connid $cmd $res $xmldata
-    } else {
-	login_aux3 $connid $cmd
-    }
-}
-
-proc jlib::login_aux3 {connid cmd} {
-    variable lib
-
-    ::LOG "(jlib::login_aux3) $connid"
-
-    if {$lib($connid,use_sasl)} {
-	$lib($connid,sasltoken) auth \
-	    -command [list [namespace current]::login_aux5 $connid $cmd]
-    } else {
-	wait_for_stream $connid \
-	    [list [namespace current]::login_aux4 $connid $cmd]
-    }
-}
-
-proc jlib::login_aux4 {connid cmd} {
-    variable lib
-
-    ::LOG "(jlib::login_aux4) $connid"
-
-    $lib($connid,authtoken) auth \
-	-command [list [namespace current]::login_aux5 $connid $cmd] \
-	-sessionid $lib($connid,sessionid)
-}
-
-proc jlib::login_aux5 {connid cmd res xmldata} {
-    ::LOG "(jlib::login_aux5) $connid"
-
-    after idle [list uplevel #0 $cmd [list $res $xmldata]]
-}
-
-########################################################################
-
-proc jlib::disconnect {{connections {}}} {
-    variable lib
-
-    ::LOG "(jlib::disconnect) $connections"
-
-    if {$connections == {}} {
-	set connections $lib(connections)
-    }
-
-    foreach connid $connections {
-	set idx [lsearch -exact $lib(connections) $connid]
-	if {$idx < 0} continue
-
-	cancel_keepalive $connid
-	outmsg [wrapper:streamtrailer] -connection $connid
-	set lib($connid,disconnecting) 1
-	catch {
-	    transport::$lib($connid,transport)::disconnect $connid
-	    transport::$lib($connid,transport)::close $connid
-	}
-
-	set lib(connections) [lreplace $lib(connections) $idx $idx]
-	clear_vars $connid
-    }
-
-    if {$lib(connections) == {}} {
-	clear_iqs
-    }
-}
-
-######################################################################
-
-proc jlib::got_stream {connid vars} {
-    variable lib
-
-    set version [jlib::wrapper:getattr $vars version]
-    if {($lib($connid,use_starttls) || $lib($connid,use_sasl) || \
-	    $lib($connid,use_compression)) && \
-		[string is double -strict $version] && ($version >= 1.0)} {
-	set lib($connid,version) $version
-    }
-    set sessionid [jlib::wrapper:getattr $vars id]
-
-    ::LOG "(jlib::got_stream $connid)\
-	   Session ID = $sessionid, Version = $lib($connid,version)"
-    if {$version < 1.0} {
-	# Register iq-register and iq-auth namespaces to allow
-	# register and auth when using non-XMPP server
-	parse_stream_features $connid \
-	    [list [wrapper:createtag register \
-		       -vars [list xmlns $::NS(iq-register)]] \
-		  [wrapper:createtag auth \
-		       -vars [list xmlns $::NS(iq-auth)]]]
-    }
-    set lib($connid,sessionid) $sessionid
-    set lib($connid,bytes_counter) 0
-}
-
-######################################################################
-
-proc jlib::wait_for_stream {connid cmd} {
-    variable lib
-
-    ::LOG "(jlib::wait_for_stream $connid)"
-
-    if {[info exists lib($connid,sessionid)]} {
-	uplevel #0 $cmd
-    } else {
-	# Must be careful so this is not triggered by a reset or something...
-	trace variable [namespace current]::lib($connid,sessionid) w \
-	    [list [namespace current]::wait_for_stream_aux $connid $cmd]
-    }
-}
-
-proc jlib::wait_for_stream_aux {connid cmd name1 name2 op} {
-    variable lib
-
-    trace vdelete [namespace current]::lib($connid,sessionid) w \
-        [list [namespace current]::wait_for_stream_aux $connid $cmd]
-
-    uplevel #0 $cmd
-}
-
-######################################################################
-
-proc jlib::end_of_parse {connid} {
-    after idle [list [namespace current]::end_of_parse1 $connid]
-}
-
-proc jlib::end_of_parse1 {connid} {
-    variable lib
-
-    ::LOG "(jlib::end_of_parse $connid)"
-
-    set lib($connid,parse_end) 1
-    if {$lib(connections) == {}} {
-	::LOG "error (jlib::end_of_parse) No connection"
-	return -1
-	# Already disconnected
-    }
-
-    cancel_keepalive $connid
-    transport::$lib($connid,transport)::close $connid
-
-    if {!$lib($connid,disconnecting)} {
-	after idle [list [namespace current]::emergency_disconnect $connid]
-    }
-}
-
-######################################################################
-
-proc jlib::outmsg {msg args} {
-    global keep_alive keep_alive_interval
-    variable keep_alive_id
-    variable lib
-
-    foreach {attr val} $args {
-	switch -- $attr {
-	    -connection {set connid $val}
-	}
-    }
-
-    if {$lib(connections) == {}} {
-	::LOG "error (jlib::outmsg) No connections"
-	return -1
-    }
-
-    if {![info exists connid]} {
-	set connid [lindex $lib(connections) 0]
-    }
-
-    cancel_keepalive $connid
-
-    if {[lsearch -exact $lib(connections) $connid] < 0} {
-	::LOG "error (jlib::outmsg) Connection $connid doesn't exist"
-	return -1
-    }
-
-    if {$lib($connid,disconnecting)} {
-	::LOG "error (jlib::outmsg) Message while disconnecting..."
-	return -1
-    }
-
-    ::LOG "(jlib::outmsg) ($connid) '$msg'"
-    ::LOG_OUTPUT $connid $msg
-
-    if {$keep_alive} {
-	set keep_alive_id [after [expr $keep_alive_interval * 60 * 1000] \
-			       [namespace current]::out_keepalive $connid]
-    }
-
-    return [transport::$lib($connid,transport)::outmsg $connid $msg]
-}
-
-######################################################################
-
-proc jlib::out_keepalive {connid} {
-    outmsg " " -connection $connid
-}
-
-# TODO: connid
-proc jlib::cancel_keepalive {connid} {
-    variable keep_alive_id
-
-    if {[info exists keep_alive_id]} {
-	after cancel $keep_alive_id
-    }
-}
-
-######################################################################
-
-proc jlib::inmsg {connid msg eof} {
-    global keep_alive keep_alive_interval
-    variable keep_alive_id
-    variable lib
-
-    if {[lsearch -exact $lib(connections) $connid] < 0} {
-	::LOG "error (jlib::inmsg) Connection $connid doesn't exist"
-	return -1
-    }
-
-    # TODO
-    if {$keep_alive} {
-	cancel_keepalive $connid
-	set keep_alive_id [after [expr $keep_alive_interval * 60 * 1000] \
-			       [namespace current]::out_keepalive $connid]
-    }
-
-    incr lib($connid,bytes_counter) [string bytelength $msg]
-
-    ::LOG "(jlib::inmsg) ($connid) '$msg'"
-    ::LOG_INPUT $connid $msg
-    wrapper:parser $lib($connid,wrap) parse $msg
-
-    if {!$lib($connid,parse_end) && $eof} {
-	cancel_keepalive $connid
-	transport::$lib($connid,transport)::close $connid
-
-	if {$lib($connid,disconnecting)} {
-	    ::LOG "(jlib::inmsg) Socket is closed by server. Disconnecting..."
-	} else {
-	    ::LOG "error (jlib::inmsg) Socket is closed by server. Disconnecting..."
-	    after idle [list [namespace current]::emergency_disconnect $connid]
-	}
-    }
-}
-
-######################################################################
-
-proc jlib::emergency_disconnect {connid} {
-    variable lib
-
-    set idx [lsearch -exact $lib(connections) $connid]
-
-    if {$idx < 0} return
-
-    set lib(connections) [lreplace $lib(connections) $idx $idx]
-
-    client $lib($connid,disconnect) $connid
-
-    clear_vars $connid
-    if {$lib(connections) == {}} {
-	clear_iqs
-    }
-}
-
-######################################################################
-
-proc jlib::clear_vars {connid} {
-    #
-    # unset all the variables
-    #
-    variable roster
-    variable pres
-    variable lib
-
-    if {![info exists lib($connid,wrap)]} return
-
-    wrapper:free $lib($connid,wrap)
-
-    if {[info exists lib($connid,tlstoken)]} {
-	$lib($connid,tlstoken) free
-    }
-    if {[info exists lib($connid,compresstoken)]} {
-	$lib($connid,compresstoken) free
-    }
-    if {[info exists lib($connid,sasltoken)]} {
-	$lib($connid,sasltoken) free
-    }
-
-    $lib($connid,authtoken) free
-
-    array unset lib $connid,*
-
-    set lib($connid,disconnect) reconnect
-}
-
-######################################################################
-
-proc jlib::clear_iqs {} {
-    variable iq
-
-    array unset iq presence,*
-
-    foreach id [array names iq] {
-	if {$id != "num"} {
-	    set cmd $iq($id)
-	    unset iq($id)
-	    uplevel #0 $cmd [list DISCONNECT [::msgcat::mc "Disconnected"]]
-	}
-    }
-
-    set iq(num) 1
-}
-
-######################################################################
-proc jlib::connections {} {
-    variable lib
-    return $lib(connections)
-}
-
-proc jlib::connection_jid {connid} {
-    variable lib
-    variable connjid
-
-    if {[info exists lib($connid,sasltoken)]} {
-	set username [$lib($connid,sasltoken) cget -username]
-	set server   [$lib($connid,sasltoken) cget -server]
-	set resource [$lib($connid,sasltoken) cget -resource]
-	return $username@$server/$resource
-    } else {
-	return \
-	    $connjid($connid,user)@$connjid($connid,server)/$connjid($connid,resource)
-    }
-}
-
-proc jlib::connection_bare_jid {connid} {
-    variable lib
-    variable connjid
-
-    if {[info exists lib($connid,sasltoken)]} {
-	set username [$lib($connid,sasltoken) cget -username]
-	set server   [$lib($connid,sasltoken) cget -server]
-	return $username@$server
-    } else {
-	return $connjid($connid,user)@$connjid($connid,server)
-    }
-}
-
-proc jlib::connection_user {connid} {
-    variable lib
-    variable connjid
-
-    if {[info exists lib($connid,sasltoken)]} {
-	set username [$lib($connid,sasltoken) cget -username]
-	return $username
-    } else {
-	return $connjid($connid,user)
-    }
-}
-
-proc jlib::connection_server {connid} {
-    variable lib
-    variable connjid
-
-    if {[info exists lib($connid,sasltoken)]} {
-	set server [$lib($connid,sasltoken) cget -server]
-	return $server
-    } else {
-	return $connjid($connid,server)
-    }
-}
-
-proc jlib::connection_resource {connid} {
-    variable lib
-    variable connjid
-
-    if {[info exists lib($connid,sasltoken)]} {
-	set resource [$lib($connid,sasltoken) cget -resource]
-	return $resource
-    } else {
-	return $connjid($connid,resource)
-    }
-}
-
-######################################################################
-
-proc jlib::connection_requested_user {connid} {
-    variable connjid
-
-    return $connjid($connid,user)
-}
-
-proc jlib::connection_requested_server {connid} {
-    variable connjid
-
-    return $connjid($connid,server)
-}
-
-proc jlib::connection_requested_resource {connid} {
-    variable connjid
-
-    return $connjid($connid,resource)
-}
-
-######################################################################
-
-proc jlib::register_xmlns {connid xmlns callback} {
-    variable lib
-
-    set lib($connid,registered_xmlns,$xmlns) $callback
-}
-
-proc jlib::unregister_xmlns {connid xmlns} {
-    variable lib
-
-    catch {unset lib($connid,registered_xmlns,$xmlns)}
-}
-
-proc jlib::xmlns_is_registered {connid xmlns} {
-    variable lib
-
-    if {[info exists lib($connid,registered_xmlns,$xmlns)]} {
-	return 1
-    } else {
-	return 0
-    }
-}
-
-proc jlib::xmlns_callback {connid xmlns} {
-    variable lib
-
-    if {[info exists lib($connid,registered_xmlns,$xmlns)]} {
-	return $lib($connid,registered_xmlns,$xmlns)
-    } else {
-	return ""
-    }
-}
-
-######################################################################
-
-proc jlib::register_element {connid element callback} {
-    variable lib
-
-    set lib($connid,registered_element,$element) $callback
-}
-
-proc jlib::unregister_element {connid element} {
-    variable lib
-
-    catch {unset lib($connid,registered_element,$element)}
-}
-
-proc jlib::element_is_registered {connid element} {
-    variable lib
-
-    if {[info exists lib($connid,registered_element,$element)]} {
-	return 1
-    } else {
-	return 0
-    }
-}
-
-proc jlib::element_callback {connid element} {
-    variable lib
-
-    if {[info exists lib($connid,registered_element,$element)]} {
-	return $lib($connid,registered_element,$element)
-    } else {
-	return ""
-    }
-}
-
-######################################################################
-
-proc jlib::parse {connid xmldata} {
-
-    variable lib
-    set size 0
-    catch {set size $lib($connid,bytes_counter) }
-    set lib($connid,bytes_counter) 0
-
-    after idle [list [namespace current]::parse1 $connid $xmldata]
-    after idle [list ::LOG_INPUT_SIZE $connid $xmldata $size]
-}
-
-proc jlib::parse1 {connid xmldata} {
-    variable global
-    variable roster
-    variable pres
-    variable lib
-    variable iq
-
-    ::LOG "(jlib::parse) xmldata: '$xmldata'"
-    ::LOG_INPUT_XML $connid $xmldata
-
-    if {$lib(connections) == {}} {
-        ::LOG "error (jlib::parse) No connection"
-        return -1
-    }
-
-    wrapper:splitxml $xmldata tag vars isempty chdata children
-
-    if {[wrapper:isattr $vars from]} {
-	set usefrom 1
-	set from [wrapper:getattr $vars from]
-    } else {
-	set usefrom 0
-	set from ""
-    }
-
-    set xmlns [wrapper:getattr $vars xmlns]
-
-    if {[xmlns_is_registered $connid $xmlns]} {
-	uplevel \#0 [xmlns_callback $connid $xmlns] [list $xmldata]
-	return
-    }
-
-    if {[element_is_registered $connid $tag]} {
-	uplevel \#0 [element_callback $connid $tag] [list $xmldata]
-	return
-    }
-
-    if {[wrapper:isattr $vars xml:lang]} {
-	set lang [wrapper:getattr $vars xml:lang]
-    } else {
-	set lang en
-    }
-
-    switch -- $tag {
-	iq {
-	    set useid 0
-	    set id ""
-	    set type [wrapper:getattr $vars type]
-
-	    if {[wrapper:isattr $vars id] == 1} {
-		set useid 1
-		set id [wrapper:getattr $vars id]
-	    }
-
-	    if {$type != "result" && $type != "error" && $type != "get" && $type != "set"} {
-		::LOG "(error) iq: unknown type:'$type' id ($useid):'$id'"
-		return
-	    }
-
-	    if {$type == "result"} {
-		if {$useid == 0} {
-		    ::LOG "(error) iq:result: no id reference"
-		    return
-		}
-		if {[info exists iq($id)] == 0} {
-		    ::LOG "(error) iq:result: id doesn't exists in memory. Probably a re-replied iq"
-		    return
-		}
-
-		set cmd $iq($id)
-		unset iq($id)
-
-		uplevel \#0 $cmd [list OK [lindex $children 0]]
-	    } elseif {$type == "error"} {
-		if {$useid == 0} {
-		    ::LOG "(error) iq:result: no id reference"
-		    return
-		}
-		if {[info exists iq($id)] == 0} {
-		    ::LOG "(error) iq:result: id doesn't exists in memory. Probably a re-replied iq."
-		    return
-		}
-
-		set cmd $iq($id)
-		unset iq($id)
-
-		set child ""
-		foreach child $children {
-		    if {[lindex $child 0] == "error"} { break }
-		    set child ""
-		}
-		if {$child == ""} {
-		    set errcode ""
-		    set errtype ""
-		    set errmsg ""
-		} else {
-		    set errcode [wrapper:getattr [lindex $child 1] code]
-		    set errtype [wrapper:getattr [lindex $child 1] type]
-		    set errmsg [lindex $child 3]
-		}
-		if {$errtype == ""} {
-		    uplevel #0 $cmd [list ERR [list $errcode $errmsg]]
-		} else {
-		    uplevel #0 $cmd [list ERR [list $errtype $child]]
-		}
-	    } elseif {$type == "get" || $type == "set"} {
-		set child [lindex $children 0]
-
-		if {$child == ""} {
-		    ::LOG "(error) iq:$type: Cannot find 'query' tag"
-		    return
-		}
-
-		#
-		# Before calling the 'client:iqreply' procedure, we should check
-		# the 'xmlns' attribute, to understand if this is some 'iq' that
-		# should be handled inside jlib, such as a roster-push.
-		#
-		if {$type == "set" && \
-			[wrapper:getattr [lindex $child 1] xmlns] == $::NS(roster)} {
-		    if {$from != "" && \
-			    !([string equal -nocase $from [connection_server $connid]] || \
-			    [string equal -nocase $from [connection_bare_jid $connid]] || \
-			    [string equal -nocase $from [connection_jid $connid]])} {
-			send_iq error \
-			    [stanzaerror::error cancel not-allowed -xml $child] \
-			    -id [wrapper:getattr $vars id] \
-			    -to $from \
-			    -connection $connid
-			return
-		    }
-
-		    # Found a roster-push
-		    ::LOG "(info) iq packet is roster-push. Handling internally"
-
-		    # First, we reply to the server, saying that, we
-		    # got the data, and accepted it.
-		    #
-		    if [wrapper:isattr $vars id] {
-			send_iq result \
-			    [wrapper:createtag query \
-				 -vars [list xmlns $::NS(roster)]] \
-			    -id [wrapper:getattr $vars id] \
-			    -connection $connid
-		    } else {
-			send_iq result \
-			    [wrapper:createtag query \
-				 -vars [list xmlns $::NS(roster)]] \
-			    -connection $connid
-		    }
-
-		    # And then, we call the jlib::parse_roster_get, because this
-		    # data is the same as the one we get from a roster-get.
-		    parse_roster_get \
-			$connid 1 [namespace current]::noop OK $child
-		    return
-		}
-
-		client iqreply $connid $from $useid $id $type $lang $child
-	    }
-	}
-	message {
-	    set type [wrapper:getattr $vars type]
-	    set id [wrapper:getattr $vars id]
-
-	    set body     ""
-	    set err      [list "" ""]
-	    set is_subject 0
-	    set subject  ""
-	    set priority ""
-	    set thread   ""
-	    set x        ""
-
-	    foreach child $children {
-		wrapper:splitxml $child ctag cvars cisempty cchdata cchildren
-
-		switch -- $ctag {
-		    body {set body $cchdata}
-		    error {
-			set errmsg $cchdata
-			set errcode [wrapper:getattr $cvars code]
-			set errtype [wrapper:getattr $cvars type]
-			if {$errtype == ""} {
-			    set err [list $errcode $errmsg]
-			} else {
-			    set err [list $errtype $child]
-			}
-		    }
-		    subject {
-			set is_subject 1
-			set subject $cchdata
-		    }
-		    priority {set priority $cchdata}
-		    thread {set thread $cchdata}
-		    default {
-			if {[wrapper:getattr $cvars xmlns] != ""} {
-			    lappend x $child
-			}
-		    }
-		}
-	    }
-
-	    client message $connid $from $id $type $is_subject \
-			   $subject $body $err $thread $priority $x
-	}
-	presence {
-	    set type [wrapper:getattr $vars type]
-
-	    set cmd      ""
-	    set status   ""
-	    set priority ""
-	    set meta     ""
-	    set icon     ""
-	    set show     ""
-	    set loc      ""
-	    set x        ""
-
-	    set param    ""
-
-	    if {[wrapper:isattr $vars id]} {
-		set id [wrapper:getattr $vars id]
-		if {[info exists iq(presence,$id)]} {
-		    set cmd $iq(presence,$id)
-		    unset iq(presence,$id)
-		}
-		lappend param -id $id
-	    }
-
-	    if {[wrapper:isattr $vars name]} {
-		lappend param -name [wrapper:getattr $vars name]
-	    }
-
-	    foreach child $children {
-		wrapper:splitxml $child ctag cvars cisempty cchdata cchildren
-
-		switch -- $ctag {
-		    status   {
-			if {$type != "error"} {
-			    lappend param -status $cchdata
-			}
-		    }
-		    priority {lappend param -priority $cchdata}
-		    meta     {lappend param -meta     $cchdata}
-		    icon     {lappend param -icon     $cchdata}
-		    show     {lappend param -show     $cchdata}
-		    loc      {lappend param -loc      $cchdata}
-		    error {
-			if {$type == "error"} {
-			    set errcode [wrapper:getattr $cvars code]
-			    set errtype [wrapper:getattr $cvars type]
-			    if {$errtype == ""} {
-				set err [list $errcode $cchdata]
-			    } else {
-				set err [list $errtype $child]
-			    }
-			    lappend param -status [lindex [stanzaerror::error_to_list $err] 2]
-			    lappend param -error [lrange [stanzaerror::error_to_list $err] 0 1]
-			}
-		    }
-		    default {lappend x $child}
-		}
-	    }
-
-	    set cont ""
-	    if {$cmd != ""} {
-		set cont \
-		    [uplevel \#0 $cmd [list $connid $from $type $x] $param]
-	    }
-
-	    if {$cont != "break"} {
-		eval [list client presence $connid $from $type $x] $param
-	    }
-	}
-	error {
-	    if {[wrapper:getattr $vars xmlns] == $::NS(stream)} {
-		parse_stream_error $connid $xmldata
-	    }
-	}
-	features {
-	    if {[wrapper:getattr $vars xmlns] == $::NS(stream)} {
-		parse_stream_features $connid $children
-	    }
-	}
-    }
-}
-
-######################################################################
-
-proc jlib::parse_send_create {cmd type data} {
-    variable lib
-
-    ::LOG "(jlib::parse_send_create) type:'$type'"
-
-    if {$type == "ERR"} {
-	::LOG "error (jlib::parse_send_create) errtype:'[lindex $data 0]'"
-	::LOG "error (jlib::parse_send_create) errdesc:'[lindex $data 1]'"
-	uplevel #0 $cmd [list ERR [lindex $data 1]]
-	return
-    }
-    uplevel #0 $cmd [list OK {}]
-}
-
-######################################################################
-
-proc jlib::parse_roster_get {connid ispush cmd type data} {
-    variable lib
-    variable roster
-
-    ::LOG "(jlib::parse_roster_get) ispush:'$ispush' type:'$type'"
-
-    if {$type == "ERR"} {
-	::LOG "error (jlib::parse_roster_get) errtype:'[lindex $data 0]'"
-	::LOG "error (jlib::parse_roster_get) errdesc:'[lindex $data 1]'"
-	uplevel #0 $cmd [list $connid ERR]
-	return
-    }
-    if {!$ispush} {
-	client status [::msgcat::mc "Got roster"]
-	uplevel #0 $cmd [list $connid BEGIN_ROSTER]
-    }
-
-    wrapper:splitxml $data tag vars isempty chdata children
-
-    if {![cequal [wrapper:getattr $vars xmlns] $::NS(roster)]} {
-	::LOG "warning (jlib::parse_roster_get) 'xmlns' attribute of\
-	       query tag doesn't match '$::NS(roster)':\
-	       '[wrapper:getattr $vars xmlns]"
-    }
-
-    foreach child $children {
-	wrapper:splitxml $child ctag cvars cisempty cchdata cchildren
-
-	switch -- $ctag {
-	    default {
-		set groups ""
-		set jid   [wrapper:getattr $cvars jid]
-		set name  [wrapper:getattr $cvars name]
-		set subsc [wrapper:getattr $cvars subscription]
-		set ask   [wrapper:getattr $cvars ask]
-
-		foreach subchild $cchildren {
-		    wrapper:splitxml $subchild subtag tmp tmp subchdata tmp
-
-		    switch -- $subtag {
-			group {lappend groups $subchdata}
-		    }
-		}
-
-		# Ok, collected information about item.
-		# Now we can set our variables...
-		#
-		if {[lsearch $roster(users) $jid] == -1} {
-		    lappend roster(users) $jid
-		}
-
-		set roster(group,$jid) $groups
-		set roster(name,$jid)  $name
-		set roster(subsc,$jid) $subsc
-		set roster(ask,$jid)   $ask
-
-		add_connection_route $connid $jid
-
-		# ...and call client procedures
-		if $ispush {
-		    client roster_push $connid $jid $name $groups $subsc $ask
-		} else {
-		    client roster_item $connid $jid $name $groups $subsc $ask
-		}
-	    }
-	}
-    }
-    if {!$ispush} {
-	uplevel #0 $cmd [list $connid END_ROSTER]
-    }
-}
-
-######################################################################
-
-proc jlib::parse_roster_set {item cmd groups name type data} {
-    variable lib
-    variable roster
-
-    ::LOG "(jlib::parse_roster_set) item:'$item' type:'$type'"
-
-    if {$type == "ERR"} {
-	::LOG "error (jlib::parse_roster_set) errtype:'[lindex $data 0]'"
-	::LOG "error (jlib::parse_roster_set) errdesc:'[lindex $data 1]'"
-	uplevel #0 $cmd ERR
-	return
-    }
-
-    if { [lsearch $roster(users) $item] == -1}   {
-	lappend roster(users) $item
-	set roster(subsc,$item) "none"
-	set roster(ask,$item)   ""
-    }
-
-    set roster(group,$item) $groups
-    set roster(name,$item)  $name
-
-    uplevel #0 $cmd OK
-}
-
-######################################################################
-
-proc jlib::parse_roster_del {item cmd type data} {
-    variable lib
-    variable roster
-
-    ::LOG "(jlib::parse_roster_del) item:'$item' type:'$type'"
-
-    if {$type == "ERR"} {
-	::LOG "error (jlib::parse_roster_set) errtype:'[lindex $data 0]'"
-	::LOG "error (jlib::parse_roster_set) errdesc:'[lindex $data 1]'"
-	uplevel #0 $cmd ERR
-	return
-    }
-
-    if {[set num [lsearch $roster(users) $item]] != -1} {
-	set roster(users) [lreplace $roster(users) $num $num]
-
-	catch {unset roster(group,$item) }
-	catch {unset roster(name,$item)  }
-	catch {unset roster(subsc,$item) }
-	catch {unset roster(ask,$item)   }
-    } else {
-	::LOG "warning (jlib::parse_roster_del) Item '$item' doesn't\
-	       exist in roster for deletion."
-    }
-    uplevel #0 $cmd OK
-}
-
-######################################################################
-
-proc jlib::parse_stream_error {connid xmldata} {
-    variable lib
-
-    switch -- [streamerror::condition $xmldata] {
-	bad-format -
-	bad-namespace-prefix -
-	connection-timeout -
-	invalid-from -
-	invalid-id -
-	invalid-namespace -
-	invalid-xml -
-	remote-connection-failed -
-	restricted-xml -
-	unsupported-encoding -
-	unsupported-stanza-type -
-	xml-not-well-formed {
-	    set lib($connid,disconnect) reconnect
-	}
-	default {
-	    set lib($connid,disconnect) disconnect
-	}
-    }
-    client errormsg [streamerror::message $xmldata]
-}
-
-######################################################################
-
-proc jlib::parse_stream_features {connid xmldata} {
-    variable lib
-
-    set features {}
-    foreach child $xmldata {
-	wrapper:splitxml $child tag vars isempty cdata children
-
-	set xmlns [wrapper:getattr $vars xmlns]
-
-	if {[xmlns_is_registered $connid $xmlns]} {
-	    lappend features $xmlns
-	    uplevel \#0 [xmlns_callback $connid $xmlns] [list $child]
-	    continue
-	}
-
-	switch -- $tag {
-	    register {
-		lappend features register
-	    }
-	}
-    }
-    set lib($connid,features) $features
-}
-
-######################################################################
-
-proc jlib::trace_stream_features {connid cmd} {
-    variable lib
-
-    if {[info exists lib($connid,features)]} {
-	uplevel #0 $cmd
-    } else {
-	# Must be careful so this is not triggered by a reset or something...
-	trace variable [namespace current]::lib($connid,features) w \
-	    [list [namespace current]::trace_stream_features_aux $connid $cmd]
-    }
-}
-
-proc jlib::trace_stream_features_aux {connid cmd name1 name2 op} {
-    trace vdelete [namespace current]::lib($connid,features) w \
-        [list [namespace current]::trace_stream_features_aux $connid $cmd]
-
-    uplevel #0 $cmd
-}
-
-######################################################################
-
-proc jlib::send_iq {type xmldata args} {
-    variable lib
-    variable iq
-
-    ::LOG "(jlib::send_iq) type:'$type'"
-
-    set useto  0
-    set useid  0
-    set to     {}
-    set id     {}
-    set cmd    [namespace current]::noop
-    set vars   {}
-    set timeout 0
-
-    foreach {attr val} $args {
-	switch -- $attr {
-	    -from    { lappend vars from $val }
-	    -to      { set useto 1 ; set to $val }
-	    -id      { set useid 1 ; set id $val }
-	    -command { set cmd $val }
-	    -timeout {
-		if {$val > 0} {
-		    set timeout $val
-		}
-	    }
-	    -connection { set connid $val }
-	}
-    }
-    if {![info exists connid]} {
-	return -code error "jlib::send_iq: -connection is mandatory"
-    }
-
-    if {[lsearch [connections] $connid] < 0} {
-        ::LOG "error (jlib::send_iq) Connection $connid doesn't exist"
-	if {$cmd != ""} {
-	    uplevel #0 $cmd [list DISCONNECT [::msgcat::mc "Disconnected"]]
-	}
-	return -1
-    }
-
-    if {$type != "set" && $type != "result" && $type != "error"} {
-	set type "get"
-    }
-
-    ::LOG "(jlib::send_iq) type:'$type' to ($useto):'$to' cmd:'$cmd' xmldata:'$xmldata'"
-
-    # Temporary hack that allows to insert more than 1 subtag in error iqs
-    if {($type != "error") && ($xmldata != "")} {
-	set xmldata [list $xmldata]
-    }
-
-    if {$type == "get" || $type == "set"} {
-	lappend vars id $iq(num)
-	set iq($iq(num)) $cmd
-	if {$timeout > 0} {
-	    after $timeout [list [namespace current]::iq_timeout $iq(num)]
-	}
-	incr iq(num)
-    } elseif {$useid} {
-	lappend vars id $id
-    }
-
-    if {$useto == 1} {
-	lappend vars to $to
-    }
-
-    lappend vars type $type xml:lang [get_lang]
-
-    if {$xmldata != ""} {
-	set data [wrapper:createtag iq -vars $vars -subtags $xmldata]
-    } else {
-	set data [wrapper:createtag iq -vars $vars]
-    }
-    set xml [wrapper:createxml $data]
-
-    ::LOG_OUTPUT_XML $connid $data
-    ::LOG_OUTPUT_SIZE $connid $data [string bytelength $xml]
-
-    outmsg $xml -connection $connid
-}
-
-######################################################################
-
-proc jlib::iq_timeout {id} {
-    variable iq
-
-    ::LOG "(jlib::iq_timeout) id: $id"
-    if {[info exists iq($id)]} {
-	set cmd $iq($id)
-	unset iq($id)
-	uplevel #0 $cmd [list TIMEOUT [::msgcat::mc "Timeout"]]
-    }
-}
-
-######################################################################
-
-proc jlib::route {jid} {
-    variable lib
-
-    if {[catch { set calling_routine [info level -1] }]} {
-	set calling_routine none
-    }
-
-    if { $lib(connections) == {} } {
-	::LOG "error (jlib::route) No connection"
-	return -1
-    }
-
-    set user $jid
-    regexp {([^/]*)/.*} $jid temp user
-    set serv $user
-    regexp {[^@]*@(.*)} $user temp serv
-
-    set connid [lindex $lib(connections) 0]
-    foreach dest [list $user $serv] {
-	foreach c $lib(connections) {
-	    if {[info exists lib($c,route,$dest)]} {
-		::LOG "(jlib::route) $jid: $c \[$calling_routine\]"
-		return $c
-	    }
-	}
-    }
-
-    ::LOG "(jlib::route) $jid: $connid \[$calling_routine\]"
-    return $connid
-}
-
-######################################################################
-
-proc jlib::add_connection_route {connid jid} {
-    variable lib
-
-    set lib($connid,route,$jid) 1
-}
-
-
-######################################################################
-# TODO
-proc jlib::send_create {connid user pass name email cmd} {
-    variable lib
-
-    ::LOG "(jlib::send_create) username:'$user' password:'$pass' name:'$name' email:'$email'"
-    if { $lib(connections) == {} } {
-	::LOG "error (jlib::send_create) No connection"
-	return -1
-    }
-
-    set data [wrapper:createtag query \
-		  -vars    [list xmlns $::NS(register)] \
-		  -subtags [list \
-				[wrapper:createtag name     -chdata $name] \
-				[wrapper:createtag email    -chdata $email] \
-				[wrapper:createtag username -chdata $user] \
-				[wrapper:createtag password -chdata $pass]]]
-
-    send_iq set $data \
-	-connection $connid \
-	-command [list [namespace current]::parse_send_create $cmd]
-}
-
-######################################################################
-proc jlib::send_msg {to args} {
-    variable lib
-
-    ::LOG "(jlib::send_msg) to:'$to'"
-
-    set vars [list to $to]
-    set children [list]
-
-    foreach {attr val} $args {
-	switch -- $attr {
-	    -from { lappend vars from $val }
-	    -type { lappend vars type $val }
-	    -id   { lappend vars id   $val }
-	    -subject {
-		lappend children [wrapper:createtag subject -chdata $val]
-	    }
-	    -thread {
-		lappend children [wrapper:createtag thread -chdata $val]
-	    }
-	    -body {
-		lappend children [wrapper:createtag body -chdata $val]
-	    }
-	    -xlist {
-		foreach x $val {
-		    lappend children $x
-		}
-	    }
-	    -connection { set connid $val }
-	}
-    }
-
-    if {![info exists connid]} {
-	return -code error "jlib::send_msg: -connection is mandatory"
-    }
-
-    if {[lsearch [connections] $connid] < 0} {
-        ::LOG "error (jlib::send_msg) Connection $connid doesn't exist"
-	return -1
-    }
-
-    lappend vars xml:lang [get_lang]
-
-    set data [wrapper:createtag message -vars $vars -subtags $children]
-    set xml [wrapper:createxml $data]
-
-    ::LOG_OUTPUT_XML $connid $data
-    ::LOG_OUTPUT_SIZE $connid $data [string bytelength $xml]
-
-    outmsg $xml -connection $connid
-}
-
-######################################################################
-proc jlib::send_presence {args} {
-    variable lib
-    variable iq
-
-    ::LOG "(jlib::send_presence)"
-
-    set children [list]
-    set vars     [list]
-
-    foreach {attr val} $args {
-	switch -glob -- $attr {
-	    -from { lappend vars from $val }
-	    -to   { lappend vars to   $val }
-	    -type { lappend vars type $val }
-	    -command {
-		lappend vars id $iq(num)
-		set iq(presence,$iq(num)) $val
-		incr iq(num)
-	    }
-	    -stat* { lappend children [wrapper:createtag status -chdata $val] }
-	    -pri*  { lappend children [wrapper:createtag priority -chdata $val] }
-	    -show  { lappend children [wrapper:createtag show -chdata $val] }
-	    -meta  { lappend children [wrapper:createtag meta -chdata $val] }
-	    -icon  { lappend children [wrapper:createtag icon -chdata $val] }
-	    -loc   { lappend children [wrapper:createtag loc -chdata $val] }
-	    -xlist {
-		foreach x $val {
-		    lappend children $x
-		}
-	    }
-	    -connection { set connid $val }
-	}
-    }
-
-    if {![info exists connid]} {
-	return -code error "jlib::send_presence: -connection is mandatory"
-    }
-
-    if {[lsearch [connections] $connid] < 0} {
-        ::LOG "error (jlib::send_presence) Connection $connid doesn't exist"
-	return -1
-    }
-
-    lappend vars xml:lang [get_lang]
-
-    set data [wrapper:createtag presence -vars $vars -subtags $children]
-    set xml [wrapper:createxml $data]
-
-    ::LOG_OUTPUT_XML $connid $data
-    ::LOG_OUTPUT_SIZE $connid $data [string bytelength $xml]
-
-    outmsg $xml -connection $connid
-}
-
-######################################################################
-proc jlib::roster_get {args} {
-    variable lib
-    variable roster
-
-    ::LOG "(jlib::roster_get)"
-    if { $lib(connections) == {} } {
-	::LOG "error (jlib::roster_get) No connection"
-	return -1
-    }
-
-    set cmd "[namespace current]::noop"
-    set connid [lindex $lib(connections) 0]
-    foreach {attr val} $args {
-	switch -- $attr {
-	    -command    {set cmd $val}
-	    -connection {set connid $val}
-	}
-    }
-
-    foreach array [array names roster] {
-	unset roster($array)
-    }
-    set roster(users) ""
-
-    set vars [list xmlns $::NS(roster)]
-    set data [wrapper:createtag query -empty 1 -vars $vars]
-    send_iq get $data \
-	-command [list [namespace current]::parse_roster_get $connid 0 $cmd] \
-	-connection $connid
-    client status [::msgcat::mc "Waiting for roster"]
-}
-
-######################################################################
-proc jlib::roster_set {connid item args} {
-    variable lib
-    variable roster
-
-    ::LOG "(jlib::roster_set) item:'$item'"
-    if {$lib(connections) == {}} {
-	::LOG "error (jlib::roster_set) No connection"
-	return -1
-    }
-
-    set usename 0
-    set name ""
-    if { [lsearch $roster(users) $item] == -1 } {
-	set groups ""
-    } else {
-	set groups $roster(group,$item)
-    }
-
-    if {[wrapper:isattr $args -name]} {
-	set usename 1
-	set name [wrapper:getattr $args -name]
-    }
-    if {[wrapper:isattr $args -groups]} {
-	set groups [wrapper:getattr $args -groups]
-    }
-    if {[wrapper:isattr $args -command]} {
-	set cmd [wrapper:getattr $args -command]
-    } else {
-	set cmd [namespace current]::noop
-    }
-
-    set vars [list jid $item]
-    if {$usename} {
-	lappend vars name $name
-    }
-
-    set subdata ""
-    foreach group $groups {
-	lappend subdata [wrapper:createtag group -chdata $group]
-    }
-
-     set xmldata [wrapper:createtag query \
-		      -vars    [list xmlns $::NS(roster)] \
-		      -subtags [list [wrapper:createtag item \
-					  -vars    $vars \
-					  -subtags $subdata]]]
-
-    send_iq set $xmldata \
-	-connection $connid \
-	-command [list [namespace current]::parse_roster_set $item $cmd $groups $name]
-}
-
-######################################################################
-proc jlib::roster_del {connid item args} {
-    variable lib
-    variable roster
-
-    ::LOG "(jlib::roster_del) item:'$item'"
-    if { $lib(connections) == {} } {
-	::LOG "error (jlib::roster_del) No connection"
-	return -1
-    }
-
-    # TODO
-
-    if [wrapper:isattr $args -command] {
-	set cmd [wrapper:getattr $args -command]
-    } else {
-	set cmd [namespace current]::noop
-    }
-
-    set xmldata [wrapper:createtag query \
-		     -vars    [list xmlns $::NS(roster)] \
-		     -subtags [list [wrapper:createtag item \
-					 -vars [list jid $item \
-						     subscription remove]]]]
-
-    send_iq set $xmldata \
-	-connection $connid \
-	-command [list [namespace current]::parse_roster_del $item $cmd]
-}
-
-######################################################################
-#
-proc jlib::x_delay {xml} {
-    foreach xelem $xml {
-	jlib::wrapper:splitxml $xelem tag vars isempty chdata children
-
-	switch -- [jlib::wrapper:getattr $vars xmlns] {
-	    urn:xmpp:delay {
-		# 2006-07-17T05:29:12Z
-		# 2006-11-18T03:35:56.415699Z
-		if {[regsub {(\d+)-(\d\d)-(\d\d)T(\d+:\d+:\d+)[^Z]*Z?} \
-			    [jlib::wrapper:getattr $vars stamp] \
-			    {\1\2\3T\4} \
-			    stamp]} {
-		    if {![catch {clock scan $stamp -gmt 1} seconds]} {
-			return $seconds
-		    }
-		}
-	    }
-	    jabber:x:delay {
-		# 20060717T05:29:12
-		# 20061118T03:35:56.415699
-		if {[regexp {\d+\d\d\d\dT\d+:\d+:\d+} \
-			    [jlib::wrapper:getattr $vars stamp] \
-			    stamp]} {
-		    if {![catch {clock scan $stamp -gmt 1} seconds]} {
-			return $seconds
-		    }
-		}
-	    }
-	}
-    }
-    return [clock seconds]
-}
-
-######################################################################
-#
-proc ::LOG {text} {
-#
-# For debugging purposes.
-#
-    puts "LOG: $text\n"
-}
-
-proc ::LOG_OUTPUT     {connid t} {}
-proc ::LOG_OUTPUT_XML {connid x} {}
-proc ::LOG_OUTPUT_SIZE {connid x size} {}
-proc ::LOG_INPUT      {connid t} {}
-proc ::LOG_INPUT_XML  {connid x} {}
-proc ::LOG_INPUT_SIZE {connid x size} {}
-
-######################################################################
-proc jlib::noop {args} {}
-
-######################################################################
-proc jlib::get_lang {} {
-    set prefs [::msgcat::mcpreferences]
-      if {[info tclversion] > 8.4} {
-          set lang [lindex $prefs end-1]
-      } else {
-          set lang [lindex $prefs end]
-      }
-    switch -- $lang {
-	"" -
-	c -
-	posix {
-	    return en
-	}
-    }
-      if {[info tclversion] > 8.4} {
-          set lang2 [lindex $prefs end-2]
-      } else {
-          set lang2 [lindex $prefs end-1]
-      }
-    if {[regexp {^([A-Za-z]+)_([0-9A-Za-z]+)} $lang2 ignore l1 l2]} {
-	return "[string tolower $l1]-[string toupper $l2]"
-    } else {
-	return $lang
-    }
-}
-
-######################################################################
-#
-# Now that we're done...
-#
-
-package provide jabberlib 0.10.0
-

Copied: trunk/tkabber/jabberlib/jabberlib.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/jabberlib.tcl)
===================================================================
--- trunk/tkabber/jabberlib/jabberlib.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/jabberlib.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,1876 @@
+######################################################################
+#
+# $Header$
+#
+# This is JabberLib (abbreviated jlib), the Tcl library for
+# use in making Jabber clients.
+#
+#
+# Variables used in JabberLib :
+#	roster(users)                : Users currently in roster
+#
+#	roster(group,$username)      : Groups $username is in.
+#
+#	roster(name,$username)       : Name of $username.
+#
+#	roster(subsc,$username)      : Subscription of $username
+#                                  ("to" | "from" | "both" | "")
+#
+#	roster(ask,$username)        : "Ask" of $username
+#                                  ("subscribe" | "unsubscribe" | "")
+#
+#	lib(wrap)                    : Wrap ID
+#
+#	lib(sck)                     : SocketName
+#
+#	lib(sckstats)                : Socket status, "on" or "off"
+#
+#	lib(disconnect)              : disconnect procedure
+#
+#	iq(num)                      : Next iq id-number. Sent in
+#                                  "id" attributes of <iq> packets.
+#
+#	iq($id)                      : Callback to run when result packet
+#                                  of $id is received.
+#
+#
+######################################################################
+#
+# Procedures defined in this library
+#
+if {0} {
+proc jlib::connect {sck server}
+proc jlib::disconnect {}
+proc jlib::got_stream {vars}
+proc jlib::end_of_parse {}
+proc jlib::outmsg {msg}
+proc jlib::inmsg {}
+proc jlib::clear_vars {}
+proc jlib::clear_iqs {}
+proc jlib::parse {xmldata}
+proc jlib::parse_send_auth {cmd type data}
+proc jlib::parse_send_create {cmd type data}
+proc jlib::parse_roster_get {connid ispush cmd type data}
+proc jlib::parse_roster_set {item cmd groups name type data}
+proc jlib::parse_roster_del {item cmd type data}
+proc jlib::send_iq {type xmldata args}
+proc jlib::send_auth {user pass res cmd}
+proc jlib::send_create {user pass name mail cmd}
+proc jlib::send_msg {to args}
+proc jlib::send_presence {args}
+proc jlib::roster_get {args}
+proc jlib::roster_set {item args}
+proc jlib::roster_del {item args}
+proc ::LOG text
+proc jlib::noop args
+}
+
+if {[info exists use_external_tclxml] && $use_external_tclxml} {
+    package require tdom 0.8
+} else {
+    package require -exact xml 2.0
+}
+
+package require sha1
+package require msgcat
+
+package require namespaces 1.0
+package require streamerror 1.0
+package require stanzaerror 1.0
+package require idna 1.0
+package require jlibauth 1.0
+package require jlibdns 1.0
+
+package require autoconnect 0.1
+
+######################################################################
+
+namespace eval jlib {
+
+    # Load XML:Wrapper
+    source [file join [file dirname [info script]] wrapper.tcl]
+
+    set lib(capabilities,auth) {non_sasl}
+
+    # Load connection transports
+    source [file join [file dirname [info script]] transports.tcl]
+
+    catch { package require jlibtls 1.0 }
+    catch { package require jlibcompress 1.0 }
+
+    if {![catch { package require jlibsasl 1.0 }]} {
+	lappend lib(capabilities,auth) sasl
+    }
+
+    set lib(connections) {}
+    set lib(connid) 0
+    set iq(num) 1
+
+    # Export procedures.
+    #
+    namespace export \
+	wrapper:splitxml wrapper:createtag \
+	wrapper:createxml wrapper:xmlcrypt \
+	wrapper:isattr wrapper:getattr
+}
+
+######################################################################
+
+proc jlib::capabilities {type} {
+    variable lib
+
+    set res {}
+    switch -- $type {
+	proxy {
+	    set res [transport::proxy::capabilities]
+	}
+	transport {
+	    set res [transport::capabilities]
+	}
+	auth {
+	    set res $lib(capabilities,$type)
+	}
+    }
+    return $res
+}
+
+######################################################################
+
+# TODO register callbacks in jlib::new
+proc jlib::client {callback args} {
+    uplevel #0 [list client:$callback] $args
+}
+
+######################################################################
+
+proc jlib::new {args} {
+    variable lib
+    variable connjid
+    variable connhist
+
+    foreach {attr val} $args {
+	switch -- $attr {
+	    -user          {set user $val}
+	    -server        {set server $val}
+	    -resource      {set resource $val}
+	}
+    }
+
+    if {![info exists user] || ![info exists server] || \
+	    ![info exists resource]} {
+	return -code error "Usage: jlib::new -user username\
+			    -server servername -resource resourcename"
+    }
+
+    set jid $user@$server/$resource
+    if {[info exists connhist($jid)]} {
+	set connid $connhist($jid)
+	if {[lsearch -exact $lib(connections) $connid] >= 0} {
+	    set connid [incr lib(connid)]
+	}
+    } else {
+	set connid [incr lib(connid)]
+	set connhist($jid) $connid
+    }
+
+    set connjid($connid,user) $user
+    set connjid($connid,server) $server
+    set connjid($connid,resource) $resource
+
+    ::LOG "(jlib::new) JID:'$jid' ConnectionID:'$connid'"
+    return $connid
+}
+
+######################################################################
+
+proc jlib::connect {connid args} {
+    variable lib
+    variable connjid
+
+    set user $connjid($connid,user)
+    set server $connjid($connid,server)
+    set resource $connjid($connid,resource)
+
+    set transport tcp
+    set host $server
+    set port 5222
+    set hosts {}
+    set xmlns jabber:client
+    set use_sasl 0
+    set allow_auth_plain 0
+    set allow_google_token 1
+    set use_starttls 0
+    set use_compression 0
+    set cacertstore ""
+    set certfile ""
+    set keyfile ""
+
+    foreach {attr val} $args {
+	switch -- $attr {
+	    -password       {set password $val}
+	    -transport      {set transport $val}
+	    -host           {set host $val}
+	    -hosts          {set hosts $val}
+	    -port           {set port $val}
+	    -xmlns          {set xmlns $val}
+	    -usesasl        {set use_sasl $val}
+	    -allowauthplain {set allow_auth_plain $val}
+	    -allowgoogletoken {set allow_google_token $val}
+	    -usestarttls    {set use_starttls $val}
+	    -usecompression {set use_compression $val}
+	    -cacertstore    {set cacertstore $val}
+	    -certfile       {set certfile $val}
+	    -keyfile        {set keyfile $val}
+	}
+    }
+
+    if {$hosts == {}} {
+	set hosts [list [list [idna::domain_toascii $host] $port]]
+    }
+
+    ::LOG "(jlib::connect) Server:'$server' ConnectionID:'$connid'"
+
+    # TODO: do not change autoconnect options on every login.
+    eval autoconnect::configure $args
+
+    foreach hp $hosts {
+	if {[catch {
+		eval [list transport::${transport}::connect \
+			   $connid \
+			   [lindex $hp 0] \
+			   [lindex $hp 1]] $args
+	    } sock]} {
+	    set error 1
+	} else {
+	    set lib($connid,sck) $sock
+	    set error 0
+	    break
+	}
+    }
+    if {$error} {
+	::LOG "error (jlib::connect) Can't connect to the server: $sock"
+	return -code error $sock
+    }
+
+    lappend lib(connections) $connid
+
+    set lib($connid,xmlns) $xmlns
+    set lib($connid,password) $password
+    set lib($connid,transport) $transport
+    add_connection_route $connid $server
+    set lib($connid,disconnect) reconnect
+    set lib($connid,parse_end) 0
+    set lib($connid,use_sasl) $use_sasl
+    set lib($connid,allow_auth_plain) $allow_auth_plain
+    set lib($connid,allow_google_token) $allow_google_token
+    set lib($connid,use_starttls) $use_starttls
+    set lib($connid,use_compression) $use_compression
+    set lib($connid,cacertstore) $cacertstore
+    set lib($connid,certfile) $certfile
+    set lib($connid,keyfile) $keyfile
+    set lib($connid,disconnecting) 0
+    set lib($connid,bytes_counter) 0
+
+    catch { unset lib($connid,features) }
+    set lib($connid,version) 0.0
+
+    set lib($connid,wrap) \
+	[wrapper:new [list [namespace current]::got_stream $connid] \
+		     [list [namespace current]::end_of_parse $connid] \
+		     [list [namespace current]::parse $connid]]
+
+    set lib($connid,authtoken) \
+	[::jlibauth::new $connid -username $user \
+				 -server $server \
+				 -resource $resource \
+				 -password $password \
+				 -allow_plain $allow_auth_plain]
+
+    if {[info commands ::jlibtls::new] != ""} {
+	set lib($connid,tlstoken) \
+	    [::jlibtls::new $connid -certfile $certfile \
+				    -cacertstore $cacertstore \
+				    -keyfile $keyfile]
+    }
+
+    if {[info commands ::jlibcompress::new] != ""} {
+	set lib($connid,compresstoken) \
+	    [::jlibcompress::new $connid]
+    }
+
+    if {[info commands ::jlibsasl::new] != ""} {
+	set lib($connid,sasltoken) \
+	    [::jlibsasl::new $connid -username $user \
+				     -server $server \
+				     -resource $resource \
+				     -password $password \
+				     -allow_plain $allow_auth_plain \
+				     -allow_google_token $allow_google_token]
+    }
+
+    set params [list -xmlns $xmlns -xml:lang [get_lang]]
+    if {$use_sasl || $use_starttls || $use_compression} {
+	lappend params -version "1.0"
+    }
+
+    eval [list start_stream $server -connection $connid] $params
+
+    return $connid
+}
+
+######################################################################
+
+proc jlib::socket_ip {connid} {
+    variable lib
+
+    if {[info exists lib($connid,sck)] && \
+	![catch {fconfigure $lib($connid,sck) -sockname} sock]} {
+	return [lindex $sock 0]
+    } else {
+	return ""
+    }
+}
+
+######################################################################
+
+proc jlib::reset {connid} {
+    variable lib
+
+    wrapper:reset $lib($connid,wrap)
+    catch { unset lib($connid,features) }
+    catch { unset lib($connid,sessionid) }
+}
+
+######################################################################
+
+proc jlib::login {connid cmd} {
+    ::LOG "(jlib::login) $connid"
+
+    wait_for_stream $connid \
+	[list [namespace current]::login_aux $connid $cmd]
+}
+
+proc jlib::login_aux {connid cmd} {
+    variable lib
+
+    ::LOG "(jlib::login_aux) $connid"
+
+    if {$lib($connid,use_starttls)} {
+	$lib($connid,tlstoken) starttls \
+	    -command [list [namespace current]::login_aux2 $connid $cmd]
+    } else {
+	login_aux1 $connid $cmd
+    }
+}
+
+proc jlib::login_aux1 {connid cmd} {
+    variable lib
+
+    ::LOG "(jlib::login_aux1) $connid"
+
+    if {$lib($connid,use_compression)} {
+	$lib($connid,compresstoken) start \
+	    -command [list [namespace current]::login_aux2 $connid $cmd]
+    } else {
+	login_aux3 $connid $cmd
+    }
+}
+
+proc jlib::login_aux2 {connid cmd res xmldata} {
+    ::LOG "(jlib::login_aux2) $connid"
+
+    if {$res == "ERR"} {
+	login_aux5 $connid $cmd $res $xmldata
+    } else {
+	login_aux3 $connid $cmd
+    }
+}
+
+proc jlib::login_aux3 {connid cmd} {
+    variable lib
+
+    ::LOG "(jlib::login_aux3) $connid"
+
+    if {$lib($connid,use_sasl)} {
+	$lib($connid,sasltoken) auth \
+	    -command [list [namespace current]::login_aux5 $connid $cmd]
+    } else {
+	wait_for_stream $connid \
+	    [list [namespace current]::login_aux4 $connid $cmd]
+    }
+}
+
+proc jlib::login_aux4 {connid cmd} {
+    variable lib
+
+    ::LOG "(jlib::login_aux4) $connid"
+
+    $lib($connid,authtoken) auth \
+	-command [list [namespace current]::login_aux5 $connid $cmd] \
+	-sessionid $lib($connid,sessionid)
+}
+
+proc jlib::login_aux5 {connid cmd res xmldata} {
+    ::LOG "(jlib::login_aux5) $connid"
+
+    after idle [list uplevel #0 $cmd [list $res $xmldata]]
+}
+
+########################################################################
+
+proc jlib::disconnect {{connections {}}} {
+    variable lib
+
+    ::LOG "(jlib::disconnect) $connections"
+
+    if {$connections == {}} {
+	set connections $lib(connections)
+    }
+
+    foreach connid $connections {
+	set idx [lsearch -exact $lib(connections) $connid]
+	if {$idx < 0} continue
+
+	finish_stream -connection $connid
+	set lib($connid,disconnecting) 1
+	catch {
+	    transport::$lib($connid,transport)::disconnect $connid
+	    transport::$lib($connid,transport)::close $connid
+	}
+
+	set lib(connections) [lreplace $lib(connections) $idx $idx]
+	clear_vars $connid
+    }
+
+    if {$lib(connections) == {}} {
+	clear_iqs
+    }
+}
+
+######################################################################
+
+proc jlib::got_stream {connid vars} {
+    variable lib
+
+    set version [jlib::wrapper:getattr $vars version]
+    if {($lib($connid,use_starttls) || $lib($connid,use_sasl) || \
+	    $lib($connid,use_compression)) && \
+		[string is double -strict $version] && ($version >= 1.0)} {
+	set lib($connid,version) $version
+    }
+    set sessionid [jlib::wrapper:getattr $vars id]
+
+    ::LOG "(jlib::got_stream $connid)\
+	   Session ID = $sessionid, Version = $lib($connid,version)"
+    if {$version < 1.0} {
+	# Register iq-register and iq-auth namespaces to allow
+	# register and auth when using non-XMPP server
+	parse_stream_features $connid \
+	    [list [wrapper:createtag register \
+		       -vars [list xmlns $::NS(iq-register)]] \
+		  [wrapper:createtag auth \
+		       -vars [list xmlns $::NS(iq-auth)]]]
+    }
+    set lib($connid,sessionid) $sessionid
+    set lib($connid,bytes_counter) 0
+}
+
+######################################################################
+
+proc jlib::wait_for_stream {connid cmd} {
+    variable lib
+
+    ::LOG "(jlib::wait_for_stream $connid)"
+
+    if {[info exists lib($connid,sessionid)]} {
+	uplevel #0 $cmd
+    } else {
+	# Must be careful so this is not triggered by a reset or something...
+	trace variable [namespace current]::lib($connid,sessionid) w \
+	    [list [namespace current]::wait_for_stream_aux $connid $cmd]
+    }
+}
+
+proc jlib::wait_for_stream_aux {connid cmd name1 name2 op} {
+    variable lib
+
+    trace vdelete [namespace current]::lib($connid,sessionid) w \
+        [list [namespace current]::wait_for_stream_aux $connid $cmd]
+
+    uplevel #0 $cmd
+}
+
+######################################################################
+
+proc jlib::end_of_parse {connid} {
+    after idle [list [namespace current]::end_of_parse1 $connid]
+}
+
+proc jlib::end_of_parse1 {connid} {
+    variable lib
+
+    ::LOG "(jlib::end_of_parse $connid)"
+
+    set lib($connid,parse_end) 1
+    if {$lib(connections) == {}} {
+	::LOG "error (jlib::end_of_parse) No connection"
+	return -1
+	# Already disconnected
+    }
+
+    transport::$lib($connid,transport)::close $connid
+
+    if {!$lib($connid,disconnecting)} {
+	after idle [list [namespace current]::emergency_disconnect $connid]
+    }
+}
+
+######################################################################
+
+proc jlib::outmsg {msg args} {
+    variable lib
+
+    foreach {attr val} $args {
+	switch -- $attr {
+	    -connection {set connid $val}
+	}
+    }
+
+    if {![info exists connid]} {
+	::LOG "error (jlib::outmsg) -connection is mandatory"
+	return -1
+    }
+
+
+    if {[lsearch -exact $lib(connections) $connid] < 0} {
+	::LOG "error (jlib::outmsg) Connection $connid doesn't exist"
+	return -1
+    }
+
+    if {$lib($connid,disconnecting)} {
+	::LOG "error (jlib::outmsg) Message while disconnecting..."
+	return -1
+    }
+
+    ::LOG "(jlib::outmsg) ($connid) '$msg'"
+    ::LOG_OUTPUT $connid $msg
+
+    return [transport::$lib($connid,transport)::outmsg $connid $msg]
+}
+
+######################################################################
+
+proc jlib::start_stream {to args} {
+    variable lib
+
+    foreach {attr val} $args {
+	switch -- $attr {
+	    -connection {set connid $val}
+	}
+    }
+
+    if {![info exists connid]} {
+	::LOG "error (jlib::start_stream) -connection is mandatory"
+	return -1
+    }
+
+
+    if {[lsearch -exact $lib(connections) $connid] < 0} {
+	::LOG "error (jlib::start_stream) Connection $connid doesn't exist"
+	return -1
+    }
+
+    if {$lib($connid,disconnecting)} {
+	::LOG "error (jlib::start_stream) Message while disconnecting..."
+	return -1
+    }
+
+    set msg [eval [list wrapper:streamheader $to] $args]
+    ::LOG "(jlib::start_stream) ($connid) '$msg'"
+    ::LOG_OUTPUT $connid $msg
+
+    return [eval [list transport::$lib($connid,transport)::start_stream \
+		       $connid $to] $args]
+}
+
+######################################################################
+
+proc jlib::finish_stream {args} {
+    variable lib
+
+    foreach {attr val} $args {
+	switch -- $attr {
+	    -connection {set connid $val}
+	}
+    }
+
+    if {![info exists connid]} {
+	::LOG "error (jlib::finish_stream) -connection is mandatory"
+	return -1
+    }
+
+
+    if {[lsearch -exact $lib(connections) $connid] < 0} {
+	::LOG "error (jlib::finish_stream) Connection $connid doesn't exist"
+	return -1
+    }
+
+    if {$lib($connid,disconnecting)} {
+	::LOG "error (jlib::finish_stream) Message while disconnecting..."
+	return -1
+    }
+
+    set msg [wrapper:streamtrailer]
+    ::LOG "(jlib::start_stream) ($connid) '$msg'"
+    ::LOG_OUTPUT $connid $msg
+
+    return [eval [list transport::$lib($connid,transport)::finish_stream \
+		       $connid] $args]
+}
+
+######################################################################
+
+proc jlib::inmsg {connid msg eof} {
+    variable lib
+
+    if {[lsearch -exact $lib(connections) $connid] < 0} {
+	::LOG "error (jlib::inmsg) Connection $connid doesn't exist"
+	return -1
+    }
+
+    incr lib($connid,bytes_counter) [string bytelength $msg]
+
+    ::LOG "(jlib::inmsg) ($connid) '$msg'"
+    ::LOG_INPUT $connid $msg
+    wrapper:parser $lib($connid,wrap) parse $msg
+
+    if {!$lib($connid,parse_end) && $eof} {
+	transport::$lib($connid,transport)::close $connid
+
+	if {$lib($connid,disconnecting)} {
+	    ::LOG "(jlib::inmsg) Socket is closed by server. Disconnecting..."
+	} else {
+	    ::LOG "error (jlib::inmsg) Socket is closed by server. Disconnecting..."
+	    after idle [list [namespace current]::emergency_disconnect $connid]
+	}
+    }
+}
+
+######################################################################
+
+proc jlib::emergency_disconnect {connid} {
+    variable lib
+
+    set idx [lsearch -exact $lib(connections) $connid]
+
+    if {$idx < 0} return
+
+    set lib(connections) [lreplace $lib(connections) $idx $idx]
+
+    client $lib($connid,disconnect) $connid
+
+    clear_vars $connid
+    if {$lib(connections) == {}} {
+	clear_iqs
+    }
+}
+
+######################################################################
+
+proc jlib::clear_vars {connid} {
+    #
+    # unset all the variables
+    #
+    variable roster
+    variable pres
+    variable lib
+
+    if {![info exists lib($connid,wrap)]} return
+
+    wrapper:free $lib($connid,wrap)
+
+    if {[info exists lib($connid,tlstoken)]} {
+	$lib($connid,tlstoken) free
+    }
+    if {[info exists lib($connid,compresstoken)]} {
+	$lib($connid,compresstoken) free
+    }
+    if {[info exists lib($connid,sasltoken)]} {
+	$lib($connid,sasltoken) free
+    }
+
+    $lib($connid,authtoken) free
+
+    array unset lib $connid,*
+
+    set lib($connid,disconnect) reconnect
+}
+
+######################################################################
+
+proc jlib::clear_iqs {} {
+    variable iq
+
+    array unset iq presence,*
+
+    foreach id [array names iq] {
+	if {$id != "num"} {
+	    set cmd $iq($id)
+	    unset iq($id)
+	    uplevel #0 $cmd [list DISCONNECT [::msgcat::mc "Disconnected"]]
+	}
+    }
+
+    set iq(num) 1
+}
+
+######################################################################
+proc jlib::connections {} {
+    variable lib
+    return $lib(connections)
+}
+
+proc jlib::connection_jid {connid} {
+    variable lib
+    variable connjid
+
+    if {[info exists lib($connid,sasltoken)]} {
+	set username [$lib($connid,sasltoken) cget -username]
+	set server   [$lib($connid,sasltoken) cget -server]
+	set resource [$lib($connid,sasltoken) cget -resource]
+	return $username@$server/$resource
+    } else {
+	return \
+	    $connjid($connid,user)@$connjid($connid,server)/$connjid($connid,resource)
+    }
+}
+
+proc jlib::connection_bare_jid {connid} {
+    variable lib
+    variable connjid
+
+    if {[info exists lib($connid,sasltoken)]} {
+	set username [$lib($connid,sasltoken) cget -username]
+	set server   [$lib($connid,sasltoken) cget -server]
+	return $username@$server
+    } else {
+	return $connjid($connid,user)@$connjid($connid,server)
+    }
+}
+
+proc jlib::connection_user {connid} {
+    variable lib
+    variable connjid
+
+    if {[info exists lib($connid,sasltoken)]} {
+	set username [$lib($connid,sasltoken) cget -username]
+	return $username
+    } else {
+	return $connjid($connid,user)
+    }
+}
+
+proc jlib::connection_server {connid} {
+    variable lib
+    variable connjid
+
+    if {[info exists lib($connid,sasltoken)]} {
+	set server [$lib($connid,sasltoken) cget -server]
+	return $server
+    } else {
+	return $connjid($connid,server)
+    }
+}
+
+proc jlib::connection_resource {connid} {
+    variable lib
+    variable connjid
+
+    if {[info exists lib($connid,sasltoken)]} {
+	set resource [$lib($connid,sasltoken) cget -resource]
+	return $resource
+    } else {
+	return $connjid($connid,resource)
+    }
+}
+
+######################################################################
+
+proc jlib::connection_requested_user {connid} {
+    variable connjid
+
+    return $connjid($connid,user)
+}
+
+proc jlib::connection_requested_server {connid} {
+    variable connjid
+
+    return $connjid($connid,server)
+}
+
+proc jlib::connection_requested_resource {connid} {
+    variable connjid
+
+    return $connjid($connid,resource)
+}
+
+######################################################################
+
+proc jlib::register_xmlns {connid xmlns callback} {
+    variable lib
+
+    set lib($connid,registered_xmlns,$xmlns) $callback
+}
+
+proc jlib::unregister_xmlns {connid xmlns} {
+    variable lib
+
+    catch {unset lib($connid,registered_xmlns,$xmlns)}
+}
+
+proc jlib::xmlns_is_registered {connid xmlns} {
+    variable lib
+
+    if {[info exists lib($connid,registered_xmlns,$xmlns)]} {
+	return 1
+    } else {
+	return 0
+    }
+}
+
+proc jlib::xmlns_callback {connid xmlns} {
+    variable lib
+
+    if {[info exists lib($connid,registered_xmlns,$xmlns)]} {
+	return $lib($connid,registered_xmlns,$xmlns)
+    } else {
+	return ""
+    }
+}
+
+######################################################################
+
+proc jlib::register_element {connid element callback} {
+    variable lib
+
+    set lib($connid,registered_element,$element) $callback
+}
+
+proc jlib::unregister_element {connid element} {
+    variable lib
+
+    catch {unset lib($connid,registered_element,$element)}
+}
+
+proc jlib::element_is_registered {connid element} {
+    variable lib
+
+    if {[info exists lib($connid,registered_element,$element)]} {
+	return 1
+    } else {
+	return 0
+    }
+}
+
+proc jlib::element_callback {connid element} {
+    variable lib
+
+    if {[info exists lib($connid,registered_element,$element)]} {
+	return $lib($connid,registered_element,$element)
+    } else {
+	return ""
+    }
+}
+
+######################################################################
+
+proc jlib::parse {connid xmldata} {
+
+    variable lib
+    set size 0
+    catch {set size $lib($connid,bytes_counter) }
+    set lib($connid,bytes_counter) 0
+
+    after idle [list [namespace current]::parse1 $connid $xmldata]
+    after idle [list ::LOG_INPUT_SIZE $connid $xmldata $size]
+}
+
+proc jlib::parse1 {connid xmldata} {
+    variable global
+    variable roster
+    variable pres
+    variable lib
+    variable iq
+
+    ::LOG "(jlib::parse) xmldata: '$xmldata'"
+    ::LOG_INPUT_XML $connid $xmldata
+
+    if {$lib(connections) == {}} {
+        ::LOG "error (jlib::parse) No connection"
+        return -1
+    }
+
+    wrapper:splitxml $xmldata tag vars isempty chdata children
+
+    if {[wrapper:isattr $vars from]} {
+	set usefrom 1
+	set from [wrapper:getattr $vars from]
+    } else {
+	set usefrom 0
+	set from ""
+    }
+
+    set xmlns [wrapper:getattr $vars xmlns]
+
+    if {[xmlns_is_registered $connid $xmlns]} {
+	uplevel \#0 [xmlns_callback $connid $xmlns] [list $xmldata]
+	return
+    }
+
+    if {[element_is_registered $connid $tag]} {
+	uplevel \#0 [element_callback $connid $tag] [list $xmldata]
+	return
+    }
+
+    if {[wrapper:isattr $vars xml:lang]} {
+	set lang [wrapper:getattr $vars xml:lang]
+    } else {
+	set lang en
+    }
+
+    switch -- $tag {
+	iq {
+	    set useid 0
+	    set id ""
+	    set type [wrapper:getattr $vars type]
+
+	    if {[wrapper:isattr $vars id] == 1} {
+		set useid 1
+		set id [wrapper:getattr $vars id]
+	    }
+
+	    if {$type != "result" && $type != "error" && $type != "get" && $type != "set"} {
+		::LOG "(error) iq: unknown type:'$type' id ($useid):'$id'"
+		return
+	    }
+
+	    if {$type == "result"} {
+		if {$useid == 0} {
+		    ::LOG "(error) iq:result: no id reference"
+		    return
+		}
+		if {[info exists iq($id)] == 0} {
+		    ::LOG "(error) iq:result: id doesn't exists in memory. Probably a re-replied iq"
+		    return
+		}
+
+		set cmd $iq($id)
+		unset iq($id)
+
+		uplevel \#0 $cmd [list OK [lindex $children 0]]
+	    } elseif {$type == "error"} {
+		if {$useid == 0} {
+		    ::LOG "(error) iq:result: no id reference"
+		    return
+		}
+		if {[info exists iq($id)] == 0} {
+		    ::LOG "(error) iq:result: id doesn't exists in memory. Probably a re-replied iq."
+		    return
+		}
+
+		set cmd $iq($id)
+		unset iq($id)
+
+		set child ""
+		foreach child $children {
+		    if {[lindex $child 0] == "error"} { break }
+		    set child ""
+		}
+		if {$child == ""} {
+		    set errcode ""
+		    set errtype ""
+		    set errmsg ""
+		} else {
+		    set errcode [wrapper:getattr [lindex $child 1] code]
+		    set errtype [wrapper:getattr [lindex $child 1] type]
+		    set errmsg [lindex $child 3]
+		}
+		if {$errtype == ""} {
+		    uplevel #0 $cmd [list ERR [list $errcode $errmsg]]
+		} else {
+		    uplevel #0 $cmd [list ERR [list $errtype $child]]
+		}
+	    } elseif {$type == "get" || $type == "set"} {
+		set child [lindex $children 0]
+
+		if {$child == ""} {
+		    ::LOG "(error) iq:$type: Cannot find 'query' tag"
+		    return
+		}
+
+		#
+		# Before calling the 'client:iqreply' procedure, we should check
+		# the 'xmlns' attribute, to understand if this is some 'iq' that
+		# should be handled inside jlib, such as a roster-push.
+		#
+		if {$type == "set" && \
+			[wrapper:getattr [lindex $child 1] xmlns] == $::NS(roster)} {
+		    if {$from != "" && \
+			    !([string equal -nocase $from [connection_server $connid]] || \
+			    [string equal -nocase $from [connection_bare_jid $connid]] || \
+			    [string equal -nocase $from [connection_jid $connid]])} {
+			send_iq error \
+			    [stanzaerror::error cancel not-allowed -xml $child] \
+			    -id [wrapper:getattr $vars id] \
+			    -to $from \
+			    -connection $connid
+			return
+		    }
+
+		    # Found a roster-push
+		    ::LOG "(info) iq packet is roster-push. Handling internally"
+
+		    # First, we reply to the server, saying that, we
+		    # got the data, and accepted it.
+		    #
+		    if [wrapper:isattr $vars id] {
+			send_iq result \
+			    [wrapper:createtag query \
+				 -vars [list xmlns $::NS(roster)]] \
+			    -id [wrapper:getattr $vars id] \
+			    -connection $connid
+		    } else {
+			send_iq result \
+			    [wrapper:createtag query \
+				 -vars [list xmlns $::NS(roster)]] \
+			    -connection $connid
+		    }
+
+		    # And then, we call the jlib::parse_roster_get, because this
+		    # data is the same as the one we get from a roster-get.
+		    parse_roster_get \
+			$connid 1 [namespace current]::noop OK $child
+		    return
+		}
+
+		client iqreply $connid $from $useid $id $type $lang $child
+	    }
+	}
+	message {
+	    set type [wrapper:getattr $vars type]
+	    set id [wrapper:getattr $vars id]
+
+	    set body     ""
+	    set err      [list "" ""]
+	    set is_subject 0
+	    set subject  ""
+	    set priority ""
+	    set thread   ""
+	    set x        ""
+
+	    foreach child $children {
+		wrapper:splitxml $child ctag cvars cisempty cchdata cchildren
+
+		switch -- $ctag {
+		    body {set body $cchdata}
+		    error {
+			set errmsg $cchdata
+			set errcode [wrapper:getattr $cvars code]
+			set errtype [wrapper:getattr $cvars type]
+			if {$errtype == ""} {
+			    set err [list $errcode $errmsg]
+			} else {
+			    set err [list $errtype $child]
+			}
+		    }
+		    subject {
+			set is_subject 1
+			set subject $cchdata
+		    }
+		    priority {set priority $cchdata}
+		    thread {set thread $cchdata}
+		    default {
+			if {[wrapper:getattr $cvars xmlns] != ""} {
+			    lappend x $child
+			}
+		    }
+		}
+	    }
+
+	    client message $connid $from $id $type $is_subject \
+			   $subject $body $err $thread $priority $x
+	}
+	presence {
+	    set type [wrapper:getattr $vars type]
+
+	    set cmd      ""
+	    set status   ""
+	    set priority ""
+	    set meta     ""
+	    set icon     ""
+	    set show     ""
+	    set loc      ""
+	    set x        ""
+
+	    set param    ""
+
+	    if {[wrapper:isattr $vars id]} {
+		set id [wrapper:getattr $vars id]
+		if {[info exists iq(presence,$id)]} {
+		    set cmd $iq(presence,$id)
+		    unset iq(presence,$id)
+		}
+		lappend param -id $id
+	    }
+
+	    if {[wrapper:isattr $vars name]} {
+		lappend param -name [wrapper:getattr $vars name]
+	    }
+
+	    foreach child $children {
+		wrapper:splitxml $child ctag cvars cisempty cchdata cchildren
+
+		switch -- $ctag {
+		    status   {
+			if {$type != "error"} {
+			    lappend param -status $cchdata
+			}
+		    }
+		    priority {lappend param -priority $cchdata}
+		    meta     {lappend param -meta     $cchdata}
+		    icon     {lappend param -icon     $cchdata}
+		    show     {lappend param -show     $cchdata}
+		    loc      {lappend param -loc      $cchdata}
+		    error {
+			if {$type == "error"} {
+			    set errcode [wrapper:getattr $cvars code]
+			    set errtype [wrapper:getattr $cvars type]
+			    if {$errtype == ""} {
+				set err [list $errcode $cchdata]
+			    } else {
+				set err [list $errtype $child]
+			    }
+			    lappend param -status [lindex [stanzaerror::error_to_list $err] 2]
+			    lappend param -error [lrange [stanzaerror::error_to_list $err] 0 1]
+			}
+		    }
+		    default {lappend x $child}
+		}
+	    }
+
+	    set cont ""
+	    if {$cmd != ""} {
+		set cont \
+		    [uplevel \#0 $cmd [list $connid $from $type $x] $param]
+	    }
+
+	    if {$cont != "break"} {
+		eval [list client presence $connid $from $type $x] $param
+	    }
+	}
+	error {
+	    if {[wrapper:getattr $vars xmlns] == $::NS(stream)} {
+		parse_stream_error $connid $xmldata
+	    }
+	}
+	features {
+	    if {[wrapper:getattr $vars xmlns] == $::NS(stream)} {
+		parse_stream_features $connid $children
+	    }
+	}
+    }
+}
+
+######################################################################
+
+proc jlib::parse_send_create {cmd type data} {
+    variable lib
+
+    ::LOG "(jlib::parse_send_create) type:'$type'"
+
+    if {$type == "ERR"} {
+	::LOG "error (jlib::parse_send_create) errtype:'[lindex $data 0]'"
+	::LOG "error (jlib::parse_send_create) errdesc:'[lindex $data 1]'"
+	uplevel #0 $cmd [list ERR [lindex $data 1]]
+	return
+    }
+    uplevel #0 $cmd [list OK {}]
+}
+
+######################################################################
+
+proc jlib::parse_roster_get {connid ispush cmd type data} {
+    variable lib
+    variable roster
+
+    ::LOG "(jlib::parse_roster_get) ispush:'$ispush' type:'$type'"
+
+    if {$type == "ERR"} {
+	::LOG "error (jlib::parse_roster_get) errtype:'[lindex $data 0]'"
+	::LOG "error (jlib::parse_roster_get) errdesc:'[lindex $data 1]'"
+	uplevel #0 $cmd [list $connid ERR]
+	return
+    }
+    if {!$ispush} {
+	client status [::msgcat::mc "Got roster"]
+	uplevel #0 $cmd [list $connid BEGIN_ROSTER]
+    }
+
+    wrapper:splitxml $data tag vars isempty chdata children
+
+    if {![cequal [wrapper:getattr $vars xmlns] $::NS(roster)]} {
+	::LOG "warning (jlib::parse_roster_get) 'xmlns' attribute of\
+	       query tag doesn't match '$::NS(roster)':\
+	       '[wrapper:getattr $vars xmlns]"
+    }
+
+    foreach child $children {
+	wrapper:splitxml $child ctag cvars cisempty cchdata cchildren
+
+	switch -- $ctag {
+	    default {
+		set groups ""
+		set jid   [wrapper:getattr $cvars jid]
+		set name  [wrapper:getattr $cvars name]
+		set subsc [wrapper:getattr $cvars subscription]
+		set ask   [wrapper:getattr $cvars ask]
+
+		foreach subchild $cchildren {
+		    wrapper:splitxml $subchild subtag tmp tmp subchdata tmp
+
+		    switch -- $subtag {
+			group {lappend groups $subchdata}
+		    }
+		}
+
+		# Ok, collected information about item.
+		# Now we can set our variables...
+		#
+		if {[lsearch $roster(users) $jid] == -1} {
+		    lappend roster(users) $jid
+		}
+
+		set roster(group,$jid) $groups
+		set roster(name,$jid)  $name
+		set roster(subsc,$jid) $subsc
+		set roster(ask,$jid)   $ask
+
+		add_connection_route $connid $jid
+
+		# ...and call client procedures
+		if $ispush {
+		    client roster_push $connid $jid $name $groups $subsc $ask
+		} else {
+		    client roster_item $connid $jid $name $groups $subsc $ask
+		}
+	    }
+	}
+    }
+    if {!$ispush} {
+	uplevel #0 $cmd [list $connid END_ROSTER]
+    }
+}
+
+######################################################################
+
+proc jlib::parse_roster_set {item cmd groups name type data} {
+    variable lib
+    variable roster
+
+    ::LOG "(jlib::parse_roster_set) item:'$item' type:'$type'"
+
+    if {$type == "ERR"} {
+	::LOG "error (jlib::parse_roster_set) errtype:'[lindex $data 0]'"
+	::LOG "error (jlib::parse_roster_set) errdesc:'[lindex $data 1]'"
+	uplevel #0 $cmd ERR
+	return
+    }
+
+    if { [lsearch $roster(users) $item] == -1}   {
+	lappend roster(users) $item
+	set roster(subsc,$item) "none"
+	set roster(ask,$item)   ""
+    }
+
+    set roster(group,$item) $groups
+    set roster(name,$item)  $name
+
+    uplevel #0 $cmd OK
+}
+
+######################################################################
+
+proc jlib::parse_roster_del {item cmd type data} {
+    variable lib
+    variable roster
+
+    ::LOG "(jlib::parse_roster_del) item:'$item' type:'$type'"
+
+    if {$type == "ERR"} {
+	::LOG "error (jlib::parse_roster_set) errtype:'[lindex $data 0]'"
+	::LOG "error (jlib::parse_roster_set) errdesc:'[lindex $data 1]'"
+	uplevel #0 $cmd ERR
+	return
+    }
+
+    if {[set num [lsearch $roster(users) $item]] != -1} {
+	set roster(users) [lreplace $roster(users) $num $num]
+
+	catch {unset roster(group,$item) }
+	catch {unset roster(name,$item)  }
+	catch {unset roster(subsc,$item) }
+	catch {unset roster(ask,$item)   }
+    } else {
+	::LOG "warning (jlib::parse_roster_del) Item '$item' doesn't\
+	       exist in roster for deletion."
+    }
+    uplevel #0 $cmd OK
+}
+
+######################################################################
+
+proc jlib::parse_stream_error {connid xmldata} {
+    variable lib
+
+    switch -- [streamerror::condition $xmldata] {
+	bad-format -
+	bad-namespace-prefix -
+	connection-timeout -
+	invalid-from -
+	invalid-id -
+	invalid-namespace -
+	invalid-xml -
+	remote-connection-failed -
+	restricted-xml -
+	unsupported-encoding -
+	unsupported-stanza-type -
+	xml-not-well-formed {
+	    set lib($connid,disconnect) reconnect
+	}
+	default {
+	    set lib($connid,disconnect) disconnect
+	}
+    }
+    client errormsg [streamerror::message $xmldata]
+}
+
+######################################################################
+
+proc jlib::parse_stream_features {connid xmldata} {
+    variable lib
+
+    set features {}
+    foreach child $xmldata {
+	wrapper:splitxml $child tag vars isempty cdata children
+
+	set xmlns [wrapper:getattr $vars xmlns]
+
+	if {[xmlns_is_registered $connid $xmlns]} {
+	    lappend features $xmlns
+	    uplevel \#0 [xmlns_callback $connid $xmlns] [list $child]
+	    continue
+	}
+
+	switch -- $tag {
+	    register {
+		lappend features register
+	    }
+	}
+    }
+    set lib($connid,features) $features
+}
+
+######################################################################
+
+proc jlib::trace_stream_features {connid cmd} {
+    variable lib
+
+    if {[info exists lib($connid,features)]} {
+	uplevel #0 $cmd
+    } else {
+	# Must be careful so this is not triggered by a reset or something...
+	trace variable [namespace current]::lib($connid,features) w \
+	    [list [namespace current]::trace_stream_features_aux $connid $cmd]
+    }
+}
+
+proc jlib::trace_stream_features_aux {connid cmd name1 name2 op} {
+    trace vdelete [namespace current]::lib($connid,features) w \
+        [list [namespace current]::trace_stream_features_aux $connid $cmd]
+
+    uplevel #0 $cmd
+}
+
+######################################################################
+
+proc jlib::send_iq {type xmldata args} {
+    variable lib
+    variable iq
+
+    ::LOG "(jlib::send_iq) type:'$type'"
+
+    set useto  0
+    set useid  0
+    set to     {}
+    set id     {}
+    set cmd    [namespace current]::noop
+    set vars   {}
+    set timeout 0
+
+    foreach {attr val} $args {
+	switch -- $attr {
+	    -from    { lappend vars from $val }
+	    -to      { set useto 1 ; set to $val }
+	    -id      { set useid 1 ; set id $val }
+	    -command { set cmd $val }
+	    -timeout {
+		if {$val > 0} {
+		    set timeout $val
+		}
+	    }
+	    -connection { set connid $val }
+	}
+    }
+    if {![info exists connid]} {
+	return -code error "jlib::send_iq: -connection is mandatory"
+    }
+
+    if {[lsearch [connections] $connid] < 0} {
+        ::LOG "error (jlib::send_iq) Connection $connid doesn't exist"
+	if {$cmd != ""} {
+	    uplevel #0 $cmd [list DISCONNECT [::msgcat::mc "Disconnected"]]
+	}
+	return -1
+    }
+
+    if {$type != "set" && $type != "result" && $type != "error"} {
+	set type "get"
+    }
+
+    ::LOG "(jlib::send_iq) type:'$type' to ($useto):'$to' cmd:'$cmd' xmldata:'$xmldata'"
+
+    # Temporary hack that allows to insert more than 1 subtag in error iqs
+    if {($type != "error") && ($xmldata != "")} {
+	set xmldata [list $xmldata]
+    }
+
+    if {$type == "get" || $type == "set"} {
+	lappend vars id $iq(num)
+	set iq($iq(num)) $cmd
+	if {$timeout > 0} {
+	    after $timeout [list [namespace current]::iq_timeout $iq(num)]
+	}
+	incr iq(num)
+    } elseif {$useid} {
+	lappend vars id $id
+    }
+
+    if {$useto == 1} {
+	lappend vars to $to
+    }
+
+    lappend vars type $type xml:lang [get_lang]
+
+    if {$xmldata != ""} {
+	set data [wrapper:createtag iq -vars $vars -subtags $xmldata]
+    } else {
+	set data [wrapper:createtag iq -vars $vars]
+    }
+    set xml [wrapper:createxml $data]
+
+    ::LOG_OUTPUT_XML $connid $data
+    ::LOG_OUTPUT_SIZE $connid $data [string bytelength $xml]
+
+    outmsg $xml -connection $connid
+}
+
+######################################################################
+
+proc jlib::iq_timeout {id} {
+    variable iq
+
+    ::LOG "(jlib::iq_timeout) id: $id"
+    if {[info exists iq($id)]} {
+	set cmd $iq($id)
+	unset iq($id)
+	uplevel #0 $cmd [list TIMEOUT [::msgcat::mc "Timeout"]]
+    }
+}
+
+######################################################################
+
+proc jlib::route {jid} {
+    variable lib
+
+    if {[catch { set calling_routine [info level -1] }]} {
+	set calling_routine none
+    }
+
+    if { $lib(connections) == {} } {
+	::LOG "error (jlib::route) No connection"
+	return -1
+    }
+
+    set user $jid
+    regexp {([^/]*)/.*} $jid temp user
+    set serv $user
+    regexp {[^@]*@(.*)} $user temp serv
+
+    set connid [lindex $lib(connections) 0]
+    foreach dest [list $user $serv] {
+	foreach c $lib(connections) {
+	    if {[info exists lib($c,route,$dest)]} {
+		::LOG "(jlib::route) $jid: $c \[$calling_routine\]"
+		return $c
+	    }
+	}
+    }
+
+    ::LOG "(jlib::route) $jid: $connid \[$calling_routine\]"
+    return $connid
+}
+
+######################################################################
+
+proc jlib::add_connection_route {connid jid} {
+    variable lib
+
+    set lib($connid,route,$jid) 1
+}
+
+
+######################################################################
+# TODO
+proc jlib::send_create {connid user pass name email cmd} {
+    variable lib
+
+    ::LOG "(jlib::send_create) username:'$user' password:'$pass' name:'$name' email:'$email'"
+    if { $lib(connections) == {} } {
+	::LOG "error (jlib::send_create) No connection"
+	return -1
+    }
+
+    set data [wrapper:createtag query \
+		  -vars    [list xmlns $::NS(register)] \
+		  -subtags [list \
+				[wrapper:createtag name     -chdata $name] \
+				[wrapper:createtag email    -chdata $email] \
+				[wrapper:createtag username -chdata $user] \
+				[wrapper:createtag password -chdata $pass]]]
+
+    send_iq set $data \
+	-connection $connid \
+	-command [list [namespace current]::parse_send_create $cmd]
+}
+
+######################################################################
+proc jlib::send_msg {to args} {
+    variable lib
+
+    ::LOG "(jlib::send_msg) to:'$to'"
+
+    set vars [list to $to]
+    set children [list]
+
+    foreach {attr val} $args {
+	switch -- $attr {
+	    -from { lappend vars from $val }
+	    -type { lappend vars type $val }
+	    -id   { lappend vars id   $val }
+	    -subject {
+		lappend children [wrapper:createtag subject -chdata $val]
+	    }
+	    -thread {
+		lappend children [wrapper:createtag thread -chdata $val]
+	    }
+	    -body {
+		lappend children [wrapper:createtag body -chdata $val]
+	    }
+	    -xlist {
+		foreach x $val {
+		    lappend children $x
+		}
+	    }
+	    -connection { set connid $val }
+	}
+    }
+
+    if {![info exists connid]} {
+	return -code error "jlib::send_msg: -connection is mandatory"
+    }
+
+    if {[lsearch [connections] $connid] < 0} {
+        ::LOG "error (jlib::send_msg) Connection $connid doesn't exist"
+	return -1
+    }
+
+    lappend vars xml:lang [get_lang]
+
+    set data [wrapper:createtag message -vars $vars -subtags $children]
+    set xml [wrapper:createxml $data]
+
+    ::LOG_OUTPUT_XML $connid $data
+    ::LOG_OUTPUT_SIZE $connid $data [string bytelength $xml]
+
+    outmsg $xml -connection $connid
+}
+
+######################################################################
+proc jlib::send_presence {args} {
+    variable lib
+    variable iq
+
+    ::LOG "(jlib::send_presence)"
+
+    set children [list]
+    set vars     [list]
+
+    foreach {attr val} $args {
+	switch -glob -- $attr {
+	    -from { lappend vars from $val }
+	    -to   { lappend vars to   $val }
+	    -type { lappend vars type $val }
+	    -command {
+		lappend vars id $iq(num)
+		set iq(presence,$iq(num)) $val
+		incr iq(num)
+	    }
+	    -stat* { lappend children [wrapper:createtag status -chdata $val] }
+	    -pri*  { lappend children [wrapper:createtag priority -chdata $val] }
+	    -show  { lappend children [wrapper:createtag show -chdata $val] }
+	    -meta  { lappend children [wrapper:createtag meta -chdata $val] }
+	    -icon  { lappend children [wrapper:createtag icon -chdata $val] }
+	    -loc   { lappend children [wrapper:createtag loc -chdata $val] }
+	    -xlist {
+		foreach x $val {
+		    lappend children $x
+		}
+	    }
+	    -connection { set connid $val }
+	}
+    }
+
+    if {![info exists connid]} {
+	return -code error "jlib::send_presence: -connection is mandatory"
+    }
+
+    if {[lsearch [connections] $connid] < 0} {
+        ::LOG "error (jlib::send_presence) Connection $connid doesn't exist"
+	return -1
+    }
+
+    lappend vars xml:lang [get_lang]
+
+    set data [wrapper:createtag presence -vars $vars -subtags $children]
+    set xml [wrapper:createxml $data]
+
+    ::LOG_OUTPUT_XML $connid $data
+    ::LOG_OUTPUT_SIZE $connid $data [string bytelength $xml]
+
+    outmsg $xml -connection $connid
+}
+
+######################################################################
+proc jlib::roster_get {args} {
+    variable lib
+    variable roster
+
+    ::LOG "(jlib::roster_get)"
+    if { $lib(connections) == {} } {
+	::LOG "error (jlib::roster_get) No connection"
+	return -1
+    }
+
+    set cmd "[namespace current]::noop"
+    set connid [lindex $lib(connections) 0]
+    foreach {attr val} $args {
+	switch -- $attr {
+	    -command    {set cmd $val}
+	    -connection {set connid $val}
+	}
+    }
+
+    foreach array [array names roster] {
+	unset roster($array)
+    }
+    set roster(users) ""
+
+    set vars [list xmlns $::NS(roster)]
+    set data [wrapper:createtag query -empty 1 -vars $vars]
+    send_iq get $data \
+	-command [list [namespace current]::parse_roster_get $connid 0 $cmd] \
+	-connection $connid
+    client status [::msgcat::mc "Waiting for roster"]
+}
+
+######################################################################
+proc jlib::roster_set {connid item args} {
+    variable lib
+    variable roster
+
+    ::LOG "(jlib::roster_set) item:'$item'"
+    if {$lib(connections) == {}} {
+	::LOG "error (jlib::roster_set) No connection"
+	return -1
+    }
+
+    set usename 0
+    set name ""
+    if { [lsearch $roster(users) $item] == -1 } {
+	set groups ""
+    } else {
+	set groups $roster(group,$item)
+    }
+
+    if {[wrapper:isattr $args -name]} {
+	set usename 1
+	set name [wrapper:getattr $args -name]
+    }
+    if {[wrapper:isattr $args -groups]} {
+	set groups [wrapper:getattr $args -groups]
+    }
+    if {[wrapper:isattr $args -command]} {
+	set cmd [wrapper:getattr $args -command]
+    } else {
+	set cmd [namespace current]::noop
+    }
+
+    set vars [list jid $item]
+    if {$usename} {
+	lappend vars name $name
+    }
+
+    set subdata ""
+    foreach group $groups {
+	lappend subdata [wrapper:createtag group -chdata $group]
+    }
+
+     set xmldata [wrapper:createtag query \
+		      -vars    [list xmlns $::NS(roster)] \
+		      -subtags [list [wrapper:createtag item \
+					  -vars    $vars \
+					  -subtags $subdata]]]
+
+    send_iq set $xmldata \
+	-connection $connid \
+	-command [list [namespace current]::parse_roster_set $item $cmd $groups $name]
+}
+
+######################################################################
+proc jlib::roster_del {connid item args} {
+    variable lib
+    variable roster
+
+    ::LOG "(jlib::roster_del) item:'$item'"
+    if { $lib(connections) == {} } {
+	::LOG "error (jlib::roster_del) No connection"
+	return -1
+    }
+
+    # TODO
+
+    if [wrapper:isattr $args -command] {
+	set cmd [wrapper:getattr $args -command]
+    } else {
+	set cmd [namespace current]::noop
+    }
+
+    set xmldata [wrapper:createtag query \
+		     -vars    [list xmlns $::NS(roster)] \
+		     -subtags [list [wrapper:createtag item \
+					 -vars [list jid $item \
+						     subscription remove]]]]
+
+    send_iq set $xmldata \
+	-connection $connid \
+	-command [list [namespace current]::parse_roster_del $item $cmd]
+}
+
+######################################################################
+#
+proc jlib::x_delay {xml} {
+    foreach xelem $xml {
+	jlib::wrapper:splitxml $xelem tag vars isempty chdata children
+
+	switch -- [jlib::wrapper:getattr $vars xmlns] {
+	    urn:xmpp:delay {
+		# 2006-07-17T05:29:12Z
+		# 2006-11-18T03:35:56.415699Z
+		if {[regsub {(\d+)-(\d\d)-(\d\d)T(\d+:\d+:\d+)[^Z]*Z?} \
+			    [jlib::wrapper:getattr $vars stamp] \
+			    {\1\2\3T\4} \
+			    stamp]} {
+		    if {![catch {clock scan $stamp -gmt 1} seconds]} {
+			return $seconds
+		    }
+		}
+	    }
+	    jabber:x:delay {
+		# 20060717T05:29:12
+		# 20061118T03:35:56.415699
+		if {[regexp {\d+\d\d\d\dT\d+:\d+:\d+} \
+			    [jlib::wrapper:getattr $vars stamp] \
+			    stamp]} {
+		    if {![catch {clock scan $stamp -gmt 1} seconds]} {
+			return $seconds
+		    }
+		}
+	    }
+	}
+    }
+    return [clock seconds]
+}
+
+######################################################################
+#
+proc ::LOG {text} {
+#
+# For debugging purposes.
+#
+    puts "LOG: $text\n"
+}
+
+proc ::LOG_OUTPUT     {connid t} {}
+proc ::LOG_OUTPUT_XML {connid x} {}
+proc ::LOG_OUTPUT_SIZE {connid x size} {}
+proc ::LOG_INPUT      {connid t} {}
+proc ::LOG_INPUT_XML  {connid x} {}
+proc ::LOG_INPUT_SIZE {connid x size} {}
+
+######################################################################
+proc jlib::noop {args} {}
+
+######################################################################
+proc jlib::get_lang {} {
+    set prefs [::msgcat::mcpreferences]
+      if {[info tclversion] > 8.4} {
+          set lang [lindex $prefs end-1]
+      } else {
+          set lang [lindex $prefs end]
+      }
+    switch -- $lang {
+	"" -
+	c -
+	posix {
+	    return en
+	}
+    }
+      if {[info tclversion] > 8.4} {
+          set lang2 [lindex $prefs end-2]
+      } else {
+          set lang2 [lindex $prefs end-1]
+      }
+    if {[regexp {^([A-Za-z]+)_([0-9A-Za-z]+)} $lang2 ignore l1 l2]} {
+	return "[string tolower $l1]-[string toupper $l2]"
+    } else {
+	return $lang
+    }
+}
+
+######################################################################
+#
+# Now that we're done...
+#
+
+package provide jabberlib 0.10.1
+

Deleted: trunk/tkabber/jabberlib/jlibauth.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/jlibauth.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/jlibauth.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,281 +0,0 @@
-#  jlibauth.tcl --
-#  
-#      This file is part of the jabberlib. It provides support for the
-#      Non-auth authentication layer (XEP-0078).
-#      
-#  Copyright (c) 2005 Sergei Golovan <sgolovan at nes.ru>
-#  
-# $Id$
-#
-# SYNOPSIS
-#   jlibauth::new connid args
-#	creates auth token
-#	args: -sessionid   sessionid
-#	      -username    username
-#	      -server      server
-#	      -resource    resource
-#	      -password    password
-#	      -allow_plain boolean
-#	      -command     callback
-#
-#   token configure args
-#	configures token parameters
-#	args: the same as in jlibauth::new
-#
-#   token auth args
-#	starts authenticating procedure
-#	args: the same as in jlibauth::new
-#
-#   token free
-#	frees token resourses
-
-##########################################################################
-
-package require sha1
-package require namespaces 1.0
-
-package provide jlibauth 1.0
-
-##########################################################################
-
-namespace eval jlibauth {
-    variable uid 0
-}
-
-##########################################################################
-
-proc jlibauth::new {connid args} {
-    variable uid
-
-    set token [namespace current]::[incr uid]
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibauth::new $connid) $token"
-
-    set state(-connid) $connid
-    set state(-allow_plain) 0
-
-    proc $token {cmd args} \
-	"eval {[namespace current]::\$cmd} {$token} \$args"
-
-    eval [list configure $token] $args
-
-    jlib::register_xmlns $state(-connid) $::NS(iq-auth) \
-	[list [namespace code parse] $token]
-    
-    return $token
-}
-
-##########################################################################
-
-proc jlibauth::free {token} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibauth::free $token)"
-
-    jlib::unregister_xmlns $state(-connid) $::NS(iq-auth)
-
-    catch { unset state }
-    catch { rename $token "" }
-}
-
-##########################################################################
-
-proc jlibauth::configure {token args} {
-    variable $token
-    upvar 0 $token state
-
-    foreach {key val} $args {
-	switch -- $key {
-	    -sessionid -
-	    -username -
-	    -server -
-	    -resource -
-	    -password -
-	    -allow_plain -
-	    -command {
-		set state($key) $val
-	    }
-	    default {
-		return -code error "Illegal option \"$key\""
-	    }
-	}
-    }
-}
-
-##########################################################################
-
-proc jlibauth::parse {token xmldata} {
-    variable $token
-    upvar 0 $token state
-
-    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children
-
-    switch -- $tag {
-	auth {
-	    set state(nonsasl) 1
-	}
-    }
-}
-
-##########################################################################
-
-proc jlibauth::auth {token args} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibauth::auth $token) start"
-
-    eval [list configure $token] $args
-
-    foreach key [list -sessionid \
-		      -username \
-		      -resource \
-		      -password] {
-	if {![info exists state($key)]} {
-	    return -code error "Auth error: missing option \"$key\""
-	}
-    }
-
-    jlib::trace_stream_features \
-	$state(-connid) \
-	[list [namespace code auth_continue] $token]
-}
-
-##########################################################################
-
-proc jlibauth::auth_continue {token} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibauth::auth_continue $token)"
-    
-    if {![info exists state(nonsasl)]} {
-	finish $token ERR \
-	    [concat modify \
-		 [stanzaerror::error modify not-acceptable -text \
-		      [::msgcat::mc \
-			   "Server haven't provided non-SASL\
-			    authentication feature"]]]
-	return
-    }
-    
-    set data [jlib::wrapper:createtag query \
-		  -vars    [list xmlns $::NS(auth)] \
-		  -subtags [list [jlib::wrapper:createtag username \
-				     -chdata $state(-username)]]]
-
-    jlib::send_iq get $data \
-	-command [list [namespace code auth_continue2] $token] \
-	-connection $state(-connid)
-}
-
-##########################################################################
-
-proc jlibauth::auth_continue2 {token res xmldata} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibauth::auth_continue2 $token) $res"
-
-    if {$res != "OK"} {
-	finish $token $res $xmldata
-	return
-    }
-
-    jlib::wrapper:splitxml $xmldata tag vars isempty chdata children
-
-    set authtype ""
-    foreach child $children {
-
-	jlib::wrapper:splitxml $child tag1 vars1 isempty1 chdata1 children1
-
-	switch -- $tag1 {
-	    password {
-		if {$authtype == ""} {
-		    if {$state(-allow_plain)} {
-			set authtype plain
-		    } else {
-			set authtype forbidden
-		    }
-		}
-	    }
-	    digest {
-		set authtype digest
-	    }
-	}
-    }
-
-    switch -- $authtype {
-	plain {
-	    set data [jlib::wrapper:createtag query \
-			  -vars    [list xmlns $::NS(auth)] \
-			  -subtags [list [jlib::wrapper:createtag username \
-					      -chdata $state(-username)] \
-					 [jlib::wrapper:createtag password \
-					      -chdata $state(-password)] \
-					 [jlib::wrapper:createtag resource \
-					      -chdata $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 [jlib::wrapper:createtag query \
-			  -vars    [list xmlns $::NS(auth)] \
-			  -subtags [list [jlib::wrapper:createtag username \
-					      -chdata $state(-username)] \
-					 [jlib::wrapper:createtag digest \
-					      -chdata $digest] \
-					 [jlib::wrapper:createtag resource \
-					      -chdata $state(-resource)]]]
-	}
-	forbidden {
-	    finish $token ERR \
-		[concat modify \
-		     [stanzaerror::error modify not-acceptable -text \
-			  [::msgcat::mc \
-			       "Server doesn't support hashed password\
-			        authentication"]]]
-	    return
-	}
-	default {
-	    finish $token ERR \
-		[concat modify \
-		     [stanzaerror::error modify not-acceptable -text \
-			  [::msgcat::mc \
-			       "Server doesn't support plain or digest\
-			        authentication"]]]
-	    return
-	}
-    }
-
-    jlib::client status [::msgcat::mc "Waiting for authentication results"]
-    jlib::send_iq set $data \
-	-command [list [namespace code finish] $token] \
-	-connection $state(-connid)
-}
-
-##########################################################################
-
-proc jlibauth::finish {token res xmldata} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibauth::finish $token) $res"
-
-    if {$res != "OK"} {
-	jlib::client status [::msgcat::mc "Authentication failed"]
-    } else {
-	jlib::client status [::msgcat::mc "Authentication successful"]
-    }
-    if {$res != "DISCONNECT" && [info exists state(-command)]} {
-	# Should we report about disconnect too?
-	uplevel #0 $state(-command) [list $res $xmldata]
-    }
-}
-
-##########################################################################
-

Copied: trunk/tkabber/jabberlib/jlibauth.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/jlibauth.tcl)
===================================================================
--- trunk/tkabber/jabberlib/jlibauth.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/jlibauth.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,281 @@
+#  jlibauth.tcl --
+#  
+#      This file is part of the jabberlib. It provides support for the
+#      Non-auth authentication layer (XEP-0078).
+#      
+#  Copyright (c) 2005 Sergei Golovan <sgolovan at nes.ru>
+#  
+# $Id$
+#
+# SYNOPSIS
+#   jlibauth::new connid args
+#	creates auth token
+#	args: -sessionid   sessionid
+#	      -username    username
+#	      -server      server
+#	      -resource    resource
+#	      -password    password
+#	      -allow_plain boolean
+#	      -command     callback
+#
+#   token configure args
+#	configures token parameters
+#	args: the same as in jlibauth::new
+#
+#   token auth args
+#	starts authenticating procedure
+#	args: the same as in jlibauth::new
+#
+#   token free
+#	frees token resourses
+
+##########################################################################
+
+package require sha1
+package require namespaces 1.0
+
+package provide jlibauth 1.0
+
+##########################################################################
+
+namespace eval jlibauth {
+    variable uid 0
+}
+
+##########################################################################
+
+proc jlibauth::new {connid args} {
+    variable uid
+
+    set token [namespace current]::[incr uid]
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibauth::new $connid) $token"
+
+    set state(-connid) $connid
+    set state(-allow_plain) 0
+
+    proc $token {cmd args} \
+	"eval {[namespace current]::\$cmd} {$token} \$args"
+
+    eval [list configure $token] $args
+
+    jlib::register_xmlns $state(-connid) $::NS(iq-auth) \
+	[list [namespace code parse] $token]
+    
+    return $token
+}
+
+##########################################################################
+
+proc jlibauth::free {token} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibauth::free $token)"
+
+    jlib::unregister_xmlns $state(-connid) $::NS(iq-auth)
+
+    catch { unset state }
+    catch { rename $token "" }
+}
+
+##########################################################################
+
+proc jlibauth::configure {token args} {
+    variable $token
+    upvar 0 $token state
+
+    foreach {key val} $args {
+	switch -- $key {
+	    -sessionid -
+	    -username -
+	    -server -
+	    -resource -
+	    -password -
+	    -allow_plain -
+	    -command {
+		set state($key) $val
+	    }
+	    default {
+		return -code error "Illegal option \"$key\""
+	    }
+	}
+    }
+}
+
+##########################################################################
+
+proc jlibauth::parse {token xmldata} {
+    variable $token
+    upvar 0 $token state
+
+    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children
+
+    switch -- $tag {
+	auth {
+	    set state(nonsasl) 1
+	}
+    }
+}
+
+##########################################################################
+
+proc jlibauth::auth {token args} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibauth::auth $token) start"
+
+    eval [list configure $token] $args
+
+    foreach key [list -sessionid \
+		      -username \
+		      -resource \
+		      -password] {
+	if {![info exists state($key)]} {
+	    return -code error "Auth error: missing option \"$key\""
+	}
+    }
+
+    jlib::trace_stream_features \
+	$state(-connid) \
+	[list [namespace code auth_continue] $token]
+}
+
+##########################################################################
+
+proc jlibauth::auth_continue {token} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibauth::auth_continue $token)"
+    
+    if {![info exists state(nonsasl)]} {
+	finish $token ERR \
+	    [concat modify \
+		 [stanzaerror::error modify not-acceptable -text \
+		      [::msgcat::mc \
+			   "Server haven't provided non-SASL\
+			    authentication feature"]]]
+	return
+    }
+    
+    set data [jlib::wrapper:createtag query \
+		  -vars    [list xmlns $::NS(auth)] \
+		  -subtags [list [jlib::wrapper:createtag username \
+				     -chdata $state(-username)]]]
+
+    jlib::send_iq get $data \
+	-command [list [namespace code auth_continue2] $token] \
+	-connection $state(-connid)
+}
+
+##########################################################################
+
+proc jlibauth::auth_continue2 {token res xmldata} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibauth::auth_continue2 $token) $res"
+
+    if {$res != "OK"} {
+	finish $token $res $xmldata
+	return
+    }
+
+    jlib::wrapper:splitxml $xmldata tag vars isempty chdata children
+
+    set authtype ""
+    foreach child $children {
+
+	jlib::wrapper:splitxml $child tag1 vars1 isempty1 chdata1 children1
+
+	switch -- $tag1 {
+	    password {
+		if {$authtype == ""} {
+		    if {$state(-allow_plain)} {
+			set authtype plain
+		    } else {
+			set authtype forbidden
+		    }
+		}
+	    }
+	    digest {
+		set authtype digest
+	    }
+	}
+    }
+
+    switch -- $authtype {
+	plain {
+	    set data [jlib::wrapper:createtag query \
+			  -vars    [list xmlns $::NS(auth)] \
+			  -subtags [list [jlib::wrapper:createtag username \
+					      -chdata $state(-username)] \
+					 [jlib::wrapper:createtag password \
+					      -chdata $state(-password)] \
+					 [jlib::wrapper:createtag resource \
+					      -chdata $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 [jlib::wrapper:createtag query \
+			  -vars    [list xmlns $::NS(auth)] \
+			  -subtags [list [jlib::wrapper:createtag username \
+					      -chdata $state(-username)] \
+					 [jlib::wrapper:createtag digest \
+					      -chdata $digest] \
+					 [jlib::wrapper:createtag resource \
+					      -chdata $state(-resource)]]]
+	}
+	forbidden {
+	    finish $token ERR \
+		[concat modify \
+		     [stanzaerror::error modify not-acceptable -text \
+			  [::msgcat::mc \
+			       "Server doesn't support hashed password\
+			        authentication"]]]
+	    return
+	}
+	default {
+	    finish $token ERR \
+		[concat modify \
+		     [stanzaerror::error modify not-acceptable -text \
+			  [::msgcat::mc \
+			       "Server doesn't support plain or digest\
+			        authentication"]]]
+	    return
+	}
+    }
+
+    jlib::client status [::msgcat::mc "Waiting for authentication results"]
+    jlib::send_iq set $data \
+	-command [list [namespace code finish] $token] \
+	-connection $state(-connid)
+}
+
+##########################################################################
+
+proc jlibauth::finish {token res xmldata} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibauth::finish $token) $res"
+
+    if {$res != "OK"} {
+	jlib::client status [::msgcat::mc "Authentication failed"]
+    } else {
+	jlib::client status [::msgcat::mc "Authentication successful"]
+    }
+    if {$res != "DISCONNECT" && [info exists state(-command)]} {
+	# Should we report about disconnect too?
+	uplevel #0 $state(-command) [list $res $xmldata]
+    }
+}
+
+##########################################################################
+

Deleted: trunk/tkabber/jabberlib/jlibcomponent.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/jlibcomponent.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/jlibcomponent.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,175 +0,0 @@
-#  jlibcomponent.tcl --
-#  
-#      This file is part of the jabberlib. It provides support for the
-#      jabber:component:accept protocol (XEP-0114).
-#      
-#  Copyright (c) 2005 Sergei Golovan <sgolovan at nes.ru>
-#  
-# $Id$
-#
-# SYNOPSIS
-#   jlibcomponent::new connid args
-#	creates handshake token
-#	args: -sessionid   sessionid
-#	      -secret      secret
-#	      -command     callback
-#
-#   token configure args
-#	configures token parameters
-#	args: the same as in jlibcomponent::new
-#
-#   token handshake args
-#	starts handshake procedure
-#	args: the same as in jlibcomponent::new
-#
-#   token free
-#	frees token resourses
-#
-# Note that this package is not loaded automatically with jabberlib.
-# You have to require it explicitly.
-#
-
-##########################################################################
-
-package require sha1
-
-package provide jlibcomponent 1.0
-
-##########################################################################
-
-namespace eval jlibcomponent {
-    variable uid 0
-}
-
-##########################################################################
-
-proc jlibcomponent::new {connid args} {
-    variable uid
-
-    set token [namespace current]::[incr uid]
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibcomponent::new $connid) $token"
-
-    set state(-connid) $connid
-
-    proc $token {cmd args} \
-	"eval {[namespace current]::\$cmd} {$token} \$args"
-
-    eval [list configure $token] $args
-
-    jlib::register_element $state(-connid) handshake \
-	[list [namespace code parse] $token]
-    jlib::register_element $state(-connid) error \
-	[list [namespace code parse] $token]
-    
-    return $token
-}
-
-##########################################################################
-
-proc jlibcomponent::free {token} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibcomponent::free $token)"
-
-    jlib::unregister_element $state(-connid) handshake
-    jlib::unregister_element $state(-connid) error
-
-    catch { unset state }
-    catch { rename $token "" }
-}
-
-##########################################################################
-
-proc jlibcomponent::configure {token args} {
-    variable $token
-    upvar 0 $token state
-
-    foreach {key val} $args {
-	switch -- $key {
-	    -sessionid -
-	    -secret -
-	    -command {
-		set state($key) $val
-	    }
-	    default {
-		return -code error "Illegal option \"$key\""
-	    }
-	}
-    }
-}
-
-##########################################################################
-
-proc jlibcomponent::parse {token xmldata} {
-    variable $token
-    upvar 0 $token state
-
-    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children
-
-    switch -- $tag {
-	handshake {
-	    finish $token OK {}
-	}
-	error {
-	    if {[wrapper:getattr $vars xmlns] = $::NS(stream)} {
-		finish $token ERR [streamerror:message $xmldata]
-	    }
-	}
-    }
-}
-
-##########################################################################
-
-proc jlibcomponent::handshake {token args} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibcomponent::handshake $token)"
-
-    eval [list configure $token] $args
-
-    foreach key [list -sessionid \
-		      -secret] {
-	if {![info exists state($key)]} {
-	    return -code error "Handshake error: missing option \"$key\""
-	}
-    }
-
-    set secret [encoding convertto utf-8 $state(-sessionid)]
-    append secret [encoding convertto utf-8 $state(-secret)]
-    set digest [sha1::sha1 $secret]
-    set data [jlib::wrapper:createtag handshake -chdata $digest]
-
-    jlib::client status [::msgcat::mc "Waiting for handshake results"]
-    outmsg [jlib::wrapper:createxml $data] -connection $state(-connid)
-}
-
-##########################################################################
-
-proc jlibcomponent::finish {token res msg} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibcomponent::finish $token) $res"
-
-    if {$res != "OK"} {
-	jlib::client status [::msgcat::mc "Handshake failed"]
-    } else {
-	jlib::client status [::msgcat::mc "Handshake successful"]
-    }
-
-    # Unregister elements after handshake
-    jlib::unregister_element $state(-connid) handshake
-    jlib::unregister_element $state(-connid) error
-
-    if {[info exists state(-command)]} {
-	uplevel #0 $state(-command) [list $res $msg]
-    }
-}
-
-##########################################################################
-

Copied: trunk/tkabber/jabberlib/jlibcomponent.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/jlibcomponent.tcl)
===================================================================
--- trunk/tkabber/jabberlib/jlibcomponent.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/jlibcomponent.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,175 @@
+#  jlibcomponent.tcl --
+#  
+#      This file is part of the jabberlib. It provides support for the
+#      jabber:component:accept protocol (XEP-0114).
+#      
+#  Copyright (c) 2005 Sergei Golovan <sgolovan at nes.ru>
+#  
+# $Id$
+#
+# SYNOPSIS
+#   jlibcomponent::new connid args
+#	creates handshake token
+#	args: -sessionid   sessionid
+#	      -secret      secret
+#	      -command     callback
+#
+#   token configure args
+#	configures token parameters
+#	args: the same as in jlibcomponent::new
+#
+#   token handshake args
+#	starts handshake procedure
+#	args: the same as in jlibcomponent::new
+#
+#   token free
+#	frees token resourses
+#
+# Note that this package is not loaded automatically with jabberlib.
+# You have to require it explicitly.
+#
+
+##########################################################################
+
+package require sha1
+
+package provide jlibcomponent 1.0
+
+##########################################################################
+
+namespace eval jlibcomponent {
+    variable uid 0
+}
+
+##########################################################################
+
+proc jlibcomponent::new {connid args} {
+    variable uid
+
+    set token [namespace current]::[incr uid]
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibcomponent::new $connid) $token"
+
+    set state(-connid) $connid
+
+    proc $token {cmd args} \
+	"eval {[namespace current]::\$cmd} {$token} \$args"
+
+    eval [list configure $token] $args
+
+    jlib::register_element $state(-connid) handshake \
+	[list [namespace code parse] $token]
+    jlib::register_element $state(-connid) error \
+	[list [namespace code parse] $token]
+    
+    return $token
+}
+
+##########################################################################
+
+proc jlibcomponent::free {token} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibcomponent::free $token)"
+
+    jlib::unregister_element $state(-connid) handshake
+    jlib::unregister_element $state(-connid) error
+
+    catch { unset state }
+    catch { rename $token "" }
+}
+
+##########################################################################
+
+proc jlibcomponent::configure {token args} {
+    variable $token
+    upvar 0 $token state
+
+    foreach {key val} $args {
+	switch -- $key {
+	    -sessionid -
+	    -secret -
+	    -command {
+		set state($key) $val
+	    }
+	    default {
+		return -code error "Illegal option \"$key\""
+	    }
+	}
+    }
+}
+
+##########################################################################
+
+proc jlibcomponent::parse {token xmldata} {
+    variable $token
+    upvar 0 $token state
+
+    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children
+
+    switch -- $tag {
+	handshake {
+	    finish $token OK {}
+	}
+	error {
+	    if {[wrapper:getattr $vars xmlns] = $::NS(stream)} {
+		finish $token ERR [streamerror:message $xmldata]
+	    }
+	}
+    }
+}
+
+##########################################################################
+
+proc jlibcomponent::handshake {token args} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibcomponent::handshake $token)"
+
+    eval [list configure $token] $args
+
+    foreach key [list -sessionid \
+		      -secret] {
+	if {![info exists state($key)]} {
+	    return -code error "Handshake error: missing option \"$key\""
+	}
+    }
+
+    set secret [encoding convertto utf-8 $state(-sessionid)]
+    append secret [encoding convertto utf-8 $state(-secret)]
+    set digest [sha1::sha1 $secret]
+    set data [jlib::wrapper:createtag handshake -chdata $digest]
+
+    jlib::client status [::msgcat::mc "Waiting for handshake results"]
+    outmsg [jlib::wrapper:createxml $data] -connection $state(-connid)
+}
+
+##########################################################################
+
+proc jlibcomponent::finish {token res msg} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibcomponent::finish $token) $res"
+
+    if {$res != "OK"} {
+	jlib::client status [::msgcat::mc "Handshake failed"]
+    } else {
+	jlib::client status [::msgcat::mc "Handshake successful"]
+    }
+
+    # Unregister elements after handshake
+    jlib::unregister_element $state(-connid) handshake
+    jlib::unregister_element $state(-connid) error
+
+    if {[info exists state(-command)]} {
+	uplevel #0 $state(-command) [list $res $msg]
+    }
+}
+
+##########################################################################
+

Deleted: trunk/tkabber/jabberlib/jlibcompress.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/jlibcompress.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/jlibcompress.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,250 +0,0 @@
-#  jlibcompress.tcl --
-#  
-#      This file is part of the jabberlib. It provides support for the
-#      compressed jabber stream.
-#      
-#  Copyright (c) 2005 Sergei Golovan <sgolovan at nes.ru>
-#  
-# $Id$
-#
-# SYNOPSIS
-#   jlibcompress::new connid args
-#	creates auth token
-#	args: -command callback
-#
-#   token configure args
-#	configures token parameters
-#	args: the same as in jlibcompress::new
-#
-#   token start args
-#	starts COMPRESS procedure
-#	args: the same as in jlibcompress::new
-#
-#   token free
-#	frees token resourses
-
-##########################################################################
-
-package require zlib 1.0
-package require namespaces 1.0
-
-package provide jlibcompress 1.0
-
-##########################################################################
-
-namespace eval jlibcompress {
-    variable uid 0
-    variable supported_methods {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"]] \
-    {
-	stanzaerror::register_error $lcode $type $cond $description
-    }
-}
-
-##########################################################################
-
-proc jlibcompress::new {connid args} {
-    variable uid
-
-    set token [namespace current]::[incr uid]
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibcompress::new $connid) $token"
-
-    set state(-connid) $connid
-
-    proc $token {cmd args} \
-	"eval {[namespace current]::\$cmd} {$token} \$args"
-
-    eval [list configure $token] $args
-
-    jlib::register_xmlns $state(-connid) $::NS(fcompress) \
-	[list [namespace code parse] $token]
-    jlib::register_xmlns $state(-connid) $::NS(compress) \
-	[list [namespace code parse] $token]
-
-    return $token
-}
-
-##########################################################################
-
-proc jlibcompress::free {token} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibcompress::free $token)"
-
-    jlib::unregister_xmlns $state(-connid) $::NS(fcompress)
-    jlib::unregister_xmlns $state(-connid) $::NS(compress)
-
-    catch { unset state }
-    catch { rename $token "" }
-}
-
-##########################################################################
-
-proc jlibcompress::configure {token args} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibcompress::configure $token)"
-
-    foreach {key val} $args {
-	switch -- $key {
-	    -command {
-		set state($key) $val
-	    }
-	    default {
-		return -code error "Illegal option \"$key\""
-	    }
-	}
-    }
-}
-
-##########################################################################
-
-proc jlibcompress::parse {token xmldata} {
-    variable $token
-    upvar 0 $token state
-
-    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children
-
-    switch -- $tag {
-	compression {
-	    set methods {}
-	    foreach child $children {
-		jlib::wrapper:splitxml $child tag1 vars1 isempty1 cdata1 children1
-		if {$tag1 == "method"} {
-		    lappend methods $cdata1
-		}
-	    }
-	    set state(-methods) $methods
-	}
-	compressed {
-	    compressed $token
-	}
-	failure {
-	    failure $token $children
-	}
-    }
-}
-
-##########################################################################
-
-proc jlibcompress::start {token args} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibcompress::start $token)"
-
-    eval [list configure $token] $args
-
-    jlib::trace_stream_features $state(-connid) \
-	[list [namespace code continue] $token]
-}
-
-##########################################################################
-
-proc jlibcompress::continue {token} {
-    variable supported_methods
-    variable $token
-    upvar 0 $token state
-    
-    ::LOG "(jlibcompress::continue $token)"
-
-    if {![info exists state(-methods)]} {
-	set err [stanzaerror::error modify not-acceptable -text \
-		     [::msgcat::mc \
-			  "Server haven't provided compress feature"]]
-	finish $token ERR [concat modify $err]
-	return
-    } else {
-	catch { unset state(-method) }
-	foreach m $supported_methods {
-	    if {[lcontain $state(-methods) $m]} {
-		set state(-method) $m
-		break
-	    }
-	    if {![info exists state(-method)]} {
-		set err [stanzaerror::error modify not-acceptable \
-			     -text [::msgcat::mc \
-				  "Server haven't provided supported\
-				   compress method"]]
-		finish $token ERR [concat modify $err]
-		return
-	    }
-	}
-    }
-
-    set data [jlib::wrapper:createtag compress \
-		  -vars [list xmlns $::NS(compress)] \
-		  -subtags [list [jlib::wrapper:createtag method \
-				      -chdata $state(-method)]]]
-    
-    jlib::outmsg [jlib::wrapper:createxml $data] -connection $state(-connid)
-}
-
-##########################################################################
-
-proc jlibcompress::failure {token children} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibcompress::failure $token)"
-
-    set error [lindex $children 0]
-    if {$error == ""} {
-	set err [stanzaerror::error modify undefined-condition \
-		     -text [::msgcat::mc "Compression negotiation failed"]]
-    } else {
-	jlib::wrapper:splitxml $error tag vars empty cdata children
-	set err [stanzaerror::error modify $tag]
-    }
-    finish $token ERR [concat modify $err]
-}
-
-##########################################################################
-
-proc jlibcompress::compressed {token} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibcompress::proceed $token)"
-
-    set transport $::jlib::lib($state(-connid),transport)
-
-    jlib::transport::${transport}::to_compress $state(-connid) $state(-method)
-
-    jlib::reset $state(-connid)
-
-    jlib::outmsg [jlib::wrapper:streamheader \
-		      [jlib::connection_server $state(-connid)] \
-		      -xml:lang [jlib::get_lang] -version "1.0"] \
-	-connection $state(-connid)
-    finish $token OK {}
-}
-
-##########################################################################
-
-proc jlibcompress::finish {token res xmldata} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibcompress::finish $token) res"
-
-    if {$res != "OK"} {
-	jlib::client status [::msgcat::mc "Compression negotiation failed"]
-    } else {
-	jlib::client status [::msgcat::mc "Compression negotiation successful"]
-    }
-    if {[info exists state(-command)]} {
-	uplevel #0 $state(-command) [list $res $xmldata]
-    }
-}
-
-##########################################################################
-

Copied: trunk/tkabber/jabberlib/jlibcompress.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/jlibcompress.tcl)
===================================================================
--- trunk/tkabber/jabberlib/jlibcompress.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/jlibcompress.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,249 @@
+#  jlibcompress.tcl --
+#  
+#      This file is part of the jabberlib. It provides support for the
+#      compressed jabber stream.
+#      
+#  Copyright (c) 2005 Sergei Golovan <sgolovan at nes.ru>
+#  
+# $Id$
+#
+# SYNOPSIS
+#   jlibcompress::new connid args
+#	creates auth token
+#	args: -command callback
+#
+#   token configure args
+#	configures token parameters
+#	args: the same as in jlibcompress::new
+#
+#   token start args
+#	starts COMPRESS procedure
+#	args: the same as in jlibcompress::new
+#
+#   token free
+#	frees token resourses
+
+##########################################################################
+
+package require zlib 1.0
+package require namespaces 1.0
+
+package provide jlibcompress 1.0
+
+##########################################################################
+
+namespace eval jlibcompress {
+    variable uid 0
+    variable supported_methods {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"]] \
+    {
+	stanzaerror::register_error $lcode $type $cond $description
+    }
+}
+
+##########################################################################
+
+proc jlibcompress::new {connid args} {
+    variable uid
+
+    set token [namespace current]::[incr uid]
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibcompress::new $connid) $token"
+
+    set state(-connid) $connid
+
+    proc $token {cmd args} \
+	"eval {[namespace current]::\$cmd} {$token} \$args"
+
+    eval [list configure $token] $args
+
+    jlib::register_xmlns $state(-connid) $::NS(fcompress) \
+	[list [namespace code parse] $token]
+    jlib::register_xmlns $state(-connid) $::NS(compress) \
+	[list [namespace code parse] $token]
+
+    return $token
+}
+
+##########################################################################
+
+proc jlibcompress::free {token} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibcompress::free $token)"
+
+    jlib::unregister_xmlns $state(-connid) $::NS(fcompress)
+    jlib::unregister_xmlns $state(-connid) $::NS(compress)
+
+    catch { unset state }
+    catch { rename $token "" }
+}
+
+##########################################################################
+
+proc jlibcompress::configure {token args} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibcompress::configure $token)"
+
+    foreach {key val} $args {
+	switch -- $key {
+	    -command {
+		set state($key) $val
+	    }
+	    default {
+		return -code error "Illegal option \"$key\""
+	    }
+	}
+    }
+}
+
+##########################################################################
+
+proc jlibcompress::parse {token xmldata} {
+    variable $token
+    upvar 0 $token state
+
+    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children
+
+    switch -- $tag {
+	compression {
+	    set methods {}
+	    foreach child $children {
+		jlib::wrapper:splitxml $child tag1 vars1 isempty1 cdata1 children1
+		if {$tag1 == "method"} {
+		    lappend methods $cdata1
+		}
+	    }
+	    set state(-methods) $methods
+	}
+	compressed {
+	    compressed $token
+	}
+	failure {
+	    failure $token $children
+	}
+    }
+}
+
+##########################################################################
+
+proc jlibcompress::start {token args} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibcompress::start $token)"
+
+    eval [list configure $token] $args
+
+    jlib::trace_stream_features $state(-connid) \
+	[list [namespace code continue] $token]
+}
+
+##########################################################################
+
+proc jlibcompress::continue {token} {
+    variable supported_methods
+    variable $token
+    upvar 0 $token state
+    
+    ::LOG "(jlibcompress::continue $token)"
+
+    if {![info exists state(-methods)]} {
+	set err [stanzaerror::error modify not-acceptable -text \
+		     [::msgcat::mc \
+			  "Server haven't provided compress feature"]]
+	finish $token ERR [concat modify $err]
+	return
+    } else {
+	catch { unset state(-method) }
+	foreach m $supported_methods {
+	    if {[lcontain $state(-methods) $m]} {
+		set state(-method) $m
+		break
+	    }
+	    if {![info exists state(-method)]} {
+		set err [stanzaerror::error modify not-acceptable \
+			     -text [::msgcat::mc \
+				  "Server haven't provided supported\
+				   compress method"]]
+		finish $token ERR [concat modify $err]
+		return
+	    }
+	}
+    }
+
+    set data [jlib::wrapper:createtag compress \
+		  -vars [list xmlns $::NS(compress)] \
+		  -subtags [list [jlib::wrapper:createtag method \
+				      -chdata $state(-method)]]]
+    
+    jlib::outmsg [jlib::wrapper:createxml $data] -connection $state(-connid)
+}
+
+##########################################################################
+
+proc jlibcompress::failure {token children} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibcompress::failure $token)"
+
+    set error [lindex $children 0]
+    if {$error == ""} {
+	set err [stanzaerror::error modify undefined-condition \
+		     -text [::msgcat::mc "Compression negotiation failed"]]
+    } else {
+	jlib::wrapper:splitxml $error tag vars empty cdata children
+	set err [stanzaerror::error modify $tag]
+    }
+    finish $token ERR [concat modify $err]
+}
+
+##########################################################################
+
+proc jlibcompress::compressed {token} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibcompress::proceed $token)"
+
+    set transport $::jlib::lib($state(-connid),transport)
+
+    jlib::transport::${transport}::to_compress $state(-connid) $state(-method)
+
+    jlib::reset $state(-connid)
+
+    jlib::start_stream [jlib::connection_server $state(-connid)] \
+		       -xml:lang [jlib::get_lang] -version "1.0" \
+		       -connection $state(-connid)
+    finish $token OK {}
+}
+
+##########################################################################
+
+proc jlibcompress::finish {token res xmldata} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibcompress::finish $token) res"
+
+    if {$res != "OK"} {
+	jlib::client status [::msgcat::mc "Compression negotiation failed"]
+    } else {
+	jlib::client status [::msgcat::mc "Compression negotiation successful"]
+    }
+    if {[info exists state(-command)]} {
+	uplevel #0 $state(-command) [list $res $xmldata]
+    }
+}
+
+##########################################################################
+

Deleted: trunk/tkabber/jabberlib/jlibdns.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/jlibdns.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/jlibdns.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,190 +0,0 @@
-#  jlibdns.tcl --
-#  
-#      This file is part of the jabberlib. It provides support for
-#      Jabber Client SRV DNS records (RFC 3920) and
-#      DNS TXT Resource Record Format (XEP-0156).
-#      
-#  Copyright (c) 2006 Sergei Golovan <sgolovan at nes.ru>
-#  
-# $Id$
-#
-#  SYNOPSIS
-#      jlibdns::get_addr_port domain
-#  RETURNS list of {hostname port} pairs
-#
-#  SYNOPSIS
-#      jlibdns::get_http_poll_url domain
-#  RETURNS URL for HTTP-poll connect method (XEP-0025)
-#
-
-##########################################################################
-
-package require dns
-package require idna
-
-if {$::tcl_platform(platform) == "windows"} {
-    package require registry
-}
-
-package provide jlibdns 1.0
-
-##########################################################################
-
-namespace eval jlibdns {}
-
-##########################################################################
-
-proc jlibdns::get_addr_port {domain} {
-    set name _xmpp-client._tcp.[idna::domain_toascii $domain]
-
-    if {[catch { resolve $name SRV } res]} {
-	return {}
-    }
-
-    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 {$rr(target) == "."} continue
-
-	if {[info exists rr(priority)] && [check $rr(priority)] && \
-		[info exists rr(weight)] && [check $rr(weight)] && \
-		[info exists rr(port)] && [check $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}] \
-				  $rr(target) $rr(port)]
-	}
-    }
-
-    set replies {}
-    foreach hp [lsort -real -index 0 $results] {
-	lappend replies [list [lindex $hp 1] [lindex $hp 2]]
-    }
-    return $replies
-}
-
-proc jlibdns::check {val} {
-    if {[string is integer -strict $val] && $val >= 0 && $val < 65536} {
-	return 1
-    } else {
-	return 0
-    }
-}
-
-##########################################################################
-
-proc jlibdns::get_http_poll_url {domain} {
-    set name _xmppconnect.[idna::domain_toascii $domain]
-
-    if {![catch { resolve $name TXT } res]} {
-	foreach reply $res {
-	    array set rr $reply
-	    if {[regexp {_xmpp-client-httppoll=(.*)} $rr(rdata) -> url]} {
-		return $url
-	    }
-	}
-    }
-    return ""
-}
-
-##########################################################################
-
-proc jlibdns::resolve {name type} {
-    set nameservers [get_nameservers]
-
-    foreach ns $nameservers {
-	set token [dns::resolve $name -type $type -nameserver $ns]
-	dns::wait $token
-	set status [dns::status $token]
-
-	if {$status == "ok"} {
-	    set res [dns::result $token]
-	    dns::cleanup $token
-	    return $res
-	} else {
-	    set err [dns::error $token]
-	    dns::cleanup $token
-	}
-    }
-    return -code error "DNS error: $err"
-}
-
-##########################################################################
-
-proc jlibdns::get_nameservers {} {
-    global tcl_platform
-
-    switch -- $tcl_platform(platform) {
-	unix {
-	    set resolv "/etc/resolv.conf"
-	    if {![file readable $resolv]} {
-		return {127.0.0.1}
-	    } else {
-		set fd [open $resolv]
-		set lines [split [read $fd] "\r\n"]
-		close $fd
-		set ns {}
-		foreach line $lines {
-		    if {[regexp {^nameserver\s+(\S+)} $line -> ip]} {
-			lappend ns $ip
-		    }
-		}
-		if {$ns == {}} {
-		    return {127.0.0.1}
-		} else {
-		    return $ns
-		}
-	    }
-	}
-	windows {
-	    set services_key \
-		"HKEY_LOCAL_MACHINE\\system\\CurrentControlSet\\Services"
-	    set win9x_key "$services_key\\VxD\\MSTCP"
-	    set winnt_key "$services_key\\TcpIp\\Parameters"
-	    set interfaces_key "$winnt_key\\Interfaces"
-
-	    # Windows 9x
-	    if {![catch { registry get $win9x_key "NameServer" } ns]} {
-		return [join [split $ns ,] " "]
-	    }
-
-	    # Windows NT/2000/XP
-	    if {![catch { registry get $winnt_key "NameServer" } ns] && \
-		    $ns != {}} {
-		return [join [split $ns ,] " "]
-	    }
-	    if {![catch { registry get $winnt_key "DhcpNameServer" } ns] && \
-		    $ns != {}} {
-		return $ns
-	    }
-            foreach key [registry keys $interfaces_key] {
-		if {![catch {
-			  registry get "$interfaces_key\\$key" \
-				       "NameServer"
-		      } ns] && $ns != {}} {
-		    return [join [split $ns ,] " "]
-		}
-		if {![catch {
-			  registry get "$interfaces_key\\$key" \
-				       "DhcpNameServer"
-		      } ns] && $ns != {}} {
-		    return $ns
-		}
-            }
-	    return {}
-	}
-    }
-}
-
-##########################################################################
-

Copied: trunk/tkabber/jabberlib/jlibdns.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/jlibdns.tcl)
===================================================================
--- trunk/tkabber/jabberlib/jlibdns.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/jlibdns.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,190 @@
+#  jlibdns.tcl --
+#  
+#      This file is part of the jabberlib. It provides support for
+#      Jabber Client SRV DNS records (RFC 3920) and
+#      DNS TXT Resource Record Format (XEP-0156).
+#      
+#  Copyright (c) 2006 Sergei Golovan <sgolovan at nes.ru>
+#  
+# $Id$
+#
+#  SYNOPSIS
+#      jlibdns::get_addr_port domain
+#  RETURNS list of {hostname port} pairs
+#
+#  SYNOPSIS
+#      jlibdns::get_http_poll_url domain
+#  RETURNS URL for HTTP-poll connect method (XEP-0025)
+#
+
+##########################################################################
+
+package require dns
+package require idna
+
+if {$::tcl_platform(platform) == "windows"} {
+    package require registry
+}
+
+package provide jlibdns 1.0
+
+##########################################################################
+
+namespace eval jlibdns {}
+
+##########################################################################
+
+proc jlibdns::get_addr_port {domain} {
+    set name _xmpp-client._tcp.[idna::domain_toascii $domain]
+
+    if {[catch { resolve $name SRV } res]} {
+	return {}
+    }
+
+    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 {$rr(target) == "."} continue
+
+	if {[info exists rr(priority)] && [check $rr(priority)] && \
+		[info exists rr(weight)] && [check $rr(weight)] && \
+		[info exists rr(port)] && [check $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}] \
+				  $rr(target) $rr(port)]
+	}
+    }
+
+    set replies {}
+    foreach hp [lsort -real -index 0 $results] {
+	lappend replies [list [lindex $hp 1] [lindex $hp 2]]
+    }
+    return $replies
+}
+
+proc jlibdns::check {val} {
+    if {[string is integer -strict $val] && $val >= 0 && $val < 65536} {
+	return 1
+    } else {
+	return 0
+    }
+}
+
+##########################################################################
+
+proc jlibdns::get_http_poll_url {domain} {
+    set name _xmppconnect.[idna::domain_toascii $domain]
+
+    if {![catch { resolve $name TXT } res]} {
+	foreach reply $res {
+	    array set rr $reply
+	    if {[regexp {_xmpp-client-httppoll=(.*)} $rr(rdata) -> url]} {
+		return $url
+	    }
+	}
+    }
+    return ""
+}
+
+##########################################################################
+
+proc jlibdns::resolve {name type} {
+    set nameservers [get_nameservers]
+
+    foreach ns $nameservers {
+	set token [dns::resolve $name -type $type -nameserver $ns]
+	dns::wait $token
+	set status [dns::status $token]
+
+	if {$status == "ok"} {
+	    set res [dns::result $token]
+	    dns::cleanup $token
+	    return $res
+	} else {
+	    set err [dns::error $token]
+	    dns::cleanup $token
+	}
+    }
+    return -code error "DNS error: $err"
+}
+
+##########################################################################
+
+proc jlibdns::get_nameservers {} {
+    global tcl_platform
+
+    switch -- $tcl_platform(platform) {
+	unix {
+	    set resolv "/etc/resolv.conf"
+	    if {![file readable $resolv]} {
+		return {127.0.0.1}
+	    } else {
+		set fd [open $resolv]
+		set lines [split [read $fd] "\r\n"]
+		close $fd
+		set ns {}
+		foreach line $lines {
+		    if {[regexp {^nameserver\s+(\S+)} $line -> ip]} {
+			lappend ns $ip
+		    }
+		}
+		if {$ns == {}} {
+		    return {127.0.0.1}
+		} else {
+		    return $ns
+		}
+	    }
+	}
+	windows {
+	    set services_key \
+		"HKEY_LOCAL_MACHINE\\system\\CurrentControlSet\\Services"
+	    set win9x_key "$services_key\\VxD\\MSTCP"
+	    set winnt_key "$services_key\\TcpIp\\Parameters"
+	    set interfaces_key "$winnt_key\\Interfaces"
+
+	    # Windows 9x
+	    if {![catch { registry get $win9x_key "NameServer" } ns]} {
+		return [join [split $ns ,] " "]
+	    }
+
+	    # Windows NT/2000/XP
+	    if {![catch { registry get $winnt_key "NameServer" } ns] && \
+		    $ns != {}} {
+		return [join [split $ns ,] " "]
+	    }
+	    if {![catch { registry get $winnt_key "DhcpNameServer" } ns] && \
+		    $ns != {}} {
+		return $ns
+	    }
+            foreach key [registry keys $interfaces_key] {
+		if {![catch {
+			  registry get "$interfaces_key\\$key" \
+				       "NameServer"
+		      } ns] && $ns != {}} {
+		    return [join [split $ns ,] " "]
+		}
+		if {![catch {
+			  registry get "$interfaces_key\\$key" \
+				       "DhcpNameServer"
+		      } ns] && $ns != {}} {
+		    return $ns
+		}
+            }
+	    return {}
+	}
+    }
+}
+
+##########################################################################
+

Deleted: trunk/tkabber/jabberlib/jlibsasl.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/jlibsasl.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/jlibsasl.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,614 +0,0 @@
-#  jlibsasl.tcl --
-#  
-#      This file is part of the jabberlib. It provides support for the
-#      SASL authentication layer via the tclsasl or tcllib SASL package.
-#      
-#  Copyright (c) 2005 Sergei Golovan <sgolovan at nes.ru>
-#  Based on jlibsasl by Mats Bengtson
-#  
-# $Id$
-#
-# SYNOPSIS
-#   jlibsasl::new connid args
-#	creates auth token
-#	args: -sessionid   sessionid
-#	      -username    username
-#	      -server      server
-#	      -resource    resource
-#	      -password    password
-#	      -allow_plain boolean
-#	      -command     callback
-#
-#   token configure args
-#	configures token parameters
-#	args: the same as in jlibsasl::new
-#
-#   token cget arg
-#	returns token parameter
-#	arg: -sessionid
-#	     -username
-#	     -server
-#	     -resource
-#	     -password
-#	     -allow_plain
-#	     -command
-#
-#   token auth args
-#	starts authenticating procedure
-#	args: the same as in jlibsasl::new
-#
-#   token free
-#	frees token resourses
-
-##########################################################################
-
-package require base64
-package require namespaces 1.0
-
-package provide jlibsasl 1.0
-
-##########################################################################
-
-namespace eval jlibsasl {
-    variable uid 0
-    variable saslpack
-
-    if {![catch {package require sasl 1.0}]} {
-	set saslpack tclsasl
-    } elseif {![catch {package require SASL 1.0}]} {
-	catch {package require SASL::NTLM}
-	catch {package require SASL::XGoogleToken}
-	set saslpack tcllib
-    } else {
-	return -code error "No SASL package found"
-    }
-
-    switch -- $saslpack {
-	tclsasl {
-	    sasl::client_init -callbacks [list [list log ::LOG]]
-	}
-	default {
-	    # empty
-	}
-    }
-
-    # SASL error messages
-    stanzaerror::register_errortype 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"]] \
-    {
-	stanzaerror::register_error $lcode $type $cond $description
-    }
-}
-
-##########################################################################
-
-proc jlibsasl::new {connid args} {
-    variable uid
-
-    set token [namespace current]::[incr uid]
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibsasl::new $connid) $token"
-
-    set state(-connid) $connid
-    set state(-allow_plain) 0
-    catch {unset state(-mechanisms)}
-
-    proc $token {cmd args} \
-	"eval {[namespace current]::\$cmd} {$token} \$args"
-
-    eval [list configure $token] $args
-
-    jlib::register_xmlns $state(-connid) $::NS(sasl) \
-	[list [namespace code parse] $token]
-
-    return $token
-}
-
-##########################################################################
-
-proc jlibsasl::free {token} {
-    variable saslpack
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibsasl::free $token)"
-
-    jlib::unregister_xmlns $state(-connid) $::NS(sasl)
-
-    if {[info exists state(-token)]} {
-	switch -- $saslpack {
-	    tclsasl {
-		rename $state(-token) ""
-	    }
-	    tcllib {
-		SASL::cleanup $state(-token)
-	    }
-	}
-    }
-
-    catch {unset state}
-    catch {rename $token ""}
-}
-
-##########################################################################
-
-proc jlibsasl::configure {token args} {
-    variable $token
-    upvar 0 $token state
-
-    foreach {key val} $args {
-	switch -- $key {
-	    -sessionid -
-	    -username -
-	    -server -
-	    -resource -
-	    -password -
-	    -allow_plain -
-	    -command {
-		set state($key) $val
-	    }
-	    default {
-		return -code error "Illegal option \"$key\""
-	    }
-	}
-    }
-}
-
-##########################################################################
-
-proc jlibsasl::cget {token arg} {
-    variable $token
-    upvar 0 $token state
-
-    switch -- $arg {
-	-sessionid -
-	-username -
-	-server -
-	-resource -
-	-password -
-	-allow_plain -
-	-command {
-	    if {[info exists state($arg)]} {
-		return $state($arg)
-	    } else {
-		return ""
-	    }
-	}
-	default {
-	    return -code error "Illegal option \"$arg\""
-	}
-    }
-}
-
-##########################################################################
-
-proc jlibsasl::parse {token xmldata} {
-    variable $token
-    upvar 0 $token state
-
-    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children
-
-    switch -- $tag {
-	mechanisms {
-	    set mechanisms {}
-	    foreach child $children {
-		jlib::wrapper:splitxml $child tag1 vars1 isempty1 cdata1 children1
-		if {$tag1 == "mechanism"} {
-		    lappend mechanisms $cdata1
-		}
-	    }
-	    set state(-mechanisms) $mechanisms
-	}
-	challenge {
-	    step $token $cdata
-	}
-	success {
-	    success $token
-	}
-	failure {
-	    failure $token $children
-	}
-    }
-}
-
-##########################################################################
-
-proc jlibsasl::auth {token args} {
-    variable saslpack
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibsasl::auth $token) start"
-
-    eval [list configure $token] $args
-
-    switch -- $saslpack {
-	tclsasl {
-	    foreach id {authname pass getrealm cnonce} {
-		lappend callbacks \
-		    [list $id [list [namespace code tclsasl_callback] \
-				    $token]]
-	    }
-
-	    set state(-token) \
-		[sasl::client_new -service     xmpp \
-				  -serverFQDN  $state(-server) \
-				  -callbacks   $callbacks \
-				  -flags       success_data]
-
-	    if {$state(-allow_plain)} {
-		set flags {}
-	    } else {
-		set flags {noplaintext}
-	    }
-
-	    $state(-token) -operation setprop \
-			   -property sec_props \
-			   -value [list min_ssf 0 \
-					max_ssf 0 \
-					flags $flags]
-	}
-	tcllib {
-	    set state(-token) \
-		[SASL::new -service xmpp \
-			   -type client \
-			   -server $state(-server) \
-			   -callback [list [namespace code tcllib_callback] \
-					   $token]]
-	    # Workaround a bug 1545306 in tcllib SASL module
-	    set ::SASL::digest_md5_noncecount 0
-	}
-    }
-
-    jlib::trace_stream_features $state(-connid) \
-	[list [namespace code auth_continue] $token]
-}
-
-##########################################################################
-
-proc jlibsasl::auth_continue {token} {
-    variable saslpack
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibsasl::auth $token)"
-    
-    if {![info exists state(-mechanisms)]} {
-	finish $token ERR \
-	    [concat modify \
-		 [stanzaerror::error modify not-acceptable -text \
-		      [::msgcat::mc \
-			   "Server haven't provided SASL authentication\
-			    feature"]]]
-	return
-    }
-    
-    ::LOG "(jlibsasl::auth $token) mechs: $state(-mechanisms)"
-
-    switch -- $saslpack {
-	tclsasl {
-	    set code [catch {
-		$state(-token) \
-		    -operation start \
-		    -mechanisms $state(-mechanisms) \
-		    -interact [list [namespace code interact] $token]
-	    } result]
-	}
-	tcllib {
-	    set code [catch {choose_mech $token} result]
-
-	    if {!$code} {
-		set mech $result
-		SASL::configure $state(-token) -mech $mech
-		switch -- $mech {
-		    PLAIN -
-		    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 $mech output $output]
-		}
-	    }
-	}
-    }
-
-    ::LOG "(jlibsasl::auth $token) SASL code $code: $result"
-
-    switch -- $code {
-	0 - 
-	4 {
-	    array set resarray $result
-	    set data [jlib::wrapper:createtag auth \
-			  -vars   [list xmlns $::NS(sasl) \
-					mechanism $resarray(mechanism)] \
-			  -chdata [base64::encode -maxlen 0 $resarray(output)]]
-
-	    jlib::outmsg [jlib::wrapper:createxml $data] \
-		-connection $state(-connid)
-	}
-	default {
-	    set str [format [::msgcat::mc "SASL auth error: %s"] $result]
-	    finish $token ERR \
-		[concat sasl [stanzaerror::error sasl undefined-condition \
-				  -text $str]]
-	}
-    }
-}
-
-##########################################################################
-
-proc jlibsasl::choose_mech {token} {
-    variable $token
-    upvar 0 $token state
-
-    if {$state(-allow_plain)} {
-	set forbidden_mechs {}
-    } else {
-	set forbidden_mechs {PLAIN LOGIN}
-    }
-
-    foreach m [SASL::mechanisms] {
-	if {[lsearch -exact $state(-mechanisms) $m] >= 0 && \
-		[lsearch -exact $forbidden_mechs $m] < 0} {
-	    return $m
-	}
-    }
-    return -code error [::msgcat::mc "no mechanism available"]
-}
-
-##########################################################################
-
-proc jlibsasl::step {token serverin64} {
-    variable saslpack
-    variable $token
-    upvar 0 $token state
-
-    set serverin [base64::decode $serverin64]
-
-    switch -- $saslpack {
-	tclsasl {
-	    set code [catch {
-		$state(-token) \
-		    -operation step \
-		    -input     $serverin \
-		    -interact  [list [namespace code interact] $token]
-	    } result]
-	}
-	tcllib {
-	    set code [catch {SASL::step $state(-token) $serverin} result]
-
-	    if {!$code} {
-		set result [SASL::response $state(-token)]
-	    }
-	}
-    }
-
-    ::LOG "(jlibsasl::step $token) SASL code $code: $result"
-
-    switch -- $code {
-	0 -
-	4 {
-	    set data [jlib::wrapper:createtag response \
-			  -vars   [list xmlns $::NS(sasl)] \
-			  -chdata [base64::encode -maxlen 0 $result]]
-
-	    jlib::outmsg [jlib::wrapper:createxml $data] \
-		-connection $state(-connid)
-	}
-	default {
-	    finish $token ERR \
-		[concat sasl \
-			[stanzaerror::error sasl undefined-condition \
-			     -text [format "SASL step error: %s" $result]]]
-	}
-    }
-}
-
-##########################################################################
-
-proc jlibsasl::tclsasl_callback {token data} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibsasl::tclsasl_callback $token) $data"
-
-    array set params $data
-
-    switch -- $params(id) {
-        user {
-	    # authzid
-            return [encoding convertto utf-8 $state(-username)@$state(-server)]
-        }
-        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 \
-		"SASL callback error: client needs to write $params(id)"
-	}
-    }
-}
-
-##########################################################################
-
-proc jlibsasl::tcllib_callback {token stoken command args} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibsasl::tcllib_callback $token) $stoken $command"
-
-    switch -- $command {
-	login {
-	    # authzid
-	    return [encoding convertto utf-8 $state(-username)@$state(-server)]
-	}
-	username {
-	    return [encoding convertto utf-8 $state(-username)]
-	}
-	password {
-	    return [encoding convertto utf-8 $state(-password)]
-	}
-	realm {
-	    return [encoding convertto utf-8 $state(-server)]
-	}
-	hostname {
-	    return [info host]
-	}
-	default {
-	    return -code error \
-		"SASL callback error: client needs to write $command"
-	}
-    }
-}
-
-##########################################################################
-
-proc jlibsasl::interact {token data} {
-    # empty
-    ::LOG "(jlibsasl::interact $token) $data"
-}
-
-##########################################################################
-
-proc jlibsasl::failure {token children} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibsasl::failure $token)"
-
-    set error [lindex $children 0]
-    if {$error == ""} {
-	set err not-authorized
-    } else {
-	jlib::wrapper:splitxml $error tag vars empty cdata children
-	set err $tag
-    }
-    finish $token ERR [concat sasl [stanzaerror::error sasl $err]]
-}
-
-##########################################################################
-
-proc jlibsasl::success {token} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibsasl::success $token)"
-    
-    # xmpp-core sect 6.2:
-    # Upon receiving the <success/> 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 </stream> tag first...
-    
-    jlib::reset $state(-connid)
-    
-    jlib::outmsg [jlib::wrapper:streamheader \
-		      [jlib::connection_server $state(-connid)] \
-		      -xml:lang [jlib::get_lang] -version "1.0"] \
-	-connection $state(-connid)
-	
-    jlib::trace_stream_features $state(-connid) \
-	[list [namespace code resource_bind] $token]
-}
-
-##########################################################################
-
-proc jlibsasl::resource_bind {token} {
-    variable $token
-    upvar 0 $token state
-
-    set data [jlib::wrapper:createtag bind \
-		  -vars [list xmlns $::NS(bind)] \
-		  -subtags [list [jlib::wrapper:createtag resource \
-				      -chdata $state(-resource)]]]
-
-    jlib::send_iq set $data \
-	-command [list [namespace code send_session] $token] \
-	-connection $state(-connid)
-    
-}
-
-##########################################################################
-
-proc jlibsasl::send_session {token res xmldata} {
-    variable $token
-    upvar 0 $token state
-
-    switch -- $res {
-	OK {
-	    # Decompose returned JID
-	    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children
-	    foreach child $children {
-		jlib::wrapper:splitxml $child tag1 vars1 isempty1 cdata1 children1
-
-		switch -- $tag1 {
-		    jid {
-			if {[regexp {([^@]*)@([^/]*)/(.*)} $cdata1 -> \
-				 username server resource]} {
-			    set state(-username) $username
-			    set state(-server) $server
-			    set state(-resource) $resource
-			}
-		    }
-		}
-	    }
-	    # Establish the session.
-	    set data [jlib::wrapper:createtag session \
-			  -vars [list xmlns $::NS(session)]]
-
-	    jlib::send_iq set $data \
-		-command [list [namespace code finish] $token] \
-		-connection $state(-connid)
-	}
-	default {
-	    ::LOG "error (jlibsasl::send_session) $xmldata"
-	    finish $token $res $xmldata
-	}
-    }
-}
-
-##########################################################################
-
-proc jlibsasl::finish {token res child} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibsasl::finish $token) $res"
-
-    if {$res != "OK"} {
-	jlib::client status [::msgcat::mc "Authentication failed"]
-    } else {
-	jlib::client status [::msgcat::mc "Authentication successful"]
-    }
-    if {[info exists state(-command)]} {
-	uplevel #0 $state(-command) [list $res $child]
-    }
-}
-
-##########################################################################
-

Copied: trunk/tkabber/jabberlib/jlibsasl.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/jlibsasl.tcl)
===================================================================
--- trunk/tkabber/jabberlib/jlibsasl.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/jlibsasl.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,629 @@
+#  jlibsasl.tcl --
+#  
+#      This file is part of the jabberlib. It provides support for the
+#      SASL authentication layer via the tclsasl or tcllib SASL package.
+#      
+#  Copyright (c) 2005 Sergei Golovan <sgolovan at nes.ru>
+#  Based on jlibsasl by Mats Bengtson
+#  
+# $Id$
+#
+# SYNOPSIS
+#   jlibsasl::new connid args
+#	creates auth token
+#	args: -sessionid   sessionid
+#	      -username    username
+#	      -server      server
+#	      -resource    resource
+#	      -password    password
+#	      -allow_plain boolean
+#	      -command     callback
+#
+#   token configure args
+#	configures token parameters
+#	args: the same as in jlibsasl::new
+#
+#   token cget arg
+#	returns token parameter
+#	arg: -sessionid
+#	     -username
+#	     -server
+#	     -resource
+#	     -password
+#	     -allow_plain
+#	     -command
+#
+#   token auth args
+#	starts authenticating procedure
+#	args: the same as in jlibsasl::new
+#
+#   token free
+#	frees token resourses
+
+##########################################################################
+
+package require base64
+package require namespaces 1.0
+
+package provide jlibsasl 1.0
+
+##########################################################################
+
+namespace eval jlibsasl {
+    variable uid 0
+    variable saslpack
+
+    if {![catch {package require sasl 1.0}]} {
+	set saslpack tclsasl
+    } elseif {![catch {package require SASL 1.0}]} {
+	catch {package require SASL::NTLM}
+	catch {package require SASL::XGoogleToken}
+	set saslpack tcllib
+    } else {
+	return -code error "No SASL package found"
+    }
+
+    switch -- $saslpack {
+	tclsasl {
+	    sasl::client_init -callbacks [list [list log ::LOG]]
+	}
+	default {
+	    # empty
+	}
+    }
+
+    # SASL error messages
+    stanzaerror::register_errortype 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"]] \
+    {
+	stanzaerror::register_error $lcode $type $cond $description
+    }
+}
+
+##########################################################################
+
+proc jlibsasl::new {connid args} {
+    variable uid
+
+    set token [namespace current]::[incr uid]
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibsasl::new $connid) $token"
+
+    set state(-connid) $connid
+    set state(-allow_plain) 0
+    set state(-allow_google_token) 1
+    catch {unset state(-mechanisms)}
+
+    proc $token {cmd args} \
+	"eval {[namespace current]::\$cmd} {$token} \$args"
+
+    eval [list configure $token] $args
+
+    jlib::register_xmlns $state(-connid) $::NS(sasl) \
+	[list [namespace code parse] $token]
+
+    return $token
+}
+
+##########################################################################
+
+proc jlibsasl::free {token} {
+    variable saslpack
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibsasl::free $token)"
+
+    jlib::unregister_xmlns $state(-connid) $::NS(sasl)
+
+    if {[info exists state(-token)]} {
+	switch -- $saslpack {
+	    tclsasl {
+		rename $state(-token) ""
+	    }
+	    tcllib {
+		SASL::cleanup $state(-token)
+	    }
+	}
+    }
+
+    catch {unset state}
+    catch {rename $token ""}
+}
+
+##########################################################################
+
+proc jlibsasl::configure {token args} {
+    variable $token
+    upvar 0 $token state
+
+    foreach {key val} $args {
+	switch -- $key {
+	    -sessionid -
+	    -username -
+	    -server -
+	    -resource -
+	    -password -
+	    -allow_plain -
+	    -allow_google_token -
+	    -command {
+		set state($key) $val
+	    }
+	    default {
+		return -code error "Illegal option \"$key\""
+	    }
+	}
+    }
+}
+
+##########################################################################
+
+proc jlibsasl::cget {token arg} {
+    variable $token
+    upvar 0 $token state
+
+    switch -- $arg {
+	-sessionid -
+	-username -
+	-server -
+	-resource -
+	-password -
+	-allow_plain -
+	-command {
+	    if {[info exists state($arg)]} {
+		return $state($arg)
+	    } else {
+		return ""
+	    }
+	}
+	default {
+	    return -code error "Illegal option \"$arg\""
+	}
+    }
+}
+
+##########################################################################
+
+proc jlibsasl::parse {token xmldata} {
+    variable $token
+    upvar 0 $token state
+
+    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children
+
+    switch -- $tag {
+	mechanisms {
+	    set mechanisms {}
+	    foreach child $children {
+		jlib::wrapper:splitxml $child tag1 vars1 isempty1 cdata1 children1
+		if {$tag1 == "mechanism"} {
+		    lappend mechanisms $cdata1
+		}
+	    }
+	    set state(-mechanisms) $mechanisms
+	}
+	challenge {
+	    step $token $cdata
+	}
+	success {
+	    success $token
+	}
+	failure {
+	    failure $token $children
+	}
+    }
+}
+
+##########################################################################
+
+proc jlibsasl::auth {token args} {
+    variable saslpack
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibsasl::auth $token) start"
+
+    eval [list configure $token] $args
+
+    switch -- $saslpack {
+	tclsasl {
+	    foreach id {authname pass getrealm cnonce} {
+		lappend callbacks \
+		    [list $id [list [namespace code tclsasl_callback] \
+				    $token]]
+	    }
+
+	    set state(-token) \
+		[sasl::client_new -service     xmpp \
+				  -serverFQDN  $state(-server) \
+				  -callbacks   $callbacks \
+				  -flags       success_data]
+
+	    if {$state(-allow_plain)} {
+		set flags {}
+	    } else {
+		set flags {noplaintext}
+	    }
+
+	    $state(-token) -operation setprop \
+			   -property sec_props \
+			   -value [list min_ssf 0 \
+					max_ssf 0 \
+					flags $flags]
+	}
+	tcllib {
+	    set state(-token) \
+		[SASL::new -service xmpp \
+			   -type client \
+			   -server $state(-server) \
+			   -callback [list [namespace code tcllib_callback] \
+					   $token]]
+	    # Workaround a bug 1545306 in tcllib SASL module
+	    set ::SASL::digest_md5_noncecount 0
+	}
+    }
+
+    jlib::trace_stream_features $state(-connid) \
+	[list [namespace code auth_continue] $token]
+}
+
+##########################################################################
+
+proc jlibsasl::auth_continue {token} {
+    variable saslpack
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibsasl::auth $token)"
+    
+    if {![info exists state(-mechanisms)]} {
+	finish $token ERR \
+	    [concat modify \
+		 [stanzaerror::error modify not-acceptable -text \
+		      [::msgcat::mc \
+			   "Server haven't provided SASL authentication\
+			    feature"]]]
+	return
+    }
+    
+    ::LOG "(jlibsasl::auth $token) mechs: $state(-mechanisms)"
+
+    switch -- $saslpack {
+	tclsasl {
+	    set code [catch {
+		$state(-token) \
+		    -operation start \
+		    -mechanisms $state(-mechanisms) \
+		    -interact [list [namespace code interact] $token]
+	    } result]
+	}
+	tcllib {
+	    set code [catch {choose_mech $token} result]
+
+	    if {!$code} {
+		set mech $result
+		SASL::configure $state(-token) -mech $mech
+		switch -- $mech {
+		    PLAIN -
+		    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 $mech output $output]
+		}
+	    }
+	}
+    }
+
+    ::LOG "(jlibsasl::auth $token) SASL code $code: $result"
+
+    switch -- $code {
+	0 - 
+	4 {
+	    array set resarray $result
+	    set data [jlib::wrapper:createtag auth \
+			  -vars   [list xmlns $::NS(sasl) \
+					mechanism $resarray(mechanism)] \
+			  -chdata [base64::encode -maxlen 0 $resarray(output)]]
+
+	    jlib::outmsg [jlib::wrapper:createxml $data] \
+		-connection $state(-connid)
+	}
+	default {
+	    set str [format [::msgcat::mc "SASL auth error:\n%s"] $result]
+	    finish $token ERR \
+		[concat sasl [stanzaerror::error sasl undefined-condition \
+				  -text $str]]
+	}
+    }
+}
+
+##########################################################################
+
+proc jlibsasl::choose_mech {token} {
+    variable $token
+    upvar 0 $token state
+
+    if {$state(-allow_plain)} {
+	set forbidden_mechs {}
+    } else {
+	set forbidden_mechs {PLAIN LOGIN}
+    }
+
+    if {!$state(-allow_google_token)} {
+	lappend forbidden_mechs X-GOOGLE-TOKEN
+    }
+
+    foreach m [SASL::mechanisms] {
+	if {[lsearch -exact $state(-mechanisms) $m] >= 0 && \
+		[lsearch -exact $forbidden_mechs $m] < 0} {
+	    return $m
+	}
+    }
+    if {[llength $state(-mechanisms)] == 0} {
+	return -code error [::msgcat::mc "Server provided no SASL mechanisms"]
+    } elseif {[llength $state(-mechanisms)] == 1} {
+	return -code error [::msgcat::mc "Server provided mechanism\
+					  %s. It is forbidden" \
+					 [lindex $state(-mechanisms) 0]]
+    } else {
+	return -code error [::msgcat::mc "Server provided mechanisms\
+					  %s. They are forbidden" \
+					 [join $state(-mechanisms) ", "]]
+    }
+}
+
+##########################################################################
+
+proc jlibsasl::step {token serverin64} {
+    variable saslpack
+    variable $token
+    upvar 0 $token state
+
+    set serverin [base64::decode $serverin64]
+
+    switch -- $saslpack {
+	tclsasl {
+	    set code [catch {
+		$state(-token) \
+		    -operation step \
+		    -input     $serverin \
+		    -interact  [list [namespace code interact] $token]
+	    } result]
+	}
+	tcllib {
+	    set code [catch {SASL::step $state(-token) $serverin} result]
+
+	    if {!$code} {
+		set result [SASL::response $state(-token)]
+	    }
+	}
+    }
+
+    ::LOG "(jlibsasl::step $token) SASL code $code: $result"
+
+    switch -- $code {
+	0 -
+	4 {
+	    set data [jlib::wrapper:createtag response \
+			  -vars   [list xmlns $::NS(sasl)] \
+			  -chdata [base64::encode -maxlen 0 $result]]
+
+	    jlib::outmsg [jlib::wrapper:createxml $data] \
+		-connection $state(-connid)
+	}
+	default {
+	    finish $token ERR \
+		[concat sasl \
+			[stanzaerror::error sasl undefined-condition \
+			     -text [format "SASL step error: %s" $result]]]
+	}
+    }
+}
+
+##########################################################################
+
+proc jlibsasl::tclsasl_callback {token data} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibsasl::tclsasl_callback $token) $data"
+
+    array set params $data
+
+    switch -- $params(id) {
+        user {
+	    # authzid
+            return [encoding convertto utf-8 $state(-username)@$state(-server)]
+        }
+        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 \
+		"SASL callback error: client needs to write $params(id)"
+	}
+    }
+}
+
+##########################################################################
+
+proc jlibsasl::tcllib_callback {token stoken command args} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibsasl::tcllib_callback $token) $stoken $command"
+
+    switch -- $command {
+	login {
+	    # authzid
+	    return [encoding convertto utf-8 $state(-username)@$state(-server)]
+	}
+	username {
+	    return [encoding convertto utf-8 $state(-username)]
+	}
+	password {
+	    return [encoding convertto utf-8 $state(-password)]
+	}
+	realm {
+	    return [encoding convertto utf-8 $state(-server)]
+	}
+	hostname {
+	    return [info host]
+	}
+	default {
+	    return -code error \
+		"SASL callback error: client needs to write $command"
+	}
+    }
+}
+
+##########################################################################
+
+proc jlibsasl::interact {token data} {
+    # empty
+    ::LOG "(jlibsasl::interact $token) $data"
+}
+
+##########################################################################
+
+proc jlibsasl::failure {token children} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibsasl::failure $token)"
+
+    set error [lindex $children 0]
+    if {$error == ""} {
+	set err not-authorized
+    } else {
+	jlib::wrapper:splitxml $error tag vars empty cdata children
+	set err $tag
+    }
+    finish $token ERR [concat sasl [stanzaerror::error sasl $err]]
+}
+
+##########################################################################
+
+proc jlibsasl::success {token} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibsasl::success $token)"
+    
+    # xmpp-core sect 6.2:
+    # Upon receiving the <success/> 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 </stream> tag first...
+    
+    jlib::reset $state(-connid)
+    
+    jlib::start_stream [jlib::connection_server $state(-connid)] \
+		       -xml:lang [jlib::get_lang] -version "1.0" \
+		       -connection $state(-connid)
+	
+    jlib::trace_stream_features $state(-connid) \
+	[list [namespace code resource_bind] $token]
+}
+
+##########################################################################
+
+proc jlibsasl::resource_bind {token} {
+    variable $token
+    upvar 0 $token state
+
+    set data [jlib::wrapper:createtag bind \
+		  -vars [list xmlns $::NS(bind)] \
+		  -subtags [list [jlib::wrapper:createtag resource \
+				      -chdata $state(-resource)]]]
+
+    jlib::send_iq set $data \
+	-command [list [namespace code send_session] $token] \
+	-connection $state(-connid)
+    
+}
+
+##########################################################################
+
+proc jlibsasl::send_session {token res xmldata} {
+    variable $token
+    upvar 0 $token state
+
+    switch -- $res {
+	OK {
+	    # Decompose returned JID
+	    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children
+	    foreach child $children {
+		jlib::wrapper:splitxml $child tag1 vars1 isempty1 cdata1 children1
+
+		switch -- $tag1 {
+		    jid {
+			if {[regexp {([^@]*)@([^/]*)/(.*)} $cdata1 -> \
+				 username server resource]} {
+			    set state(-username) $username
+			    set state(-server) $server
+			    set state(-resource) $resource
+			}
+		    }
+		}
+	    }
+	    # Establish the session.
+	    set data [jlib::wrapper:createtag session \
+			  -vars [list xmlns $::NS(session)]]
+
+	    jlib::send_iq set $data \
+		-command [list [namespace code finish] $token] \
+		-connection $state(-connid)
+	}
+	default {
+	    ::LOG "error (jlibsasl::send_session) $xmldata"
+	    finish $token $res $xmldata
+	}
+    }
+}
+
+##########################################################################
+
+proc jlibsasl::finish {token res child} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibsasl::finish $token) $res"
+
+    if {$res != "OK"} {
+	jlib::client status [::msgcat::mc "Authentication failed"]
+    } else {
+	jlib::client status [::msgcat::mc "Authentication successful"]
+    }
+    if {[info exists state(-command)]} {
+	uplevel #0 $state(-command) [list $res $child]
+    }
+}
+
+##########################################################################
+

Deleted: trunk/tkabber/jabberlib/jlibtls.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/jlibtls.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/jlibtls.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,246 +0,0 @@
-#  jlibtls.tcl --
-#  
-#      This file is part of the jabberlib. It provides support for the
-#      tls network socket security layer.
-#      
-#  Copyright (c) 2005 Sergei Golovan <sgolovan at nes.ru>
-#  Based on jlibtls by Mats Bengtsson
-#  
-# $Id$
-#
-# SYNOPSIS
-#   jlibtls::new connid args
-#	creates auth token
-#	args: -certfile    certfile
-#	      -cacertstore cacertstore
-#	      -keyfile     keyfile
-#	      -command     callback
-#
-#   token configure args
-#	configures token parameters
-#	args: the same as in jlibtls::new
-#
-#   token starttls args
-#	starts STARTTLS procedure
-#	args: the same as in jlibtls::new
-#
-#   token free
-#	frees token resourses
-
-##########################################################################
-
-package require tls 1.4
-package require namespaces 1.0
-
-package provide jlibtls 1.0
-
-##########################################################################
-
-namespace eval jlibtls {
-    variable uid 0
-}
-
-##########################################################################
-
-proc jlibtls::new {connid args} {
-    variable uid
-
-    set token [namespace current]::[incr uid]
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibtls::new $connid) $token"
-
-    set state(-connid) $connid
-    catch { unset state(-starttls) }
-    catch { unset state(-required) }
-
-    proc $token {cmd args} \
-	"eval {[namespace current]::\$cmd} {$token} \$args"
-
-    eval [list configure $token] $args
-
-    jlib::register_xmlns $state(-connid) $::NS(tls) \
-	[list [namespace code parse] $token]
-
-    return $token
-}
-
-##########################################################################
-
-proc jlibtls::free {token} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibtls::free $token)"
-
-    jlib::unregister_xmlns $state(-connid) $::NS(tls)
-
-    catch { unset state }
-    catch { rename $token "" }
-}
-
-##########################################################################
-
-proc jlibtls::configure {token args} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibtls::configure $token)"
-
-    foreach {key val} $args {
-	switch -- $key {
-	    -cacertstore {
-		if {$val != ""} {
-		    if {[file isdirectory $val]} {
-			set state(-cadir) $val
-		    } else {
-			set state(-cafile) $val
-		    }
-		}
-	    }
-	    -certfile -
-	    -keyfile -
-	    -command {
-		set state($key) $val
-	    }
-	    default {
-		return -code error "Illegal option \"$key\""
-	    }
-	}
-    }
-}
-
-##########################################################################
-
-proc jlibtls::parse {token xmldata} {
-    variable $token
-    upvar 0 $token state
-
-    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children
-
-    switch -- $tag {
-	starttls {
-	    set state(-starttls) 1
-	    foreach ch $children {
-		jlib::wrapper:splitxml $ch tag1 vars1 isempty1 cdata1 children1
-		if {$tag1 == "required"} {
-		    set state(-required) 1
-		}
-	    }
-	}
-	proceed {
-	    proceed $token
-	}
-	failure {
-	    failure $token $children
-	}
-    }
-}
-
-##########################################################################
-
-proc jlibtls::starttls {token args} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibtls::start $token)"
-
-    eval [list configure $token] $args
-
-    jlib::trace_stream_features $state(-connid) \
-	[list [namespace code tls_continue] $token]
-}
-
-##########################################################################
-
-proc jlibtls::tls_continue {token} {
-    variable $token
-    upvar 0 $token state
-    
-    ::LOG "(jlibtls::tls_continue $token)"
-
-    if {![info exists state(-starttls)]} {
-	set err [stanzaerror::error modify not-acceptable -text \
-		     [::msgcat::mc \
-			  "Server haven't provided STARTTLS feature"]]
-	finish $token ERR [concat modify $err]
-	return
-    }
-
-    set data [jlib::wrapper:createtag starttls -vars [list xmlns $::NS(tls)]]
-    
-    jlib::outmsg [jlib::wrapper:createxml $data] -connection $state(-connid)
-}
-
-##########################################################################
-
-proc jlibtls::failure {token children} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibtls::failure $token)"
-
-    set error [lindex $children 0]
-    if {$error == ""} {
-	set err [stanzaerror::error modify undefined-condition \
-		     -text [::msgcat::mc "STARTTLS failed"]]
-    } else {
-	jlib::wrapper:splitxml $error tag vars empty cdata children
-	set err [stanzaerror::error modify $tag]
-    }
-    finish $token ERR [concat modify $err]
-}
-
-##########################################################################
-
-proc jlibtls::proceed {token} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibtls::proceed $token)"
-
-    set args {}
-    foreach key {-cadir -cafile -certfile -keyfile} {
-	if {[info exists state($key)] && $state($key) != ""} {
-	    lappend args $key $state($key)
-	}
-    }
-
-    if {[catch {
-	     eval [list jlib::transport::tcp::to_tls $state(-connid)] $args
-         } msg]} {
-	set err [stanzaerror::error modify undefined-condition -text $msg]
-	finish $token ERR [concat modify $err]
-	return
-    }
-
-    jlib::reset $state(-connid)
-
-    jlib::outmsg [jlib::wrapper:streamheader \
-		      [jlib::connection_server $state(-connid)] \
-		      -xml:lang [jlib::get_lang] -version "1.0"] \
-	-connection $state(-connid)
-    finish $token OK {}
-}
-
-##########################################################################
-
-proc jlibtls::finish {token res xmldata} {
-    variable $token
-    upvar 0 $token state
-
-    ::LOG "(jlibtls::finish $token) res"
-
-    if {$res != "OK"} {
-	jlib::client status [::msgcat::mc "STARTTLS failed"]
-    } else {
-	jlib::client status [::msgcat::mc "STARTTLS successful"]
-    }
-    if {[info exists state(-command)]} {
-	uplevel #0 $state(-command) [list $res $xmldata]
-    }
-}
-
-##########################################################################
-

Copied: trunk/tkabber/jabberlib/jlibtls.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/jlibtls.tcl)
===================================================================
--- trunk/tkabber/jabberlib/jlibtls.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/jlibtls.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,245 @@
+#  jlibtls.tcl --
+#  
+#      This file is part of the jabberlib. It provides support for the
+#      tls network socket security layer.
+#      
+#  Copyright (c) 2005 Sergei Golovan <sgolovan at nes.ru>
+#  Based on jlibtls by Mats Bengtsson
+#  
+# $Id$
+#
+# SYNOPSIS
+#   jlibtls::new connid args
+#	creates auth token
+#	args: -certfile    certfile
+#	      -cacertstore cacertstore
+#	      -keyfile     keyfile
+#	      -command     callback
+#
+#   token configure args
+#	configures token parameters
+#	args: the same as in jlibtls::new
+#
+#   token starttls args
+#	starts STARTTLS procedure
+#	args: the same as in jlibtls::new
+#
+#   token free
+#	frees token resourses
+
+##########################################################################
+
+package require tls 1.4
+package require namespaces 1.0
+
+package provide jlibtls 1.0
+
+##########################################################################
+
+namespace eval jlibtls {
+    variable uid 0
+}
+
+##########################################################################
+
+proc jlibtls::new {connid args} {
+    variable uid
+
+    set token [namespace current]::[incr uid]
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibtls::new $connid) $token"
+
+    set state(-connid) $connid
+    catch { unset state(-starttls) }
+    catch { unset state(-required) }
+
+    proc $token {cmd args} \
+	"eval {[namespace current]::\$cmd} {$token} \$args"
+
+    eval [list configure $token] $args
+
+    jlib::register_xmlns $state(-connid) $::NS(tls) \
+	[list [namespace code parse] $token]
+
+    return $token
+}
+
+##########################################################################
+
+proc jlibtls::free {token} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibtls::free $token)"
+
+    jlib::unregister_xmlns $state(-connid) $::NS(tls)
+
+    catch { unset state }
+    catch { rename $token "" }
+}
+
+##########################################################################
+
+proc jlibtls::configure {token args} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibtls::configure $token)"
+
+    foreach {key val} $args {
+	switch -- $key {
+	    -cacertstore {
+		if {$val != ""} {
+		    if {[file isdirectory $val]} {
+			set state(-cadir) $val
+		    } else {
+			set state(-cafile) $val
+		    }
+		}
+	    }
+	    -certfile -
+	    -keyfile -
+	    -command {
+		set state($key) $val
+	    }
+	    default {
+		return -code error "Illegal option \"$key\""
+	    }
+	}
+    }
+}
+
+##########################################################################
+
+proc jlibtls::parse {token xmldata} {
+    variable $token
+    upvar 0 $token state
+
+    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children
+
+    switch -- $tag {
+	starttls {
+	    set state(-starttls) 1
+	    foreach ch $children {
+		jlib::wrapper:splitxml $ch tag1 vars1 isempty1 cdata1 children1
+		if {$tag1 == "required"} {
+		    set state(-required) 1
+		}
+	    }
+	}
+	proceed {
+	    proceed $token
+	}
+	failure {
+	    failure $token $children
+	}
+    }
+}
+
+##########################################################################
+
+proc jlibtls::starttls {token args} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibtls::start $token)"
+
+    eval [list configure $token] $args
+
+    jlib::trace_stream_features $state(-connid) \
+	[list [namespace code tls_continue] $token]
+}
+
+##########################################################################
+
+proc jlibtls::tls_continue {token} {
+    variable $token
+    upvar 0 $token state
+    
+    ::LOG "(jlibtls::tls_continue $token)"
+
+    if {![info exists state(-starttls)]} {
+	set err [stanzaerror::error modify not-acceptable -text \
+		     [::msgcat::mc \
+			  "Server haven't provided STARTTLS feature"]]
+	finish $token ERR [concat modify $err]
+	return
+    }
+
+    set data [jlib::wrapper:createtag starttls -vars [list xmlns $::NS(tls)]]
+    
+    jlib::outmsg [jlib::wrapper:createxml $data] -connection $state(-connid)
+}
+
+##########################################################################
+
+proc jlibtls::failure {token children} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibtls::failure $token)"
+
+    set error [lindex $children 0]
+    if {$error == ""} {
+	set err [stanzaerror::error modify undefined-condition \
+		     -text [::msgcat::mc "STARTTLS failed"]]
+    } else {
+	jlib::wrapper:splitxml $error tag vars empty cdata children
+	set err [stanzaerror::error modify $tag]
+    }
+    finish $token ERR [concat modify $err]
+}
+
+##########################################################################
+
+proc jlibtls::proceed {token} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibtls::proceed $token)"
+
+    set args {}
+    foreach key {-cadir -cafile -certfile -keyfile} {
+	if {[info exists state($key)] && $state($key) != ""} {
+	    lappend args $key $state($key)
+	}
+    }
+
+    if {[catch {
+	     eval [list jlib::transport::tcp::to_tls $state(-connid)] $args
+         } msg]} {
+	set err [stanzaerror::error modify undefined-condition -text $msg]
+	finish $token ERR [concat modify $err]
+	return
+    }
+
+    jlib::reset $state(-connid)
+
+    jlib::start_stream [jlib::connection_server $state(-connid)] \
+		       -xml:lang [jlib::get_lang] -version "1.0" \
+		       -connection $state(-connid)
+    finish $token OK {}
+}
+
+##########################################################################
+
+proc jlibtls::finish {token res xmldata} {
+    variable $token
+    upvar 0 $token state
+
+    ::LOG "(jlibtls::finish $token) res"
+
+    if {$res != "OK"} {
+	jlib::client status [::msgcat::mc "STARTTLS failed"]
+    } else {
+	jlib::client status [::msgcat::mc "STARTTLS successful"]
+    }
+    if {[info exists state(-command)]} {
+	uplevel #0 $state(-command) [list $res $xmldata]
+    }
+}
+
+##########################################################################
+

Deleted: trunk/tkabber/jabberlib/namespaces.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/namespaces.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/namespaces.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,54 +0,0 @@
-#  namespaces.tcl --
-#  
-#      This file is part of the jabberlib. It lists Jabber
-#      namespaces registered by JSF.
-#      
-#  Copyright (c) 2005 Sergei Golovan <sgolovan at nes.ru>
-#   
-# $Id$
-
-##########################################################################
-
-package provide namespaces 1.0
-
-##########################################################################
-
-namespace eval :: {
-    array set NS [list \
-	stream	    "http://etherx.jabber.org/streams" \
-	tls	    "urn:ietf:params:xml:ns:xmpp-tls" \
-	sasl	    "urn:ietf:params:xml:ns:xmpp-sasl" \
-	bind	    "urn:ietf:params:xml:ns:xmpp-bind" \
-	session	    "urn:ietf:params:xml:ns:xmpp-session" \
-	iq-auth	    "http://jabber.org/features/iq-auth" \
-	iq-register "http://jabber.org/features/iq-register" \
-	fcompress   "http://jabber.org/features/compress" \
-	compress    "http://jabber.org/protocol/compress" \
-	component   "jabber:component:accept" \
-	auth	    "jabber:iq:auth" \
-	register    "jabber:iq:register" \
-	roster	    "jabber:iq:roster" \
-	signed      "jabber:x:signed" \
-	encrypted   "jabber:x:encrypted" \
-	iqavatar    "jabber:iq:avatar" \
-	xavatar     "jabber:x:avatar" \
-	xconference "jabber:x:conference" \
-	data	    "jabber:x:data" \
-	event       "jabber:x:event" \
-	xroster     "jabber:x:roster" \
-	rosterx     "http://jabber.org/protocol/rosterx" \
-	chatstate   "http://jabber.org/protocol/chatstates" \
-	commands    "http://jabber.org/protocol/commands" \
-	privacy     "jabber:iq:privacy" \
-	private     "jabber:iq:private" \
-	delimiter   "roster:delimiter" \
-	bookmarks   "storage:bookmarks" \
-	tkabber:groups "tkabber:bookmarks:groups" \
-	pubsub      "http://jabber.org/protocol/pubsub" \
-	pubsub#owner "http://jabber.org/protocol/pubsub#owner" \
-	disco#publish "http://jabber.org/protocol/disco#publish"
-    ]
-}
-
-##########################################################################
-

Copied: trunk/tkabber/jabberlib/namespaces.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/namespaces.tcl)
===================================================================
--- trunk/tkabber/jabberlib/namespaces.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/namespaces.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,54 @@
+#  namespaces.tcl --
+#  
+#      This file is part of the jabberlib. It lists Jabber
+#      namespaces registered by JSF.
+#      
+#  Copyright (c) 2005 Sergei Golovan <sgolovan at nes.ru>
+#   
+# $Id$
+
+##########################################################################
+
+package provide namespaces 1.0
+
+##########################################################################
+
+namespace eval :: {
+    array set NS [list \
+	stream	    "http://etherx.jabber.org/streams" \
+	tls	    "urn:ietf:params:xml:ns:xmpp-tls" \
+	sasl	    "urn:ietf:params:xml:ns:xmpp-sasl" \
+	bind	    "urn:ietf:params:xml:ns:xmpp-bind" \
+	session	    "urn:ietf:params:xml:ns:xmpp-session" \
+	iq-auth	    "http://jabber.org/features/iq-auth" \
+	iq-register "http://jabber.org/features/iq-register" \
+	fcompress   "http://jabber.org/features/compress" \
+	compress    "http://jabber.org/protocol/compress" \
+	component   "jabber:component:accept" \
+	auth	    "jabber:iq:auth" \
+	register    "jabber:iq:register" \
+	roster	    "jabber:iq:roster" \
+	signed      "jabber:x:signed" \
+	encrypted   "jabber:x:encrypted" \
+	iqavatar    "jabber:iq:avatar" \
+	xavatar     "jabber:x:avatar" \
+	xconference "jabber:x:conference" \
+	data	    "jabber:x:data" \
+	event       "jabber:x:event" \
+	xroster     "jabber:x:roster" \
+	rosterx     "http://jabber.org/protocol/rosterx" \
+	chatstate   "http://jabber.org/protocol/chatstates" \
+	commands    "http://jabber.org/protocol/commands" \
+	privacy     "jabber:iq:privacy" \
+	private     "jabber:iq:private" \
+	delimiter   "roster:delimiter" \
+	bookmarks   "storage:bookmarks" \
+	tkabber:groups "tkabber:bookmarks:groups" \
+	pubsub      "http://jabber.org/protocol/pubsub" \
+	pubsub#owner "http://jabber.org/protocol/pubsub#owner" \
+	disco#publish "http://jabber.org/protocol/disco#publish"
+    ]
+}
+
+##########################################################################
+

Deleted: trunk/tkabber/jabberlib/ntlm.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/ntlm.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/ntlm.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,530 +0,0 @@
-# ntlm.tcl --
-#
-#	This file implements NTLM Authentication messages in Tcl.
-#	This module is based on Mozilla NTLM authenticattion module and
-#	documentation from http://davenport.sourceforge.net/ntlm.html
-#
-# Copyright (c) 2004-2007 Sergei Golovan <sgolovan at nes.ru>
-#
-# This file is distributed under BSD license.
-#
-# $Id$
-
-package require des
-package require md4
-package require md5
-package require base64
-
-package provide ntlm 1.0
-
-namespace eval NTLM {
-    namespace export new free type1Message parseType2Message type3Messasge
-
-    # NTLM flags.
-    array set NTLM {
-	NegotiateUnicode             0x00000001
-	NegotiateOEM                 0x00000002
-	RequestTarget                0x00000004
-	Unknown1                     0x00000008
-	NegotiateSign                0x00000010
-	NegotiateSeal                0x00000020
-	NegotiateDatagramStyle       0x00000040
-	NegotiateLanManagerKey       0x00000080
-	NegotiateNetware             0x00000100
-	NegotiateNTLMKey             0x00000200
-	Unknown2                     0x00000400
-	Unknown3                     0x00000800
-	NegotiateDomainSupplied      0x00001000
-	NegotiateWorkstationSupplied 0x00002000
-	NegotiateLocalCall           0x00004000
-	NegotiateAlwaysSign          0x00008000
-	TargetTypeDomain             0x00010000
-	TargetTypeServer             0x00020000
-	TargetTypeShare              0x00040000
-	NegotiateNTLM2Key            0x00080000
-	RequestInitResponse          0x00100000
-	RequestAcceptResponse        0x00200000
-	RequestNonNTSessionKey       0x00400000
-	NegotiateTargetInfo          0x00800000
-	Unknown4                     0x01000000
-	Unknown5                     0x02000000
-	Unknown6                     0x04000000
-	Unknown7                     0x08000000
-	Unknown8                     0x10000000
-	Negotiate128                 0x20000000
-	NegotiateKeyExchange         0x40000000
-	Negotiate56                  0x80000000
-    }
-    # Send these flags with our Type1 message.
-    set NTLM(TYPE1_FLAGS_INT) [expr {($NTLM(NegotiateUnicode) | \
-				      $NTLM(NegotiateOEM)     | \
-				      $NTLM(RequestTarget)    | \
-				      $NTLM(NegotiateNTLMKey) | \
-				      $NTLM(NegotiateNTLM2Key))}]
-    set NTLM(TYPE1_FLAGS) [binary format i $NTLM(TYPE1_FLAGS_INT)]
-
-    # Markers and signatures.
-    array set NTLM [list \
-	SIGNATURE    [binary format a8 "NTLMSSP"] \
-	TYPE1_MARKER [binary format i 1]          \
-	TYPE2_MARKER [binary format i 2]          \
-	TYPE3_MARKER [binary format i 3]          \
-	LM_MAGIC     [binary format a* "KGS!@#$%"]]
-    
-    # Token counter.
-    variable uid 0
-}
-
-# NTLM::new --
-#
-#	Allocates new NTLM token.
-#
-# Arguments:
-#	    -domain   Domain	(optional)
-#	    -host     Host	(optional)
-#	    -username Username	(optional)
-#	    -password Password	(optional)
-#	    All credentials are empty strings by default.
-#
-# Result:
-#	A NTLM token.
-#
-# Side effects:
-#	A new state variable in NTLM namespace is created. Also,
-#	a new procedure with token name is created.
-
-proc NTLM::new {args} {
-    variable uid
-
-    set token [namespace current]::[incr uid]
-    variable $token
-    upvar 0 $token state
-
-    set state(-domain) ""
-    set state(-host) ""
-    set state(-username) ""
-    set state(-password) ""
-
-    foreach {opt val} $args {
-	switch -- $opt {
-	    -domain -
-	    -host -
-	    -username -
-	    -password {
-		set state($opt) $val
-	    }
-	    default {
-		return -code error "Illegal option \"$key\""
-	    }
-	}
-    }
-
-    proc $token {cmd args} \
-	"eval {[namespace current]::\$cmd} {$token} \$args"
-
-    return $token
-}
-
-# NTLM::free --
-#
-#	Frees previously allocated NTLM token.
-#
-# Arguments:
-#	token	    A previously allocated NTLM token.
-#
-# Result:
-#	An empty string.
-#
-# Side effects:
-#	A state variable is destroyed.
-
-proc NTLM::free {token} {
-    variable $token
-    upvar 0 $token state
-
-    catch {unset state}
-    catch {rename $token ""}
-    return
-}
-
-# NTLM::type1Message --
-#
-#	Generates NTLM Type1 message (start of the authentication process).
-#
-# Arguments:
-#	token	    A NTLM token.
-#
-# Result:
-#	A BASE64 encoded NTLM Type1 message.
-#
-# Side effects:
-#	None.
-
-proc NTLM::type1Message {token} {
-    variable NTLM
-    variable $token
-    upvar 0 $token state
-
-    # two empty strings correspond to security buffers for empty domain and
-    # workstation data blocks
-    set msg1 [binary format a*a*a*a8a8 \
-		  $NTLM(SIGNATURE)    \
-		  $NTLM(TYPE1_MARKER) \
-		  $NTLM(TYPE1_FLAGS)  \
-		  "" ""]
-    return [string map {\n {}} [base64::encode $msg1]]
-}
-
-# NTLM::parseType2Message --
-#
-#	Parses NTLM Type2 message (server response).
-#
-# Arguments:
-#	token		    A NTLM token.
-#	-message Message    (required) A server Type2 message.
-#
-# Result:
-#	Empty string in case of success or error if something goes wrong.
-#
-# Side effects:
-#	A target, challenge and negotiated flags are stored in state variable.
-
-proc NTLM::parseType2Message {token args} {
-    variable NTLM
-    variable $token
-    upvar 0 $token state
-
-    foreach {opt val} $args {
-	switch -- $opt {
-	    -message {
-		set msg $val
-	    }
-	    default {
-		return -code error "Illegal option \"$key\""
-	    }
-	}
-    }
-    if {![info exists msg]} {
-	return -code error "Message to parse isn't provided"
-    }
-
-    set msg2 [base64::decode $msg]
-
-    # checking NTLM signature
-    if {![string equal [string range $msg2 0 7] $NTLM(SIGNATURE)]} {
-	return -code error "Invalid NTLM protocol signature"
-    }
-
-    # checking type2 message marker
-    if {![string equal [string range $msg2 8 11] $NTLM(TYPE2_MARKER)]} {
-	return -code error "Invalid NTLM message type (must be equal to 2)"
-    }
-    
-    # storing target name (NTLM realm)
-    binary scan [string range $msg2 12 13] s target_len
-    binary scan [string range $msg2 16 19] i target_offset
-    set state(target) [string range $msg2 $target_offset \
-			   [expr {$target_offset + $target_len - 1}]]
-
-    # storing negotiated flags
-    binary scan [string range $msg2 20 23] i state(flags)
-
-    # storing and returning challenge
-    set state(challenge) [string range $msg2 24 31]
-
-    return
-}
-
-# NTLM::type3Message --
-#
-#	Generates NTLM Type3 message (the end of the authentication process).
-#
-# Arguments:
-#	token	    A NTLM token after parsing Type2 message.
-#
-# Result:
-#	A BASE64 encoded NTLM Type3 message.
-#
-# Side effects:
-#	None.
-
-proc NTLM::type3Message {token} {
-    variable NTLM
-    variable $token
-    upvar 0 $token state
-
-    set unicode [expr {$state(flags) & $NTLM(NegotiateUnicode)}]
-    set target_type_domain [expr {$state(flags) & $NTLM(TargetTypeDomain)}]
-
-    if {$unicode} {
-	set domain [ToUnicodeLe [string toupper $state(-domain)]]
-	set host [ToUnicodeLe [string toupper $state(-host)]]
-	set username [ToUnicodeLe $state(-username)]
-    } else {
-	set domain [encoding convertto [string toupper $state(-domain)]]
-	set host [encoding convertto [string toupper $state(-host)]]
-	set username [encoding convertto $state(-username)]
-    }
-    if {$target_type_domain && ($state(-domain) == "")} {
-	set domain $state(target)
-    }
-
-    set challenge $state(challenge)
-
-    if {[expr {$state(flags) & $NTLM(NegotiateNTLM2Key)}]} {
-	set rnd1 [expr {int((1<<16)*rand())}]
-	set rnd2 [expr {int((1<<16)*rand())}]
-	set rnd3 [expr {int((1<<16)*rand())}]
-	set rnd4 [expr {int((1<<16)*rand())}]
-	set random [binary format ssss $rnd1 $rnd2 $rnd3 $rnd4]
-
-	set lm_response [binary format a24 $random]
-	set session_hash [md5 [binary format a8a8 $challenge $random]]
-
-	set ntlm_hash [NtlmHash $state(-password)]
-	set ntlm_response [LmResponse $ntlm_hash $session_hash]
-    } else {
-	set lm_hash [LmHash $state(-password)]
-	set lm_response [LmResponse $lm_hash $challenge]
-	
-	set ntlm_hash [NtlmHash $state(-password)]
-	set ntlm_response [LmResponse $ntlm_hash $challenge]
-    }
-
-    # Offset of the end of header.
-    set offset 64
-
-    set offset [CreateData $domain        $offset data(domain)]
-    set offset [CreateData $username      $offset data(username)]
-    set offset [CreateData $host          $offset data(host)]
-    set offset [CreateData $lm_response   $offset data(lm)]
-    set offset [CreateData $ntlm_response $offset data(ntlm)]
-
-    set flags [expr {$state(flags) & $NTLM(TYPE1_FLAGS_INT)}]
-
-    set msg3 [binary format a*a*a*a*a*a*a*a8ia*a*a*a*a* \
-		  $NTLM(SIGNATURE) $NTLM(TYPE3_MARKER) \
-		  $data(lm) $data(ntlm) $data(domain) $data(username) $data(host) \
-		  "" $flags \
-		  $domain $username $host $lm_response $ntlm_response]
-
-    return [string map {\n {}} [base64::encode $msg3]]
-}
-
-# NTLM::md5 --
-#
-#	Returns binary MD5 hash of specified string. This procedure is needed
-#	if md5 package has version less than 2.0.
-#
-# Arguments:
-#	str
-#
-# Result:
-#	The binary MD5 hash.
-#
-# Side effects:
-#	None.
-
-proc NTLM::md5 {str} {
-    if {[catch {::md5::md5 -hex $str} hash]} {
-	# Old md5 package.
-	set hash [::md5::md5 $str]
-    }
-    return [binary format H32 $hash]
-}
-
-# NTLM::CreateData --
-#
-#	Returns next offset (in error code) and security buffer data
-#
-# Arguments:
-#	str
-#	offset
-#	dataVar
-#
-# Result:
-#	The next offset.
-#
-# Side effects:
-#	Variable dataVar is set to a binary value for packing into a NTLM
-#	message.
-
-proc NTLM::CreateData {str offset dataVar} {
-    upvar $dataVar data
-
-    set len [string length $str]
-    set data [binary format ssi $len $len $offset]
-    return [expr {$offset + $len}]
-}
-
-# NTLM::LmHash --
-#
-#	Computes the LM hash of the given password.
-#
-# Arguments:
-#	password	A password to hash.
-#
-# Result:
-#	A LM hash of the given password.
-#
-# Side effects:
-#	None.
-
-proc NTLM::LmHash {password} {
-    variable NTLM
-
-    set password [encoding convertto [string toupper $password]]
-
-    # pad password with zeros or truncate if it is longer than 14
-    set pwd [binary format a14 $password]
-
-    # setup two DES keys
-    set key1 [MakeKey [string range $pwd 0 6]]
-    set key2 [MakeKey [string range $pwd 7 13]]
-
-    # do hash
-    set res1 [DES::des -mode encode -key $key1 $NTLM(LM_MAGIC)]
-    set res2 [DES::des -mode encode -key $key2 $NTLM(LM_MAGIC)]
-
-    return [binary format a8a8 $res1 $res2]
-}
-
-# NTLM::NtlmHash --
-#
-#	Computes the NTLM hash of the given password.
-#
-# Arguments:
-#	password	A password to hash.
-#
-# Result:
-#	A NTLM hash of the given password.
-#
-# Side effects:
-#	None.
-
-proc NTLM::NtlmHash {password} {
-    # we have to have UNICODE password
-    set pw [ToUnicodeLe $password]
-
-    # do MD4 hash
-    return [md4::md4 -- $pw]
-}
-
-# NTLM::LmResponse --
-#
-#	Generates the LM response given a 16-byte password hash and the
-#	challenge from the Type-2 message.
-#
-# Arguments:
-#	hash	    A password hash
-#	challenge   A challenge.
-#
-# Result:
-#	A LM hash (3 concatenated DES-encrypted strings).
-#
-# Side effects:
-#	None.
-
-proc NTLM::LmResponse {hash challenge} {
-    # zero pad hash to 21 bytes
-    set hash [binary format a21 $hash]
-    # truncate challenge to 8 bytes
-    set challenge [binary format a8 $challenge]
-
-    set key1 [MakeKey [string range $hash 0 6]]
-    set key2 [MakeKey [string range $hash 7 13]]
-    set key3 [MakeKey [string range $hash 14 20]]
-
-    set res1 [DES::des -mode encode -key $key1 $challenge]
-    set res2 [DES::des -mode encode -key $key2 $challenge]
-    set res3 [DES::des -mode encode -key $key3 $challenge]
-
-    return [binary format a8a8a8 $res1 $res2 $res3]
-}
-
-# NTLM::MakeKey --
-#
-#	Builds 64-bit DES key from 56-bit raw key.
-#
-# Arguments:
-#	key	A 56-bit key.
-#
-# Result:
-#	A 64-bit DES key.
-#
-# Side effects:
-#	None.
-
-proc NTLM::MakeKey {key} {
-    binary scan $key ccccccc k(0) k(1) k(2) k(3) k(4) k(5) k(6)
-    # make numbers unsigned
-    foreach i [array names k] {
-	set k($i) [expr {($k($i) + 0x100) % 0x100}]
-    }
-
-    set n(0) [SetKeyParity $k(0)]
-    set n(1) [SetKeyParity [expr {(($k(0) << 7) & 0xFF) | ($k(1) >> 1)}]]
-    set n(2) [SetKeyParity [expr {(($k(1) << 6) & 0xFF) | ($k(2) >> 2)}]]
-    set n(3) [SetKeyParity [expr {(($k(2) << 5) & 0xFF) | ($k(3) >> 3)}]]
-    set n(4) [SetKeyParity [expr {(($k(3) << 4) & 0xFF) | ($k(4) >> 4)}]]
-    set n(5) [SetKeyParity [expr {(($k(4) << 3) & 0xFF) | ($k(5) >> 5)}]]
-    set n(6) [SetKeyParity [expr {(($k(5) << 2) & 0xFF) | ($k(6) >> 6)}]]
-    set n(7) [SetKeyParity [expr  {($k(6) << 1) & 0xFF}]]
-
-    return [binary format cccccccc \
-		$n(0) $n(1) $n(2) $n(3) $n(4) $n(5) $n(6) $n(7)]
-}
-
-# NTLM::SetKeyParity --
-#
-#	Sets odd parity bit (in least significant bit position)
-#	DES::des seems not to require setting parity, but...
-#
-# Arguments:
-#	x	A byte integer.
-#
-# Result:
-#	An integer with parity bit set, so the total number of bits set is
-#	odd.
-#
-# Side effects:
-#	None.
-
-proc NTLM::SetKeyParity {x} {
-    set xor [expr {(($x >> 7) ^ ($x >> 6) ^ ($x >> 5) ^
-		    ($x >> 4) ^ ($x >> 3) ^ ($x >> 2) ^
-		    ($x >> 1)) & 0x01}]
-    if {$xor == 0} {
-	return [expr {($x & 0xFF) | 0x01}]
-    } else {
-	return [expr {$x & 0xFE}]
-    }
-}
-
-# NTLM::ToUnicodeLe --
-#
-#	Converts a string to unicode in little endian byte order
-#	(taken from tcllib/sasl).
-#
-# Arguments:
-#	str	A string to convert.
-#
-# Result:
-#	A converted to little endian byte order string.
-#
-# Side effects:
-#	None.
-
-proc NTLM::ToUnicodeLe {str} {
-    set result [encoding convertto unicode $str]
-    if {[string equal $::tcl_platform(byteOrder) "bigEndian"]} {
-	set r {} ; set n 0
-	while {[binary scan $result @${n}cc a b] == 2} {
-	    append r [binary format cc $b $a]
-	    incr n 2
-	}
-	set result $r
-    }
-    return $result
-}
-

Copied: trunk/tkabber/jabberlib/ntlm.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/ntlm.tcl)
===================================================================
--- trunk/tkabber/jabberlib/ntlm.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/ntlm.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,530 @@
+# ntlm.tcl --
+#
+#	This file implements NTLM Authentication messages in Tcl.
+#	This module is based on Mozilla NTLM authenticattion module and
+#	documentation from http://davenport.sourceforge.net/ntlm.html
+#
+# Copyright (c) 2004-2007 Sergei Golovan <sgolovan at nes.ru>
+#
+# This file is distributed under BSD license.
+#
+# $Id$
+
+package require des
+package require md4
+package require md5
+package require base64
+
+package provide ntlm 1.0
+
+namespace eval NTLM {
+    namespace export new free type1Message parseType2Message type3Messasge
+
+    # NTLM flags.
+    array set NTLM {
+	NegotiateUnicode             0x00000001
+	NegotiateOEM                 0x00000002
+	RequestTarget                0x00000004
+	Unknown1                     0x00000008
+	NegotiateSign                0x00000010
+	NegotiateSeal                0x00000020
+	NegotiateDatagramStyle       0x00000040
+	NegotiateLanManagerKey       0x00000080
+	NegotiateNetware             0x00000100
+	NegotiateNTLMKey             0x00000200
+	Unknown2                     0x00000400
+	Unknown3                     0x00000800
+	NegotiateDomainSupplied      0x00001000
+	NegotiateWorkstationSupplied 0x00002000
+	NegotiateLocalCall           0x00004000
+	NegotiateAlwaysSign          0x00008000
+	TargetTypeDomain             0x00010000
+	TargetTypeServer             0x00020000
+	TargetTypeShare              0x00040000
+	NegotiateNTLM2Key            0x00080000
+	RequestInitResponse          0x00100000
+	RequestAcceptResponse        0x00200000
+	RequestNonNTSessionKey       0x00400000
+	NegotiateTargetInfo          0x00800000
+	Unknown4                     0x01000000
+	Unknown5                     0x02000000
+	Unknown6                     0x04000000
+	Unknown7                     0x08000000
+	Unknown8                     0x10000000
+	Negotiate128                 0x20000000
+	NegotiateKeyExchange         0x40000000
+	Negotiate56                  0x80000000
+    }
+    # Send these flags with our Type1 message.
+    set NTLM(TYPE1_FLAGS_INT) [expr {($NTLM(NegotiateUnicode) | \
+				      $NTLM(NegotiateOEM)     | \
+				      $NTLM(RequestTarget)    | \
+				      $NTLM(NegotiateNTLMKey) | \
+				      $NTLM(NegotiateNTLM2Key))}]
+    set NTLM(TYPE1_FLAGS) [binary format i $NTLM(TYPE1_FLAGS_INT)]
+
+    # Markers and signatures.
+    array set NTLM [list \
+	SIGNATURE    [binary format a8 "NTLMSSP"] \
+	TYPE1_MARKER [binary format i 1]          \
+	TYPE2_MARKER [binary format i 2]          \
+	TYPE3_MARKER [binary format i 3]          \
+	LM_MAGIC     [binary format a* "KGS!@#$%"]]
+    
+    # Token counter.
+    variable uid 0
+}
+
+# NTLM::new --
+#
+#	Allocates new NTLM token.
+#
+# Arguments:
+#	    -domain   Domain	(optional)
+#	    -host     Host	(optional)
+#	    -username Username	(optional)
+#	    -password Password	(optional)
+#	    All credentials are empty strings by default.
+#
+# Result:
+#	A NTLM token.
+#
+# Side effects:
+#	A new state variable in NTLM namespace is created. Also,
+#	a new procedure with token name is created.
+
+proc NTLM::new {args} {
+    variable uid
+
+    set token [namespace current]::[incr uid]
+    variable $token
+    upvar 0 $token state
+
+    set state(-domain) ""
+    set state(-host) ""
+    set state(-username) ""
+    set state(-password) ""
+
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -domain -
+	    -host -
+	    -username -
+	    -password {
+		set state($opt) $val
+	    }
+	    default {
+		return -code error "Illegal option \"$key\""
+	    }
+	}
+    }
+
+    proc $token {cmd args} \
+	"eval {[namespace current]::\$cmd} {$token} \$args"
+
+    return $token
+}
+
+# NTLM::free --
+#
+#	Frees previously allocated NTLM token.
+#
+# Arguments:
+#	token	    A previously allocated NTLM token.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	A state variable is destroyed.
+
+proc NTLM::free {token} {
+    variable $token
+    upvar 0 $token state
+
+    catch {unset state}
+    catch {rename $token ""}
+    return
+}
+
+# NTLM::type1Message --
+#
+#	Generates NTLM Type1 message (start of the authentication process).
+#
+# Arguments:
+#	token	    A NTLM token.
+#
+# Result:
+#	A BASE64 encoded NTLM Type1 message.
+#
+# Side effects:
+#	None.
+
+proc NTLM::type1Message {token} {
+    variable NTLM
+    variable $token
+    upvar 0 $token state
+
+    # two empty strings correspond to security buffers for empty domain and
+    # workstation data blocks
+    set msg1 [binary format a*a*a*a8a8 \
+		  $NTLM(SIGNATURE)    \
+		  $NTLM(TYPE1_MARKER) \
+		  $NTLM(TYPE1_FLAGS)  \
+		  "" ""]
+    return [string map {\n {}} [base64::encode $msg1]]
+}
+
+# NTLM::parseType2Message --
+#
+#	Parses NTLM Type2 message (server response).
+#
+# Arguments:
+#	token		    A NTLM token.
+#	-message Message    (required) A server Type2 message.
+#
+# Result:
+#	Empty string in case of success or error if something goes wrong.
+#
+# Side effects:
+#	A target, challenge and negotiated flags are stored in state variable.
+
+proc NTLM::parseType2Message {token args} {
+    variable NTLM
+    variable $token
+    upvar 0 $token state
+
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -message {
+		set msg $val
+	    }
+	    default {
+		return -code error "Illegal option \"$key\""
+	    }
+	}
+    }
+    if {![info exists msg]} {
+	return -code error "Message to parse isn't provided"
+    }
+
+    set msg2 [base64::decode $msg]
+
+    # checking NTLM signature
+    if {![string equal [string range $msg2 0 7] $NTLM(SIGNATURE)]} {
+	return -code error "Invalid NTLM protocol signature"
+    }
+
+    # checking type2 message marker
+    if {![string equal [string range $msg2 8 11] $NTLM(TYPE2_MARKER)]} {
+	return -code error "Invalid NTLM message type (must be equal to 2)"
+    }
+    
+    # storing target name (NTLM realm)
+    binary scan [string range $msg2 12 13] s target_len
+    binary scan [string range $msg2 16 19] i target_offset
+    set state(target) [string range $msg2 $target_offset \
+			   [expr {$target_offset + $target_len - 1}]]
+
+    # storing negotiated flags
+    binary scan [string range $msg2 20 23] i state(flags)
+
+    # storing and returning challenge
+    set state(challenge) [string range $msg2 24 31]
+
+    return
+}
+
+# NTLM::type3Message --
+#
+#	Generates NTLM Type3 message (the end of the authentication process).
+#
+# Arguments:
+#	token	    A NTLM token after parsing Type2 message.
+#
+# Result:
+#	A BASE64 encoded NTLM Type3 message.
+#
+# Side effects:
+#	None.
+
+proc NTLM::type3Message {token} {
+    variable NTLM
+    variable $token
+    upvar 0 $token state
+
+    set unicode [expr {$state(flags) & $NTLM(NegotiateUnicode)}]
+    set target_type_domain [expr {$state(flags) & $NTLM(TargetTypeDomain)}]
+
+    if {$unicode} {
+	set domain [ToUnicodeLe [string toupper $state(-domain)]]
+	set host [ToUnicodeLe [string toupper $state(-host)]]
+	set username [ToUnicodeLe $state(-username)]
+    } else {
+	set domain [encoding convertto [string toupper $state(-domain)]]
+	set host [encoding convertto [string toupper $state(-host)]]
+	set username [encoding convertto $state(-username)]
+    }
+    if {$target_type_domain && ($state(-domain) == "")} {
+	set domain $state(target)
+    }
+
+    set challenge $state(challenge)
+
+    if {[expr {$state(flags) & $NTLM(NegotiateNTLM2Key)}]} {
+	set rnd1 [expr {int((1<<16)*rand())}]
+	set rnd2 [expr {int((1<<16)*rand())}]
+	set rnd3 [expr {int((1<<16)*rand())}]
+	set rnd4 [expr {int((1<<16)*rand())}]
+	set random [binary format ssss $rnd1 $rnd2 $rnd3 $rnd4]
+
+	set lm_response [binary format a24 $random]
+	set session_hash [md5 [binary format a8a8 $challenge $random]]
+
+	set ntlm_hash [NtlmHash $state(-password)]
+	set ntlm_response [LmResponse $ntlm_hash $session_hash]
+    } else {
+	set lm_hash [LmHash $state(-password)]
+	set lm_response [LmResponse $lm_hash $challenge]
+	
+	set ntlm_hash [NtlmHash $state(-password)]
+	set ntlm_response [LmResponse $ntlm_hash $challenge]
+    }
+
+    # Offset of the end of header.
+    set offset 64
+
+    set offset [CreateData $domain        $offset data(domain)]
+    set offset [CreateData $username      $offset data(username)]
+    set offset [CreateData $host          $offset data(host)]
+    set offset [CreateData $lm_response   $offset data(lm)]
+    set offset [CreateData $ntlm_response $offset data(ntlm)]
+
+    set flags [expr {$state(flags) & $NTLM(TYPE1_FLAGS_INT)}]
+
+    set msg3 [binary format a*a*a*a*a*a*a*a8ia*a*a*a*a* \
+		  $NTLM(SIGNATURE) $NTLM(TYPE3_MARKER) \
+		  $data(lm) $data(ntlm) $data(domain) $data(username) $data(host) \
+		  "" $flags \
+		  $domain $username $host $lm_response $ntlm_response]
+
+    return [string map {\n {}} [base64::encode $msg3]]
+}
+
+# NTLM::md5 --
+#
+#	Returns binary MD5 hash of specified string. This procedure is needed
+#	if md5 package has version less than 2.0.
+#
+# Arguments:
+#	str
+#
+# Result:
+#	The binary MD5 hash.
+#
+# Side effects:
+#	None.
+
+proc NTLM::md5 {str} {
+    if {[catch {::md5::md5 -hex $str} hash]} {
+	# Old md5 package.
+	set hash [::md5::md5 $str]
+    }
+    return [binary format H32 $hash]
+}
+
+# NTLM::CreateData --
+#
+#	Returns next offset (in error code) and security buffer data
+#
+# Arguments:
+#	str
+#	offset
+#	dataVar
+#
+# Result:
+#	The next offset.
+#
+# Side effects:
+#	Variable dataVar is set to a binary value for packing into a NTLM
+#	message.
+
+proc NTLM::CreateData {str offset dataVar} {
+    upvar $dataVar data
+
+    set len [string length $str]
+    set data [binary format ssi $len $len $offset]
+    return [expr {$offset + $len}]
+}
+
+# NTLM::LmHash --
+#
+#	Computes the LM hash of the given password.
+#
+# Arguments:
+#	password	A password to hash.
+#
+# Result:
+#	A LM hash of the given password.
+#
+# Side effects:
+#	None.
+
+proc NTLM::LmHash {password} {
+    variable NTLM
+
+    set password [encoding convertto [string toupper $password]]
+
+    # pad password with zeros or truncate if it is longer than 14
+    set pwd [binary format a14 $password]
+
+    # setup two DES keys
+    set key1 [MakeKey [string range $pwd 0 6]]
+    set key2 [MakeKey [string range $pwd 7 13]]
+
+    # do hash
+    set res1 [DES::des -mode encode -key $key1 $NTLM(LM_MAGIC)]
+    set res2 [DES::des -mode encode -key $key2 $NTLM(LM_MAGIC)]
+
+    return [binary format a8a8 $res1 $res2]
+}
+
+# NTLM::NtlmHash --
+#
+#	Computes the NTLM hash of the given password.
+#
+# Arguments:
+#	password	A password to hash.
+#
+# Result:
+#	A NTLM hash of the given password.
+#
+# Side effects:
+#	None.
+
+proc NTLM::NtlmHash {password} {
+    # we have to have UNICODE password
+    set pw [ToUnicodeLe $password]
+
+    # do MD4 hash
+    return [md4::md4 -- $pw]
+}
+
+# NTLM::LmResponse --
+#
+#	Generates the LM response given a 16-byte password hash and the
+#	challenge from the Type-2 message.
+#
+# Arguments:
+#	hash	    A password hash
+#	challenge   A challenge.
+#
+# Result:
+#	A LM hash (3 concatenated DES-encrypted strings).
+#
+# Side effects:
+#	None.
+
+proc NTLM::LmResponse {hash challenge} {
+    # zero pad hash to 21 bytes
+    set hash [binary format a21 $hash]
+    # truncate challenge to 8 bytes
+    set challenge [binary format a8 $challenge]
+
+    set key1 [MakeKey [string range $hash 0 6]]
+    set key2 [MakeKey [string range $hash 7 13]]
+    set key3 [MakeKey [string range $hash 14 20]]
+
+    set res1 [DES::des -mode encode -key $key1 $challenge]
+    set res2 [DES::des -mode encode -key $key2 $challenge]
+    set res3 [DES::des -mode encode -key $key3 $challenge]
+
+    return [binary format a8a8a8 $res1 $res2 $res3]
+}
+
+# NTLM::MakeKey --
+#
+#	Builds 64-bit DES key from 56-bit raw key.
+#
+# Arguments:
+#	key	A 56-bit key.
+#
+# Result:
+#	A 64-bit DES key.
+#
+# Side effects:
+#	None.
+
+proc NTLM::MakeKey {key} {
+    binary scan $key ccccccc k(0) k(1) k(2) k(3) k(4) k(5) k(6)
+    # make numbers unsigned
+    foreach i [array names k] {
+	set k($i) [expr {($k($i) + 0x100) % 0x100}]
+    }
+
+    set n(0) [SetKeyParity $k(0)]
+    set n(1) [SetKeyParity [expr {(($k(0) << 7) & 0xFF) | ($k(1) >> 1)}]]
+    set n(2) [SetKeyParity [expr {(($k(1) << 6) & 0xFF) | ($k(2) >> 2)}]]
+    set n(3) [SetKeyParity [expr {(($k(2) << 5) & 0xFF) | ($k(3) >> 3)}]]
+    set n(4) [SetKeyParity [expr {(($k(3) << 4) & 0xFF) | ($k(4) >> 4)}]]
+    set n(5) [SetKeyParity [expr {(($k(4) << 3) & 0xFF) | ($k(5) >> 5)}]]
+    set n(6) [SetKeyParity [expr {(($k(5) << 2) & 0xFF) | ($k(6) >> 6)}]]
+    set n(7) [SetKeyParity [expr  {($k(6) << 1) & 0xFF}]]
+
+    return [binary format cccccccc \
+		$n(0) $n(1) $n(2) $n(3) $n(4) $n(5) $n(6) $n(7)]
+}
+
+# NTLM::SetKeyParity --
+#
+#	Sets odd parity bit (in least significant bit position)
+#	DES::des seems not to require setting parity, but...
+#
+# Arguments:
+#	x	A byte integer.
+#
+# Result:
+#	An integer with parity bit set, so the total number of bits set is
+#	odd.
+#
+# Side effects:
+#	None.
+
+proc NTLM::SetKeyParity {x} {
+    set xor [expr {(($x >> 7) ^ ($x >> 6) ^ ($x >> 5) ^
+		    ($x >> 4) ^ ($x >> 3) ^ ($x >> 2) ^
+		    ($x >> 1)) & 0x01}]
+    if {$xor == 0} {
+	return [expr {($x & 0xFF) | 0x01}]
+    } else {
+	return [expr {$x & 0xFE}]
+    }
+}
+
+# NTLM::ToUnicodeLe --
+#
+#	Converts a string to unicode in little endian byte order
+#	(taken from tcllib/sasl).
+#
+# Arguments:
+#	str	A string to convert.
+#
+# Result:
+#	A converted to little endian byte order string.
+#
+# Side effects:
+#	None.
+
+proc NTLM::ToUnicodeLe {str} {
+    set result [encoding convertto unicode $str]
+    if {[string equal $::tcl_platform(byteOrder) "bigEndian"]} {
+	set r {} ; set n 0
+	while {[binary scan $result @${n}cc a b] == 2} {
+	    append r [binary format cc $b $a]
+	    incr n 2
+	}
+	set result $r
+    }
+    return $result
+}
+

Deleted: trunk/tkabber/jabberlib/pkgIndex.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/pkgIndex.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/pkgIndex.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,17 +0,0 @@
-package ifneeded jabberlib 0.10.0 [list source [file join $dir jabberlib.tcl]]
-package ifneeded namespaces 1.0 [list source [file join $dir namespaces.tcl]]
-package ifneeded jlibauth 1.0 [list source [file join $dir jlibauth.tcl]]
-package ifneeded jlibsasl 1.0 [list source [file join $dir jlibsasl.tcl]]
-package ifneeded jlibtls 1.0 [list source [file join $dir jlibtls.tcl]]
-package ifneeded jlibcompress 1.0 [list source [file join $dir jlibcompress.tcl]]
-package ifneeded streamerror 1.0 [list source [file join $dir streamerror.tcl]]
-package ifneeded stanzaerror 1.0 [list source [file join $dir stanzaerror.tcl]]
-package ifneeded jlibdns 1.0 [list source [file join $dir jlibdns.tcl]]
-package ifneeded idna 1.0 [list source [file join $dir idna.tcl]]
-package ifneeded ntlm 1.0 [list source [file join $dir ntlm.tcl]]
-package ifneeded autoconnect 0.1 [list source [file join $dir autoconnect.tcl]]
-package ifneeded socks4 1.0 [list source [file join $dir socks4.tcl]]
-package ifneeded socks5 1.0 [list source [file join $dir socks5.tcl]]
-package ifneeded https 1.0 [list source [file join $dir https.tcl]]
-
-# don't forget to define ::LOG

Copied: trunk/tkabber/jabberlib/pkgIndex.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/pkgIndex.tcl)
===================================================================
--- trunk/tkabber/jabberlib/pkgIndex.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/pkgIndex.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,17 @@
+package ifneeded jabberlib 0.10.1 [list source [file join $dir jabberlib.tcl]]
+package ifneeded namespaces 1.0 [list source [file join $dir namespaces.tcl]]
+package ifneeded jlibauth 1.0 [list source [file join $dir jlibauth.tcl]]
+package ifneeded jlibsasl 1.0 [list source [file join $dir jlibsasl.tcl]]
+package ifneeded jlibtls 1.0 [list source [file join $dir jlibtls.tcl]]
+package ifneeded jlibcompress 1.0 [list source [file join $dir jlibcompress.tcl]]
+package ifneeded streamerror 1.0 [list source [file join $dir streamerror.tcl]]
+package ifneeded stanzaerror 1.0 [list source [file join $dir stanzaerror.tcl]]
+package ifneeded jlibdns 1.0 [list source [file join $dir jlibdns.tcl]]
+package ifneeded idna 1.0 [list source [file join $dir idna.tcl]]
+package ifneeded ntlm 1.0 [list source [file join $dir ntlm.tcl]]
+package ifneeded autoconnect 0.1 [list source [file join $dir autoconnect.tcl]]
+package ifneeded socks4 1.0 [list source [file join $dir socks4.tcl]]
+package ifneeded socks5 1.0 [list source [file join $dir socks5.tcl]]
+package ifneeded https 1.0 [list source [file join $dir https.tcl]]
+
+# don't forget to define ::LOG

Deleted: trunk/tkabber/jabberlib/socks4.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/socks4.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/socks4.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,321 +0,0 @@
-# socks4.tcl ---
-#
-#	Package for using the SOCKS4a method for connecting TCP sockets.
-#	Only client side.
-#
-# Copyright (c) 2007  Mats Bengtsson
-# Modifications Copyright (c) 2007 Sergei Golovan <sgolovan at nes.ru>
-#
-#  This source file is distributed under the BSD license.
-#
-# $Id$
-
-package provide socks4 1.0
-
-namespace eval 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
-    }
-
-    # Practical when mapping errors to error codes.
-    variable iconst
-    array set iconst {
-	4   ver
-	1   cmd_connect
-	2   cmd_bind
-	90  rsp_granted
-	91  rsp_failure
-	92  rsp_errconnect
-	93  rsp_erruserid
-    }
-
-    variable debug 0
-}
-
-# socks4::connect --
-#
-#       Negotiates with a SOCKS server.
-#
-# Arguments:
-#       sock:       an open socket token 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 empty string.
-#
-# 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 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 length $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]} {
-	if {$state(async)} {
-	    after idle [list $state(-command) ERROR network-failure]
-	    Free $token
-	    return
-	} else {
-	    Free $token
-	    return -code error network-failure
-	}
-    }
-
-    # Setup timeout timer.
-    set state(timeoutid)  \
-	[after $state(-timeout) [namespace current]::Timeout $token]
-
-    fileevent $sock readable  \
-	[list [namespace current]::Response $token]
-
-    if {$state(async)} {
-	return
-    } 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 {
-	    return -code error $sock
-	}
-    }
-}
-
-# 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 socks4::Response {token} {
-    variable $token
-    upvar 0 $token state
-    variable const
-    variable iconst
-
-    Debug 2 "socks4::response"
-
-    set sock $state(sock)
-    fileevent $sock readable {}
-
-    # Read and parse status.
-    if {[catch {read $sock 2} data] || [eof $sock]} {
-	Finish $token network-failure
-	return
-    }
-    binary scan $data cc null status
-    if {![string equal $null 0]} {
-	Finish $token err_version
-	return
-    }
-    if {![info exists iconst($status)]} {
-	Finish $token err_unknown
-	return
-    } elseif {![string equal $iconst($status) rsp_granted]} {
-	Finish $token $iconst($status)
-	return
-    }
-	
-    # Read and parse port (2 bytes) and ip (4 bytes).
-    if {[catch {read $sock 6} data] || [eof $sock]} {
-	Finish $token network-failure
-	return
-    }
-    binary scan $data ccccS i0 i1 i2 i3 port
-    set addr ""
-    foreach n [list $i0 $i1 $i2 $i3] {
-	# Translate to unsigned!
-	append addr [expr ( $n + 0x100 ) % 0x100]
-	if {$n <= 2} {
-	    append addr .
-	}
-    }
-    # Translate to unsigned!
-    set port [expr ( $port + 0x10000 ) % 0x10000]
-    set state(bnd_port) $port
-    set state(bnd_addr) $addr
-
-    Finish $token
-    return
-}
-
-# 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 socks4::Timeout {token} {
-    Finish $token timeout
-    return
-}
-
-# 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 socks4::Free {token} {
-    variable $token
-    upvar 0 $token state
-
-    catch {after cancel $state(timeoutid)}
-    catch {unset state}
-    return
-}
-
-# 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 https::connect to return
-#	with either success or error.
-
-proc socks4::Finish {token {errormsg ""}} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "socks4::Finish token=$token, errormsg=$errormsg"
-
-    catch {after cancel $state(timeoutid)}
-
-    if {$state(async)} {
-	# In case of asynchronous connection we do the cleanup.
-	if {[string length $errormsg]} {
-	    catch {close $state(sock)}
-	    uplevel #0 $state(-command) [list ERROR $errormsg]
-	} else {
-	    uplevel #0 $state(-command) [list OK $state(sock)]
-	}
-	Free $token
-    } else {
-	# Otherwise we trigger state(status).
-	if {[string length $errormsg]} {
-	    catch {close $state(sock)}
-	    set state(sock) $errormsg
-	    set state(status) ERROR
-	} else {
-	    set state(status) OK
-	}
-    }
-    return
-}
-
-# https::Debug --
-#
-#	Prints debug information.
-#
-# Arguments:
-#	num	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
-#	https::debug variable is not less than num.
-
-proc socks4::Debug {num str} {
-    variable debug
-    if {$num <= $debug} {
-	puts $str
-    }
-}
-
-# Test
-if {0} {
-    set s [socket 192.168.0.1 1080]
-    set t [socks4::connect $s jabber.ru 5222 -username sergei]
-}
-

Copied: trunk/tkabber/jabberlib/socks4.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/socks4.tcl)
===================================================================
--- trunk/tkabber/jabberlib/socks4.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/socks4.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,321 @@
+# socks4.tcl ---
+#
+#	Package for using the SOCKS4a method for connecting TCP sockets.
+#	Only client side.
+#
+# Copyright (c) 2007  Mats Bengtsson
+# Modifications Copyright (c) 2007 Sergei Golovan <sgolovan at nes.ru>
+#
+#  This source file is distributed under the BSD license.
+#
+# $Id$
+
+package provide socks4 1.0
+
+namespace eval 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
+    }
+
+    # Practical when mapping errors to error codes.
+    variable iconst
+    array set iconst {
+	4   ver
+	1   cmd_connect
+	2   cmd_bind
+	90  rsp_granted
+	91  rsp_failure
+	92  rsp_errconnect
+	93  rsp_erruserid
+    }
+
+    variable debug 0
+}
+
+# socks4::connect --
+#
+#       Negotiates with a SOCKS server.
+#
+# Arguments:
+#       sock:       an open socket token 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 empty string.
+#
+# 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 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 length $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]} {
+	if {$state(async)} {
+	    after idle [list $state(-command) ERROR network-failure]
+	    Free $token
+	    return
+	} else {
+	    Free $token
+	    return -code error network-failure
+	}
+    }
+
+    # Setup timeout timer.
+    set state(timeoutid)  \
+	[after $state(-timeout) [namespace current]::Timeout $token]
+
+    fileevent $sock readable  \
+	[list [namespace current]::Response $token]
+
+    if {$state(async)} {
+	return
+    } 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 {
+	    return -code error $sock
+	}
+    }
+}
+
+# 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 socks4::Response {token} {
+    variable $token
+    upvar 0 $token state
+    variable const
+    variable iconst
+
+    Debug 2 "socks4::response"
+
+    set sock $state(sock)
+    fileevent $sock readable {}
+
+    # Read and parse status.
+    if {[catch {read $sock 2} data] || [eof $sock]} {
+	Finish $token network-failure
+	return
+    }
+    binary scan $data cc null status
+    if {![string equal $null 0]} {
+	Finish $token err_version
+	return
+    }
+    if {![info exists iconst($status)]} {
+	Finish $token err_unknown
+	return
+    } elseif {![string equal $iconst($status) rsp_granted]} {
+	Finish $token $iconst($status)
+	return
+    }
+	
+    # Read and parse port (2 bytes) and ip (4 bytes).
+    if {[catch {read $sock 6} data] || [eof $sock]} {
+	Finish $token network-failure
+	return
+    }
+    binary scan $data ccccS i0 i1 i2 i3 port
+    set addr ""
+    foreach n [list $i0 $i1 $i2 $i3] {
+	# Translate to unsigned!
+	append addr [expr ( $n + 0x100 ) % 0x100]
+	if {$n <= 2} {
+	    append addr .
+	}
+    }
+    # Translate to unsigned!
+    set port [expr ( $port + 0x10000 ) % 0x10000]
+    set state(bnd_port) $port
+    set state(bnd_addr) $addr
+
+    Finish $token
+    return
+}
+
+# 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 socks4::Timeout {token} {
+    Finish $token timeout
+    return
+}
+
+# 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 socks4::Free {token} {
+    variable $token
+    upvar 0 $token state
+
+    catch {after cancel $state(timeoutid)}
+    catch {unset state}
+    return
+}
+
+# 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 https::connect to return
+#	with either success or error.
+
+proc socks4::Finish {token {errormsg ""}} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "socks4::Finish token=$token, errormsg=$errormsg"
+
+    catch {after cancel $state(timeoutid)}
+
+    if {$state(async)} {
+	# In case of asynchronous connection we do the cleanup.
+	if {[string length $errormsg]} {
+	    catch {close $state(sock)}
+	    uplevel #0 $state(-command) [list ERROR $errormsg]
+	} else {
+	    uplevel #0 $state(-command) [list OK $state(sock)]
+	}
+	Free $token
+    } else {
+	# Otherwise we trigger state(status).
+	if {[string length $errormsg]} {
+	    catch {close $state(sock)}
+	    set state(sock) $errormsg
+	    set state(status) ERROR
+	} else {
+	    set state(status) OK
+	}
+    }
+    return
+}
+
+# https::Debug --
+#
+#	Prints debug information.
+#
+# Arguments:
+#	num	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
+#	https::debug variable is not less than num.
+
+proc socks4::Debug {num str} {
+    variable debug
+    if {$num <= $debug} {
+	puts $str
+    }
+}
+
+# Test
+if {0} {
+    set s [socket 192.168.0.1 1080]
+    set t [socks4::connect $s jabber.ru 5222 -username sergei]
+}
+

Deleted: trunk/tkabber/jabberlib/socks5.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/socks5.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/socks5.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,1063 +0,0 @@
-#  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 'Waster_' HADIMLI (minor parts)
-#  Copyright (c) 2003-2007  Mats Bengtsson
-#  Modifications Copyright (c) 2007 Sergei Golovan <sgolovan at nes.ru>
-#
-#  This source file is distributed under the BSD license.
-#
-# $Id$
-#
-# TODO:  GSSAPI authentication which is a MUST is missing.
-#        Only CMD CONNECT implemented.
-#        Do not report English text in callback but rather error keys like
-#        rsp_notallowed etc. Client done, server to go.
-
-package provide socks5 1.0
-
-namespace eval 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
-	rsp_succeeded       \x00
-	rsp_failure         \x01
-	rsp_notallowed      \x02
-	rsp_netunreachable  \x03
-	rsp_hostunreachable \x04
-	rsp_refused         \x05
-	rsp_expired         \x06
-	rsp_cmdunsupported  \x07
-	rsp_addrunsupported \x08
-    }
-
-    # Practical when mapping errors to error codes.
-    variable iconst
-    array set iconst {
-	0    rsp_succeeded
-	1    rsp_failure
-	2    rsp_notallowed
-	3    rsp_netunreachable
-	4    rsp_hostunreachable
-	5    rsp_refused
-	6    rsp_expired
-	7    rsp_cmdunsupported
-	8    rsp_addrunsupported
-    }
-
-    variable ipv4_num_re {([0-9]{1,3}\.){3}[0-9]{1,3}}
-    variable ipv6_num_re {([0-9a-fA-F]{4}:){7}[0-9a-fA-F]{4}}
-
-    variable msg
-    array set msg {
-	1 "General SOCKS server failure"
-	2 "Connection not allowed by ruleset"
-	3 "Network unreachable"
-	4 "Host unreachable"
-	5 "Connection refused"
-	6 "TTL expired"
-	7 "Command not supported"
-	8 "Address type not supported"
-    }
-
-    variable debug 0
-    variable uid 0
-}
-
-# socks5::connect --
-#
-#       Negotiates with a SOCKS server.
-#
-# Arguments:
-#       sock:       an open socket token to the SOCKS server
-#       addr:       the peer address, not SOCKS 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 empty string.
-#
-# 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 socks5::connect {sock addr port args} {
-    variable msg
-    variable const
-    variable uid
-
-    Debug 2 "socks5::init $addr $port $args"
-
-    # Initialize the state variable, an array.  We'll return the
-    # name of this array as the token for the transaction.
-
-    set token [namespace current]::[incr uid]
-    variable $token
-    upvar 0 $token state
-
-    array set state {
-	-password         ""
-	-timeout          60000
-	-username         ""
-	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 {[info exists state(-command)] && [string length $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 2 "\tsend: ver nmethods methods"
-
-    # Request authorization methods
-    if {[catch {
-	puts -nonewline $sock "$const(ver)$nmethods$methods"
-	flush $sock
-    } err]} {
-	if {$state(async)} {
-	    after idle [list $state(-command) ERROR network-failure]
-	    Free $token
-	    return
-	} else {
-	    Free $token
-	    return -code error $err
-	}
-    }
-
-    # Setup timeout timer.
-    set state(timeoutid)  \
-	[after $state(-timeout) [namespace current]::Timeout $token]
-
-    fileevent $sock readable  \
-	[list [namespace current]::ResponseMethod $token]
-
-    if {$state(async)} {
-	return
-    } 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 {
-	    return -code error $sock
-	}
-    }
-}
-
-# 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 socks5::ResponseMethod {token} {
-    variable $token
-    variable const
-    upvar 0 $token state
-
-    Debug 2 "socks5::ResponseMethod"
-
-    set sock $state(sock)
-
-    if {[catch {read $sock 2} data] || [eof $sock]} {
-	Finish $token network-failure
-	return
-    }
-    set serv_ver ""
-    set method $const(nomatchingmethod)
-    binary scan $data cc serv_ver smethod
-    Debug 2 "\tserv_ver=$serv_ver, smethod=$smethod"
-
-    if {![string equal $serv_ver 5]} {
-	Finish $token err_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 err_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 2 "\tsend: 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 network-failure
-	    return
-	}
-
-	fileevent $sock readable  \
-	    [list [namespace current]::ResponseAuth $token]
-    } else {
-	Finish $token err_unsupported_method
-    }
-    return
-}
-
-# 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 socks5::ResponseAuth {token} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "socks5::ResponseAuth"
-
-    set sock $state(sock)
-
-    if {[catch {read $sock 2} data] || [eof $sock]} {
-	Finish $token network-failure
-	return
-    }
-
-    set auth_ver -1
-    set status -1
-    binary scan $data cc auth_ver status
-    Debug 2 "\tauth_ver=$auth_ver, status=$status"
-
-    if {![string equal $auth_ver 1]} {
-	Finish $token err_authentication_unsupported
-	return
-    }
-    if {![string equal $status 0]} {
-	Finish $token err_authorization
-	return
-    }
-
-    # Now, request address and port.
-    Request $token
-    return
-}
-
-# 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 socks5::Request {token} {
-    variable $token
-    variable const
-    variable ipv4_num_re
-    variable ipv6_num_re
-    upvar 0 $token state
-
-    Debug 2 "socks5::Request"
-
-    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 {[regexp $ipv4_num_re $state(addr)]} {
-	Debug 2 "\tipv4"
-
-	# IPv4 numerical address.
-	set atyp_addr_port $const(atyp_ipv4)
-    	foreach i [split $state(addr) .] {
-	    append atyp_addr_port [binary format c $i]
-	}
-	append atyp_addr_port $bport
-    } elseif {[regexp $ipv6_num_re $state(addr)]} {
-	# todo
-    } else {
-	Debug 2 "\tdomainname"
-
-	# 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 2 "\tsend: 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 network-failure
-	return
-    }
-
-    fileevent $sock readable  \
-	[list [namespace current]::Response $token]
-    return
-}
-
-# 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 socks5::Response {token} {
-    variable $token
-    upvar 0 $token state
-    variable iconst
-
-    Debug 2 "socks5::Response"
-
-    set sock $state(sock)
-    fileevent $sock readable {}
-
-    # Start by reading ver+cmd+rsv.
-    if {[catch {read $sock 3} data] || [eof $sock]} {
-	Finish $token network-failure
-	return
-    }
-    set serv_ver ""
-    set rep ""
-    binary scan $data ccc serv_ver rep rsv
-
-    if {![string equal $serv_ver 5]} {
-	Finish $token err_version
-	return
-    }
-    if {$rep == 0} {
-	# OK
-    } elseif {[info exists iconst($rep)]} {
-	Finish $token $iconst($rep)
-	return
-    } else {
-	Finish $token err_unknown
-	return
-    }
-
-    # Now parse the variable length atyp+addr+host.
-    if {[catch {ParseAtypAddr $token addr port} err]} {
-	Finish $token $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
-    return
-}
-
-# 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 socks5::ParseAtypAddr {token addrVar portVar} {
-    variable $token
-    variable const
-    upvar 0 $token state
-    upvar $addrVar addr
-    upvar $portVar port
-
-    Debug 2 "socks5::ParseAtypAddr"
-
-    set sock $state(sock)
-
-    # Start by reading atyp.
-    if {[catch {read $sock 1} data] || [eof $sock]} {
-	return -code error network-failure
-    }
-    set atyp ""
-    binary scan $data c atyp
-    Debug 2 "\tatyp=$atyp"
-
-    # Treat the three address types in order.
-    switch -- $atyp {
-	1 {
-	    if {[catch {read $sock 6} data] || [eof $sock]} {
-		return -code error network-failure
-	    }
-	    binary scan $data ccccS i0 i1 i2 i3 port
-	    set addr ""
-	    foreach n [list $i0 $i1 $i2 $i3] {
-		# Translate to unsigned!
-		append addr [expr ( $n + 0x100 ) % 0x100]
-		if {$n <= 2} {
-		    append addr .
-		}
-	    }
-	    # Translate to unsigned!
-	    set port [expr ( $port + 0x10000 ) % 0x10000]
-	}
-	3 {
-	    if {[catch {read $sock 1} data] || [eof $sock]} {
-		return -code error network-failure
-	    }
-	    binary scan $data c len
-	    Debug 2 "\tlen=$len"
-	    set len [expr ( $len + 0x100 ) % 0x100]
-	    if {[catch {read $sock $len} data] || [eof $sock]} {
-		return -code error network-failure
-	    }
-	    set addr $data
-	    Debug 2 "\taddr=$addr"
-	    if {[catch {read $sock 2} data] || [eof $sock]} {
-		return -code error network-failure
-	    }
-	    binary scan $data S port
-	    # Translate to unsigned!
-	    set port [expr ( $port + 0x10000 ) % 0x10000]
-	    Debug 2 "\tport=$port"
-	}
-	4 {
-	    # todo
-	}
-	default {
-	    return -code error err_unknown_address_type
-	}
-    }
-}
-
-proc socks5::GetIpAndPort {token} {
-    variable $token
-    upvar 0 $token state
-    return [list $state(bnd_addr) $state(bnd_port)]
-}
-
-# 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 socks5::Timeout {token} {
-    Finish $token timeout
-    return
-}
-
-# 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 socks5::Free {token} {
-    variable $token
-    upvar 0 $token state
-
-    catch {after cancel $state(timeoutid)}
-    catch {unset state}
-}
-
-# 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 https::connect to return
-#	with either success or error.
-
-proc socks5::Finish {token {errormsg ""}} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "socks5::Finish errormsg=$errormsg"
-
-    catch {after cancel $state(timeoutid)}
-
-    if {$state(async)} {
-	# In case of asynchronous connection we do the cleanup.
-	if {[string length $errormsg]} {
-	    catch {close $state(sock)}
-	    uplevel #0 $state(-command) [list ERROR $errormsg]
-	} else {
-	    uplevel #0 $state(-command) [list OK $state(sock)]
-	}
-	Free $token
-    } else {
-	# Otherwise we trigger state(status).
-	if {[string length $errormsg]} {
-	    catch {close $state(sock)}
-	    set state(sock) $errormsg
-	    set state(status) ERROR
-	} else {
-	    set state(status) OK
-	}
-    }
-    return
-}
-
-# socks5::serverinit --
-#
-#       The SOCKS5 server. Negotiates with a SOCKS5 client.
-#       Sets up bytestreams between client and DST.
-#
-# Arguments:
-#       sock:       socket connected to the servers socket
-#       ip:         ip address
-#       port:       it's port number
-#       command:    tclProc for callabcks {token type args}
-#       args:
-#               -blocksize     bytes
-#               -bytestream    boolean
-#               -opendstsocket boolean
-#               -timeout       millisecs
-#
-# Results:
-#       token.
-
-proc socks5::serverinit {sock ip port command args} {
-    variable msg
-    variable const
-    variable uid
-
-    Debug 2 "socks5::serverinit"
-
-    # Initialize the state variable, an array.  We'll return the
-    # name of this array as the token for the transaction.
-
-    set token [namespace current]::[incr uid]
-    variable $token
-    upvar 0 $token state
-
-    array set state {
-	-blocksize        8192
-	-bytestream       1
-	-opendstsocket    1
-	-timeout          60000
-	auth              0
-	state             ""
-	status            ""
-    }
-    array set state [list        \
-      command       $command     \
-      sock          $sock]
-    array set state $args
-
-    fconfigure $sock -translation {binary binary} -blocking 0
-    fileevent $sock writable {}
-
-    # Start by reading the method stuff.
-    if {[catch {read $sock 2} data] || [eof $sock]} {
-	serv_finish $token network-failure
-	return
-    }
-    set ver ""
-    set method $const(nomatchingmethod)
-    binary scan $data cc ver nmethods
-    set nmethods [expr ( $nmethods + 0x100 ) % 0x100]
-    Debug 2 "\tver=$ver, nmethods=$nmethods"
-
-    # Error checking. Must have either noauth or userpasswdauth.
-    if {![string equal $ver 5]} {
-	serv_finish $token "Socks server isn't version 5!"
-	return
-    }
-    for {set i 0} {$i < $nmethods} {incr i} {
-	if {[catch {read $sock 1} data] || [eof $sock]} {
-	    serv_finish $token network-failure
-	    return
-	}
-	binary scan $data c method
-	set method [expr ( $method + 0x100 ) % 0x100]
-	Debug 2 "\tmethod=$method"
-	if {[string equal $method 0]} {
-	    set noauthmethod 1
-	} elseif {[string equal $method 2]} {
-	    set userpasswdmethod 1
-	}
-    }
-    set isok 1
-    if {[info exists userpasswdmethod]} {
-	set ans "$const(ver)$const(auth_userpass)"
-	set state(auth) 1
-    } elseif {[info exists noauthmethod]} {
-	set ans "$const(ver)$const(auth_no)"
-    } else {
-	set ans "$const(ver)$const(nomatchingmethod)"
-	set isok 0
-    }
-
-    Debug 2 "\tsend: ver method"
-    if {[catch {
-	puts -nonewline $sock $ans
-	flush $sock
-    } err]} {
-	serv_finish $token $err
-	return
-    }
-    if {!$isok} {
-	serv_finish $token "Unrecognized method requested by client"
-	return
-    }
-
-    if {$state(auth)} {
-	fileevent $sock readable  \
-	  [list [namespace current]::serv_auth $token]
-    } else {
-	fileevent $sock readable  \
-	  [list [namespace current]::serv_request $token]
-    }
-    return $token
-}
-
-proc socks5::serv_auth {token} {
-    variable $token
-    variable const
-    upvar 0 $token state
-
-    Debug 2 "socks5::serv_auth"
-
-    set sock $state(sock)
-    fileevent $sock readable {}
-
-    if {[catch {read $sock 2} data] || [eof $sock]} {
-	serv_finish $token network-failure
-	return
-    }
-    set auth_ver ""
-    set method $const(nomatchingmethod)
-    binary scan $data cc auth_ver ulen
-    set ulen [expr ( $ulen + 0x100 ) % 0x100]
-    Debug 2 "\tauth_ver=$auth_ver, ulen=$ulen"
-    if {![string equal $auth_ver 2]} {
-	serv_finish $token "Wrong authorization method"
-	return
-    }
-    if {[catch {read $sock $ulen} data] || [eof $sock]} {
-	return -code error network-failure
-    }
-    set state(username) $data
-    Debug 2 "\tusername=$data"
-    if {[catch {read $sock 1} data] || [eof $sock]} {
-	serv_finish $token network-failure
-	return
-    }
-    binary scan $data c plen
-    set plen [expr ( $plen + 0x100 ) % 0x100]
-    Debug 2 "\tplen=$plen"
-    if {[catch {read $sock $plen} data] || [eof $sock]} {
-	serv_finish $token network-failure
-	return
-    }
-    set state(password) $data
-    Debug 2 "\tpassword=$data"
-
-    set ans [uplevel #0 $state(command) [list $token authorize \
-      -username $state(username) -password $state(password)]]
-    if {!$ans} {
-	catch {
-	    puts -nonewline $state(sock) "\x00\x01"
-	}
-	serv_finish $token notauthorized
-	return
-    }
-
-    # Write auth response.
-    if {[catch {
-	puts -nonewline $sock "\x01\x00"
-	flush $sock
-    } err]} {
-	serv_finish $token $err
-	return
-    }
-    fileevent $sock readable  \
-      [list [namespace current]::serv_request $token]
-}
-
-proc socks5::serv_request {token} {
-    variable $token
-    variable const
-    variable msg
-    variable ipv4_num_re
-    variable ipv6_num_re
-    upvar 0 $token state
-
-    Debug 2 "socks5::serv_request"
-
-    set sock $state(sock)
-
-    # Start by reading ver+cmd+rsv.
-    if {[catch {read $sock 3} data] || [eof $sock]} {
-	serv_finish $token network-failure
-	return
-    }
-    set ver ""
-    set cmd ""
-    set rsv ""
-    binary scan $data ccc ver cmd rsv
-    Debug 2 "\tver=$ver, cmd=$cmd, rsv=$rsv"
-
-    if {![string equal $ver 5]} {
-	serv_finish $token "Socks server isn't version 5!"
-	return
-    }
-    if {![string equal $cmd 1]} {
-	serv_finish $token "Unsuported CMD, must be CONNECT"
-	return
-    }
-
-    # Now parse the variable length atyp+addr+host.
-    if {[catch {ParseAtypAddr $token addr port} err]} {
-	serv_finish $token $err
-	return
-    }
-
-    # Store in our state array.
-    set state(dst_addr) $addr
-    set state(dst_port) $port
-
-    # Init the SOCKS connection to dst if wanted. Else???
-    if {$state(-opendstsocket)} {
-	if {[catch {socket -async $addr $port} sock_dst]} {
-	    serv_finish $token network-failure
-	    return
-	}
-	set state(sock_dst) $sock_dst
-
-	# Setup timeout timer.
-	set state(timeoutid)  \
-	  [after $state(-timeout) [namespace current]::ServTimeout $token]
-	fileevent $sock_dst writable  \
-	  [list [namespace current]::serv_dst_connect $token]
-    } else {
-
-	# ???
-	uplevel #0 $state(command) [list $token reply]
-    }
-}
-
-proc socks5::serv_dst_connect {token} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "socks5::serv_dst_connect"
-    fileevent $state(sock_dst) writable {}
-    after cancel $state(timeoutid)
-
-    set sock_dst $state(sock_dst)
-    if {[eof $sock_dst]} {
-	serv_finish $token network-failure
-	return
-    }
-
-    if {[catch {
-	fconfigure $sock_dst -translation {binary binary} -blocking 0
-	foreach {bnd_ip bnd_addr bnd_port} [fconfigure $sock_dst -sockname] \
-	  break
-    } err]} {
-	Debug 2 "\tfconfigure failed: $err"
-	serv_finish $token network-failure
-	return
-    }
-    array set state [list bnd_ip $bnd_ip bnd_addr $bnd_addr bnd_port $bnd_port]
-    serv_reply $token
-}
-
-proc socks5::serv_reply {token} {
-    variable $token
-    variable const
-    upvar 0 $token state
-
-    Debug 2 "socks5:serv_reply"
-    set sock $state(sock)
-    set bnd_addr $state(bnd_addr)
-    set bnd_port $state(bnd_port)
-    Debug 2 "\tbnd_addr=$bnd_addr, bnd_port=$bnd_port"
-
-    set aconst "$const(ver)$const(rsp_succeeded)$const(rsv)"
-
-    # Domain length (binary 1 byte)
-    set dlen [binary format c [string length $bnd_addr]]
-
-    # Network byte-ordered port (2 binary-bytes, short)
-    set bport [binary format S $bnd_port]
-    set atyp_addr_port \
-      "$const(atyp_domainname)$dlen$bnd_addr$bport"
-
-    # We send SOCKS server's reply to client.
-    Debug 2 "\tsend: ver rep rsv atyp_domainname dlen bnd_addr bnd_port"
-    if {[catch {
-	puts -nonewline $sock "$aconst$atyp_addr_port"
-	flush $sock
-    } err]} {
-	serv_finish $token $err
-	return
-    }
-
-    # New we are ready to stream data if wanted.
-    if {$state(-bytestream)} {
-	establish_bytestreams $token
-    } else {
-	# ???
-	serv_finish $token
-    }
-}
-
-proc socks5::establish_bytestreams {token} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "socks5::establish_bytestreams"
-    set sock $state(sock)
-    set sock_dst $state(sock_dst)
-
-    # Forward client stream to dst.
-    fileevent $sock readable  \
-      [list [namespace current]::read_stream $token $sock $sock_dst]
-
-    # Forward dst stream to client.
-    fileevent $sock_dst readable  \
-      [list [namespace current]::read_stream $token $sock_dst $sock]
-}
-
-proc socks5::read_stream {token in out} {
-    variable $token
-    upvar 0 $token state
-
-    set primary [string equal $state(sock) $in]
-    Debug 3 "::socks5::read_stream primary=$primary: in=$in, out=$out"
-
-    # If any of client (sock) or dst (sock_dst) closes down we shall
-    # close down everthing.
-    # Only client or dst can determine if a close down is premature.
-
-    if {[catch {eof $in} iseof] || $iseof} {
-	serv_finish $token
-    } elseif {[catch {eof $out} iseof] || $iseof} {
-	serv_finish $token
-    } elseif {[catch {read $in} data]} {
-	serv_finish $token network-failure
-    } else {
-
-	# We could wait here (in the event loop) for channel to be writable
-	# to avoid any blocking...
-	# BUT, this would keep $data in memory for a while which is a bad idee.
-	if {0} {
-	    fileevent $out writable  \
-	      [list [namespace current]::stream_writeable $token $primary]
-	    vwait $token\(writetrigger${primary})
-	}
-	if {[catch {puts -nonewline $out $data; flush $out}]} {
-	    serv_finish $token network-failure
-	}
-    }
-}
-
-proc socks5::stream_writeable {token primary} {
-    variable $token
-    upvar 0 $token state
-
-    incr state(writetrigger${primary})
-}
-
-proc socks5::serv_finish {token {errormsg ""}} {
-    variable $token
-    upvar 0 $token state
-
-    Debug 2 "socks5::serv_finish"
-    if {$state(-bytestream)} {
-	catch {close $state(sock)}
-	catch {close $state(sock_dst)}
-    }
-    if {[string length $errormsg]} {
-	uplevel #0 $state(command) [list $token $errormsg]
-    } else {
-	uplevel #0 $state(command) [list $token ok]
-    }
-    unset state
-}
-
-#       Just a trigger for vwait.
-
-proc socks5::readable {token} {
-    variable $token
-    upvar 0 $token state
-
-    incr state(trigger)
-}
-
-proc socks5::ServTimeout {token} {
-    variable $token
-    upvar 0 $token state
-
-    serv_finish $token timeout
-}
-
-proc socks5::Debug {num str} {
-    variable debug
-    if {$num <= $debug} {
-	puts $str
-    }
-}
-
-# Test code...
-
-if {0} {
-
-    # Server
-    proc serv_cmd {token status} {
-	puts "server: token=$token, status=$status"
-	switch -- $status {
-	    ok {
-
-	    }
-	    authorize {
-		# Here we should check that the username and password is ok.
-		return 1
-	    }
-	    default {
-		puts "error $status"
-	    }
-	}
-    }
-    proc server_connect {sock ip port} {
-	fileevent $sock readable  \
-	  [list socks5::serverinit $sock $ip $port serv_cmd]
-    }
-    socket -server server_connect 1080
-}
-
-if {0} {
-    # Client
-    proc cb {status socket} {
-	puts "client: status=$status, socket=$socket"
-	if {$status eq "OK"} {
-	    fconfigure $socket -buffering none
-	    close $socket
-	}
-    }
-    proc dump {} {
-	puts "dump:"
-    }
-    set s [socket 192.168.0.1 1080]
-    #socks5::connect $s jabber.ru 5222 -command cb
-    socks5::connect $s jabber.ru 5222 -command cb -username xxx -password xxx
-}
-

Copied: trunk/tkabber/jabberlib/socks5.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/socks5.tcl)
===================================================================
--- trunk/tkabber/jabberlib/socks5.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/socks5.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,1063 @@
+#  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 'Waster_' HADIMLI (minor parts)
+#  Copyright (c) 2003-2007  Mats Bengtsson
+#  Modifications Copyright (c) 2007 Sergei Golovan <sgolovan at nes.ru>
+#
+#  This source file is distributed under the BSD license.
+#
+# $Id$
+#
+# TODO:  GSSAPI authentication which is a MUST is missing.
+#        Only CMD CONNECT implemented.
+#        Do not report English text in callback but rather error keys like
+#        rsp_notallowed etc. Client done, server to go.
+
+package provide socks5 1.0
+
+namespace eval 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
+	rsp_succeeded       \x00
+	rsp_failure         \x01
+	rsp_notallowed      \x02
+	rsp_netunreachable  \x03
+	rsp_hostunreachable \x04
+	rsp_refused         \x05
+	rsp_expired         \x06
+	rsp_cmdunsupported  \x07
+	rsp_addrunsupported \x08
+    }
+
+    # Practical when mapping errors to error codes.
+    variable iconst
+    array set iconst {
+	0    rsp_succeeded
+	1    rsp_failure
+	2    rsp_notallowed
+	3    rsp_netunreachable
+	4    rsp_hostunreachable
+	5    rsp_refused
+	6    rsp_expired
+	7    rsp_cmdunsupported
+	8    rsp_addrunsupported
+    }
+
+    variable ipv4_num_re {([0-9]{1,3}\.){3}[0-9]{1,3}}
+    variable ipv6_num_re {([0-9a-fA-F]{4}:){7}[0-9a-fA-F]{4}}
+
+    variable msg
+    array set msg {
+	1 "General SOCKS server failure"
+	2 "Connection not allowed by ruleset"
+	3 "Network unreachable"
+	4 "Host unreachable"
+	5 "Connection refused"
+	6 "TTL expired"
+	7 "Command not supported"
+	8 "Address type not supported"
+    }
+
+    variable debug 0
+    variable uid 0
+}
+
+# socks5::connect --
+#
+#       Negotiates with a SOCKS server.
+#
+# Arguments:
+#       sock:       an open socket token to the SOCKS server
+#       addr:       the peer address, not SOCKS 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 empty string.
+#
+# 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 socks5::connect {sock addr port args} {
+    variable msg
+    variable const
+    variable uid
+
+    Debug 2 "socks5::init $addr $port $args"
+
+    # Initialize the state variable, an array.  We'll return the
+    # name of this array as the token for the transaction.
+
+    set token [namespace current]::[incr uid]
+    variable $token
+    upvar 0 $token state
+
+    array set state {
+	-password         ""
+	-timeout          60000
+	-username         ""
+	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 {[info exists state(-command)] && [string length $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 2 "\tsend: ver nmethods methods"
+
+    # Request authorization methods
+    if {[catch {
+	puts -nonewline $sock "$const(ver)$nmethods$methods"
+	flush $sock
+    } err]} {
+	if {$state(async)} {
+	    after idle [list $state(-command) ERROR network-failure]
+	    Free $token
+	    return
+	} else {
+	    Free $token
+	    return -code error $err
+	}
+    }
+
+    # Setup timeout timer.
+    set state(timeoutid)  \
+	[after $state(-timeout) [namespace current]::Timeout $token]
+
+    fileevent $sock readable  \
+	[list [namespace current]::ResponseMethod $token]
+
+    if {$state(async)} {
+	return
+    } 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 {
+	    return -code error $sock
+	}
+    }
+}
+
+# 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 socks5::ResponseMethod {token} {
+    variable $token
+    variable const
+    upvar 0 $token state
+
+    Debug 2 "socks5::ResponseMethod"
+
+    set sock $state(sock)
+
+    if {[catch {read $sock 2} data] || [eof $sock]} {
+	Finish $token network-failure
+	return
+    }
+    set serv_ver ""
+    set method $const(nomatchingmethod)
+    binary scan $data cc serv_ver smethod
+    Debug 2 "\tserv_ver=$serv_ver, smethod=$smethod"
+
+    if {![string equal $serv_ver 5]} {
+	Finish $token err_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 err_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 2 "\tsend: 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 network-failure
+	    return
+	}
+
+	fileevent $sock readable  \
+	    [list [namespace current]::ResponseAuth $token]
+    } else {
+	Finish $token err_unsupported_method
+    }
+    return
+}
+
+# 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 socks5::ResponseAuth {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "socks5::ResponseAuth"
+
+    set sock $state(sock)
+
+    if {[catch {read $sock 2} data] || [eof $sock]} {
+	Finish $token network-failure
+	return
+    }
+
+    set auth_ver -1
+    set status -1
+    binary scan $data cc auth_ver status
+    Debug 2 "\tauth_ver=$auth_ver, status=$status"
+
+    if {![string equal $auth_ver 1]} {
+	Finish $token err_authentication_unsupported
+	return
+    }
+    if {![string equal $status 0]} {
+	Finish $token err_authorization
+	return
+    }
+
+    # Now, request address and port.
+    Request $token
+    return
+}
+
+# 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 socks5::Request {token} {
+    variable $token
+    variable const
+    variable ipv4_num_re
+    variable ipv6_num_re
+    upvar 0 $token state
+
+    Debug 2 "socks5::Request"
+
+    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 {[regexp $ipv4_num_re $state(addr)]} {
+	Debug 2 "\tipv4"
+
+	# IPv4 numerical address.
+	set atyp_addr_port $const(atyp_ipv4)
+    	foreach i [split $state(addr) .] {
+	    append atyp_addr_port [binary format c $i]
+	}
+	append atyp_addr_port $bport
+    } elseif {[regexp $ipv6_num_re $state(addr)]} {
+	# todo
+    } else {
+	Debug 2 "\tdomainname"
+
+	# 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 2 "\tsend: 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 network-failure
+	return
+    }
+
+    fileevent $sock readable  \
+	[list [namespace current]::Response $token]
+    return
+}
+
+# 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 socks5::Response {token} {
+    variable $token
+    upvar 0 $token state
+    variable iconst
+
+    Debug 2 "socks5::Response"
+
+    set sock $state(sock)
+    fileevent $sock readable {}
+
+    # Start by reading ver+cmd+rsv.
+    if {[catch {read $sock 3} data] || [eof $sock]} {
+	Finish $token network-failure
+	return
+    }
+    set serv_ver ""
+    set rep ""
+    binary scan $data ccc serv_ver rep rsv
+
+    if {![string equal $serv_ver 5]} {
+	Finish $token err_version
+	return
+    }
+    if {$rep == 0} {
+	# OK
+    } elseif {[info exists iconst($rep)]} {
+	Finish $token $iconst($rep)
+	return
+    } else {
+	Finish $token err_unknown
+	return
+    }
+
+    # Now parse the variable length atyp+addr+host.
+    if {[catch {ParseAtypAddr $token addr port} err]} {
+	Finish $token $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
+    return
+}
+
+# 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 socks5::ParseAtypAddr {token addrVar portVar} {
+    variable $token
+    variable const
+    upvar 0 $token state
+    upvar $addrVar addr
+    upvar $portVar port
+
+    Debug 2 "socks5::ParseAtypAddr"
+
+    set sock $state(sock)
+
+    # Start by reading atyp.
+    if {[catch {read $sock 1} data] || [eof $sock]} {
+	return -code error network-failure
+    }
+    set atyp ""
+    binary scan $data c atyp
+    Debug 2 "\tatyp=$atyp"
+
+    # Treat the three address types in order.
+    switch -- $atyp {
+	1 {
+	    if {[catch {read $sock 6} data] || [eof $sock]} {
+		return -code error network-failure
+	    }
+	    binary scan $data ccccS i0 i1 i2 i3 port
+	    set addr ""
+	    foreach n [list $i0 $i1 $i2 $i3] {
+		# Translate to unsigned!
+		append addr [expr ( $n + 0x100 ) % 0x100]
+		if {$n <= 2} {
+		    append addr .
+		}
+	    }
+	    # Translate to unsigned!
+	    set port [expr ( $port + 0x10000 ) % 0x10000]
+	}
+	3 {
+	    if {[catch {read $sock 1} data] || [eof $sock]} {
+		return -code error network-failure
+	    }
+	    binary scan $data c len
+	    Debug 2 "\tlen=$len"
+	    set len [expr ( $len + 0x100 ) % 0x100]
+	    if {[catch {read $sock $len} data] || [eof $sock]} {
+		return -code error network-failure
+	    }
+	    set addr $data
+	    Debug 2 "\taddr=$addr"
+	    if {[catch {read $sock 2} data] || [eof $sock]} {
+		return -code error network-failure
+	    }
+	    binary scan $data S port
+	    # Translate to unsigned!
+	    set port [expr ( $port + 0x10000 ) % 0x10000]
+	    Debug 2 "\tport=$port"
+	}
+	4 {
+	    # todo
+	}
+	default {
+	    return -code error err_unknown_address_type
+	}
+    }
+}
+
+proc socks5::GetIpAndPort {token} {
+    variable $token
+    upvar 0 $token state
+    return [list $state(bnd_addr) $state(bnd_port)]
+}
+
+# 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 socks5::Timeout {token} {
+    Finish $token timeout
+    return
+}
+
+# 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 socks5::Free {token} {
+    variable $token
+    upvar 0 $token state
+
+    catch {after cancel $state(timeoutid)}
+    catch {unset state}
+}
+
+# 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 https::connect to return
+#	with either success or error.
+
+proc socks5::Finish {token {errormsg ""}} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "socks5::Finish errormsg=$errormsg"
+
+    catch {after cancel $state(timeoutid)}
+
+    if {$state(async)} {
+	# In case of asynchronous connection we do the cleanup.
+	if {[string length $errormsg]} {
+	    catch {close $state(sock)}
+	    uplevel #0 $state(-command) [list ERROR $errormsg]
+	} else {
+	    uplevel #0 $state(-command) [list OK $state(sock)]
+	}
+	Free $token
+    } else {
+	# Otherwise we trigger state(status).
+	if {[string length $errormsg]} {
+	    catch {close $state(sock)}
+	    set state(sock) $errormsg
+	    set state(status) ERROR
+	} else {
+	    set state(status) OK
+	}
+    }
+    return
+}
+
+# socks5::serverinit --
+#
+#       The SOCKS5 server. Negotiates with a SOCKS5 client.
+#       Sets up bytestreams between client and DST.
+#
+# Arguments:
+#       sock:       socket connected to the servers socket
+#       ip:         ip address
+#       port:       it's port number
+#       command:    tclProc for callabcks {token type args}
+#       args:
+#               -blocksize     bytes
+#               -bytestream    boolean
+#               -opendstsocket boolean
+#               -timeout       millisecs
+#
+# Results:
+#       token.
+
+proc socks5::serverinit {sock ip port command args} {
+    variable msg
+    variable const
+    variable uid
+
+    Debug 2 "socks5::serverinit"
+
+    # Initialize the state variable, an array.  We'll return the
+    # name of this array as the token for the transaction.
+
+    set token [namespace current]::[incr uid]
+    variable $token
+    upvar 0 $token state
+
+    array set state {
+	-blocksize        8192
+	-bytestream       1
+	-opendstsocket    1
+	-timeout          60000
+	auth              0
+	state             ""
+	status            ""
+    }
+    array set state [list        \
+      command       $command     \
+      sock          $sock]
+    array set state $args
+
+    fconfigure $sock -translation {binary binary} -blocking 0
+    fileevent $sock writable {}
+
+    # Start by reading the method stuff.
+    if {[catch {read $sock 2} data] || [eof $sock]} {
+	serv_finish $token network-failure
+	return
+    }
+    set ver ""
+    set method $const(nomatchingmethod)
+    binary scan $data cc ver nmethods
+    set nmethods [expr ( $nmethods + 0x100 ) % 0x100]
+    Debug 2 "\tver=$ver, nmethods=$nmethods"
+
+    # Error checking. Must have either noauth or userpasswdauth.
+    if {![string equal $ver 5]} {
+	serv_finish $token "Socks server isn't version 5!"
+	return
+    }
+    for {set i 0} {$i < $nmethods} {incr i} {
+	if {[catch {read $sock 1} data] || [eof $sock]} {
+	    serv_finish $token network-failure
+	    return
+	}
+	binary scan $data c method
+	set method [expr ( $method + 0x100 ) % 0x100]
+	Debug 2 "\tmethod=$method"
+	if {[string equal $method 0]} {
+	    set noauthmethod 1
+	} elseif {[string equal $method 2]} {
+	    set userpasswdmethod 1
+	}
+    }
+    set isok 1
+    if {[info exists userpasswdmethod]} {
+	set ans "$const(ver)$const(auth_userpass)"
+	set state(auth) 1
+    } elseif {[info exists noauthmethod]} {
+	set ans "$const(ver)$const(auth_no)"
+    } else {
+	set ans "$const(ver)$const(nomatchingmethod)"
+	set isok 0
+    }
+
+    Debug 2 "\tsend: ver method"
+    if {[catch {
+	puts -nonewline $sock $ans
+	flush $sock
+    } err]} {
+	serv_finish $token $err
+	return
+    }
+    if {!$isok} {
+	serv_finish $token "Unrecognized method requested by client"
+	return
+    }
+
+    if {$state(auth)} {
+	fileevent $sock readable  \
+	  [list [namespace current]::serv_auth $token]
+    } else {
+	fileevent $sock readable  \
+	  [list [namespace current]::serv_request $token]
+    }
+    return $token
+}
+
+proc socks5::serv_auth {token} {
+    variable $token
+    variable const
+    upvar 0 $token state
+
+    Debug 2 "socks5::serv_auth"
+
+    set sock $state(sock)
+    fileevent $sock readable {}
+
+    if {[catch {read $sock 2} data] || [eof $sock]} {
+	serv_finish $token network-failure
+	return
+    }
+    set auth_ver ""
+    set method $const(nomatchingmethod)
+    binary scan $data cc auth_ver ulen
+    set ulen [expr ( $ulen + 0x100 ) % 0x100]
+    Debug 2 "\tauth_ver=$auth_ver, ulen=$ulen"
+    if {![string equal $auth_ver 2]} {
+	serv_finish $token "Wrong authorization method"
+	return
+    }
+    if {[catch {read $sock $ulen} data] || [eof $sock]} {
+	return -code error network-failure
+    }
+    set state(username) $data
+    Debug 2 "\tusername=$data"
+    if {[catch {read $sock 1} data] || [eof $sock]} {
+	serv_finish $token network-failure
+	return
+    }
+    binary scan $data c plen
+    set plen [expr ( $plen + 0x100 ) % 0x100]
+    Debug 2 "\tplen=$plen"
+    if {[catch {read $sock $plen} data] || [eof $sock]} {
+	serv_finish $token network-failure
+	return
+    }
+    set state(password) $data
+    Debug 2 "\tpassword=$data"
+
+    set ans [uplevel #0 $state(command) [list $token authorize \
+      -username $state(username) -password $state(password)]]
+    if {!$ans} {
+	catch {
+	    puts -nonewline $state(sock) "\x00\x01"
+	}
+	serv_finish $token notauthorized
+	return
+    }
+
+    # Write auth response.
+    if {[catch {
+	puts -nonewline $sock "\x01\x00"
+	flush $sock
+    } err]} {
+	serv_finish $token $err
+	return
+    }
+    fileevent $sock readable  \
+      [list [namespace current]::serv_request $token]
+}
+
+proc socks5::serv_request {token} {
+    variable $token
+    variable const
+    variable msg
+    variable ipv4_num_re
+    variable ipv6_num_re
+    upvar 0 $token state
+
+    Debug 2 "socks5::serv_request"
+
+    set sock $state(sock)
+
+    # Start by reading ver+cmd+rsv.
+    if {[catch {read $sock 3} data] || [eof $sock]} {
+	serv_finish $token network-failure
+	return
+    }
+    set ver ""
+    set cmd ""
+    set rsv ""
+    binary scan $data ccc ver cmd rsv
+    Debug 2 "\tver=$ver, cmd=$cmd, rsv=$rsv"
+
+    if {![string equal $ver 5]} {
+	serv_finish $token "Socks server isn't version 5!"
+	return
+    }
+    if {![string equal $cmd 1]} {
+	serv_finish $token "Unsuported CMD, must be CONNECT"
+	return
+    }
+
+    # Now parse the variable length atyp+addr+host.
+    if {[catch {ParseAtypAddr $token addr port} err]} {
+	serv_finish $token $err
+	return
+    }
+
+    # Store in our state array.
+    set state(dst_addr) $addr
+    set state(dst_port) $port
+
+    # Init the SOCKS connection to dst if wanted. Else???
+    if {$state(-opendstsocket)} {
+	if {[catch {socket -async $addr $port} sock_dst]} {
+	    serv_finish $token network-failure
+	    return
+	}
+	set state(sock_dst) $sock_dst
+
+	# Setup timeout timer.
+	set state(timeoutid)  \
+	  [after $state(-timeout) [namespace current]::ServTimeout $token]
+	fileevent $sock_dst writable  \
+	  [list [namespace current]::serv_dst_connect $token]
+    } else {
+
+	# ???
+	uplevel #0 $state(command) [list $token reply]
+    }
+}
+
+proc socks5::serv_dst_connect {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "socks5::serv_dst_connect"
+    fileevent $state(sock_dst) writable {}
+    after cancel $state(timeoutid)
+
+    set sock_dst $state(sock_dst)
+    if {[eof $sock_dst]} {
+	serv_finish $token network-failure
+	return
+    }
+
+    if {[catch {
+	fconfigure $sock_dst -translation {binary binary} -blocking 0
+	foreach {bnd_ip bnd_addr bnd_port} [fconfigure $sock_dst -sockname] \
+	  break
+    } err]} {
+	Debug 2 "\tfconfigure failed: $err"
+	serv_finish $token network-failure
+	return
+    }
+    array set state [list bnd_ip $bnd_ip bnd_addr $bnd_addr bnd_port $bnd_port]
+    serv_reply $token
+}
+
+proc socks5::serv_reply {token} {
+    variable $token
+    variable const
+    upvar 0 $token state
+
+    Debug 2 "socks5:serv_reply"
+    set sock $state(sock)
+    set bnd_addr $state(bnd_addr)
+    set bnd_port $state(bnd_port)
+    Debug 2 "\tbnd_addr=$bnd_addr, bnd_port=$bnd_port"
+
+    set aconst "$const(ver)$const(rsp_succeeded)$const(rsv)"
+
+    # Domain length (binary 1 byte)
+    set dlen [binary format c [string length $bnd_addr]]
+
+    # Network byte-ordered port (2 binary-bytes, short)
+    set bport [binary format S $bnd_port]
+    set atyp_addr_port \
+      "$const(atyp_domainname)$dlen$bnd_addr$bport"
+
+    # We send SOCKS server's reply to client.
+    Debug 2 "\tsend: ver rep rsv atyp_domainname dlen bnd_addr bnd_port"
+    if {[catch {
+	puts -nonewline $sock "$aconst$atyp_addr_port"
+	flush $sock
+    } err]} {
+	serv_finish $token $err
+	return
+    }
+
+    # New we are ready to stream data if wanted.
+    if {$state(-bytestream)} {
+	establish_bytestreams $token
+    } else {
+	# ???
+	serv_finish $token
+    }
+}
+
+proc socks5::establish_bytestreams {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "socks5::establish_bytestreams"
+    set sock $state(sock)
+    set sock_dst $state(sock_dst)
+
+    # Forward client stream to dst.
+    fileevent $sock readable  \
+      [list [namespace current]::read_stream $token $sock $sock_dst]
+
+    # Forward dst stream to client.
+    fileevent $sock_dst readable  \
+      [list [namespace current]::read_stream $token $sock_dst $sock]
+}
+
+proc socks5::read_stream {token in out} {
+    variable $token
+    upvar 0 $token state
+
+    set primary [string equal $state(sock) $in]
+    Debug 3 "::socks5::read_stream primary=$primary: in=$in, out=$out"
+
+    # If any of client (sock) or dst (sock_dst) closes down we shall
+    # close down everthing.
+    # Only client or dst can determine if a close down is premature.
+
+    if {[catch {eof $in} iseof] || $iseof} {
+	serv_finish $token
+    } elseif {[catch {eof $out} iseof] || $iseof} {
+	serv_finish $token
+    } elseif {[catch {read $in} data]} {
+	serv_finish $token network-failure
+    } else {
+
+	# We could wait here (in the event loop) for channel to be writable
+	# to avoid any blocking...
+	# BUT, this would keep $data in memory for a while which is a bad idee.
+	if {0} {
+	    fileevent $out writable  \
+	      [list [namespace current]::stream_writeable $token $primary]
+	    vwait $token\(writetrigger${primary})
+	}
+	if {[catch {puts -nonewline $out $data; flush $out}]} {
+	    serv_finish $token network-failure
+	}
+    }
+}
+
+proc socks5::stream_writeable {token primary} {
+    variable $token
+    upvar 0 $token state
+
+    incr state(writetrigger${primary})
+}
+
+proc socks5::serv_finish {token {errormsg ""}} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "socks5::serv_finish"
+    if {$state(-bytestream)} {
+	catch {close $state(sock)}
+	catch {close $state(sock_dst)}
+    }
+    if {[string length $errormsg]} {
+	uplevel #0 $state(command) [list $token $errormsg]
+    } else {
+	uplevel #0 $state(command) [list $token ok]
+    }
+    unset state
+}
+
+#       Just a trigger for vwait.
+
+proc socks5::readable {token} {
+    variable $token
+    upvar 0 $token state
+
+    incr state(trigger)
+}
+
+proc socks5::ServTimeout {token} {
+    variable $token
+    upvar 0 $token state
+
+    serv_finish $token timeout
+}
+
+proc socks5::Debug {num str} {
+    variable debug
+    if {$num <= $debug} {
+	puts $str
+    }
+}
+
+# Test code...
+
+if {0} {
+
+    # Server
+    proc serv_cmd {token status} {
+	puts "server: token=$token, status=$status"
+	switch -- $status {
+	    ok {
+
+	    }
+	    authorize {
+		# Here we should check that the username and password is ok.
+		return 1
+	    }
+	    default {
+		puts "error $status"
+	    }
+	}
+    }
+    proc server_connect {sock ip port} {
+	fileevent $sock readable  \
+	  [list socks5::serverinit $sock $ip $port serv_cmd]
+    }
+    socket -server server_connect 1080
+}
+
+if {0} {
+    # Client
+    proc cb {status socket} {
+	puts "client: status=$status, socket=$socket"
+	if {$status eq "OK"} {
+	    fconfigure $socket -buffering none
+	    close $socket
+	}
+    }
+    proc dump {} {
+	puts "dump:"
+    }
+    set s [socket 192.168.0.1 1080]
+    #socks5::connect $s jabber.ru 5222 -command cb
+    socks5::connect $s jabber.ru 5222 -command cb -username xxx -password xxx
+}
+

Deleted: trunk/tkabber/jabberlib/stanzaerror.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/stanzaerror.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/stanzaerror.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,236 +0,0 @@
-# $Id$
-# 
-
-##########################################################################
-
-package provide stanzaerror 1.0
-
-##########################################################################
-
-namespace eval stanzaerror {
-
-    variable NS
-    set NS(stanzas) "urn:ietf:params:xml:ns:xmpp-stanzas"
-
-    array set error_type [list \
-	auth	    [::msgcat::mc "Authentication Error"] \
-	cancel	    [::msgcat::mc "Unrecoverable Error"] \
-	continue    [::msgcat::mc "Warning"] \
-	modify	    [::msgcat::mc "Request Error"] \
-	wait	    [::msgcat::mc "Temporary Error"]]
-
-    set defined_error_conditions {}
-    # Code is zero iff the condition isn't mentioned in 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 defined_error_conditions $cond
-	set error_description($type,$cond) $description
-	# XEP-0086
-	foreach code $clist {
-	    set error_type_descelem($code) [list $type $cond]
-	}
-	set legacy_error_codes($cond) $lcode
-    }
-}
-
-##########################################################################
-
-proc stanzaerror::register_errortype {type description} {
-    variable error_type
-
-    set error_type($type) $description
-}
-
-##########################################################################
-
-proc stanzaerror::register_error {lcode type cond description} {
-    variable defined_error_conditions
-    variable error_description
-    variable error_type_descelem
-
-    lappend defined_error_conditions $cond
-    set error_description($type,$cond) $description
-    set legacy_error_codes($cond) $lcode
-}
-
-##########################################################################
-
-proc stanzaerror::error_to_list {errmsg} {
-    variable NS
-    variable error_type
-    variable defined_error_conditions
-    variable error_description
-    variable error_type_descelem
-
-    if {$errmsg == [::msgcat::mc "Disconnected"]} {
-	return [list none none [::msgcat::mc "Disconnected"]]
-    }
-
-    lassign $errmsg code desc
-    if {[string is integer $code]} {
-	if {[info exists error_type_descelem($code)]} {
-	    lassign $error_type_descelem($code) type descelem
-	} else {
-	    lassign {none none} type descelem
-	}
-	return [list $type $descelem "$code ([::msgcat::mc $desc])"]
-    } else {
-	set type $code
-	set errelem $desc
-	set condition "undefined-condition"
-	set description ""
-	set textdescription ""
-	jlib::wrapper:splitxml $errelem tag vars isempty chdata children
-	foreach child $children {
-	    jlib::wrapper:splitxml $child tag1 vars1 isempty1 chdata1 children1
-	    set xmlns [jlib::wrapper:getattr $vars1 xmlns]
-	    set cond $tag1
-	    switch -- $cond {
-		text {
-		    if {$xmlns == $NS(stanzas)} {
-			set textdescription ": $chdata1"
-		    }
-		}
-		undefined-condition {
-		    # TODO
-		    set description $error_description(any,undefined-condition)
-		}
-		default {
-		    if {[lsearch -exact $defined_error_conditions $cond] >= 0} {
-			set condition $cond
-			if {[info exists error_description($type,$cond)] && \
-				($description == "")} {
-			    set description $error_description($type,$cond)
-			}
-		    } else {
-			# TODO
-		    }
-		}
-	    }
-	}
-	if {[info exists error_type($type)]} {
-	    set typedesc $error_type($type)
-	}
-	set res ""
-	if {$description != ""} {
-	    set res $description
-	}
-	if {[info exists typedesc] && $typedesc != ""} {
-	    if {$res == ""} {
-		set res $typedesc
-	    } else {
-		set res "$typedesc ($res)"
-	    }
-	}
-	return [list $type $condition "$res$textdescription"]
-    }
-}
-
-##########################################################################
-
-proc stanzaerror::error {type condition args} {
-    return [eval {xmpp_error $type $condition} $args]
-}
-
-##########################################################################
-
-proc stanzaerror::legacy_error {type condition args} {
-    variable NS
-    variable legacy_error_codes
-    variable error_description
-
-    if {[info exists legacy_error_codes($condition)] && \
-	    $legacy_error_codes($condition)} {
-	set code $legacy_error_codes($condition)
-    } else {
-	set code 501
-    }
-    if {[info exists error_description($type,$condition)]} {
-	set description $error_description($type,$condition)
-    } else {
-	set description ""
-    }
-    set xml ""
-    foreach {opt val} $args {
-	switch -- $opt {
-	    -xml {
-		set xml $val
-	    }
-	    -text {
-		set description $val
-	    }
-	}
-    }
-    set err [jlib::wrapper:createtag error \
-		-vars [list code $code] \
-		-chdata $description]
-    if {$xml == ""} {
-	return [list $err]
-    } else {
-	return [list $xml $err]
-    }
-}
-
-##########################################################################
-
-proc stanzaerror::xmpp_error {type condition args} {
-    variable NS
-    variable legacy_error_codes
-
-    set subtags [list [jlib::wrapper:createtag $condition \
-			   -vars [list xmlns $NS(stanzas)]]]
-    set xml ""
-    foreach {opt val} $args {
-	switch -- $opt {
-	    -xml {
-		set xml $val
-	    }
-	    -text {
-		lappend subtags [jlib::wrapper:createtag text \
-				     -vars [list xmlns $NS(stanzas)] \
-				     -chdata $val]
-	    }
-	    -application-specific {
-		lappend subtags $val
-	    }
-	}
-    }
-    set vars [list type $type]
-    if {[info exists legacy_error_codes($condition)] && \
-	    $legacy_error_codes($condition)} {
-	lappend vars code $legacy_error_codes($condition)
-    }
-    set err [jlib::wrapper:createtag error \
-		-vars $vars \
-		-subtags $subtags]
-    if {$xml == ""} {
-	return [list $err]
-    } else {
-	return [list $xml $err]
-    }
-}
-
-##########################################################################
-

Copied: trunk/tkabber/jabberlib/stanzaerror.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/stanzaerror.tcl)
===================================================================
--- trunk/tkabber/jabberlib/stanzaerror.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/stanzaerror.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,236 @@
+# $Id$
+# 
+
+##########################################################################
+
+package provide stanzaerror 1.0
+
+##########################################################################
+
+namespace eval stanzaerror {
+
+    variable NS
+    set NS(stanzas) "urn:ietf:params:xml:ns:xmpp-stanzas"
+
+    array set error_type [list \
+	auth	    [::msgcat::mc "Authentication Error"] \
+	cancel	    [::msgcat::mc "Unrecoverable Error"] \
+	continue    [::msgcat::mc "Warning"] \
+	modify	    [::msgcat::mc "Request Error"] \
+	wait	    [::msgcat::mc "Temporary Error"]]
+
+    set defined_error_conditions {}
+    # Code is zero iff the condition isn't mentioned in 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 defined_error_conditions $cond
+	set error_description($type,$cond) $description
+	# XEP-0086
+	foreach code $clist {
+	    set error_type_descelem($code) [list $type $cond]
+	}
+	set legacy_error_codes($cond) $lcode
+    }
+}
+
+##########################################################################
+
+proc stanzaerror::register_errortype {type description} {
+    variable error_type
+
+    set error_type($type) $description
+}
+
+##########################################################################
+
+proc stanzaerror::register_error {lcode type cond description} {
+    variable defined_error_conditions
+    variable error_description
+    variable error_type_descelem
+
+    lappend defined_error_conditions $cond
+    set error_description($type,$cond) $description
+    set legacy_error_codes($cond) $lcode
+}
+
+##########################################################################
+
+proc stanzaerror::error_to_list {errmsg} {
+    variable NS
+    variable error_type
+    variable defined_error_conditions
+    variable error_description
+    variable error_type_descelem
+
+    if {$errmsg == [::msgcat::mc "Disconnected"]} {
+	return [list none none [::msgcat::mc "Disconnected"]]
+    }
+
+    lassign $errmsg code desc
+    if {[string is integer $code]} {
+	if {[info exists error_type_descelem($code)]} {
+	    lassign $error_type_descelem($code) type descelem
+	} else {
+	    lassign {none none} type descelem
+	}
+	return [list $type $descelem "$code ([::msgcat::mc $desc])"]
+    } else {
+	set type $code
+	set errelem $desc
+	set condition "undefined-condition"
+	set description ""
+	set textdescription ""
+	jlib::wrapper:splitxml $errelem tag vars isempty chdata children
+	foreach child $children {
+	    jlib::wrapper:splitxml $child tag1 vars1 isempty1 chdata1 children1
+	    set xmlns [jlib::wrapper:getattr $vars1 xmlns]
+	    set cond $tag1
+	    switch -- $cond {
+		text {
+		    if {$xmlns == $NS(stanzas)} {
+			set textdescription ": $chdata1"
+		    }
+		}
+		undefined-condition {
+		    # TODO
+		    set description $error_description(any,undefined-condition)
+		}
+		default {
+		    if {[lsearch -exact $defined_error_conditions $cond] >= 0} {
+			set condition $cond
+			if {[info exists error_description($type,$cond)] && \
+				($description == "")} {
+			    set description $error_description($type,$cond)
+			}
+		    } else {
+			# TODO
+		    }
+		}
+	    }
+	}
+	if {[info exists error_type($type)]} {
+	    set typedesc $error_type($type)
+	}
+	set res ""
+	if {$description != ""} {
+	    set res $description
+	}
+	if {[info exists typedesc] && $typedesc != ""} {
+	    if {$res == ""} {
+		set res $typedesc
+	    } else {
+		set res "$typedesc ($res)"
+	    }
+	}
+	return [list $type $condition "$res$textdescription"]
+    }
+}
+
+##########################################################################
+
+proc stanzaerror::error {type condition args} {
+    return [eval {xmpp_error $type $condition} $args]
+}
+
+##########################################################################
+
+proc stanzaerror::legacy_error {type condition args} {
+    variable NS
+    variable legacy_error_codes
+    variable error_description
+
+    if {[info exists legacy_error_codes($condition)] && \
+	    $legacy_error_codes($condition)} {
+	set code $legacy_error_codes($condition)
+    } else {
+	set code 501
+    }
+    if {[info exists error_description($type,$condition)]} {
+	set description $error_description($type,$condition)
+    } else {
+	set description ""
+    }
+    set xml ""
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -xml {
+		set xml $val
+	    }
+	    -text {
+		set description $val
+	    }
+	}
+    }
+    set err [jlib::wrapper:createtag error \
+		-vars [list code $code] \
+		-chdata $description]
+    if {$xml == ""} {
+	return [list $err]
+    } else {
+	return [list $xml $err]
+    }
+}
+
+##########################################################################
+
+proc stanzaerror::xmpp_error {type condition args} {
+    variable NS
+    variable legacy_error_codes
+
+    set subtags [list [jlib::wrapper:createtag $condition \
+			   -vars [list xmlns $NS(stanzas)]]]
+    set xml ""
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -xml {
+		set xml $val
+	    }
+	    -text {
+		lappend subtags [jlib::wrapper:createtag text \
+				     -vars [list xmlns $NS(stanzas)] \
+				     -chdata $val]
+	    }
+	    -application-specific {
+		lappend subtags $val
+	    }
+	}
+    }
+    set vars [list type $type]
+    if {[info exists legacy_error_codes($condition)] && \
+	    $legacy_error_codes($condition)} {
+	lappend vars code $legacy_error_codes($condition)
+    }
+    set err [jlib::wrapper:createtag error \
+		-vars $vars \
+		-subtags $subtags]
+    if {$xml == ""} {
+	return [list $err]
+    } else {
+	return [list $xml $err]
+    }
+}
+
+##########################################################################
+

Deleted: trunk/tkabber/jabberlib/streamerror.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/streamerror.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/streamerror.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,104 +0,0 @@
-# $Id$
-# 
-
-##########################################################################
-
-package provide streamerror 1.0
-
-##########################################################################
-
-namespace eval streamerror {
-    variable NS
-    set NS(streams) "urn:ietf:params:xml:ns:xmpp-streams"
-
-    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 streamerror_desc($cond) $message
-    }
-}
-
-##########################################################################
-
-proc streamerror::condition {error} {
-    return [lindex [cond_msg $error] 0]
-}
-
-##########################################################################
-
-proc streamerror::message {error} {
-    return [lindex [cond_msg $error] 1]
-}
-
-##########################################################################
-
-proc streamerror::cond_msg {error} {
-    variable NS
-    variable streamerror_desc
-
-    jlib::wrapper:splitxml $error tag1 vars1 isempty1 chdata1 children1
-    if {[llength $children1] == 0} {
-	# Legacy error
-	if {$chdata1 != ""} {
-	    set chdata1 " ($chdata1)"
-	}
-	return [list legacy \
-		     [format [::msgcat::mc "Stream Error%s%s"] $chdata1 ""]]
-    } else {
-	# XMPP error
-	set condition undefined-condition
-	set description ""
-	set textdescription ""
-	foreach errelem $children1 {
-	    jlib::wrapper:splitxml $errelem tag vars isempty chdata children
-	    set xmlns [jlib::wrapper:getattr $vars xmlns]
-	    set cond $tag
-	    switch -- $cond {
-		text {
-		    if {$xmlns == $NS(streams)} {
-			set textdescription ": $chdata"
-		    }
-		}
-		undefined-condition {
-		    # TODO
-		}
-		default {
-		    if {[info exists streamerror_desc($cond)]} {
-			set condition $cond
-			set description " ($streamerror_desc($cond))"
-		    }
-		}
-	    }
-	}
-	return [list $condition \
-		     [format [::msgcat::mc "Stream Error%s%s"] \
-			     $description $textdescription]]
-    }
-}
-
-##########################################################################
-

Copied: trunk/tkabber/jabberlib/streamerror.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/streamerror.tcl)
===================================================================
--- trunk/tkabber/jabberlib/streamerror.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/streamerror.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,104 @@
+# $Id$
+# 
+
+##########################################################################
+
+package provide streamerror 1.0
+
+##########################################################################
+
+namespace eval streamerror {
+    variable NS
+    set NS(streams) "urn:ietf:params:xml:ns:xmpp-streams"
+
+    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 streamerror_desc($cond) $message
+    }
+}
+
+##########################################################################
+
+proc streamerror::condition {error} {
+    return [lindex [cond_msg $error] 0]
+}
+
+##########################################################################
+
+proc streamerror::message {error} {
+    return [lindex [cond_msg $error] 1]
+}
+
+##########################################################################
+
+proc streamerror::cond_msg {error} {
+    variable NS
+    variable streamerror_desc
+
+    jlib::wrapper:splitxml $error tag1 vars1 isempty1 chdata1 children1
+    if {[llength $children1] == 0} {
+	# Legacy error
+	if {$chdata1 != ""} {
+	    set chdata1 " ($chdata1)"
+	}
+	return [list legacy \
+		     [format [::msgcat::mc "Stream Error%s%s"] $chdata1 ""]]
+    } else {
+	# XMPP error
+	set condition undefined-condition
+	set description ""
+	set textdescription ""
+	foreach errelem $children1 {
+	    jlib::wrapper:splitxml $errelem tag vars isempty chdata children
+	    set xmlns [jlib::wrapper:getattr $vars xmlns]
+	    set cond $tag
+	    switch -- $cond {
+		text {
+		    if {$xmlns == $NS(streams)} {
+			set textdescription ": $chdata"
+		    }
+		}
+		undefined-condition {
+		    # TODO
+		}
+		default {
+		    if {[info exists streamerror_desc($cond)]} {
+			set condition $cond
+			set description " ($streamerror_desc($cond))"
+		    }
+		}
+	    }
+	}
+	return [list $condition \
+		     [format [::msgcat::mc "Stream Error%s%s"] \
+			     $description $textdescription]]
+    }
+}
+
+##########################################################################
+

Deleted: trunk/tkabber/jabberlib/transports.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/transports.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/transports.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,691 +0,0 @@
-# $Id$
-
-namespace eval transport {
-    variable capabilities [list tcp http_poll]
-    variable disconnect quick
-}
-
-proc transport::capabilities {} {
-    variable capabilities
-    return $capabilities
-}
-
-######################################################################
-
-# TODO
-namespace eval transport::proxy {}
-
-proc transport::proxy::capabilities {} {
-    return [list none socks4 socks5 https]
-}
-
-######################################################################
-#
-# TCP Socket Support
-#
-######################################################################
-
-namespace eval transport::tcp {}
-
-proc transport::tcp::connect {connid server port args} {
-    variable lib
-
-    set sock [eval [list autoconnect::socket $server $port] $args]
-    fconfigure $sock -blocking 0 -buffering none \
-	       -translation auto -encoding utf-8
-    set lib($connid,socket) $sock
-
-    fileevent $sock readable \
-	      [list [namespace current]::inmsg $connid $sock]
-
-    return $sock
-}
-
-proc transport::tcp::outmsg {connid msg} {
-    variable lib
-
-    if {![info exists lib($connid,socket)]} {
-	::LOG "error ([namespace current]::outmsg)\
-	       Cannot write to socket: socket for\
-	       connection $connid doesn't exist"
-	return -2
-    }
-
-    if {[catch { puts -nonewline $lib($connid,socket) $msg }]} {
-	::LOG "error ([namespace current]::outmsg)\
-	       Cannot write to socket: $lib($connid,socket)"
-	return -2
-    }
-}
-
-proc transport::tcp::disconnect {connid} {
-    variable lib
-
-    catch {
-	if {[set [namespace parent]::disconnect] == "quick"} {
-	    flush $lib($connid,socket)
-	} else {
-	    fconfigure $lib($connid,socket) -blocking 1
-	    flush $lib($connid,socket)
-	    vwait [namespace current]::lib($connid,socket)
-	}
-    }
-}
-
-proc transport::tcp::close {connid} {
-    variable lib
-
-    catch { fileevent $lib($connid,socket) readable {} }
-    catch { ::close $lib($connid,socket) }
-
-    array unset lib $connid,*
-}
-
-######################################################################
-proc transport::tcp::inmsg {connid sock} {
-    set msg ""
-    catch { set msg [read $sock] }
-
-    jlib::inmsg $connid $msg [eof $sock]
-}
-
-######################################################################
-# TODO Cleanup
-proc transport::tcp::to_compress {connid method} {
-    variable lib
-
-    set [namespace parent]::${method}::lib($connid,socket) \
-	$lib($connid,socket)
-    eval [list [namespace parent]::${method}::import $connid]
-    set ::jlib::lib($connid,transport) $method
-
-    array unset lib $connid,*
-}
-
-proc transport::tcp::to_tls {connid args} {
-    variable lib
-
-    set [namespace parent]::tls::lib($connid,socket) $lib($connid,socket)
-    eval [list [namespace parent]::tls::tls_import $connid] $args
-    set ::jlib::lib($connid,transport) tls
-
-    array unset lib $connid,*
-}
-
-
-######################################################################
-#
-# Zlib Compressed Socket Support
-#
-######################################################################
-
-if {![catch { package require zlib 1.0 }]} {
-    lappend transport::capabilities compress
-}
-
-namespace eval transport::zlib {}
-
-proc transport::zlib::connect {connid server port args} {
-    variable lib
-
-    set sock [eval [list autoconnect::socket $server $port] $args]
-
-    set lib($connid,socket) $sock
-    import $connid
-
-    return $sock
-}
-
-proc transport::zlib::outmsg {connid msg} {
-    variable lib
-
-    if {![info exists lib($connid,socket)]} {
-	::LOG "error ([namespace current]::outmsg)\
-	       Cannot write to socket: socket for connection\
-	       $connid doesn't exist"
-	return -2
-    }
-
-    if {[catch { puts -nonewline $lib($connid,socket) $msg }]} {
-	::LOG "error ([namespace current]::outmsg)\
-	       Cannot write to socket: $lib($connid,socket)"
-	return -2
-    }
-    flush $lib($connid,socket)
-    fconfigure $lib($connid,socket) -flush output
-}
-
-proc transport::zlib::disconnect {connid} {
-    variable lib
-
-    catch {
-	if {[set [namespace parent]::disconnect] == "quick"} {
-	    flush $lib($connid,socket)
-	    fconfigure $lib($connid,socket) -finish output
-	} else {
-	    fconfigure $lib($connid,socket) -blocking 1
-	    flush $lib($connid,socket)
-	    fconfigure $lib($connid,socket) -finish output
-	    vwait [namespace current]::lib($connid,socket)
-	}
-    }
-}
-
-proc transport::zlib::close {connid} {
-    variable lib
-
-    catch { fileevent $lib($connid,socket) readable {} }
-    catch { ::close $lib($connid,socket) }
-
-    array unset lib $connid,*
-}
-
-######################################################################
-proc transport::zlib::inmsg {connid sock} {
-    set msg ""
-    catch {
-	fconfigure $sock -flush input
-	set msg [read $sock]
-    }
-
-    jlib::inmsg $connid $msg [eof $sock]
-}
-
-######################################################################
-proc transport::zlib::import {connid args} {
-    variable lib
-
-    set sock $lib($connid,socket)
-    fconfigure $sock -blocking 0 -buffering none \
-	       -translation auto -encoding utf-8
-    zlib stream $lib($connid,socket) RDWR -output compress \
-	 -input decompress
-
-    fileevent $sock readable \
-	      [list [namespace current]::inmsg $connid $sock]
-}
-
-######################################################################
-#
-# TLS Socket Support
-#
-######################################################################
-
-if {![catch { package require tls 1.4 }]} {
-    lappend transport::capabilities tls
-}
-
-namespace eval transport::tls {}
-
-proc transport::tls::connect {connid server port args} {
-    variable lib
-
-    set tlsargs {}
-    foreach {opt val} $args {
-	switch -- $opt {
-	    -cacertstore {
-		if {$val != ""} {
-		    if {[file isdirectory $val]} {
-			lappend tlsargs -cadir $val
-		    } else {
-			lappend tlsargs -cafile $val
-		    }
-		}
-	    }
-	    -certfile  -
-	    -keyfile   {
-		if {$val != ""} {
-		    lappend tlsargs $opt $val
-		}
-	    }
-	}
-    }
-
-    set sock [eval [list autoconnect::socket $server $port] $args]
-
-    fconfigure $sock -encoding binary -translation binary
-
-    set lib($connid,socket) $sock
-    eval [list tls_import $connid] $tlsargs
-
-    return $sock
-}
-
-proc transport::tls::outmsg {connid msg} {
-    variable lib
-
-    if {![info exists lib($connid,socket)]} {
-	::LOG "error ([namespace current]::outmsg)\
-	       Cannot write to socket: socket for connection\
-	       $connid doesn't exist"
-	return -2
-    }
-
-    if {[catch { puts -nonewline $lib($connid,socket) $msg }]} {
-	::LOG "error ([namespace current]::outmsg)\
-	       Cannot write to socket: $lib($connid,socket)"
-	return -2
-    }
-}
-
-proc transport::tls::disconnect {connid} {
-    variable lib
-
-    catch {
-	if {[set [namespace parent]::disconnect] == "quick"} {
-	    flush $lib($connid,socket)
-	} else {
-	    fconfigure $lib($connid,socket) -blocking 1
-	    flush $lib($connid,socket)
-	    vwait [namespace current]::lib($connid,socket)
-	}
-    }
-}
-
-proc transport::tls::close {connid} {
-    variable lib
-
-    catch { fileevent $lib($connid,socket) readable {} }
-    catch { ::close $lib($connid,socket) }
-
-    array unset lib $connid,*
-}
-
-######################################################################
-proc transport::tls::inmsg {connid sock} {
-    set msg ""
-    catch { set msg [read $sock] }
-
-    jlib::inmsg $connid $msg [eof $sock]
-}
-
-######################################################################
-proc ::client:tls_callback {args} {
-    return 1
-}
-
-######################################################################
-proc transport::tls::tls_import {connid args} {
-    variable lib
-
-    set sock $lib($connid,socket)
-
-    fileevent $sock readable {}
-    fileevent $sock writable {}
-    fconfigure $sock -blocking 1
-
-    eval [list tls::import $sock \
-	       -command [list client:tls_callback $connid] \
-	       -ssl2    false \
-	       -ssl3    true \
-	       -tls1    true \
-	       -request true \
-	       -require false \
-	       -server  false] $args
-
-    if {[catch { tls::handshake $sock } tls_result]} {
-	catch { ::close $sock }
-	error $tls_result
-    }
-
-    fconfigure $sock -blocking 0 -buffering none \
-               -translation auto -encoding utf-8
-
-    fileevent $sock readable \
-	      [list [namespace current]::inmsg $connid $sock]
-}
-
-######################################################################
-# TODO Cleanup
-proc transport::tls::to_compress {connid method} {
-    variable lib
-
-    set [namespace parent]::${method}::lib($connid,socket) \
-	$lib($connid,socket)
-    eval [list [namespace parent]::${method}::import $connid]
-    set ::jlib::lib($connid,transport) $method
-
-    array unset lib $connid,*
-}
-
-######################################################################
-#
-# HTTP Polling
-#
-######################################################################
-
-package require sha1
-
-namespace eval transport::http_poll {
-    variable lib
-    set lib(http_version) [package require http]
-}
-
-if {![catch { package require tls 1.4 }]} {
-    ::http::register https 443 ::tls::socket
-}
-
-proc transport::http_poll::connect {connid server port args} {
-    variable lib
-
-    set lib($connid,polltimeout) 0
-    set lib($connid,pollint) 3000
-    set lib($connid,pollmin) 3000
-    set lib($connid,pollmax) 30000
-    set lib($connid,proxyhost) ""
-    set lib($connid,proxyport) ""
-    set lib($connid,proxyusername) ""
-    set lib($connid,proxypassword) ""
-    set lib($connid,proxyuseragent) ""
-    set lib($connid,pollurl) ""
-    set lib($connid,pollusekeys) 1
-    set lib($connid,pollnumkeys) 100
-
-    foreach {opt val} $args {
-	switch -- $opt {
-	    -polltimeout   { set lib($connid,polltimeout) $val }
-	    -pollint       { set lib($connid,pollint) $val }
-	    -pollmin       { set lib($connid,pollmin) $val }
-	    -pollmax       { set lib($connid,pollmax) $val }
-	    -pollurl       { set lib($connid,pollurl) $val }
-	    -pollusekeys   { set lib($connid,pollusekeys) $val }
-	    -pollnumkeys   { set lib($connid,pollnumkeys) $val }
-	    -proxyhost     { set lib($connid,proxyhost) $val }
-	    -proxyport     { set lib($connid,proxyport) $val }
-	    -proxyusername { set lib($connid,proxyusername) $val }
-	    -proxypassword { set lib($connid,proxypassword) $val }
-	    -proxyuseragent { set lib($connid,proxyuseragent) $val }
-	}
-    }
-
-    set lib($connid,pollwait) disconnected
-    set lib($connid,polloutdata) ""
-    set lib($connid,pollseskey) 0
-    set lib($connid,pollid) ""
-    set lib($connid,pollkeys) {}
-
-    if {$lib($connid,proxyuseragent) != ""} {
-	::http::config -useragent $lib($connid,proxyuseragent)
-    }
-
-    if {($lib($connid,proxyhost) != "") && ($lib($connid,proxyport) != "")} {
-	::http::config -proxyhost $lib($connid,proxyhost) \
-		       -proxyport $lib($connid,proxyport)
-
-	if {$lib($connid,proxyusername) != ""} {
-	    set auth \
-		[base64::encode \
-                     [encoding convertto \
-			  "$lib($connid,proxyusername):$lib($connid,proxypassword)"]]
-	    set lib($connid,proxyauth) [list "Proxy-Authorization" "Basic $auth"]
-	} else {
-	    set lib($connid,proxyauth) {}
-	}
-    } else {
-	    set lib($connid,proxyauth) {}
-    }
-
-    if {$lib($connid,pollusekeys)} {
-        # generate keys
-	::HTTP_LOG "connect ($connid): generating keys"
-        set seed [rand 1000000000]
-        set oldkey $seed
-        set key_count $lib($connid,pollnumkeys)
-        while { $key_count } {
-            set nextkey [base64::encode [hex_decode [sha1::sha1 $oldkey]]]
-            # skip the initial seed
-            lappend lib($connid,pollkeys) $nextkey
-            set oldkey $nextkey
-            incr key_count -1
-        }
-    }
-
-    set_httpwait $connid connected
-}
-
-proc transport::http_poll::outmsg {connid msg} {
-    variable lib
-
-    if {![info exists lib($connid,pollwait)]} {
-	return
-    }
-
-    switch -- $lib($connid,pollwait) {
-	disconnected -
-	waiting -
-	disconnecting { }
-	default { poll $connid $msg }
-    }
-}
-
-proc transport::http_poll::disconnect {connid} {
-    variable lib
-
-    if {![info exists lib($connid,pollwait)]} {
-	return
-    }
-
-    switch -- $lib($connid,pollwait) {
-	disconnected -
-	waiting { }
-	polling { set_httpwait $connid waiting }
-	default { set_httpwait $connid disconnecting }
-    }
-
-    if {[set [namespace parent]::disconnect] != "quick"} {
-	while {[info exists lib($connid,pollwait)] && \
-		    $lib($connid,pollwait) != "disconnected"} {
-	    vwait [namespace current]::lib($connid,pollwait)
-	}
-    }
-}
-
-proc transport::http_poll::close {connid} {
-    variable lib
-
-    set_httpwait $connid disconnected
-
-    array unset lib $connid,*
-}
-
-######################################################################
-proc transport::http_poll::inmsg {connid body} {
-    if {[string length $body] > 2} {
-	jlib::inmsg $connid $body 0
-    }
-}
-
-######################################################################
-proc ::HTTP_LOG {args} {}
-
-######################################################################
-proc transport::http_poll::set_httpwait {connid opt} {
-    variable lib
-
-    set lib($connid,pollwait) $opt
-    if {$opt == "disconnected"} {
-	if {[info exists lib($connid,pollid)] && \
-		$lib($connid,pollid) != ""} {
-	    after cancel $lib($connid,pollid)
-	}
-    }
-}
-
-proc transport::http_poll::process_httpreply {connid try query token} {
-    variable lib
-
-    upvar #0 $token state
-
-    if {[set temp [::http::ncode $token]] != 200} {
-	::HTTP_LOG "error (process_httpreply)\
-($connid) Http returned $temp $state(status)"
-	if {$try < 3} {
-	    get_url $connid [expr {$try + 1}] $query
-	} else {
-	    set_httpwait $connid disconnected
-	    jlib::emergency_disconnect $connid
-	}
-	::http::cleanup $token
-	return
-    }
-
-    foreach {name value} $state(meta) {
-	if {[string equal -nocase "Set-Cookie" $name]} {
-	    ::HTTP_LOG "process_httpreply ($connid): Set-Cookie: $value"
-	    set start 0
-	    set end [string first ";" $value]
-	    if {$end < 1} {
-		set end [string length $value]
-	    }
-	    if {[string equal -nocase -length 3 "ID=" $value]} {
-		set start 3
-	    }
-	    set lib($connid,pollseskey) [string range $value $start [expr {$end - 1}]]
-	}
-    }
-    set inmsg [encoding convertfrom utf-8 $state(body)]
-    ::HTTP_LOG "process_httpreply ($connid): '$inmsg'"
-    ::http::cleanup $token
-
-    if {[regexp {:0$} $lib($connid,pollseskey)] || \
-	    [regexp {%3A0$} $lib($connid,pollseskey)]} {
-	::HTTP_LOG "error (process_httpreply) Cookie Error"
-	set_httpwait $connid disconnected
-	jlib::emergency_disconnect $connid
-	return
-    }
-
-    if {[string length $inmsg] > 5 } {
-	set lib($connid,pollint) [expr $lib($connid,pollint) / 2]
-	if {$lib($connid,pollint) < $lib($connid,pollmin)} {
-	    set lib($connid,pollint) $lib($connid,pollmin)
-	}
-    } else {
-	set lib($connid,pollint) [expr $lib($connid,pollint) * 11 / 10]
-	if {$lib($connid,pollint) > $lib($connid,pollmax)} {
-	    set lib($connid,pollint) $lib($connid,pollmax)
-	}
-    }
-
-    inmsg $connid $inmsg
-
-    switch -- $lib($connid,pollwait) {
-	waiting { set_httpwait $connid disconnecting }
-	polling { set_httpwait $connid connected }
-    }
-}
-
-proc transport::http_poll::poll {connid what} {
-    variable lib
-
-    ::HTTP_LOG "poll ($connid): '$what'"
-
-    if {![info exists lib($connid,pollwait)]} {
-	set_httpwait $connid disconnected
-	return
-    }
-
-    append lib($connid,polloutdata) [encoding convertto utf-8 $what]
-    switch -- $lib($connid,pollwait) {
-	disconnected {
-	    ::HTTP_LOG "poll ($connid): DISCONNECTED"
-	    return
-	}
-	disconnecting {
-	    ::HTTP_LOG "poll ($connid): DISCONNECTING"
-	    if {$lib($connid,polloutdata) == ""} {
-		set_httpwait $connid disconnected
-		return
-	    }
-	}
-	waiting -
-	polling {
-	    ::HTTP_LOG "poll ($connid): RESCHEDULING"
-	    if {[info exists lib($connid,pollid)]} {
-		after cancel $lib($connid,pollid)
-	    }
-	    ::HTTP_LOG "poll ($connid): $lib($connid,pollint)"
-	    set lib($connid,pollid) \
-		[after $lib($connid,pollint) \
-		       [list [namespace current]::poll $connid ""]]
-	    return
-	}
-    }
-
-    if {$lib($connid,pollusekeys)} {
-	# regenerate 
-	set firstkey [lindex $lib($connid,pollkeys) end]
-	set secondkey ""
-	if { [llength $lib($connid,pollkeys)] == 1} {
-	    ::HTTP_LOG "poll ($connid): regenerating keys"
-	    set lib($connid,pollkeys) {}
-	    set seed [rand 1000000000]
-	    set oldkey $seed
-	    set key_count $lib($connid,pollnumkeys)
-	    while { $key_count } {
-		set nextkey [base64::encode [hex_decode [sha1::sha1 $oldkey]]]
-		# skip the initial seed
-		lappend lib($connid,pollkeys) $nextkey
-		set oldkey $nextkey
-		incr key_count -1
-	    }
-	    set secondkey [lindex $lib($connid,pollkeys) end]
-	}
-	set l [llength $lib($connid,pollkeys)]
-	set lib($connid,pollkeys) \
-	    [lrange $lib($connid,pollkeys) 0 [expr {$l - 2}]]
-
-	if {[string length $firstkey]} {
-	    set firstkey ";$firstkey"
-        }
-
-        if {[string length $secondkey]} {
-            set secondkey ";$secondkey"
-        }
-
-        set query "$lib($connid,pollseskey)$firstkey$secondkey,$lib($connid,polloutdata)"
-    } else {
-        set query "$lib($connid,pollseskey),$lib($connid,polloutdata)"
-    }
-    switch -- $lib($connid,pollwait) {
-	disconnecting { set_httpwait $connid waiting }
-	default { set_httpwait $connid polling }
-    }
-    ::HTTP_LOG "poll ($connid): query: '[encoding convertfrom utf-8 $query]'"
-
-    get_url $connid 0 $query
-
-    set lib($connid,polloutdata) ""
-
-    if {[info exists lib($connid,pollid)]} {
-        after cancel $lib($connid,pollid)
-    }
-    ::HTTP_LOG "poll ($connid): $lib($connid,pollint)"
-    set lib($connid,pollid) \
-	[after $lib($connid,pollint) \
-	       [list [namespace current]::poll $connid ""]]
-}
-
-proc transport::http_poll::get_url {connid try query} {
-    variable lib
-
-    set get_url_args [list -headers $lib($connid,proxyauth)]
-    if {[package vcompare 2.3.3 $lib(http_version)] <= 0} {
-	lappend get_url_args -binary 1
-    }
-
-    eval [list ::http::geturl $lib($connid,pollurl) -query $query \
-	       -command [list [namespace current]::process_httpreply $connid $try $query] \
-	       -timeout $lib($connid,polltimeout)] $get_url_args
-}
-
-proc transport::http_poll::hex_decode {hexstring} {
-    set result ""
-    while { [string length $hexstring] } {
-	scan [string range $hexstring 0 1] "%x" X
-	regsub "^.." $hexstring "" hexstring
-	set result [binary format "a*c" $result $X]
-    }
-    return $result
-}
-

Copied: trunk/tkabber/jabberlib/transports.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/transports.tcl)
===================================================================
--- trunk/tkabber/jabberlib/transports.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/transports.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,742 @@
+# $Id$
+
+namespace eval transport {
+    variable capabilities [list tcp http_poll]
+    variable disconnect quick
+}
+
+proc transport::capabilities {} {
+    variable capabilities
+    return $capabilities
+}
+
+######################################################################
+
+# TODO
+namespace eval transport::proxy {}
+
+proc transport::proxy::capabilities {} {
+    return [list none socks4 socks5 https]
+}
+
+######################################################################
+#
+# TCP Socket Support
+#
+######################################################################
+
+namespace eval transport::tcp {}
+
+proc transport::tcp::connect {connid server port args} {
+    variable $connid
+    upvar 0 $connid lib
+
+    set sock [eval [list autoconnect::socket $server $port] $args]
+    fconfigure $sock -blocking 0 -buffering none \
+	       -translation auto -encoding utf-8
+    set lib(socket) $sock
+
+    fileevent $sock readable \
+	      [list [namespace current]::inmsg $connid $sock]
+
+    return $sock
+}
+
+proc transport::tcp::outmsg {connid msg} {
+    variable $connid
+    upvar 0 $connid lib
+
+    if {![info exists lib(socket)]} {
+	::LOG "error ([namespace current]::outmsg)\
+	       Cannot write to socket: socket for\
+	       connection $connid doesn't exist"
+	return -2
+    }
+
+    if {[catch { puts -nonewline $lib(socket) $msg }]} {
+	::LOG "error ([namespace current]::outmsg)\
+	       Cannot write to socket: $lib(socket)"
+	return -2
+    }
+}
+
+proc transport::tcp::start_stream {connid server args} {
+    return [outmsg $connid \
+		   [eval [list jlib::wrapper:streamheader $server] $args]]
+}
+
+proc transport::tcp::finish_stream {connid args} {
+    return [outmsg $connid [jlib::wrapper:streamtrailer]]
+}
+
+proc transport::tcp::disconnect {connid} {
+    variable $connid
+    upvar 0 $connid lib
+
+    catch {
+	if {[set [namespace parent]::disconnect] == "quick"} {
+	    flush $lib(socket)
+	} else {
+	    fconfigure $lib(socket) -blocking 1
+	    flush $lib(socket)
+	    vwait [namespace current]::${connid}(socket)
+	}
+    }
+}
+
+proc transport::tcp::close {connid} {
+    variable $connid
+    upvar 0 $connid lib
+
+    catch {fileevent $lib(socket) readable {}}
+    catch {::close $lib(socket)}
+
+    catch {unset lib}
+}
+
+######################################################################
+proc transport::tcp::inmsg {connid sock} {
+    set msg ""
+    catch { set msg [read $sock] }
+
+    jlib::inmsg $connid $msg [eof $sock]
+}
+
+######################################################################
+# TODO Cleanup
+proc transport::tcp::to_compress {connid method} {
+    variable $connid
+    upvar 0 $connid lib
+
+    set [namespace parent]::${method}::${connid}(socket) $lib(socket)
+    eval [list [namespace parent]::${method}::import $connid]
+    set ::jlib::lib($connid,transport) $method
+
+    catch {unset lib}
+}
+
+proc transport::tcp::to_tls {connid args} {
+    variable $connid
+    upvar 0 $connid lib
+
+    set [namespace parent]::tls::${connid}(socket) $lib(socket)
+    eval [list [namespace parent]::tls::tls_import $connid] $args
+    set ::jlib::lib($connid,transport) tls
+
+    catch {unset lib}
+}
+
+
+######################################################################
+#
+# Zlib Compressed Socket Support
+#
+######################################################################
+
+if {![catch { package require zlib 1.0 }]} {
+    lappend transport::capabilities compress
+}
+
+namespace eval transport::zlib {}
+
+proc transport::zlib::connect {connid server port args} {
+    variable $connid
+    upvar 0 $connid lib
+
+    set sock [eval [list autoconnect::socket $server $port] $args]
+
+    set lib(socket) $sock
+    import $connid
+
+    return $sock
+}
+
+proc transport::zlib::outmsg {connid msg} {
+    variable $connid
+    upvar 0 $connid lib
+
+    if {![info exists lib(socket)]} {
+	::LOG "error ([namespace current]::outmsg)\
+	       Cannot write to socket: socket for connection\
+	       $connid doesn't exist"
+	return -2
+    }
+
+    if {[catch { puts -nonewline $lib(socket) $msg }]} {
+	::LOG "error ([namespace current]::outmsg)\
+	       Cannot write to socket: $lib(socket)"
+	return -2
+    }
+    flush $lib(socket)
+    fconfigure $lib(socket) -flush output
+}
+
+proc transport::zlib::start_stream {connid server args} {
+    return [outmsg $connid \
+		   [eval [list jlib::wrapper:streamheader $server] $args]]
+}
+
+proc transport::zlib::finish_stream {connid args} {
+    return [outmsg $connid [jlib::wrapper:streamtrailer]]
+}
+
+proc transport::zlib::disconnect {connid} {
+    variable $connid
+    upvar 0 $connid lib
+
+    catch {
+	if {[set [namespace parent]::disconnect] == "quick"} {
+	    flush $lib(socket)
+	    fconfigure $lib(socket) -finish output
+	} else {
+	    fconfigure $lib(socket) -blocking 1
+	    flush $lib(socket)
+	    fconfigure $lib(socket) -finish output
+	    vwait [namespace current]::${connid}(socket)
+	}
+    }
+}
+
+proc transport::zlib::close {connid} {
+    variable $connid
+    upvar 0 $connid lib
+
+    catch {fileevent $lib(socket) readable {}}
+    catch {::close $lib(socket)}
+
+    catch {unset lib}
+}
+
+######################################################################
+proc transport::zlib::inmsg {connid sock} {
+    set msg ""
+    catch {
+	fconfigure $sock -flush input
+	set msg [read $sock]
+    }
+
+    jlib::inmsg $connid $msg [eof $sock]
+}
+
+######################################################################
+proc transport::zlib::import {connid args} {
+    variable $connid
+    upvar 0 $connid lib
+
+    set sock $lib(socket)
+    fconfigure $sock -blocking 0 -buffering none \
+	       -translation auto -encoding utf-8
+    zlib stream $sock RDWR -output compress -input decompress
+
+    fileevent $sock readable \
+	      [list [namespace current]::inmsg $connid $sock]
+}
+
+######################################################################
+#
+# TLS Socket Support
+#
+######################################################################
+
+if {![catch { package require tls 1.4 }]} {
+    lappend transport::capabilities tls
+}
+
+namespace eval transport::tls {}
+
+proc transport::tls::connect {connid server port args} {
+    variable $connid
+    upvar 0 $connid lib
+
+    set tlsargs {}
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -cacertstore {
+		if {$val != ""} {
+		    if {[file isdirectory $val]} {
+			lappend tlsargs -cadir $val
+		    } else {
+			lappend tlsargs -cafile $val
+		    }
+		}
+	    }
+	    -certfile  -
+	    -keyfile   {
+		if {$val != ""} {
+		    lappend tlsargs $opt $val
+		}
+	    }
+	}
+    }
+
+    set sock [eval [list autoconnect::socket $server $port] $args]
+
+    fconfigure $sock -encoding binary -translation binary
+
+    set lib(socket) $sock
+    eval [list tls_import $connid] $tlsargs
+
+    return $sock
+}
+
+proc transport::tls::outmsg {connid msg} {
+    variable $connid
+    upvar 0 $connid lib
+
+    if {![info exists lib(socket)]} {
+	::LOG "error ([namespace current]::outmsg)\
+	       Cannot write to socket: socket for connection\
+	       $connid doesn't exist"
+	return -2
+    }
+
+    if {[catch { puts -nonewline $lib(socket) $msg }]} {
+	::LOG "error ([namespace current]::outmsg)\
+	       Cannot write to socket: $lib(socket)"
+	return -2
+    }
+}
+
+proc transport::tls::start_stream {connid server args} {
+    return [outmsg $connid \
+		   [eval [list jlib::wrapper:streamheader $server] $args]]
+}
+
+proc transport::tls::finish_stream {connid args} {
+    return [outmsg $connid [jlib::wrapper:streamtrailer]]
+}
+
+proc transport::tls::disconnect {connid} {
+    variable $connid
+    upvar 0 $connid lib
+
+    catch {
+	if {[set [namespace parent]::disconnect] == "quick"} {
+	    flush $lib(socket)
+	} else {
+	    fconfigure $lib(socket) -blocking 1
+	    flush $lib(socket)
+	    vwait [namespace current]::${connid}(socket)
+	}
+    }
+}
+
+proc transport::tls::close {connid} {
+    variable $connid
+    upvar 0 $connid lib
+
+    catch {fileevent $lib(socket) readable {}}
+    catch {::close $lib(socket)}
+
+    catch {unset lib}
+}
+
+######################################################################
+proc transport::tls::inmsg {connid sock} {
+    set msg ""
+    catch { set msg [read $sock] }
+
+    jlib::inmsg $connid $msg [eof $sock]
+}
+
+######################################################################
+proc ::client:tls_callback {args} {
+    return 1
+}
+
+######################################################################
+proc transport::tls::tls_import {connid args} {
+    variable $connid
+    upvar 0 $connid lib
+
+    set sock $lib(socket)
+
+    fileevent $sock readable {}
+    fileevent $sock writable {}
+    fconfigure $sock -blocking 1
+
+    eval [list tls::import $sock \
+	       -command [list client:tls_callback $connid] \
+	       -ssl2    false \
+	       -ssl3    true \
+	       -tls1    true \
+	       -request true \
+	       -require false \
+	       -server  false] $args
+
+    if {[catch {tls::handshake $sock} tls_result]} {
+	catch {::close $sock}
+	error $tls_result
+    }
+
+    fconfigure $sock -blocking 0 -buffering none \
+               -translation auto -encoding utf-8
+
+    fileevent $sock readable \
+	      [list [namespace current]::inmsg $connid $sock]
+}
+
+######################################################################
+# TODO Cleanup
+proc transport::tls::to_compress {connid method} {
+    variable $connid
+    upvar 0 $connid lib
+
+    set [namespace parent]::${method}::${connid}(socket) $lib(socket)
+    eval [list [namespace parent]::${method}::import $connid]
+    set ::jlib::lib($connid,transport) $method
+
+    catch {unset lib}
+}
+
+######################################################################
+#
+# HTTP Polling
+#
+######################################################################
+
+package require sha1
+
+namespace eval transport::http_poll {
+    variable http_version [package require http]
+}
+
+if {![catch { package require tls 1.4 }]} {
+    ::http::register https 443 ::tls::socket
+}
+
+proc transport::http_poll::connect {connid server port args} {
+    variable $connid
+    upvar 0 $connid lib
+
+    set lib(polltimeout)    0
+    set lib(pollint)        6000
+    set lib(pollmin)        6000
+    set lib(pollmax)        60000
+    set lib(proxyhost)      ""
+    set lib(proxyport)      ""
+    set lib(proxyusername)  ""
+    set lib(proxypassword)  ""
+    set lib(proxyuseragent) ""
+    set lib(httpurl)        ""
+    set lib(httpusekeys)    1
+    set lib(httpnumkeys)    100
+
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -polltimeout    { set lib(polltimeout)    $val }
+	    -pollint        { set lib(pollint)        $val }
+	    -pollmin        { set lib(pollmin)        $val }
+	    -pollmax        { set lib(pollmax)        $val }
+	    -httpurl        { set lib(httpurl)        $val }
+	    -httpusekeys    { set lib(httpusekeys)    $val }
+	    -httpnumkeys    { set lib(httpnumkeys)    $val }
+	    -proxyhost      { set lib(proxyhost)      $val }
+	    -proxyport      { set lib(proxyport)      $val }
+	    -proxyusername  { set lib(proxyusername)  $val }
+	    -proxypassword  { set lib(proxypassword)  $val }
+	    -proxyuseragent { set lib(proxyuseragent) $val }
+	}
+    }
+
+    set lib(httpwait)    disconnected
+    set lib(httpoutdata) ""
+    set lib(httpseskey)  0
+    set lib(httpid)      ""
+    set lib(httpkeys)    {}
+
+    if {$lib(proxyuseragent) != ""} {
+	::http::config -useragent $lib(proxyuseragent)
+    }
+
+    if {($lib(proxyhost) != "") && ($lib(proxyport) != "")} {
+	::http::config -proxyhost $lib(proxyhost) -proxyport $lib(proxyport)
+
+	if {$lib(proxyusername) != ""} {
+	    set auth \
+		[base64::encode \
+                     [encoding convertto \
+			  "$lib(proxyusername):$lib(proxypassword)"]]
+	    set lib(proxyauth) [list "Proxy-Authorization" "Basic $auth"]
+	} else {
+	    set lib(proxyauth) {}
+	}
+    } else {
+	    set lib(proxyauth) {}
+    }
+
+    if {$lib(httpusekeys)} {
+        # generate keys
+	::HTTP_LOG "connect ($connid): generating keys"
+        set seed [rand 1000000000]
+        set oldkey $seed
+        set key_count $lib(httpnumkeys)
+        while {$key_count > 0} {
+            set nextkey [base64::encode [hex_decode [sha1::sha1 $oldkey]]]
+            # skip the initial seed
+            lappend lib(httpkeys) $nextkey
+            set oldkey $nextkey
+            incr key_count -1
+        }
+    }
+
+    set_httpwait $connid connected
+}
+
+proc transport::http_poll::outmsg {connid msg} {
+    variable $connid
+    upvar 0 $connid lib
+
+    if {![info exists lib(httpwait)]} {
+	return
+    }
+
+    switch -- $lib(httpwait) {
+	disconnected -
+	waiting -
+	disconnecting { }
+	default { poll $connid $msg }
+    }
+}
+
+proc transport::http_poll::start_stream {connid server args} {
+    return [outmsg $connid \
+		   [eval [list jlib::wrapper:streamheader $server] $args]]
+}
+
+proc transport::http_poll::finish_stream {connid args} {
+    return [outmsg $connid [jlib::wrapper:streamtrailer]]
+}
+
+proc transport::http_poll::disconnect {connid} {
+    variable $connid
+    upvar 0 $connid lib
+
+    if {![info exists lib(httpwait)]} {
+	return
+    }
+
+    switch -- $lib(httpwait) {
+	disconnected -
+	waiting { }
+	polling { set_httpwait $connid waiting }
+	default { set_httpwait $connid disconnecting }
+    }
+
+    if {[set [namespace parent]::disconnect] == "quick"} return
+
+    while {[info exists lib(httpwait)] && $lib(httpwait) != "disconnected"} {
+	vwait [namespace current]::${connid}(httpwait)
+    }
+}
+
+proc transport::http_poll::close {connid} {
+    variable $connid
+    upvar 0 $connid lib
+
+    set_httpwait $connid disconnected
+
+    catch {unset lib}
+}
+
+######################################################################
+proc transport::http_poll::inmsg {connid body} {
+    if {[string length $body] > 2} {
+	jlib::inmsg $connid $body 0
+    }
+}
+
+######################################################################
+proc ::HTTP_LOG {args} {}
+
+######################################################################
+proc transport::http_poll::set_httpwait {connid opt} {
+    variable $connid
+    upvar 0 $connid lib
+
+    set lib(httpwait) $opt
+    if {$opt == "disconnected" && \
+	    [info exists lib(httpid)] && $lib(httpid) != ""} {
+	after cancel $lib(httpid)
+    }
+}
+
+proc transport::http_poll::process_httpreply {connid try query token} {
+    variable $connid
+    upvar 0 $connid lib
+    upvar #0 $token state
+
+    if {[::http::ncode $token] != 200} {
+	::HTTP_LOG "error (process_httpreply) ($connid)\
+		    Http returned [::http::ncode $token] $state(status)"
+	if {$try < 3} {
+	    get_url $connid [expr {$try + 1}] $query
+	} else {
+	    set_httpwait $connid disconnected
+	    jlib::emergency_disconnect $connid
+	}
+	::http::cleanup $token
+	return
+    }
+
+    foreach {name value} $state(meta) {
+	if {[string equal -nocase "Set-Cookie" $name]} {
+	    ::HTTP_LOG "process_httpreply ($connid): Set-Cookie: $value"
+	    set start 0
+	    set end [string first ";" $value]
+	    if {$end < 1} {
+		set end [string length $value]
+	    }
+	    if {[string equal -nocase -length 3 "ID=" $value]} {
+		set start 3
+	    }
+	    set lib(httpseskey) [string range $value $start [expr {$end - 1}]]
+	}
+    }
+
+    set inmsg [encoding convertfrom utf-8 $state(body)]
+    ::HTTP_LOG "process_httpreply ($connid): '$inmsg'"
+    ::http::cleanup $token
+
+    if {[regexp {:0$} $lib(httpseskey)] || [regexp {%3A0$} $lib(httpseskey)]} {
+	::HTTP_LOG "error (process_httpreply) Cookie Error"
+	set_httpwait $connid disconnected
+	jlib::emergency_disconnect $connid
+	return
+    }
+
+    if {[string length $inmsg] > 5 } {
+	set lib(pollint) [expr $lib(pollint) / 2]
+	if {$lib(pollint) < $lib(pollmin)} {
+	    set lib(pollint) $lib(pollmin)
+	}
+    } else {
+	set lib(pollint) [expr $lib(pollint) * 11 / 10]
+	if {$lib(pollint) > $lib(pollmax)} {
+	    set lib(pollint) $lib(pollmax)
+	}
+    }
+
+    inmsg $connid $inmsg
+
+    switch -- $lib(httpwait) {
+	waiting { set_httpwait $connid disconnecting }
+	polling { set_httpwait $connid connected }
+    }
+}
+
+proc transport::http_poll::poll {connid what} {
+    variable $connid
+    upvar 0 $connid lib
+
+    ::HTTP_LOG "poll ($connid): '$what'"
+
+    if {![info exists lib(httpwait)]} {
+	set_httpwait $connid disconnected
+	return
+    }
+
+    append lib(httpoutdata) [encoding convertto utf-8 $what]
+    switch -- $lib(httpwait) {
+	disconnected {
+	    ::HTTP_LOG "poll ($connid): DISCONNECTED"
+	    return
+	}
+	disconnecting {
+	    ::HTTP_LOG "poll ($connid): DISCONNECTING"
+	    if {$lib(httpoutdata) == ""} {
+		set_httpwait $connid disconnected
+		return
+	    }
+	}
+	waiting -
+	polling {
+	    ::HTTP_LOG "poll ($connid): RESCHEDULING"
+	    if {[info exists lib(httpid)]} {
+		after cancel $lib(httpid)
+	    }
+	    ::HTTP_LOG "poll ($connid): $lib(pollint)"
+	    set lib(httpid) \
+		[after $lib(pollint) \
+		       [list [namespace current]::poll $connid ""]]
+	    return
+	}
+    }
+
+    if {$lib(httpusekeys)} {
+	# regenerate 
+	set firstkey [lindex $lib(httpkeys) end]
+	set secondkey ""
+	if {[llength $lib(httpkeys)] == 1} {
+	    ::HTTP_LOG "poll ($connid): regenerating keys"
+	    set lib(httpkeys) {}
+	    set seed [rand 1000000000]
+	    set oldkey $seed
+	    set key_count $lib(httpnumkeys)
+	    while {$key_count > 0} {
+		set nextkey [base64::encode [hex_decode [sha1::sha1 $oldkey]]]
+		# skip the initial seed
+		lappend lib(httpkeys) $nextkey
+		set oldkey $nextkey
+		incr key_count -1
+	    }
+	    set secondkey [lindex $lib(httpkeys) end]
+	}
+	set l [llength $lib(httpkeys)]
+	set lib(httpkeys) [lrange $lib(httpkeys) 0 [expr {$l - 2}]]
+
+	if {[string length $firstkey]} {
+	    set firstkey ";$firstkey"
+        }
+
+        if {[string length $secondkey]} {
+            set secondkey ";$secondkey"
+        }
+
+        set query "$lib(httpseskey)$firstkey$secondkey,$lib(httpoutdata)"
+    } else {
+        set query "$lib(httpseskey),$lib(httpoutdata)"
+    }
+    switch -- $lib(httpwait) {
+	disconnecting { set_httpwait $connid waiting }
+	default { set_httpwait $connid polling }
+    }
+    ::HTTP_LOG "poll ($connid): query: '[encoding convertfrom utf-8 $query]'"
+
+    get_url $connid 0 $query
+
+    set lib(httpoutdata) ""
+
+    if {[info exists lib(httpid)]} {
+        after cancel $lib(httpid)
+    }
+    ::HTTP_LOG "poll ($connid): $lib(pollint)"
+    set lib(httpid) \
+	[after $lib(pollint) [list [namespace current]::poll $connid ""]]
+}
+
+proc transport::http_poll::get_url {connid try query} {
+    variable http_version
+    variable $connid
+    upvar 0 $connid lib
+
+    set get_url_args [list -headers $lib(proxyauth)]
+    if {[package vcompare 2.3.3 $http_version] <= 0} {
+	lappend get_url_args -binary 1
+    }
+
+    eval [list ::http::geturl $lib(httpurl) -query $query \
+	       -command [list [namespace current]::process_httpreply $connid $try $query] \
+	       -timeout $lib(polltimeout)] $get_url_args
+}
+
+proc transport::http_poll::hex_decode {hexstring} {
+    set result ""
+    while { [string length $hexstring] } {
+	scan [string range $hexstring 0 1] "%x" X
+	regsub "^.." $hexstring "" hexstring
+	set result [binary format "a*c" $result $X]
+    }
+    return $result
+}
+

Deleted: trunk/tkabber/jabberlib/wrapper.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/wrapper.tcl	2007-09-03 10:47:14 UTC (rev 1219)
+++ trunk/tkabber/jabberlib/wrapper.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,386 +0,0 @@
-######################################################################
-#
-# wrapper.tcl 
-#
-# This file defines wrapper procedures.  These
-# procedures are called by functions in jabberlib, and
-# they in turn call the TclXML library functions.
-#
-# $Header$
-#
-#
-######################################################################
-#
-# Here is a list of the procedures defined here:
-#
-if {0} { 
-proc wrapper:new {streamstartcmd streamendcmd parsecmd}
-proc wrapper:free {id}
-proc wrapper:parser {id args}
-proc wrapper:reset {id}
-proc wrapper:elementstart {id tagname varlist args}
-proc wrapper:elementend {id tagname args}
-proc wrapper:chdata {id chardata}
-proc wrapper:xmlerror {id args}
-proc wrapper:xmlcrypt {text}
-proc wrapper:createxml {xmldata}
-proc wrapper:createtag {tagname args}
-proc wrapper:getattr {varlist attrname}
-proc wrapper:isattr {varlist attrname}
-proc wrapper:splitxml {xmldata vtag vvars visempty vchdata vchildren}
-proc wrapper:streamheader {args}
-proc wrapper:streamtrailer {}
-}
-#
-#
-######################################################################
-#
-set wrapper(list) ""
-set wrapper(freeid) 0
-
-######################################################################
-proc wrapper:new {streamstartcmd streamendcmd parsecmd} {
-    variable wrapper
-
-    set id "wrap#$wrapper(freeid)"
-    incr wrapper(freeid)
-
-    lappend wrapper(list) $id
-
-    set wrapper($id,streamstartcmd) $streamstartcmd
-    set wrapper($id,streamendcmd)   $streamendcmd
-    set wrapper($id,parsecmd)       $parsecmd
-
-    set wrapper($id,parser) \
-	[::xml::parser "_parser_$id" \
-	     -final 0 \
-	     -reportempty 1 \
-	     -elementstartcommand  "[namespace current]::wrapper:elementstart [list $id]" \
-	     -elementendcommand    "[namespace current]::wrapper:elementend [list $id]" \
-	     -characterdatacommand "[namespace current]::wrapper:chdata [list $id]"
-	 #   -errorcommand         "[namespace current]::wrapper:xmlerror [list $id]"
-	]
-
-    if {[info commands ::$wrapper($id,parser)] == ""} {
-	set wrapper($id,parser) [namespace current]::$wrapper($id,parser)
-    }
-
-    set wrapper($id,stack) {}
-
-    return $id
-}
-
-######################################################################
-proc wrapper:free {id} {
-    variable wrapper
-    if {[set ind [lsearch $wrapper(list) $id]] == -1} {
-	return -code error -errorinfo "No such wrapper: \"$id\""
-    }
-    set wrapper(list) [lreplace $wrapper(list) $ind $ind]
-    $wrapper($id,parser) free
-    array unset wrapper $id,*
-}
-
-######################################################################
-proc wrapper:parser {id args} {
-    variable wrapper
-    if {[lsearch $wrapper(list) $id] == -1} {
-	return -code error -errorinfo "No such wrapper: \"$id\""
-    }
-
-    return [uplevel 1 "[list $wrapper($id,parser)] $args"]
-}
-
-######################################################################
-proc wrapper:reset {id} {
-    variable wrapper
-    if {[lsearch $wrapper(list) $id] == -1} {
-	return -code error -errorinfo "No such wrapper: \"$id\""
-    }
-
-    $wrapper($id,parser) reset
-    $wrapper($id,parser) configure -final 0 \
-	-reportempty 1 \
-	-elementstartcommand  "[namespace current]::wrapper:elementstart [list $id]" \
-	-elementendcommand    "[namespace current]::wrapper:elementend [list $id]" \
-	-characterdatacommand "[namespace current]::wrapper:chdata [list $id]" 
-    #	-errorcommand         "[namespace current]::wrapper:xmlerror [list $id]"
-
-    set wrapper($id,stack) {}
-}
-
-######################################################################
-proc wrapper:elementstart {id tagname varlist args} {
-    variable wrapper
-    if {[lsearch $wrapper(list) $id] == -1} {
-	return -code error -errorinfo "No such wrapper: \"$id\""
-    }
-
-    foreach {attr val} $args {
-	switch -- $attr {
-	    -namespace {lappend varlist xmlns $val}
-	}
-    }
-
-    if {$wrapper($id,stack) == {}} {
-	set wrapper($id,level1tag) $tagname
-	uplevel #0 "$wrapper($id,streamstartcmd) [list $varlist]"
-    }
-    set wrapper($id,stack) \
-	[linsert $wrapper($id,stack) 0 \
-	     [list $tagname $varlist {} "" "" ""]]
-}
-
-######################################################################
-proc wrapper:elementend {id tagname args} {
-    variable wrapper
-    if {[lsearch $wrapper(list) $id] == -1} {
-	return -code error -errorinfo "No such wrapper: \"$id\""
-    }
-
-    set new_el [lindex $wrapper($id,stack) 0]
-    set tail [lrange $wrapper($id,stack) 1 end]
-
-    set len [llength $tail]
-
-    if {$len > 1} {
-	set head [lindex $tail 0]
-	#set subtail [lrange $tail 1 end]
-	set els [linsert [lindex $head 2] end $new_el]
-	set wrapper($id,stack) \
-	    [lreplace $tail 0 0 \
-		 [lreplace $head 2 2 $els]]
-    } elseif {$len == 1} {
-	uplevel \#0 $wrapper($id,parsecmd) [list $new_el]
-	set wrapper($id,stack) $tail
-    } else { # $len == 0
-	uplevel \#0 $wrapper($id,streamendcmd)
-	set wrapper($id,stack) $tail
-    }
-}
-
-######################################################################
-proc wrapper:chdata {id chardata} {
-    variable wrapper
-    if {[lsearch $wrapper(list) $id] == -1} {
-	return -code error -errorinfo "No such wrapper: \"$id\""
-    }
-
-    set new_el [lindex $wrapper($id,stack) 0]
-    #set tail [lrange $wrapper($id,stack) 1 end]
-
-    set chdata "[lindex $new_el 3]$chardata"
-    set new_el [lreplace $new_el 3 3 $chdata]
-
-    set els [lindex $new_el 2]
-    if {$els == {}} {
-	set new_el [lreplace $new_el 4 4 "[lindex $new_el 4]$chardata"]
-    } else {
-	set els [lindex $new_el 2]
-	set last_el [lindex $els end]
-	set last_el [lreplace $last_el 5 5 "[lindex $last_el 5]$chardata"]
-	set els [lreplace $els end end $last_el]
-	set new_el [lreplace $new_el 2 2 $els]
-    }
-
-    set wrapper($id,stack) [lreplace $wrapper($id,stack) 0 0 $new_el]
-}
-
-######################################################################
-#
-# Called when there's an error with parsing XML.
-#
-proc wrapper:xmlerror {id args} {
-    variable wrapper
-    if {[lsearch $wrapper(list) $id] == -1} {
-	return -code error -errorinfo "No such wrapper: \"$id\""
-    }
-
-    LOG "XML Parsing Error: $args"
-    uplevel #0 $wrapper($id,streamendcmd)
-}
-
-######################################################################
-proc wrapper:xmlcrypt {text} {
-    return [string map {& &amp; < &lt; > &gt; \" &quot; ' &apos;
-			\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 " "} $text]
-}
-
-######################################################################
-#
-# This procedure converts (and returns) $xmldata to raw-XML
-#
-proc wrapper:createxml {xmldata {xmlns jabber:client}} {
-    set retext ""
-
-    set tagname [lindex $xmldata 0]
-    set vars    [lindex $xmldata 1]
-    set subtags [lindex $xmldata 2]
-    set chdata  [lindex $xmldata 3]
-
-    append retext "<$tagname"
-    foreach {attr value} $vars {
-	if {$attr == "xmlns"} {
-	    if {$value == $xmlns} {
-		continue
-	    } else {
-		set xmlns $value
-	    }
-	}
-	append retext " $attr='[wrapper:xmlcrypt $value]'"
-    }
-    if {$chdata == "" && [llength $subtags] == 0} {
-	append retext "/>"
-	return $retext
-    } else {
-	append retext ">"
-    }
-
-    append retext [wrapper:xmlcrypt $chdata]
-
-    foreach subdata $subtags {
-	append retext [wrapper:createxml $subdata $xmlns]
-    }
-
-    append retext "</$tagname>"
-
-    return $retext
-}
-
-######################################################################
-#
-# This proc creates (and returns) xmldata of tag $tagname, 
-# with the parameters given.
-#
-# Parameters:
-#  -empty   0|1         Is this an empty tag? If $chdata 
-#                       and $subtags are empty, then whether 
-#                       to make the tag empty or not is decided 
-#                       here. (default: 1)
-#
-#	-vars    {attr1 value1 attr2 value2 ..}   Vars is a list 
-#                       consisting of attr/value pairs, as shown.
-#
-#	-chdata  $chdata    ChData of tag (default: ""), if you use 
-#                       this attr multiple times, new chdata will 
-#                       be appended to old one.
-#
-#	-subtags $subchilds $subchilds is a list containing xmldatas 
-#                       of $tagname's subtags. (default: no sub-tags)
-#
-proc wrapper:createtag {tagname args} {
-
-    set isempty 1
-    set vars    ""
-    set chdata  ""
-    set subtags ""
-
-    foreach {attr val} $args {
-	switch -- $attr {
-	    -empty   {set isempty $val}
-	    -vars    {set vars $val}
-	    -chdata  {set chdata $chdata$val}
-	    -subtags {set subtags $val}
-	}
-    }
-
-    set retext [list $tagname $vars $subtags $chdata "" ""]
-
-    return $retext
-}
-
-######################################################################
-#
-# This proc returns the value of $attr from varlist
-#
-proc wrapper:getattr {varlist attrname} {
-
-  foreach {attr val} $varlist {
-	if {$attr == $attrname} {return $val}
-  }
-  return ""
-}
-
-######################################################################
-#
-# This proc returns 1, or 0, depending on the attr exists in varlist or not
-#
-proc wrapper:isattr {varlist attrname} {
-
-  foreach {attr val} $varlist {
-	if {$attr == $attrname} {return 1}
-  }
-  return 0
-}
-
-######################################################################
-#
-# This proc splits the xmldata to 5 different variables.
-#
-proc wrapper:splitxml {xmldata vtag vvars visempty vchdata vchildren} {
-    set tag      [lindex $xmldata 0]
-    set vars     [lindex $xmldata 1]
-    set children [lindex $xmldata 2]
-    set chdata   [lindex $xmldata 3]
-    
-    uplevel 1 "set [list $vtag]      [list $tag] \n     \
-               set [list $vvars]     [list $vars] \n    \
-               set [list $visempty]  0 \n \
-               set [list $vchdata]   [list $chdata] \n  \
-               set [list $vchildren] [list $children]"
-}
-
-proc wrapper:get_subchdata {xmldata} {
-    lindex $xmldata 4
-}
-
-proc wrapper:get_fchdata {xmldata} {
-    lindex $xmldata 5
-}
-
-
-######################################################################
-#
-# This proc returns stream header
-#
-proc wrapper:streamheader {to args} {
-    set to [wrapper:xmlcrypt $to]
-    set xmlns_stream [wrapper:xmlcrypt "http://etherx.jabber.org/streams"]
-    set xmlns [wrapper:xmlcrypt "jabber:client"]
-    set lang ""
-    set version ""
-    foreach {opt val} $args {
-	switch -- $opt {
-	    -xmlns:stream {
-		set xmlns_stream [wrapper:xmlcrypt $val]
-	    }
-	    -xmlns {
-		set xmlns [wrapper:xmlcrypt $val]
-	    }
-	    -xml:lang {
-		set lang " xml:lang='[wrapper:xmlcrypt $val]'"
-	    }
-	    -version {
-		set version " version='$val'"
-	    }
-	}
-    }
-    return "<stream:stream xmlns:stream='$xmlns_stream'\
-	    xmlns='$xmlns'$lang to='$to'$version>"
-}
-
-######################################################################
-#
-# This proc returns stream trailer
-#
-proc wrapper:streamtrailer {} {
-    return "</stream:stream>"
-}
-

Copied: trunk/tkabber/jabberlib/wrapper.tcl (from rev 1243, trunk/tkabber/jabberlib-tclxml/wrapper.tcl)
===================================================================
--- trunk/tkabber/jabberlib/wrapper.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib/wrapper.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -0,0 +1,392 @@
+######################################################################
+#
+# wrapper.tcl 
+#
+# This file defines wrapper procedures.  These
+# procedures are called by functions in jabberlib, and
+# they in turn call the TclXML library functions.
+#
+# $Header$
+#
+#
+######################################################################
+#
+# Here is a list of the procedures defined here:
+#
+if {0} { 
+proc wrapper:new {streamstartcmd streamendcmd parsecmd}
+proc wrapper:free {id}
+proc wrapper:parser {id args}
+proc wrapper:reset {id}
+proc wrapper:elementstart {id tagname varlist args}
+proc wrapper:elementend {id tagname args}
+proc wrapper:chdata {id chardata}
+proc wrapper:xmlerror {id args}
+proc wrapper:xmlcrypt {text}
+proc wrapper:createxml {xmldata}
+proc wrapper:createtag {tagname args}
+proc wrapper:getattr {varlist attrname}
+proc wrapper:isattr {varlist attrname}
+proc wrapper:splitxml {xmldata vtag vvars visempty vchdata vchildren}
+proc wrapper:streamheader {args}
+proc wrapper:streamtrailer {}
+}
+#
+#
+######################################################################
+#
+set wrapper(list) ""
+set wrapper(freeid) 0
+
+######################################################################
+proc wrapper:new {streamstartcmd streamendcmd parsecmd} {
+    variable wrapper
+
+    set id "wrap#$wrapper(freeid)"
+    incr wrapper(freeid)
+
+    lappend wrapper(list) $id
+
+    set wrapper($id,streamstartcmd) $streamstartcmd
+    set wrapper($id,streamendcmd)   $streamendcmd
+    set wrapper($id,parsecmd)       $parsecmd
+
+    set wrapper($id,parser) \
+	[::xml::parser "_parser_$id" \
+	     -namespace \
+	     -final 0 \
+	     -elementstartcommand  "[namespace current]::wrapper:elementstart [list $id]" \
+	     -elementendcommand    "[namespace current]::wrapper:elementend [list $id]" \
+	     -characterdatacommand "[namespace current]::wrapper:chdata [list $id]"
+	 #   -errorcommand         "[namespace current]::wrapper:xmlerror [list $id]"
+	]
+
+    if {[info commands ::$wrapper($id,parser)] == ""} {
+	set wrapper($id,parser) [namespace current]::$wrapper($id,parser)
+    }
+
+    set wrapper($id,stack) {}
+
+    return $id
+}
+
+######################################################################
+proc wrapper:free {id} {
+    variable wrapper
+    if {[set ind [lsearch $wrapper(list) $id]] == -1} {
+	return -code error -errorinfo "No such wrapper: \"$id\""
+    }
+    set wrapper(list) [lreplace $wrapper(list) $ind $ind]
+    $wrapper($id,parser) free
+    array unset wrapper $id,*
+}
+
+######################################################################
+proc wrapper:parser {id args} {
+    variable wrapper
+    if {[lsearch $wrapper(list) $id] == -1} {
+	return -code error -errorinfo "No such wrapper: \"$id\""
+    }
+
+    return [uplevel 1 "[list $wrapper($id,parser)] $args"]
+}
+
+######################################################################
+proc wrapper:reset {id} {
+    variable wrapper
+    if {[lsearch $wrapper(list) $id] == -1} {
+	return -code error -errorinfo "No such wrapper: \"$id\""
+    }
+
+    $wrapper($id,parser) reset
+    $wrapper($id,parser) configure \
+	-final 0 \
+	-elementstartcommand  "[namespace current]::wrapper:elementstart [list $id]" \
+	-elementendcommand    "[namespace current]::wrapper:elementend [list $id]" \
+	-characterdatacommand "[namespace current]::wrapper:chdata [list $id]" 
+    #	-errorcommand         "[namespace current]::wrapper:xmlerror [list $id]"
+
+    set wrapper($id,stack) {}
+}
+
+######################################################################
+proc wrapper:elementstart {id tagname varlist args} {
+    variable wrapper
+    if {[lsearch $wrapper(list) $id] == -1} {
+	return -code error -errorinfo "No such wrapper: \"$id\""
+    }
+
+    foreach {attr val} $args {
+	switch -- $attr {
+	    -namespace {lappend varlist xmlns $val}
+	}
+    }
+
+    set idx [string last : $tagname]
+    if {$idx >= 0} {
+	lappend varlist xmlns [string range $tagname 0 [expr {$idx - 1}]]
+	set tagname [string range $tagname [expr {$idx + 1}] end]
+    }
+
+    if {$wrapper($id,stack) == {}} {
+	set wrapper($id,level1tag) $tagname
+	uplevel #0 "$wrapper($id,streamstartcmd) [list $varlist]"
+    }
+    set wrapper($id,stack) \
+	[linsert $wrapper($id,stack) 0 \
+	     [list $tagname $varlist {} "" "" ""]]
+}
+
+######################################################################
+proc wrapper:elementend {id tagname args} {
+    variable wrapper
+    if {[lsearch $wrapper(list) $id] == -1} {
+	return -code error -errorinfo "No such wrapper: \"$id\""
+    }
+
+    set new_el [lindex $wrapper($id,stack) 0]
+    set tail [lrange $wrapper($id,stack) 1 end]
+
+    set len [llength $tail]
+
+    if {$len > 1} {
+	set head [lindex $tail 0]
+	#set subtail [lrange $tail 1 end]
+	set els [linsert [lindex $head 2] end $new_el]
+	set wrapper($id,stack) \
+	    [lreplace $tail 0 0 \
+		 [lreplace $head 2 2 $els]]
+    } elseif {$len == 1} {
+	uplevel \#0 $wrapper($id,parsecmd) [list $new_el]
+	set wrapper($id,stack) $tail
+    } else { # $len == 0
+	uplevel \#0 $wrapper($id,streamendcmd)
+	set wrapper($id,stack) $tail
+    }
+}
+
+######################################################################
+proc wrapper:chdata {id chardata} {
+    variable wrapper
+    if {[lsearch $wrapper(list) $id] == -1} {
+	return -code error -errorinfo "No such wrapper: \"$id\""
+    }
+
+    set new_el [lindex $wrapper($id,stack) 0]
+    #set tail [lrange $wrapper($id,stack) 1 end]
+
+    set chdata "[lindex $new_el 3]$chardata"
+    set new_el [lreplace $new_el 3 3 $chdata]
+
+    set els [lindex $new_el 2]
+    if {$els == {}} {
+	set new_el [lreplace $new_el 4 4 "[lindex $new_el 4]$chardata"]
+    } else {
+	set els [lindex $new_el 2]
+	set last_el [lindex $els end]
+	set last_el [lreplace $last_el 5 5 "[lindex $last_el 5]$chardata"]
+	set els [lreplace $els end end $last_el]
+	set new_el [lreplace $new_el 2 2 $els]
+    }
+
+    set wrapper($id,stack) [lreplace $wrapper($id,stack) 0 0 $new_el]
+}
+
+######################################################################
+#
+# Called when there's an error with parsing XML.
+#
+proc wrapper:xmlerror {id args} {
+    variable wrapper
+    if {[lsearch $wrapper(list) $id] == -1} {
+	return -code error -errorinfo "No such wrapper: \"$id\""
+    }
+
+    LOG "XML Parsing Error: $args"
+    uplevel #0 $wrapper($id,streamendcmd)
+}
+
+######################################################################
+proc wrapper:xmlcrypt {text} {
+    return [string map {& &amp; < &lt; > &gt; \" &quot; ' &apos;
+			\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 " "} $text]
+}
+
+######################################################################
+#
+# This procedure converts (and returns) $xmldata to raw-XML
+#
+proc wrapper:createxml {xmldata {xmlns jabber:client}} {
+    set retext ""
+
+    set tagname [lindex $xmldata 0]
+    set vars    [lindex $xmldata 1]
+    set subtags [lindex $xmldata 2]
+    set chdata  [lindex $xmldata 3]
+
+    append retext "<$tagname"
+    foreach {attr value} $vars {
+	if {$attr == "xmlns"} {
+	    if {$value == $xmlns} {
+		continue
+	    } else {
+		set xmlns $value
+	    }
+	}
+	append retext " $attr='[wrapper:xmlcrypt $value]'"
+    }
+    if {$chdata == "" && [llength $subtags] == 0} {
+	append retext "/>"
+	return $retext
+    } else {
+	append retext ">"
+    }
+
+    append retext [wrapper:xmlcrypt $chdata]
+
+    foreach subdata $subtags {
+	append retext [wrapper:createxml $subdata $xmlns]
+    }
+
+    append retext "</$tagname>"
+
+    return $retext
+}
+
+######################################################################
+#
+# This proc creates (and returns) xmldata of tag $tagname, 
+# with the parameters given.
+#
+# Parameters:
+#  -empty   0|1         Is this an empty tag? If $chdata 
+#                       and $subtags are empty, then whether 
+#                       to make the tag empty or not is decided 
+#                       here. (default: 1)
+#
+#	-vars    {attr1 value1 attr2 value2 ..}   Vars is a list 
+#                       consisting of attr/value pairs, as shown.
+#
+#	-chdata  $chdata    ChData of tag (default: ""), if you use 
+#                       this attr multiple times, new chdata will 
+#                       be appended to old one.
+#
+#	-subtags $subchilds $subchilds is a list containing xmldatas 
+#                       of $tagname's subtags. (default: no sub-tags)
+#
+proc wrapper:createtag {tagname args} {
+
+    set isempty 1
+    set vars    ""
+    set chdata  ""
+    set subtags ""
+
+    foreach {attr val} $args {
+	switch -- $attr {
+	    -empty   {set isempty $val}
+	    -vars    {set vars $val}
+	    -chdata  {set chdata $chdata$val}
+	    -subtags {set subtags $val}
+	}
+    }
+
+    set retext [list $tagname $vars $subtags $chdata "" ""]
+
+    return $retext
+}
+
+######################################################################
+#
+# This proc returns the value of $attr from varlist
+#
+proc wrapper:getattr {varlist attrname} {
+
+  foreach {attr val} $varlist {
+	if {$attr == $attrname} {return $val}
+  }
+  return ""
+}
+
+######################################################################
+#
+# This proc returns 1, or 0, depending on the attr exists in varlist or not
+#
+proc wrapper:isattr {varlist attrname} {
+
+  foreach {attr val} $varlist {
+	if {$attr == $attrname} {return 1}
+  }
+  return 0
+}
+
+######################################################################
+#
+# This proc splits the xmldata to 5 different variables.
+#
+proc wrapper:splitxml {xmldata vtag vvars visempty vchdata vchildren} {
+    set tag      [lindex $xmldata 0]
+    set vars     [lindex $xmldata 1]
+    set children [lindex $xmldata 2]
+    set chdata   [lindex $xmldata 3]
+    
+    uplevel 1 "set [list $vtag]      [list $tag] \n     \
+               set [list $vvars]     [list $vars] \n    \
+               set [list $visempty]  0 \n \
+               set [list $vchdata]   [list $chdata] \n  \
+               set [list $vchildren] [list $children]"
+}
+
+proc wrapper:get_subchdata {xmldata} {
+    lindex $xmldata 4
+}
+
+proc wrapper:get_fchdata {xmldata} {
+    lindex $xmldata 5
+}
+
+
+######################################################################
+#
+# This proc returns stream header
+#
+proc wrapper:streamheader {to args} {
+    set to [wrapper:xmlcrypt $to]
+    set xmlns_stream [wrapper:xmlcrypt "http://etherx.jabber.org/streams"]
+    set xmlns [wrapper:xmlcrypt "jabber:client"]
+    set lang ""
+    set version ""
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -xmlns:stream {
+		set xmlns_stream [wrapper:xmlcrypt $val]
+	    }
+	    -xmlns {
+		set xmlns [wrapper:xmlcrypt $val]
+	    }
+	    -xml:lang {
+		set lang " xml:lang='[wrapper:xmlcrypt $val]'"
+	    }
+	    -version {
+		set version " version='$val'"
+	    }
+	}
+    }
+    return "<stream:stream xmlns:stream='$xmlns_stream'\
+	    xmlns='$xmlns'$lang to='$to'$version>"
+}
+
+######################################################################
+#
+# This proc returns stream trailer
+#
+proc wrapper:streamtrailer {} {
+    return "</stream:stream>"
+}
+

Modified: trunk/tkabber/plugins/general/avatars.tcl
===================================================================
--- trunk/tkabber/plugins/general/avatars.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/plugins/general/avatars.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -216,13 +216,16 @@
 proc ::avatar::store_on_server {args} {
     variable avatar
 
+    if {[llength [jlib::connections]] == 0} return
+
     foreach {opt val} $args {
 	switch -- $opt {
 	    -connection { set connid $val }
 	}
     }
+
     if {![info exists connid]} {
-	set connid [jlib::route ""]
+	set connid [lindex [jlib::connections] 0]
     }
 
     if {![info exists avatar(userdata)]} {

Modified: trunk/tkabber/plugins/general/subscribe_gateway.tcl
===================================================================
--- trunk/tkabber/plugins/general/subscribe_gateway.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/plugins/general/subscribe_gateway.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -10,22 +10,12 @@
 proc gateway::add_menu_item {m connid jid} {
 
     $m add command -label [::msgcat::mc "Add user to roster..."] \
-	-command [list [namespace current]::subscribe_dialog $jid \
-		       -connection $connid]
+	-command [list [namespace current]::subscribe_dialog $connid $jid]
 }
 
-proc gateway::subscribe_dialog {service args} {
+proc gateway::subscribe_dialog {connid service} {
     variable msgid
 
-    foreach {opt val} $args {
-	switch -- $opt {
-	    -connection { set connid $val }
-	}
-    }
-    if {![info exists connid]} {
-	set connid [jlib::route $service]
-    }
-
     set mw .gwmsg$msgid
     toplevel $mw
     wm group $mw .
@@ -37,7 +27,7 @@
 
     set bbox [ButtonBox $mw.buttons -spacing 0 -padx 10 -default 0]
     $bbox add -text [::msgcat::mc "Subscribe"] \
-        -command [list [namespace current]::send_subscribe $mw $service -connection $connid]
+        -command [list [namespace current]::send_subscribe $mw $connid $service]
     $bbox add -text [::msgcat::mc "Cancel"] -command [list destroy $mw]
 
     bind $mw <Return> "ButtonBox::invoke $bbox default"
@@ -110,18 +100,9 @@
     }
 }
 
-proc gateway::send_subscribe {mw service args} {
+proc gateway::send_subscribe {mw connid service} {
     variable $mw.prompt
     
-    foreach {opt val} $args {
-	switch -- $opt {
-	    -connection { set connid $val }
-	}
-    }
-    if {![info exists connid]} {
-	set connid [jlib::route $service]
-    }
-
     switch -- [set $mw.prompt] {
 	fulljid {
 	    $mw.subj.entry insert end "@$service"
@@ -175,7 +156,7 @@
 	}
     }
     if {![info exists connid]} {
-	set connid [jlib::route $jid]
+	return -code error "Option -connection mandatory"
     }
 
     jlib::send_iq get \
@@ -201,8 +182,7 @@
     set f [$w getframe]
 
     $w add -text [::msgcat::mc "Convert"] \
-        -command [list [namespace current]::convert_screenname $w \
-	                $jid -connection $connid]
+        -command [list [namespace current]::convert_screenname $w $connid $jid]
     $w add -text [::msgcat::mc "Cancel"] -command [list destroy $w]
 
     jlib::wrapper:splitxml $child tag vars isempty chdata children
@@ -236,17 +216,7 @@
     $w draw $f.prompt
 }
 
-proc gateway::convert_screenname {w jid args} {
-
-    foreach {opt val} $args {
-	switch -- $opt {
-	    -connection {set connid $val}
-	}
-    }
-    if {![info exists connid]} {
-	set connid [jlib::route $jid]
-    }
-
+proc gateway::convert_screenname {w connid jid} {
     set f [$w getframe]
     set screenname [$f.prompt get]
     

Modified: trunk/tkabber/plugins/general/xcommands.tcl
===================================================================
--- trunk/tkabber/plugins/general/xcommands.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/plugins/general/xcommands.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -20,7 +20,7 @@
 	}
     }
     if {![info exists connid]} {
-	set connid [jlib::route $jid]
+	return -code error "Option -connection is mandatory"
     }
 
     if {$category != "automation"} return

Modified: trunk/tkabber/plugins/roster/conferences.tcl
===================================================================
--- trunk/tkabber/plugins/roster/conferences.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/plugins/roster/conferences.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -381,7 +381,8 @@
 	}
     }
     if {![info exists connid]} {
-	set connid [jlib::route $jid]
+	# Disconnect while dialog is opened
+	return
     }
 
     if {[info exists bookmarks($connid,jid,$jid)]} {

Modified: trunk/tkabber/privacy.tcl
===================================================================
--- trunk/tkabber/privacy.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/privacy.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -48,14 +48,16 @@
 #
 
 proc privacy::request_lists {args} {
+
     foreach {opt val} $args {
 	switch -- $opt {
 	    -connection { set connid $val }
 	}
     }
     if {![info exists connid]} {
-	set connid [jlib::route ""]
+	set connid [first_supported]
     }
+    if {$connid == ""} return
 
     jlib::send_iq get \
 	[jlib::wrapper:createtag query \
@@ -605,7 +607,7 @@
 	}
     }
     if {![info exists connid]} {
-	set connid [jlib::route ""]
+	return -code error "Option -connection is mandatory"
     }
 
     jlib::send_iq set \
@@ -708,7 +710,7 @@
 	}
     }
     if {![info exists connid]} {
-	set connid [jlib::route ""]
+	return -code error "Option -connection is mandatory"
     }
 
     if {$name != ""} {
@@ -737,8 +739,9 @@
 	}
     }
     if {![info exists connid]} {
-	set connid [jlib::route ""]
+	set connid [first_supported]
     }
+    if {$connid == ""} return
 
     jlib::send_iq get \
 	[jlib::wrapper:createtag query \
@@ -939,8 +942,9 @@
 	}
     }
     if {![info exists connid]} {
-	set connid [jlib::route ""]
+	set connid [first_supported]
     }
+    if {$connid == ""} return
 
     send_subscription_list $connid
 }
@@ -1610,12 +1614,21 @@
 
 ###############################################################################
 
-proc privacy::enable_menu {connid} {
-    set c [::jlib::route ""]
-    if {![is_supported $c]} {
-	return
+proc privacy::first_supported {} {
+    foreach connid [jlib::connections] {
+	if {[is_supported $connid]} {
+	    return $connid
+	}
     }
+    return ""
+}
 
+###############################################################################
+
+proc privacy::enable_menu {connid} {
+
+    if {[first_supported] == ""} return
+
     set m [.mainframe getmenu privacy]
     if {$::ifacetk::options(show_tearoffs)} {
 	set start 1
@@ -1628,9 +1641,9 @@
 }
 
 proc privacy::disable_menu {connid} {
-    set c [::jlib::route ""]
-    if {[llength [jlib::connections]] > 0 && [is_supported $c]} return
 
+    if {[first_supported] != ""} return
+
     set m [.mainframe getmenu privacy]
     if {$::ifacetk::options(show_tearoffs)} {
 	set start 1

Modified: trunk/tkabber/pubsub.tcl
===================================================================
--- trunk/tkabber/pubsub.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/pubsub.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1492,7 +1492,8 @@
     }
 
     if {![info exists connid]} {
-	set connid [jlib::route $service]
+	return -code error \
+	       "pubsub::request_entities: -connection is mandatory"
     }
 
     if {$node == ""} {

Modified: trunk/tkabber/splash.tcl
===================================================================
--- trunk/tkabber/splash.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/splash.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -204,18 +204,20 @@
 	    } else {
 		set name [file rootname [lindex $srelpath 0]]
 	    }
-	    if {[info exists splash_text($name)]} {
-		set splash_info $splash_text($name)
-	    } else {
-		# Process plugins separately
-		set nlist [split $name :]
-		if {[lindex $nlist 0] == "plugins"} {
-		    set splash_info \
-			[::msgcat::mc "%s plugin" [join [lrange $nlist 1 end] :]]
+	    if {![string equal -nocase [lindex $srelpath end] "pkgIndex.tcl"]} {
+		if {[info exists splash_text($name)]} {
+		    set splash_info $splash_text($name)
+		} else {
+		    # Process plugins separately
+		    set nlist [split $name :]
+		    if {[lindex $nlist 0] == "plugins"} {
+			set splash_info \
+			    [::msgcat::mc "%s plugin" [join [lrange $nlist 1 end] :]]
+		    }
 		}
+		incr splash_count
+		update
 	    }
-	    incr splash_count
-	    update
 	}
     }
 

Modified: trunk/tkabber/tclxml/pkgIndex.tcl
===================================================================
--- trunk/tkabber/tclxml/pkgIndex.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/tclxml/pkgIndex.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -2,14 +2,6 @@
 #
 # $Id$
 
-package ifneeded xml::tcl 2.0 [list source [file join $dir xml__tcl.tcl]]
-package ifneeded sgmlparser 1.0 [list source [file join $dir sgmlparser.tcl]]
-
-package ifneeded xpath 1.0 [list source [file join $dir xpath.tcl]]
-package ifneeded xmldep 1.0 [list source [file join $dir xmldep.tcl]]
-
-namespace eval ::xml {}
-
 package ifneeded xml 2.0 {
     package require -exact xml::tcl 2.0
     package require -exact xmldefs 2.0
@@ -17,6 +9,9 @@
     package provide xml 2.0
 }
 
+package ifneeded xml::tcl 2.0 [list source [file join $dir xml__tcl.tcl]]
+package ifneeded sgmlparser 1.0 [list source [file join $dir sgmlparser.tcl]]
+
 package ifneeded sgml 1.8 [list source [file join $dir sgml-8.1.tcl]]
 package ifneeded xmldefs 2.0 [list source [file join $dir xml-8.1.tcl]]
 package ifneeded xml::tclparser 2.0 [list source [file join $dir tclparser-8.1.tcl]]

Modified: trunk/tkabber/tclxml/sgmlparser.tcl
===================================================================
--- trunk/tkabber/tclxml/sgmlparser.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/tclxml/sgmlparser.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -34,7 +34,7 @@
 #
 # $Id$
 
-package require sgml 1.8
+package require -exact sgml 1.8
 
 package require uri 1.0
 

Modified: trunk/tkabber/tclxml/tclparser-8.1.tcl
===================================================================
--- trunk/tkabber/tclxml/tclparser-8.1.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/tclxml/tclparser-8.1.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -42,7 +42,8 @@
 
 namespace eval xml::tclparser {
 
-    namespace export create createexternal externalentity parse configure get delete
+    namespace export create createexternal externalentity parse \
+		     configure get delete
 
     # Tokenising expressions
 
@@ -73,21 +74,22 @@
 
     # Initialise state variable
     upvar \#0 [namespace current]::$name parser
-    array set parser [list -name $name			\
-	-final 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 {}                                     \
+    array set parser [list \
+	-name $name							 \
+	-final 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
@@ -114,7 +116,8 @@
     upvar \#0 [namespace current]::$name external
     array set external [array get p]
 
-    array set external [list -name $name			\
+    array set external [list \
+	-name $name					\
 	-statevariable [namespace current]::$name	\
 	internaldtd {}					\
 	line 0						\
@@ -140,23 +143,24 @@
 
     # 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 \
-      -validate -baseurl \
-      -name -emptyelement \
-      -parseattributelistcommand -parseentitydeclcommand \
-      -normalize -internaldtd \
-      -reportempty -ignorewhitespace \
-      -reportempty \
+    set options {
+	-elementstartcommand -elementendcommand \
+	-characterdatacommand -processinginstructioncommand \
+	-externalentitycommand -xmldeclcommand \
+	-doctypecommand -commentcommand \
+	-entitydeclcommand -unparsedentitydeclcommand \
+	-parameterentitydeclcommand -notationdeclcommand \
+	-elementdeclcommand -attlistdeclcommand \
+	-paramentityparsing -defaultexpandinternalentities \
+	-startdoctypedeclcommand -enddoctypedeclcommand \
+	-entityreferencecommand -warningcommand \
+	-errorcommand -final \
+	-validate -baseurl \
+	-name -emptyelement \
+	-parseattributelistcommand -parseentitydeclcommand \
+	-normalize -internaldtd \
+	-reportempty -ignorewhitespace \
+	-reportempty \
     }
     set usage [join $options ", "]
     regsub -all -- - $options {} options
@@ -254,7 +258,7 @@
     }
 
     lappend tokenOptions  \
-      -internaldtdvariable [namespace current]::${name}(internaldtd)
+	    -internaldtdvariable [namespace current]::${name}(internaldtd)
     
     # Mats: If -final 0 we also need to maintain the state with a -statevariable !
     if {!$parser(-final)} {
@@ -303,7 +307,7 @@
 	}
     }
 }
-
+
 # xml::tclparser::ParseAttrs -- Tcl 8.1+ version
 #
 #	Parse element attributes.
@@ -333,9 +337,11 @@
     set result {}
 
     while {[string length [string trim $attrs]]} {
-	if {[regexp ($::xml::Name)[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')([::sgml::cl ^<]*?)\\2(.*) $attrs discard attrName delimiter value 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]} {
+	} 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"
@@ -464,7 +470,8 @@
 
 proc xml::tclparser::ParseEntity data {
     set data [string trim $data]
-    if {[regexp $::sgml::ExternalEntityExpr $data discard type delimiter1 id1 discard delimiter2 id2 optNDATA ndata]} {
+    if {[regexp $::sgml::ExternalEntityExpr $data \
+		-> type delimiter1 id1 discard delimiter2 id2 optNDATA ndata]} {
 	switch $type {
 	    PUBLIC {
 		return [list external $id2 $id1 $ndata]
@@ -473,7 +480,7 @@
 		return [list external $id1 {} $ndata]
 	    }
 	}
-    } elseif {[regexp {^("|')(.*?)\1$} $data discard delimiter value]} {
+    } elseif {[regexp {^(\"|')(.*?)\1$} $data discard delimiter value]} {
 	return [list internal $value]
     } else {
 	return -code error "badly formed entity declaration"
@@ -529,19 +536,22 @@
 		    if {[info exists elements([lindex $args 0])]} {
 			return [array get elements [lindex $args 0]]
 		    } else {
-			return -code error "element \"[lindex $args 0]\" not declared"
+			return -code error "element \"[lindex $args 0]\" not\
+					    declared"
 		    }
 		}
 
 		default {
-		    return -code error "wrong number of arguments: should be \"elementdecl ?element?\""
+		    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\""
+		return -code error "wrong number of arguments: should be\
+				    \"get attlist element\""
 	    }
 
 	    upvar #0 $parser(attlistdecls)

Modified: trunk/tkabber/tclxml/xml__tcl.tcl
===================================================================
--- trunk/tkabber/tclxml/xml__tcl.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/tclxml/xml__tcl.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -71,12 +71,14 @@
 
 	create {
 	    if {[llength $args] < 1} {
-		return -code error "wrong number of arguments, should be xml::parserclass create name ?args?"
+		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]\""
+		return -code error "missing value for option\
+				    \"[lindex $args end]\""
 	    }
 	    array set classes [list $name [list \
 		    -createcommand [namespace current]::noop \
@@ -93,7 +95,8 @@
 
 	destroy {
 	    if {[llength $args] < 1} {
-		return -code error "wrong number of arguments, should be xml::parserclass destroy name"
+		return -code error "wrong number of arguments, should be\
+				    xml::parserclass destroy name"
 	    }
 
 	    if {[info exists classes([lindex $args 0])]} {
@@ -105,7 +108,8 @@
 
 	info {
 	    if {[llength $args] < 1} {
-		return -code error "wrong number of arguments, should be xml::parserclass info method"
+		return -code error "wrong number of arguments, should be\
+				    xml::parserclass info method"
 	    }
 
 	    switch -- [lindex $args 0] {
@@ -131,7 +135,7 @@
 #	Create a parser object instance
 #
 # Arguments:
-#	args	optional name, configuration options
+#	args	optional name, optional -namespace, configuration options
 #
 # Results:
 #	Returns object name.  Parser instance created.
@@ -170,7 +174,9 @@
 
     # 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"]
+    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)]
 
@@ -239,7 +245,9 @@
 	    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"]
+	    uplevel 1 [list proc $new {method args} \
+			    "eval [namespace current]::ParserCmd [list $new]\
+				  \[list \$method\] \$args"]
 
 	    eval $classinfo(-createentityparsercommand) [list $name $new] $args
 
@@ -258,7 +266,8 @@
 
 	parse {
 	    if {[llength $args] < 1} {
-		return -code error "wrong number of arguments, should be $name parse xml ?options?"
+		return -code error "wrong number of arguments, should be\
+				    $name parse xml ?options?"
 	    }
 	    eval $classinfo(-parsecommand) [list $name] $args
 	}

Deleted: trunk/tkabber/tclxml/xmldep.tcl
===================================================================
--- trunk/tkabber/tclxml/xmldep.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/tclxml/xmldep.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,176 +0,0 @@
-# xmldep.tcl --
-#
-#	Find the dependencies in an XML document.
-#	Supports external entities and XSL include/import.
-#
-# TODO:
-#	XInclude
-#
-# Copyright (c) 2001 Zveno Pty Ltd
-# http://www.zveno.com/
-#
-# $Id$
-
-package require xml
-
-package provide xml::dep
-
-namespace eval xml::dep {
-    namespace export depend
-
-    variable extEntities
-    array set extEntities {}
-
-    variable XSLTNS http://www.w3.org/1999/XSL/Transform
-}
-
-# xml::dep::depend --
-#
-#	Find the resources which an XML document
-#	depends on.  The document is parsed
-#	sequentially, rather than using DOM, for efficiency.
-#
-# TODO:
-#	Asynchronous parsing.
-#
-# Arguments:
-#	xml	XML document entity
-#	args	configuration options
-#
-# Results:
-#	Returns list of resource (system) identifiers
-
-proc xml::dep::depend {xml args} {
-    variable resources
-    variable entities
-
-    set resources {}
-    catch {unset entities}
-    array set entities {}
-
-    set p [xml::parser \
-	    -elementstartcommand [namespace code ElStart]	\
-	    -doctypecommand [namespace code DocTypeDecl]	\
-	    -entitydeclcommand [namespace code EntityDecl]	\
-	    -entityreferencecommand [namespace code EntityReference]	\
-	    -validate 1	\
-	    ]
-    if {[llength $args]} {
-	eval [list $p] configure $args
-    }
-    $p parse $xml
-
-    return $resources
-}
-
-# xml::dep::ElStart --
-#
-#	Process start element
-#
-# Arguments:
-#	name	tag name
-#	atlist	attribute list
-#	args	options
-#
-# Results:
-#	May add to resources list
-
-proc xml::dep::ElStart {name atlist args} {
-    variable XSLTNS
-    variable resources
-
-    array set opts {
-	-namespace {}
-    }
-    array set opts $args
-
-    switch -- $opts(-namespace) \
-	    $XSLTNS {
-	switch $name {
-	    import -
-	    include {
-		array set attr {
-		    href {}
-		}
-		array set attr $atlist
-
-		if {[string length $attr(href)]} {
-		    if {[lsearch $resources $attr(href)] < 0} {
-			lappend resources $attr(href)
-		    }
-		}
-
-	    }
-	}
-    }
-}
-
-# xml::dep::DocTypeDecl --
-#
-#	Process Document Type Declaration
-#
-# Arguments:
-#	name	Document element
-#	pubid	Public identifier
-#	sysid	System identifier
-#	dtd	Internal DTD Subset
-#
-# Results:
-#	Resource added to list
-
-proc xml::dep::DocTypeDecl {name pubid sysid dtd} {
-    variable resources
-
-    puts stderr [list DocTypeDecl $name $pubid $sysid dtd]
-
-    if {[string length $sysid] && \
-	    [lsearch $resources $sysid] < 0} {
-	lappend resources $sysid
-    }
-
-    return {}
-}
-
-# xml::dep::EntityDecl --
-#
-#	Process entity declaration, looking for external entity
-#
-# Arguments:
-#	name	entity name
-#	sysid	system identifier
-#	pubid	public identifier or repl. text
-#
-# Results:
-#	Store external entity info for later reference
-
-proc xml::dep::EntityDecl {name sysid pubid} {
-    variable extEntities
-
-    puts stderr [list EntityDecl $name $sysid $pubid]
-
-    set extEntities($name) $sysid
-}
-
-# xml::dep::EntityReference --
-#
-#	Process entity reference
-#
-# Arguments:
-#	name	entity name
-#
-# Results:
-#	May add to resources list
-
-proc xml::dep::EntityReference name {
-    variable extEntities
-    variable resources
-
-    puts stderr [list EntityReference $name]
-
-    if {[info exists extEntities($name)] && \
-	[lsearch $resources $extEntities($name)] < 0} {
-	lappend resources $extEntities($name)
-    }
-
-}
-

Deleted: trunk/tkabber/tclxml/xpath.tcl
===================================================================
--- trunk/tkabber/tclxml/xpath.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/tclxml/xpath.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -1,359 +0,0 @@
-# xpath.tcl --
-#
-#	Provides an XPath parser for Tcl,
-#	plus various support procedures
-#
-# Copyright (c) 2000-2002 Zveno Pty Ltd
-#
-# $Id$
-
-package provide xpath 1.0
-
-# We need the XML package for definition of Names
-package require xml
-
-namespace eval xpath {
-    namespace export split join createnode
-
-    variable axes {
-	ancestor
-	ancestor-or-self
-	attribute
-	child
-	descendant
-	descendant-or-self
-	following
-	following-sibling
-	namespace
-	parent
-	preceding
-	preceding-sibling
-	self
-    }
-
-    variable nodeTypes {
-	comment
-	text
-	processing-instruction
-	node
-    }
-
-    # NB. QName has parens for prefix
-
-    variable nodetestExpr ^(${::xml::QName})${::xml::allWsp}(\\(${::xml::allWsp}(("|')(.*?)\\5)?${::xml::allWsp}\\))?${::xml::allWsp}(.*)
-
-    variable nodetestExpr2 ((($::xml::QName)${::xml::allWsp}(\\(${::xml::allWsp}(("|')(.*?)\\7)?${::xml::allWsp}\\))?)|${::xml::allWsp}(\\*))${::xml::allWsp}(.*)
-}
-
-# xpath::split --
-#
-#	Parse an XPath location path
-#
-# Arguments:
-#	locpath	location path
-#
-# Results:
-#	A Tcl list representing the location path.
-#	The list has the form: {{axis node-test {predicate predicate ...}} ...}
-#	Where each list item is a location step.
-
-proc xpath::split locpath {
-    set leftover {}
-
-    set result [InnerSplit $locpath leftover]
-
-    if {[string length [string trim $leftover]]} {
-	return -code error "unexpected text \"$leftover\""
-    }
-
-    return $result
-}
-
-proc xpath::InnerSplit {locpath leftoverVar} {
-    upvar $leftoverVar leftover
-
-    variable axes
-    variable nodetestExpr
-    variable nodetestExpr2
-
-    # First determine whether we have an absolute location path
-    if {[regexp {^/(.*)} $locpath discard locpath]} {
-	set path {{}}
-    } else {
-	set path {}
-    }
-
-    while {[string length [string trimleft $locpath]]} {
-	if {[regexp {^\.\.(.*)} $locpath discard locpath]} {
-	    # .. abbreviation
-	    set axis parent
-	    set nodetest *
-	} elseif {[regexp {^/(.*)} $locpath discard locpath]} {
-	    # // abbreviation
-	    set axis descendant-or-self
-	    if {[regexp ^$nodetestExpr2 [string trimleft $locpath] discard discard discard nodetest discard typetest discard discard literal wildcard locpath]} {
-		set nodetest [ResolveWildcard $nodetest $typetest $wildcard $literal]
-	    } else {
-		set leftover $locpath
-		return $path
-	    }
-	} elseif {[regexp ^\\.${::xml::allWsp}(.*) $locpath discard locpath]} {
-	    # . abbreviation
-	    set axis self
-	    set nodetest *
-	} elseif {[regexp ^@($::xml::QName)${::xml::allWsp}=${::xml::allWsp}"(\[^"\])"(.*) $locpath discard attrName discard attrValue locpath]} {
-	    # @ abbreviation
-	    set axis attribute
-	    set nodetest $attrName
-	} elseif {[regexp ^@($::xml::QName)${::xml::allWsp}=${::xml::allWsp}'(\[^'\])'(.*) $locpath discard attrName discard attrValue locpath]} {
-	    # @ abbreviation
-	    set axis attribute
-	    set nodetest $attrName
-	} elseif {[regexp ^@($::xml::QName)(.*) $locpath discard attrName discard2 locpath]} {
-	    # @ abbreviation
-	    set axis attribute
-	    set nodetest $attrName
-	} elseif {[regexp ^((${::xml::QName})${::xml::allWsp}::${::xml::allWsp})?\\*(.*) $locpath discard discard axis discard locpath]} {
-	    # wildcard specified
-	    set nodetest *
-	    if {![string length $axis]} {
-		set axis child
-	    }
-	} elseif {[regexp ^((${::xml::QName})${::xml::allWsp}::${::xml::allWsp})?$nodetestExpr2 $locpath discard discard axis discard discard discard nodetest discard typetest discard discard literal wildcard locpath]} {
-	    # nodetest, with or without axis
-	    if {![string length $axis]} {
-		set axis child
-	    }
-	    set nodetest [ResolveWildcard $nodetest $typetest $wildcard $literal]
-	} else {
-	    set leftover $locpath
-	    return $path
-	}
-
-	# ParsePredicates
-	set predicates {}
-	set locpath [string trimleft $locpath]
-	while {[regexp {^\[(.*)} $locpath discard locpath]} {
-	    if {[regexp {^([0-9]+)(\].*)} [string trim $locpath] discard posn locpath]} {
-		set predicate [list = {function position {}} [list number $posn]]
-	    } else {
-		set leftover2 {}
-		set predicate [ParseExpr $locpath leftover2]
-		set locpath $leftover2
-		unset leftover2
-	    }
-
-	    if {[regexp {^\](.*)} [string trimleft $locpath] discard locpath]} {
-		lappend predicates $predicate
-	    } else {
-		return -code error "unexpected text in predicate \"$locpath\""
-	    }
-	}
-
-	set axis [string trim $axis]
-	set nodetest [string trim $nodetest]
-
-	# This step completed
-	if {[lsearch $axes $axis] < 0} {
-	    return -code error "invalid axis \"$axis\""
-	}
-	lappend path [list $axis $nodetest $predicates]
-
-	# Move to next step
-
-	if {[string length $locpath] && ![regexp ^/(.*) $locpath discard locpath]} {
-            set leftover $locpath
-	    return $path
-	}
-
-    }
-
-    return $path
-}
-
-# xpath::ParseExpr --
-#
-#	Parse one expression in a predicate
-#
-# Arguments:
-#	locpath	location path to parse
-#	leftoverVar	Name of variable in which to store remaining path
-#
-# Results:
-#	Returns parsed expression as a Tcl list
-
-proc xpath::ParseExpr {locpath leftoverVar} {
-    upvar $leftoverVar leftover
-    variable nodeTypes
-
-    set expr {}
-    set mode expr
-    set stack {}
-
-    while {[string index [string trimleft $locpath] 0] != "\]"} {
-	set locpath [string trimleft $locpath]
-	switch $mode {
-	    expr {
-		# We're looking for a term
-		if {[regexp ^-(.*) $locpath discard locpath]} {
-		    # UnaryExpr
-		    lappend stack "-"
-		} elseif {[regexp ^\\\$({$::xml::QName})(.*) $locpath discard varname discard locpath]} {
-		    # VariableReference
-		    lappend stack [list varRef $varname]
-		    set mode term
-		} elseif {[regexp {^\((.*)} $locpath discard locpath]} {
-		    # Start grouping
-		    set leftover2 {}
-		    lappend stack [list group [ParseExpr $locpath leftover2]]
-		    set locpath $leftover2
-		    unset leftover2
-
-		    if {[regexp {^\)(.*)} [string trimleft $locpath] discard locpath]} {
-			set mode term
-		    } else {
-			return -code error "unexpected text \"$locpath\", expected \")\""
-		    }
-
-		} elseif {[regexp {^"([^"]*)"(.*)} $locpath discard literal locpath]} {
-		    # Literal (" delimited)
-		    lappend stack [list literal $literal]
-		    set mode term
-		} elseif {[regexp {^'([^']*)'(.*)} $locpath discard literal locpath]} {
-		    # Literal (' delimited)
-		    lappend stack [list literal $literal]
-		    set mode term
-		} elseif {[regexp {^([0-9]+(\.[0-9]+)?)(.*)} $locpath discard number discard locpath]} {
-		    # Number
-		    lappend stack [list number $number]
-		    set mode term
-		} elseif {[regexp {^(\.[0-9]+)(.*)} $locpath discard number locpath]} {
-		    # Number
-		    lappend stack [list number $number]
-		    set mode term
-		} elseif {[regexp ^(${::xml::QName})\\(${::xml::allWsp}(.*) $locpath discard functionName discard locpath]} {
-		    # Function call start or abbreviated node-type test
-
-		    if {[lsearch $nodeTypes $functionName] >= 0} {
-			# Looking like a node-type test
-			if {[regexp ^\\)${::xml::allWsp}(.*) $locpath discard locpath]} {
-			    lappend stack [list path [list child [list $functionName ()] {}]]
-			    set mode term
-			} else {
-			    return -code error "invalid node-type test \"$functionName\""
-			}
-		    } else {
-			if {[regexp ^\\)${::xml::allWsp}(.*) $locpath discard locpath]} {
-			    set parameters {}
-			} else {
-			    set leftover2 {}
-			    set parameters [ParseExpr $locpath leftover2]
-			    set locpath $leftover2
-			    unset leftover2
-			    while {[regexp {^,(.*)} $locpath discard locpath]} {
-				set leftover2 {}
-				lappend parameters [ParseExpr $locpath leftover2]
-				set locpath $leftover2
-				unset leftover2
-			    }
-
-			    if {![regexp ^\\)${::xml::allWsp}(.*) [string trimleft $locpath] discard locpath]} {
-				return -code error "unexpected text \"locpath\" - expected \")\""
-			    }
-		        }
-
-			lappend stack [list function $functionName $parameters]
-			set mode term
-		    }
-
-		} else {
-		    # LocationPath
-		    set leftover2 {}
-		    lappend stack [list path [InnerSplit $locpath leftover2]]
-		    set locpath $leftover2
-		    unset leftover2
-		    set mode term
-		}
-	    }
-	    term {
-		# We're looking for an expression operator
-		if {[regexp ^-(.*) $locpath discard locpath]} {
-		    # UnaryExpr
-		    set stack [linsert $stack 0 expr "-"]
-		    set mode expr
-		} elseif {[regexp ^(and|or|\\=|!\\=|<|>|<\\=|>\\=|\\||\\+|\\-|\\*|div|mod)(.*) $locpath discard exprtype locpath]} {
-		    # AndExpr, OrExpr, EqualityExpr, RelationalExpr or UnionExpr
-		    set stack [linsert $stack 0 $exprtype]
-		    set mode expr
-		} else {
-		    return -code error "unexpected text \"$locpath\", expecting operator"
-		}
-	    }
-	    default {
-		# Should never be here!
-		return -code error "internal error"
-	    }
-	}
-    }
-
-    set leftover $locpath
-    return $stack
-}
-
-# xpath::ResolveWildcard --
-
-proc xpath::ResolveWildcard {nodetest typetest wildcard literal} {
-    variable nodeTypes
-
-    switch -glob -- [string length $nodetest],[string length $typetest],[string length $wildcard],[string length $literal] {
-	0,0,0,* {
-	    return -code error "bad location step (nothing parsed)"
-	}
-	0,0,* {
-	    # Name wildcard specified
-	    return *
-	}
-	*,0,0,* {
-	    # Element type test - nothing to do
-	    return $nodetest
-	}
-	*,0,*,* {
-	    # Internal error?
-	    return -code error "bad location step (found both nodetest and wildcard)"
-	}
-	*,*,0,0 {
-	    # Node type test
-	    if {[lsearch $nodeTypes $nodetest] < 0} {
-		return -code error "unknown node type \"$typetest\""
-	    }
-	    return [list $nodetest $typetest]
-	}
-	*,*,0,* {
-	    # Node type test
-	    if {[lsearch $nodeTypes $nodetest] < 0} {
-		return -code error "unknown node type \"$typetest\""
-	    }
-	    return [list $nodetest $literal]
-	}
-	default {
-	    # Internal error?
-	    return -code error "bad location step"
-	}
-    }
-}
-
-# xpath::join --
-#
-#	Reconstitute an XPath location path from a
-#	Tcl list representation.
-#
-# Arguments:
-#	spath	split path
-#
-# Results:
-#	Returns an Xpath location path
-
-proc xpath::join spath {
-    return -code error "not yet implemented"
-}
-

Modified: trunk/tkabber/tkabber.tcl
===================================================================
--- trunk/tkabber/tkabber.tcl	2007-10-06 06:14:20 UTC (rev 1243)
+++ trunk/tkabber/tkabber.tcl	2007-10-06 07:53:04 UTC (rev 1244)
@@ -182,7 +182,7 @@
     load_source Tclx.tcl
 }
 
-package require jabberlib 0.10.0
+package require jabberlib 0.10.1
 load_source xmppmime.tcl
 
 foreach {opt val} $argv {



More information about the Tkabber-dev mailing list