######################################################################
#
# $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 {[catch {package present tdom}]} {
    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.2
catch {package require autoconnect::https 1.0}
catch {package require autoconnect::socks5 1.0}
catch {package require autoconnect::socks4 1.0}

######################################################################

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 [autoconnect::proxies]
	}
	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
    }

    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"
    }

    lappend lib(connections) $connid

    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 {connid} {
    variable lib

    ::LOG "(jlib::disconnect) $connid"

    set idx [lsearch -exact $lib(connections) $connid]
    if {$idx < 0} continue

    set lib(connections) [lreplace $lib(connections) $idx $idx]

    if {!$lib($connid,disconnecting)} {
	set lib($connid,disconnecting) 1

	finish_stream -connection $connid

	catch {
	    transport::$lib($connid,transport)::disconnect $connid
	    transport::$lib($connid,transport)::close $connid
	}
    }

    clear_vars $connid

    if {$lib(connections) == {}} {
	clear_iqs
    }
}

######################################################################

proc jlib::emergency_disconnect {connid} {
    variable lib

    ::LOG "(jlib::emergency_disconnect) $connid"

    if {[lsearch -exact $lib(connections) $connid] < 0} return

    set lib($connid,disconnecting) 1

    catch {
	transport::$lib($connid,transport)::close $connid
    }

    client $lib($connid,disconnect) $connid
}

######################################################################

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
    }

    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::finish_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::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"} {
	if {!$useid} {
	    set id $iq(num)
	    incr iq(num)
	}
	lappend vars id $id
	set iq($id) $cmd
	if {$timeout > 0} {
	    after $timeout [list [namespace current]::iq_timeout $id]
	}
    } 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

