From: Pat Thoyts <patthoyts@users.sourceforge.net>
Date: Thu, 19 Jun 2008 00:21:39 +0000 (+0100)
Subject: imported the vfs tree info a git repository
X-Git-Url: http://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=b246224b5a26343d3e3f3e97b7636968db6f3c3f;p=Bullfrog

imported the vfs tree info a git repository
    Note that the lib/ tree contains copies of files from 3rd party products
    like the tcllib cvs and a few binaries for win32-ix86 (tls, udp and tdom).
---

b246224b5a26343d3e3f3e97b7636968db6f3c3f
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..29763f6
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,4 @@
+# Ignore all CVS dirs and emacs temp copies.
+CVS
+.#*
+*~
diff --git a/bin/bf_irc.tcl b/bin/bf_irc.tcl
new file mode 100644
index 0000000..4be8638
--- /dev/null
+++ b/bin/bf_irc.tcl
@@ -0,0 +1,331 @@
+# bf_irc.tcl -- Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+#	Handle the IRC transport (using picoirc)
+#
+#
+
+package require picoirc 0.5;     # tcllib
+
+variable ircuid
+if {![info exists ircuid]} { set ircuid -1 }
+
+proc IrcLogin {app} {
+    set dlg $app.irclogin
+    variable $dlg {}
+    variable irc
+    if {![info exists irc]} {
+        array set irc {server irc.freenode.net port 6667 channel "" passwd ""}
+    }
+    if {![winfo exists $dlg]} {
+        set dlg [toplevel $dlg -class Dialog]
+        wm withdraw $dlg
+        wm transient $dlg $app
+        wm title $dlg "IRC Login"
+        
+        set f [ttk::frame $dlg.f]
+        set g [ttk::frame $f.g]
+        ttk::label $f.sl -text Server -anchor w
+        ttk::entry $f.se -textvariable [namespace which -variable irc](server)
+        ttk::entry $f.sp -textvariable \
+            [namespace which -variable irc](port) -width 5
+        ttk::label $f.nl -text Username -anchor w
+        ttk::entry $f.nn -textvariable [namespace which -variable irc](nick)
+        ttk::label $f.pl -text Password -anchor w
+        ttk::entry $f.pw -show * -textvariable [namespace which -variable irc](passwd)
+        ttk::label $f.cl -text Channel -anchor w
+        ttk::entry $f.cn -textvariable [namespace which -variable irc](channel)
+        ttk::button $f.ok -text Login -default active \
+            -command [list set [namespace which -variable $dlg] "ok"]
+        ttk::button $f.cancel -text Cancel \
+            -command [list set [namespace which -variable $dlg] "cancel"]
+
+        bind $dlg <Return> [list $f.ok invoke]
+        bind $dlg <Escape> [list $f.cancel invoke]
+        wm protocol $dlg WM_DELETE_WINDOW [list $f.cancel invoke]
+        
+        grid $f.sl $f.se $f.sp -in $g -sticky new -padx 1 -pady 1
+        grid $f.nl $f.nn -     -in $g -sticky new -padx 1 -pady 1
+        grid $f.pl $f.pw -     -in $g -sticky new -padx 1 -pady 1
+        grid $f.cl $f.cn -     -in $g -sticky new -padx 1 -pady 1
+        grid columnconfigure $g 1 -weight 1
+
+        grid $g    -         -sticky news
+        grid $f.ok $f.cancel -sticky e -padx 1 -pady 1
+        grid rowconfigure    $f 0 -weight 1
+        grid columnconfigure $f 0 -weight 1
+        
+        grid $f -sticky news
+        grid rowconfigure $dlg 0 -weight 1
+        grid columnconfigure $dlg 0 -weight 1
+
+	wm resizable $dlg 0 0
+        raise $dlg
+    }     
+
+    catch {::tk::PlaceWindow $dlg widget $app}
+    wm deiconify $dlg
+    tkwait visibility $dlg
+    focus -force $dlg.f.ok
+    grab $dlg
+    vwait [namespace which -variable $dlg]
+    grab release $dlg
+    wm withdraw $dlg
+
+    if {[set $dlg] eq "ok"} {
+        after idle [list [namespace origin IrcConnect] $app \
+                        -server $irc(server) -port $irc(port) \
+                        -channel $irc(channel) \
+                        -nick $irc(nick) -passwd $irc(passwd)]
+    }
+}
+
+proc IrcConnect {app args} {
+    variable ircuid
+    set id irc[incr ircuid]
+    set Chat [namespace current]::$id
+    upvar #0 $Chat chat
+    array set chat [list app $app type irc passwd "" nick ""]
+    while {[string match -* [set option [lindex $args 0]]]} {
+        switch -exact -- $option {
+            -server   { set chat(server)   [Pop args 1] }
+            -port     { set chat(port)     [Pop args 1] }
+            -channel  { set chat(channel)  [Pop args 1] }
+            -nick     { set chat(nick)     [Pop args 1] }
+            -passwd   { set chat(passwd)   [Pop args 1] }
+            default {
+                return -code error "invalid option \"$option\""
+            }
+        }
+        Pop args
+    }
+    set chat(window) [chatwidget::chatwidget $app.nb.$id]
+    $chat(window) names hide
+    set chat(targets) [list]
+    set url irc://$chat(server):$chat(port)
+    if {[info exists chat(channel)] && $chat(channel) ne ""} {
+        append url /$chat(channel)
+    }
+    set chat(irc) [picoirc::connect \
+                       [list [namespace origin IrcCallback] $Chat] \
+                       $chat(nick) $chat(passwd) $url]
+    $chat(window) hook add post [list ::picoirc::post $chat(irc) ""]
+    bind $chat(window) <Destroy> "+unset -nocomplain $Chat"
+    $app.nb add $chat(window) -text $chat(server)
+    after idle [list $app.nb select $chat(window)]
+    return $Chat
+}
+
+proc IrcJoinChannel {Chat args} {
+    variable ircuid
+    # FIX ME:
+}
+
+proc IrcAddChannel {Chat channel} {
+    upvar #0 $Chat chat
+    set Channel "${Chat}/$channel"
+    upvar #0 $Channel chan
+    array set chan [array get chat]
+    set chan(channel) $channel
+    set chan(window) [chatwidget::chatwidget $chat(window)$channel]
+    lappend chat(targets) [list $channel $chan(window)]
+    set m0 [font measure ChatwidgetFont {[00:00]m}]
+    set m1 [font measure ChatwidgetFont [string repeat m 10]]
+    set mm [expr {$m0 + $m1}]
+    $chan(window) chat configure -tabs [list $m0 $mm]
+    $chan(window) chat tag configure MSG -lmargin1 $mm -lmargin2 $mm
+    $chan(window) chat tag configure NICK -font ChatwidgetBoldFont
+    $chan(window) chat tag configure TYPE-system -font ChatwidgetItalicFont
+    $chan(window) chat tag bind URL <Enter> [list UrlEnter %W]
+    $chan(window) chat tag bind URL <Leave> [list UrlLeave %W]
+    $chan(window) chat tag bind URL <Button-1> [list UrlClick %W %x %y]
+    $chan(window) names tag bind NICK <Button-3> \
+        [list [namespace origin IrcChannelNickMenu] $Channel %W %x %y]
+    $chan(window) names tag bind NICK <Enter> \
+        [list [namespace origin IrcNickTooltip] $Chat enter %W %x %y]
+    $chan(window) names tag bind NICK <Leave> \
+        [list [namespace origin IrcNickTooltip] $Chat leave %W %x %y]
+    $chan(window) hook add post [list ::picoirc::post $chan(irc) $channel]
+    bind $chan(window) <Destroy> "+unset -nocomplain $Channel"
+    $chat(app).nb add $chan(window) -text $channel
+    after idle [list $chat(app).nb select $chan(window)]
+    return
+}
+
+proc IrcRemoveChannel {Chat target} {
+    upvar #0 $Chat chat
+    Status $Chat "Left channel $target"
+    set w [IrcFindWindow $Chat $target]
+    if {[winfo exists $w]} { destroy $w }
+    if {[set ndx [lsearch -index 0 $chat(targets) $target]] != -1} {
+        set chat(targets) [lreplace $chat(targets) $ndx $ndx]
+    }
+}
+
+proc IrcChannelNickMenu {Channel w x y} {
+    set nick [string trim [$w get "@$x,$y linestart" "@$x,$y lineend"]]
+    if {$nick eq ""} { return }
+    destroy $w.popup
+    set m [menu $w.popup -tearoff 0]
+    $m add command -label "$nick" -state disabled
+    $m add separator
+    $m add command -label "Whois" -underline 0 \
+        -command [list [namespace origin IrcChannelNickCommand] $Channel whois $nick]
+    $m add command -label "Version" \
+        -command [list [namespace origin IrcChannelNickCommand] $Channel version $nick]
+    tk_popup $m [winfo pointerx $w] [winfo pointery $w]
+}
+
+proc IrcChannelNickCommand {Channel cmd nick} {
+    upvar #0 $Channel chan
+    switch -exact -- $cmd {
+        whois { picoirc::send $chan(irc) "WHOIS $nick" }
+        version { picoirc::send $chan(irc) "PRIVMSG $nick :\001VERSION\001" }
+        default {}
+    }
+}
+
+proc IrcNickTooltip {Chat type w x y} {
+    if {[package provide tooltip] eq {}} { return }
+    set nick [string trim [$w get "@$x,$y linestart" "@$x,$y lineend"]]
+    if {$nick eq ""} { return }
+    puts stderr "Tooltip $type $nick"
+    return
+}
+
+proc IrcFindWindow {Chat target} {
+    upvar #0 $Chat chat
+    set w $chat(window)
+    if {[set ndx [lsearch -nocase -index 0 $chat(targets) $target]] != -1} {
+        set w [lindex [lindex $chat(targets) $ndx] 1]
+    }
+    return $w
+}
+
+proc IrcCallback {Chat context state args} {
+    upvar #0 $Chat chat
+    upvar #0 $context irc
+    switch -exact -- $state {
+        init {
+            Status $Chat "Attempting to connect to $irc(server)"
+        }
+        connect {
+            $chat(window) message "Logging into $irc(server) as $irc(nick)" -type system
+            Status $Chat "Connection to IRC server established."
+            State $Chat connected
+        }
+        close {
+            if {[llength $args] != 0} {
+                $chat(window) message "Failed to connect: [lindex $args 0]" -type system
+                Status $Chat [lindex $args 0]
+            } else {
+                $chat(window) message "Disconnected from server" -type system
+                Status $Chat "Disconnected."
+            }
+            State $Chat !connected
+        }
+        userlist {
+            foreach {target users} $args break
+            set colors {black SteelBlue4 tomato chocolate SeaGreen4 red4
+                green4 blue4 pink4}
+            set w [IrcFindWindow $Chat $target]
+            set current [$w name list -full]
+            foreach nick $users {
+                set opts [list -status online]
+                if {[string match @* $nick]} {
+                    set nick [string range $nick 1 end]
+                    lappend opts -group operators 
+                } else { lappend opts -group users }
+                if {[lsearch -index 0 $current $nick] == -1} {
+                    lappend opts -color \
+                        [lindex $colors [expr {int(rand() * [llength $colors])}]]
+                }
+                eval [list $w name add $nick] $opts
+            }
+        }
+        userinfo {
+            foreach {nick userinfo} $args break
+            array set info {name {} host {} channels {} userinfo {}}
+            array set info $userinfo
+            set chat(userinfo,$nick) [array get info]
+        }
+        chat {
+            foreach {target nick msg type} $args break
+            if {$type eq ""} {set type normal}
+            set w [IrcFindWindow $Chat $target]
+            if {$nick eq "tcl@tach.tclers.tk"} {
+                set action ""; set jnick "" ; set jnew ""
+                if {[regexp {^\s*([^ ]+) is now known as (.*)} $msg -> jnick jnew]} {
+                    set action nickchange
+                } elseif {[regexp {^\s*([^ ]+) has left} $msg -> jnick]} {
+                    set action left
+                } elseif {[regexp {^\s*([^ ]+) has become available} $msg -> jnick]} {
+                    set action entered
+                }
+                if {$action ne ""} {
+                    IrcCallbackNick $w $action $target $jnick $jnew jabber
+                    return
+                }
+            }
+            $w message $msg -nick $nick -type $type
+        }
+        system {
+            foreach {target msg} $args break
+            [IrcFindWindow $Chat $target] message $msg -type system
+        }
+        topic {
+            foreach {target topic} $args break
+            set w [IrcFindWindow $Chat $target]
+            $w topic show
+            $w topic set $topic
+        }
+        traffic {
+            foreach {action target nick new} $args break
+            if {$nick eq $irc(nick)} {
+                switch -exact -- $action {
+                    left    { IrcRemoveChannel $Chat $target }
+                    entered { IrcAddChannel $Chat $target}
+                    nickchange { set irc(nick) $new }
+                }
+            }
+            if {$target ne {}} {
+                set w [IrcFindWindow $Chat $target]
+                IrcCallbackNick $w $action $target $nick $new
+            } else {
+                foreach window_target $chat(targets) {
+                    foreach {window_channel w} $window_target break
+                    set current [$w name list -full]
+                    if {[lsearch -index 0 $current $nick] != -1} {
+                        IrcCallbackNick $w $action $target $nick $new
+                    }
+                }
+            }
+        }
+        debug {
+            foreach {type line} $args break
+            Debug $Chat $line $type
+
+            # You can log raw IRC to file by uncommenting the following lines:
+            #if {![info exists chat(log)]} {set chat(log) [open irc.log a]}
+            #puts $chat(log) "[string toupper [string range $type 0 0]] $line"
+        }
+        version { return "" }
+        default {
+            $chat(window) message "unknown irc callback \"$state\": $args" -type error
+        }
+    }
+}
+
+proc IrcCallbackNick {w action target nick new {group users}} {
+    #puts stderr "process traffic $w $nick $action $new $target"
+    if {$action eq "nickchange"} {
+        $w name delete $nick
+        $w name add $new -group $group
+        $w message "$nick changed to $new" -type system
+    } else {
+        switch -exact -- $action {
+            left    { $w name delete $nick }
+            entered { $w name add $nick -group $group }
+        }
+        $w message "$nick $action" -type system
+    }
+}
diff --git a/bin/bf_xmpp.tcl b/bin/bf_xmpp.tcl
new file mode 100644
index 0000000..d9a984d
--- /dev/null
+++ b/bin/bf_xmpp.tcl
@@ -0,0 +1,1394 @@
+# Present a callback interface akin to the picoirc callback. 
+# The idea is to have the picoirc application be able to use multiple transports
+# with only the callback being the comms interface.
+#
+#
+# TODO:
+#
+#   One-to-one chats should show the nick name - either from the
+#   additional elements in the message stanza, or the resource if from a
+#   groupchat source or just the node.
+#   They also don't need a names window.
+#   We must echo our own messages in such a window.
+# <message xmlns='jabber:client' 
+#     to='patthoyts@all.tclers.tk/Bullfrog'
+#     type='chat'
+#     from='tcl@tach.tclers.tk/rmax'>
+#   <body>:)</body>
+#   <x xmlns='urn:tkchat:chat' color='660016'/>
+# </message>
+#
+package require jlib
+package require jlib::connect
+package require jlib::disco
+package require jlib::roster
+package require jlib::muc
+package require jlib::caps
+package require jlib::vcard
+
+package require uuid
+package require messagewidget
+
+namespace eval ::xmppplugin {
+    variable version 0.2
+    variable uid; if {![info exists uid]} { set uid 0 }
+    variable defaults {
+        -server   "all.tclers.tk"
+        -resource "Bullfrog"
+        -port     5222
+        -channel  "tcl@tach.tclers.tk"
+        callback ""
+        motd     {}
+        users    {}
+    }
+    namespace export connect send post splituri
+}
+
+proc ::xmppplugin::connect {callback args} {
+    variable defaults
+    variable uid
+    set context [namespace current]::xmpp[incr uid]
+    upvar #0 $context xmpp
+    array set xmpp $defaults
+    array set xmpp $args         ;# see XmppLogin for the list of pairs
+
+    set xmpp(callback) $callback
+    set xmpp(jlib) [jlib::new [namespace origin OnNetwork] \
+                        -messagecommand [namespace origin OnMessage] \
+                        -presencecommand [namespace origin OnPresence] \
+                        -iqcommand [namespace origin OnIq] \
+                        -keepalivesecs 90 \
+                        -autodiscocaps 1]
+
+    # IQ handlers
+    $xmpp(jlib) iq_register get jabber:iq:version \
+        [namespace code [list OnIqVersion $context]] 40
+    $xmpp(jlib) iq_register get jabber:iq:last \
+        [namespace code [list OnIqLast $context]] 40
+    $xmpp(jlib) iq_register result jabber:iq:version \
+        [namespace code [list OnIqVersionResult $context]] 40
+
+    # Presence handlers
+    $xmpp(jlib) roster register_cmd [list [namespace origin OnRosterChange] $context]
+    $xmpp(jlib) presence_register available \
+        [namespace code [list OnPresenceChange $context]]
+    $xmpp(jlib) presence_register unavailable \
+        [namespace code [list OnPresenceChange $context]]
+
+    # Discovery support
+    $xmpp(jlib) disco registeridentity client pc Bullfrog
+    foreach feature {jabber:client jabber:iq:last jabber:iq:time \
+                         jabber:iq:version jabber:x:event} {
+        jlib::disco::registerfeature $feature
+    }
+
+    #$xmpp(jlib) caps register ? ? ?
+    set [set xmpp(jlib)]::AppContext $context
+    Callback $context init
+    set xmpp(jid) [jlib::joinjid $xmpp(-username) $xmpp(-server) $xmpp(-resource)]
+    $xmpp(jlib) connect init
+    $xmpp(jlib) connect configure -defaultresource $xmpp(-resource)
+
+    if {$xmpp(-useproxy)} {
+        # this one traverses an http proxy:
+        if {$xmpp(-connect) eq "plain"} {set method sasl} else {set method ssl}
+        $xmpp(jlib) connect connect $xmpp(jid) $xmpp(-passwd) \
+            -command [list [namespace origin OnConnect] $context] \
+            -secure 1 -method $method -transport tunnel\
+            -ip $xmpp(-server) -port $xmpp(-port)
+    } else {
+        $xmpp(jlib) connect connect $xmpp(jid) $xmpp(-passwd) \
+            -command [list [namespace origin OnConnect] $context] \
+            -secure 1 -method tlssasl \
+            -ip $xmpp(-server) -port $xmpp(-port)
+    }
+    return $context
+}
+
+proc ::xmppplugin::post {ctx channel msg} {
+    upvar #0 $ctx xmpp
+    if {[string match "/*" $msg]} {
+        switch -glob -- $msg {
+            "/join *" {
+                set target [string trim [string range $msg 6 end]]
+                JoinMUC $ctx $target $xmpp(jlib) $xmpp(-nick)
+                return
+            }
+            "/part*" - "/close*" {
+                set target [string trim [string range $msg 6 end]]
+                if {$target eq ""} {set target $channel}
+                if {[$xmpp(jlib) muc isroom $target]} {
+                    $xmpp(jlib) muc exit $target ;# no -command it seems
+                } else {
+                    #$xmpp(jlib) send_presence -type unavailable -to who
+                }
+                Callback $ctx close $target
+                return
+            }
+            "/nick *" {
+                set nick [string trim [string range $msg 6 end]]
+                $xmpp(jlib) muc setnick $channel $nick
+                set xmpp(-nick) $nick ;# should be ony if it works.
+                Callback $ctx userlist muc $target
+                return
+            }
+            "/users*" - "/userlist*" {
+                set target $channel
+                regexp {^/users?(?:list)?(?:\s+(.*))?$} $msg -> target
+                if {[$xmpp(jlib) muc isroom $target]} {
+                    Callback $ctx userlist muc $target
+                } else {
+                    Callback $ctx userlist roster
+                }
+                return
+            }
+            "/create *" {
+                set target [string trim [string range $msg 8 end]]
+                $xmpp(jlib) muc create $target $xmpp(-nick) \
+                    [namespace code [list OnMucCreate $ctx $target]]
+                return
+            }
+            "/invite *" {
+                if {[regexp {^/invite\s+(\S+)\s+(.*)$} $msg -> who reason]} {
+                    $xmpp(jlib) muc invite $channel $who -reason $reason
+                } else {
+                    Callback $ctx system $channel "usage: /invite jid ?reason?"
+                }
+                return
+            }
+            "/me *" { }
+            default {
+                Callback $ctx system $channel "unrecognised chat command '$msg'"
+                return
+            }
+        }
+    }
+    
+    # Check the type of channel and for one-to-one chat re-use the thread
+    # or create a thread if this is a new conversation.
+    set type groupchat
+    set thread ""
+    if {![$xmpp(jlib) muc isroom $channel]} {
+        set type chat
+        catch {set thread [dict get $xmpp(opts) $channel -thread]}
+        if {$thread eq ""} {set thread [uuid::uuid generate] }
+    }
+
+    if {[catch {dict get $xmll(opts) $channel -chatstate} chatstate]} {
+        set chatstate active
+    }
+
+    lappend xlist [wrapper::createtag x \
+                       -attrlist {xmlns urn:tkchat:chat color 387070}]
+    if {$chatstate ne {}} {
+        lappend xlist [wrapper::createtag $chatstate \
+                            -attrlist {xmlns http://jabber.org/protocol/chatstates}]
+    }
+    set margs [list -type $type -body $msg -xlist $xlist]
+    if {$thread ne ""} { lappend margs -thread $thread }
+    eval [linsert $margs 0 $xmpp(jlib) send_message $channel]
+    if {$type eq "chat"} {
+        set mtype normal
+        if {[string match "/me *" $msg]} { set mtype action }
+        Callback $ctx chat $channel $xmpp(-nick) $msg $mtype
+    }
+}
+
+proc ::xmppplugin::Callback {ctx state args} {
+    upvar #0 $ctx xmpp
+    if {[llength $xmpp(callback)] > 0
+        && [llength [info commands [lindex $xmpp(callback) 0]]] == 1} {
+        if {[catch {eval $xmpp(callback) [list $ctx $state] $args} err]} {
+            puts stderr "callback error \"$state\": $err"
+        }
+    }
+}
+
+proc ::xmppplugin::Version {ctx} {
+    global tcl_platform
+    if {[catch {Callback $ctx version} ver]} { set ver {} }
+    if {$ver eq {}} {
+        set os $tcl_platform(os)
+        if {[info exists tcl_platform(osVersion)]} {
+            append os " $tcl_platform(osVersion)"
+        }
+        append os "/Tcl [info patchlevel]"
+        set os [string map {":" ";"} $os]
+        set ver "Bullfrog:[package provide xmppplugin]:$os"
+    }
+    return $ver
+}
+
+proc ::xmppplugin::get_caps {ctx} {
+    foreach {name ver os} [split [Version $ctx] :] break
+    set caps [wrapper::createtag c -attrlist \
+                  [list xmlns "http://jabber.org/protocol/caps" \
+                       node "http://tkchat.tclers.tk/$name/caps" \
+                       ver $ver ext {color time}]]
+    return $caps
+}
+
+proc ::xmppplugin::Log {ctx msg {type {}}} {
+    Callback $ctx debug system $msg
+}
+
+proc ::xmppplugin::OnAnything {ctx args} {
+    Log $ctx "Anything: $args"
+}
+
+proc ::xmppplugin::OnNetwork {jlib cmd args} {
+    puts stderr "-- OnNetwork $jlib $cmd $args"
+    set ctx [set [set jlib]::AppContext]
+    if {[catch {
+        array set a [linsert $args 0 -body {} -errormsg {}]
+        switch -glob -- $cmd {
+            connect { Log $ctx "* connected" }
+            disconnect {
+                Log $ctx "* disconnected" 
+                Callback $ctx disconnect "disconnected"
+            }
+            networkerror {
+                Log $ctx "* Network error: $a(-body)"
+                Callback $ctx disconnect "network error: $a(-body)"
+            }
+            xmpp-streams-error-* - streamerror {
+                Log $ctx "* Stream error: $a(-errormsg)" 
+                Callback $ctx disconnect "stream error: $a(-errormsg)"
+            }
+            xmlerror {
+                Log $ctx "* XML parse error: $a(-errormsg)"
+                Callback $ctx disconnect "xml error: $a(-errormsg)"
+            }
+            default { Log $ctx "* Default: $cmd $args" }
+        }
+    } err]} { Log $ctx "OnNetwork: $err" error }
+}
+
+proc ::xmppplugin::OnConnect {ctx jlib type args} {
+    Log $ctx "OnConnect $ctx $jlib $type $args"
+    upvar #0 $ctx xmpp
+    switch -exact -- $type {
+        initnetwork { Log $ctx "$type $args" }
+        initstream  { Log $ctx "$type $args" }
+        authenticate { Log $ctx "$type $args" }
+        ok {
+            Callback $ctx connect
+            $jlib send_presence
+            $jlib send_presence -priority 2 -extras [list [get_caps $ctx]]
+            $jlib roster send_get -command [list [namespace origin OnRosterGet] $ctx]
+            if {$xmpp(-autoconnect) && $xmpp(-channel) ne {}} {
+                Log $ctx "Attempting to join $xmpp(-channel)"
+                JoinMUC $ctx $xmpp(-channel) $jlib $xmpp(-nick)
+            }
+        }
+        error {
+            Log $ctx "network error: $args" 
+            Callback $ctx close
+            Callback $ctx disconnect $args
+        }
+    }
+}
+
+proc ::xmppplugin::JoinMUC {ctx channel jlib nick} {
+    #set t 1202713200
+    #set since [list since [clock format $t -format {%Y-%m-%dT%T}]]
+    set since [list maxstanzas 100]
+    set x [wrapper::createtag x \
+               -attrlist {xmlns http://jabber.org/protocol/muc} \
+               -subtags [list [wrapper::createtag history \
+                                   -attrlist $since]]]
+    Callback $ctx addchat $channel groupchat
+    $jlib muc enter $channel $nick -extras [list $x] \
+        -command [list [namespace origin OnMucEnter] $ctx $channel]    
+}
+
+proc ::xmppplugin::OnMucEnter {ctx channel jlib xmldata} {
+    if {[catch {
+        #puts stderr "MucEnter: $xmldata"
+        switch -exact -- [wrapper::getattribute $xmldata type] {
+            "" - available {
+                Log $ctx "Joined $channel"
+                Callback $ctx traffic joining $channel
+                after idle [list [namespace origin Callback] \
+                                $ctx userlist muc $channel]
+                # FIX ME: cause history loading
+                # FIX ME: send custom presence to the conference for auto-away?
+            }
+            error {
+                set e [wrapper::getfirstchildwithtag $xmldata error]
+                set code [wrapper::getattribute $e code]
+                set msg {}
+                switch -exact -- $code {
+                    401 { set msg "This conference is password protected." }
+                    403 { set msg "You have been banned from this conference." }
+                    404 { set msg "The requested server does not exist." }
+                    405 { set msg "The maximum number of participants has been reached."}
+                    407 { set msg "You must be a member to enter this conference." }
+                    409 {
+                        # nick conflict
+                        upvar #0 $ctx xmpp
+                        set n 0 ; set nick $xmpp(-nick)
+                        regexp {^(.*)/(\d+)$} $nick -> nick n
+                        set xmpp(-nick) $nick/[incr $n]
+                        JoinMUC $ctx $channel $jlib $xmpp(-nick)
+                    }
+                    default {
+                        set msg "An unknown error was returned on attempting to join the\
+                            conference."
+                    }
+                }
+                if {$msg ne {}} {
+                    tk_messageBox -icon error -title "Failed to join conference" \
+                        -message $msg
+                }
+            }
+        }
+    } err]} {
+        puts stderr "OnMucEnter: $err {$ctx $channel}"
+    }
+}
+proc ::xmppplugin::OnMucCreate {ctx channel jlib xmldata} {
+    if {[catch {
+        Log $ctx "MucCreate $xmldata"
+        set x [wrapper::getchildswithtagandxmlns $xmldata x \
+                   "http://jabber.org/protocol/muc#user"]
+        if {[llength $x] > 0} {
+            set status [wrapper::getchildswithtag [lindex $x 0] status]
+            array set s [linsert [wrapper::getattrlist [lindex $status 0]] 0 code 0]
+            switch -exact -- $s(code) {
+                201 {
+                    $jlib muc getroom $channel \
+                        [namespace code [list OnMucConfigure $ctx $channel]]
+                }
+                default {
+                    Callback $ctx system $channel "muc create code $s(code)!"
+                }
+            }
+        }
+    } err]} { puts stderr "OnMucCreate $err" }
+}
+proc ::xmppplugin::OnMucConfigure {ctx channel jlib type subiq} {
+    if {[catch {
+        set form [lindex [wrapper::getchildswithtagandxmlns $subiq x jabber:x:data] 0]
+        #set r [ShowForm $form]
+        $jlib muc setroom $channel submit -form [list $form] \
+            -command [namespace code [list OnMucConfigured $ctx $channel]]
+    } err]} { puts stderr "OnMucConfigure $err" }
+}
+proc ::xmppplugin::OnMucConfigured {ctx channel jlib type subiq} {
+    upvar #0 $ctx xmpp
+    if {[catch {
+        $jlib muc enter $channel $xmpp(-nick) \
+            -command [list [namespace origin OnMucEnter] $ctx $channel]
+    } err]} { puts stderr "OnMucConfigured $err" }
+}
+
+proc ::xmppplugin::ShowForm {ctx form} {
+    set dlg [toplevel .xmppform -class Dialog]
+    wm title $dlg "Configure room"
+    wm withdraw $dlg
+    set f [ttk::frame $dlg.f]
+    set wid 0
+    foreach field [wrapper::getchildren $form] {
+        set ftag [wrapper::gettag $field]
+        puts "$ftag"
+        switch -exact -- [wrapper::gettag $field] {
+            title { wm title $dlg [wrapper::getcdata $field] }
+            instructions {
+                set w [ttk::label $f.w[incr wid] -text [wrapper::getcdata $field]]
+                grid $w - -sticky news
+            }
+            field {
+                array set a [linsert [wrapper::getattrlist $field] 0 type {}]
+                switch -exact -- $a(type) {
+                    hidden {}
+                    text-single {}
+                    text-multi {}
+                    fixed {
+                        set txt {}
+                        foreach node [wrapper::getchildswithtag $field "value"] {
+                            lappend txt [wrapper::getcdata $node]
+                        }
+                        set w [ttk::label $f.w[incr wid] -text [join $txt "\n"]
+                        grid $w - -sticky news
+                    }
+                    boolean {
+                        set w [ttk::checkbutton $f.w[incr wid] -text $a(label)]
+                        grid $w - -sticky news
+                    }
+                    list-single {}
+                    
+                }
+            }
+        }
+    }
+    set b0 [ttk::button $f.ok -text OK -default active \
+                -command [list set [namespace current]::$dlg ok]]
+    set b1 [ttk::button $f.cn -text Cancel -default normal \
+                -command [list set [namespace current]::$dlg cancel]]
+
+    grid $b0 $b1 -sticky e
+    grid rowconfigure $f [incr n] -weight 1
+    grid columnconfigure $f 2 -weight 1
+    grid $f -sticky news
+    grid rowconfigure $dlg 0 -weight 1
+    grid columnconfigure $dlg 0 -weight 1
+
+    bind $dlg <Return> [list $b0 invoke]
+    bind $dlg <Escape> [list $b1 invoke]
+    wm deiconify $dlg
+    set [namespace current]::$dlg waiting
+    tkwait variable [namespace current]::$dlg
+    set r [set [namespace current]::$dlg]
+    unset [namespace current]::$dlg
+    destroy $dlg
+    return $r
+}
+
+
+proc ::xmppplugin::OnIqVersion {ctx jlib from subiq args} {
+    array set a [linsert $args 0 -id {}]
+    set opts [list -to $from]
+    if {$a(-id) ne {}} {lappend opts -id $a(-id)}
+    foreach {cname cver cos} [split [Version $ctx] :] break
+    set subtags [list \
+                     [wrapper::createtag name -chdata $cname] \
+                     [wrapper::createtag version -chdata $cver] \
+                     [wrapper::createtag os -chdata $cos]]
+    set xmllist [wrapper::createtag query -subtags $subtags \
+                     -attrlist {xmlns jabber:iq:version}]
+    eval [linsert $opts 0 $jlib send_iq result [list $xmllist]]
+    return 1 ;# handled
+}
+
+proc ::xmppplugin::OnIqLast {ctx jlib from subiq args} {
+    if {[catch {tk inactive} last]} {
+        return 0 ;# not handled
+    }
+    set last [expr {int($last / 1000.0)}]
+    array set a [linsert $args 0 -id {}]
+    set opts [list -to $from]
+    if {$a(-id) ne {}} { lappend opts -id $a(-id) }
+    set xml [wrapper::createtag query \
+                 -attrlist [list xmlns jabber:id:last seconds $last]]
+    eval [linsert $opts 0 $jlib send_iq result [list $xml]]
+    return 1 ;# handled
+}
+
+proc ::xmppplugin::OnIqVersionResult {ctx jlib from subiq args} {
+    upvar #0 $ctx xmpp
+    if {[catch {
+        array set a [linsert $args 0 -id {}]
+        jlib::splitjid $from jid nick
+        puts stderr "result: $jid $nick => $xmpp(-channel)"
+        if {[jlib::jidequal $jid $xmpp(-channel)]} {
+            array set data {}
+            foreach sub [wrapper::getchildren $subiq] {
+                set data([wrapper::gettag $sub]) [wrapper::getcdata $sub]
+            }
+            set ver ""
+            if {[info exists data(name)]} { append ver $data(name) }
+            if {[info exists data(version)]} { append ver " " $data(version) }
+            if {[info exists data(os)]} { append ver " : $data(os)" }
+            set xmpp(userversion,$nick) $ver
+            Callback $ctx userinfo $xmpp(-channel) $nick -version $ver
+            Log $ctx "$nick: $ver"
+        }
+    } err]} {
+        tk_messageBox -icon error -message $err \
+            -title "Error handling version result"
+    }
+    return 1 ;# handled
+}
+
+# initiate from $jlib vcard get_async $jid [namespace code OnVCard]
+# once got - try get_cache if getcache is {} then do above.
+proc ::xmppplugin::OnVCard {jlib type xmldata} {
+    switch -exact -- $type {
+        result {
+            foreach kid [wrapper::getchildren $xmldata] {
+                # tags are FN, NICKNAME, URL etc
+            }
+        }
+        error {
+            foreach {code text} $xmldata break
+            
+        }
+    }
+}
+
+proc ::xmppplugin::OnRosterGet {ctx args} {
+    if {[catch {
+        Log $ctx "Recieved roster"
+        after idle [list [namespace origin Callback] $ctx userlist roster]
+    } err]} { puts stderr "OnRosterGet: $err" }
+    return 0;
+}
+
+proc ::xmppplugin::OnRosterChange {ctx jlib what {jid {}} args} {
+    #Log $ctx "Roster '$what' '$jid' '$args'"
+    #enterroster | exitroster | set jid args | remove jid | 
+    #switch -exact -- $what {}
+    return 0
+}
+
+# Look for MUC presence changes
+proc ::xmppplugin::OnPresenceChange {ctx jlib xmldata} {
+    if {[catch {
+        set x [lindex [wrapper::getchildswithtagandxmlns $xmldata x \
+                           "http://jabber.org/protocol/muc#user"] 0]
+        if {[llength $x] > 0} {
+            array set a [linsert [wrapper::getattrlist $xmldata] 0 type available]
+            jlib::splitjid $a(from) room nick
+            # avoid people just becoming active/inactive
+            if {$a(type) eq "available"} {
+                if {[set present [lsearch [$jlib muc participants $room] $a(from)]] == -1} {
+                    set status [wrapper::getcdata \
+                                    [wrapper::getfirstchildwithtag $xmldata status]]
+                    Callback $ctx traffic entered $room $nick -status $status
+                } else {
+                    Log $ctx "presence available for $nick who is present index $present"
+                }
+
+                # update the userlist
+                set details {}
+                lappend details -show [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata show]]
+                lappend details -status [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata status]]
+                lappend details -priority [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata priority]]
+                # x/item contains attrs jid (full jid), affiliation and role
+                if {[set item [wrapper::getfirstchildwithtag $x item]] ne {}} {
+                    lappend details -jid [wrapper::getattribute $item jid]
+                    lappend details -role [wrapper::getattribute $item role]
+                    lappend details -affiliation [wrapper::getattribute $item affiliation]
+                }
+                eval [linsert $details 0 Callback $ctx userinfo $room $nick]
+            } elseif {$a(type) eq "unavailable"} {
+                set status [wrapper::getcdata \
+                                [wrapper::getfirstchildwithtag $xmldata status]]
+                Callback $ctx traffic left $room $nick -status $status
+            }
+        }
+    } err]} { puts stderr "OnPresenceChange: $err" }
+    return 0
+}
+
+proc ::xmppplugin::OnPresence {jlib xmldata} {
+    set ctx [set [set jlib]::AppContext]
+    if {[catch {OnPresence2 $ctx $jlib $xmldata} res]} {
+        Log $ctx "OnPresence: $err" error
+        return 0
+    }
+    return $res
+}
+proc ::xmppplugin::OnPresence2 {ctx jlib xmldata} {
+    #Log $ctx "P: $xmldata"
+    return 0
+}
+
+proc ::xmppplugin::OnIq {jlib xmldata} {
+    set ctx [set [set jlib]::AppContext]
+    if {[catch {OnIq2 $ctx $jlib $xmldata} res]} {
+        Log $ctx "OnIq: $err" error
+        return 0
+    }
+    return $res
+}
+proc ::xmppplugin::OnIq2 {ctx jlib xmldata} {
+    Log $ctx "IQ: $xmldata"
+    return 0
+}
+
+proc ::xmppplugin::OnMessage {jlib xmldata} {
+    set ctx [set [set jlib]::AppContext]
+    if {[catch {OnMessage2 $ctx $jlib $xmldata} err]} {
+        Log $ctx "OnMessage: $err" error
+    }
+    return 0
+}
+proc ::xmppplugin::OnMessage2 {ctx jlib xmldata} {
+    upvar #0 $ctx xmpp
+    array set a [linsert [wrapper::getattrlist $xmldata] 0 from {} to {} type normal]
+    jlib::splitjid $a(from) fromjid fromres
+    jlib::splitjid $a(to) tojid tores
+    set body [wrapper::getchildswithtag $xmldata body]
+    set subject [string trim [wrapper::getcdata \
+                    [wrapper::getfirstchildwithtag $xmldata subject]]]
+    set thread [string trim [wrapper::getcdata \
+                   [wrapper::getfirstchildwithtag $xmldata thread]]]
+    set chatstate [wrapper::gettag \
+             [wrapper::getfirstchildwithxmlns $xmldata http://jabber.org/protocol/chatstates]]
+
+    foreach x [wrapper::getchildswithtag $xmldata x] {
+        switch -exact -- [wrapper::getattribute $x xmlns] {
+            "jabber:x:delay" {}
+            "jabber:x:event" {}
+            "urn:tkchat:chat" {
+                set color [wrapper::getattribute $x color]
+                if {[regexp {^[[:xdigit:]]{6}$} $color]} {
+                    Callback $ctx userlist update $fromjid $fromres -color "#$color"
+                }
+            }
+            "urn:tkchat:changenick" {}
+            "urn:tkchat:whiteboard" {}
+            "coccinella:whiteboard" {}
+        }
+    }
+
+    switch -exact -- $a(type) {
+        groupchat {
+            #Log $ctx "groupchat: $a(from)->$a(to)"
+            if {$subject ne {}} {
+                Callback $ctx topic $fromjid $subject
+            }
+            set msg [wrapper::getcdata [lindex $body 0]]
+            set what normal
+            if {$fromres eq "ijchain"} {
+                if {![regexp {^(<.*?>)\s(.*)$} $msg -> fromres msg]} {
+                    # *** x left | *** x entered | *** x is now known as y
+                    if {[regexp {\*{3} ([^\s]+)\s(.*)$} $msg -> fromres msg]} {
+                        set newnick {} ; set what unknown
+                        switch -glob -- $msg {
+                            joins* -
+                            entered* { set what entered }
+                            leaves* -
+                            left* { set what left }
+                            is* {
+                                set what nickchange
+                                set newnick [lindex [split $msg] 4]
+                            }
+                        }
+                        Callback $ctx traffic $what $fromjid $fromres $newnick -group irc
+                        return 0
+                    } elseif {[regexp {^\* (\S+) (.*)$} $msg -> fromres msg]} {
+                        set what action
+                    }
+                }
+            }
+            if {[string match "/me *" $msg]} {
+                set what action
+                set msg [string range $msg 3 end]
+            }
+            if {[string length $msg] > 0} {
+                Callback $ctx chat $fromjid $fromres $msg $what
+            }
+        }
+        chat {
+            # subject? could show the topic if we ever get such an element.
+
+            # record the current conversation thread or create one
+            if {$thread eq {}} { set thread [uuid::uuid generate] }
+            # maintain per chat state in dicts. Note: we should receive an active
+            # from the remote client in response to our initial message which enables
+            # chatstate support.
+            dict set xmpp(opts) $a(from) \
+                [dict create -thread $thread -chatstate $chatstate]
+            
+            set nick [string trim [wrapper::getcdata \
+                         [wrapper::getfirstchildwithtag $xmldata nick]]]
+            if {$nick eq {}} {
+                jlib::splitjid $a(from) node resource
+                if {[$jlib muc isroom $node]} {
+                    set nick $resource
+                } else {
+                    set nick $node
+                }
+            }
+            # if chatstate stuff -- display somehow
+            if {[llength $body] > 0} {
+                Callback $ctx chat $a(from) $nick \
+                    [wrapper::getcdata [lindex $body 0]] normal
+            }
+        }
+        normal {
+            set nicktag [wrapper::getchildswithtag $xmldata nick]
+            jlib::splitjid $a(from) from res
+            if {[llength $nicktag] >0} {
+                set from "[wrapper::getcdata [lindex $nicktag 0]] <$from>"
+            }
+            set time [clock seconds]
+            set delay [lindex [wrapper::getchildswithtag $xmldata delay] 0]
+            if {$delay ne {}} {
+                set stamp [wrapper::getattribute $delay stamp]
+                catch {set time [clock scan $da(stamp) \
+                                     -format {%Y-%m-%dT%H:%M:%S%Z}]}
+            }
+            set p [list -date $time -subject $subject]
+            if {$thread ne {}} {lappend p -thread $thread}
+            lappend p -body [wrapper::getcdata [lindex $body 0]]
+            eval [linsert $p 0 Callback $ctx message $a(to) $from]
+        }
+        headline {
+            Callback $ctx chat $a(to) $a(from) \
+                "header: [wrapper::etcdata [lindex $body 0]]" normal
+            Log $ctx "$a(from)->$a(to) headline $xmldata"
+        }
+        error {
+            # If we receive a error from a chat partner we must stop the thread and
+            # avoid sending anything else.
+            # Had thread, gone(chatstate) and <error code='404'>Not Found</error>
+            Log $ctx "Message error: $xmldata" error
+            set err [wrapper::getchildswithtag $xmldata error]
+            set emsg [wrapper::getcdata [lindex $err 0]]
+            Callback $ctx system $a(from) "error from $a(from): $emsg"
+        }
+        default {
+            set body [wrapper::getcdata [lindex $body 0]]
+            Log $ctx "message: $a(type) $a(from)->$a(to): $subject\n$body"
+        }
+    }
+}
+
+
+proc ::xmppplugin::query_user {Chat user what} {
+    upvar #0 $Chat ctx
+    upvar #0 $ctx(xmpp) xmpp
+
+    array set q {
+        version  "jabber:iq:version"
+        last     "jabber:iq:last"
+        time     "jabber:iq:time"
+        discover "http://jabber.org/protocol/disco#info"
+    }
+    if {![info exists q($what)]} {
+        return -code error "invalid query \"$what\": must be one of\
+            [join [array names q] {, }]"
+    }
+    
+    if {[string first @ $user] == -1} {
+        set jid $xmpp(-channel)/$user
+    } else {
+        set jid $user
+    }
+    set xmllist [wrapper::createtag query -attrlist [list xmlns $q($what)]]
+    $xmpp(jlib) send_iq get [list $xmllist] -to $jid
+    return
+}
+
+package provide xmppplugin $::xmppplugin::version
+
+# -------------------------------------------------------------------------
+# APPLICATION LEVEL CODE
+# -------------------------------------------------------------------------
+variable xmppuid
+if {![info exists xmppuid]} { set xmppuid 0 }
+
+proc Grid {w junk row junk column} {
+    grid rowconfigure $w $row -weight 1
+    grid columnconfigure $w $column -weight 1
+}
+proc Var {arrayname key} {
+    set n [uplevel 1 namespace which -variable $arrayname]
+    if {$n eq {}} { return -code error "invalid variable name \"$arrayname\"" }
+    return $n\($key\)
+}
+proc EnableChildren { parent varname } {
+    upvar #0 $varname var
+    set state [expr {$var ? "normal" : "disabled"}]
+    foreach child [winfo children $parent] {
+        catch {EnableChildren $child $varname}
+        catch {$child configure -state $state}
+    }
+}
+        
+proc XmppLogin {app} {
+    set dlg $app.xmpplogin
+    variable $dlg {}
+    variable xmpp
+    if {![info exists xmpp(-connect)]} {
+        array set xmpp {
+            -useproxy 0 -proxyhost "" -proxyport "" -proxyuser "" -proxypass ""
+            -server all.tclers.tk -port 5222 -username "" -passwd ""
+            -connect tlssasl -resource Bullfrog
+            -autoconnect 0 -channel "tcl@tach.tclers.tk" -nick ""
+        }
+        set xmpp(-proxyhost) [autoproxy::cget -proxy_host]
+        set xmpp(-proxyport) [autoproxy::cget -proxy_port]
+        puts stderr "proxy: $xmpp(-proxyhost) $xmpp(-proxyport)"
+    }
+    if {![winfo exists $dlg]} {
+        set dlg [toplevel $dlg -class Dialog]
+        wm withdraw $dlg
+        wm transient $dlg $app
+        wm title $dlg "Login"
+        
+        set f [ttk::frame $dlg.f]
+        set g [ttk::frame $f.g]
+
+        ttk::checkbutton $f.prx -text "Use proxy" \
+            -command [list EnableChildren $f.fp [Var xmpp -useproxy]] \
+            -variable [Var xmpp -useproxy] -underline 7
+        set fp [ttk::labelframe $f.fp -labelwidget $f.prx]
+        ttk::label $fp.lph -text "Proxy host:port" -underline 0
+        set fpx [ttk::frame $fp.fpx]
+        ttk::entry $fpx.eph -textvariable [Var xmpp -proxyhost]
+        ttk::entry $fpx.epp -textvariable [Var xmpp -proxyport] -width 5
+        ttk::label $fp.lpan -text "Proxy username" -underline 11
+        ttk::entry $fp.epan -textvariable [Var xmpp -proxyuser]
+        ttk::label $fp.lpap -text "Proxy password" -underline 13
+        ttk::entry $fp.epap -textvariable [Var xmpp -proxypass] -show {*}
+        grid $fpx.eph $fpx.epp -sticky news -padx 1 -pady 1
+        Grid $fpx row 0 column 0
+        grid $fp.lph $fpx      -sticky new -padx 1 -pady 1
+        grid $fp.lpan $fp.epan -sticky new -padx 1 -pady 1
+        grid $fp.lpap $fp.epap -sticky new -padx 1 -pady 1
+        EnableChildren $f.fp [Var xmpp -useproxy]
+        
+        ttk::label $f.sl -text Server -anchor w
+        ttk::entry $f.se -textvariable [Var xmpp -server]
+        ttk::entry $f.sp -textvariable [Var xmpp -port] -width 5
+        ttk::label $f.nl -text Username -anchor w
+        ttk::entry $f.nn -textvariable [Var xmpp -username]
+        ttk::label $f.pl -text Password -anchor w
+        ttk::entry $f.pw -textvariable [Var xmpp -passwd] -show {*}
+        ttk::label $f.rl -text Resource -anchor w
+        ttk::entry $f.re -textvariable [Var xmpp -resource]
+
+        set fo [ttk::labelframe $f.fo -text "Connection options"]
+        ttk::radiobutton $fo.ssl0 -text Normal -underline 0 \
+            -variable [Var xmpp -connect] -value tlssasl
+        ttk::radiobutton $fo.ssl1 -text SSL -underline 0 \
+            -variable [Var xmpp -connect] -value tls
+        ttk::radiobutton $fo.ssl2 -text Plain -underline 0 \
+            -variable [Var xmpp -connect] -value sasl
+        grid $fo.ssl0 $fo.ssl1 $fo.ssl2 -sticky ew -padx 1 -pady 1
+        Grid $fo row 1 column 3
+
+        ttk::checkbutton $f.acx -text "Auto-connect" \
+            -command [list EnableChildren $f.ac [Var xmpp -autoconnect]]\
+            -variable [Var xmpp -autoconnect] -underline 0
+        set fa [ttk::labelframe $f.ac -labelwidget $f.acx]
+        ttk::label $fa.cl -text Channel -anchor w
+        ttk::entry $fa.cn -textvariable [Var xmpp -channel]
+        ttk::label $fa.kl -text Nick -anchor w
+        ttk::entry $fa.kn -textvariable [Var xmpp -nick]
+        grid $fa.cl $fa.cn -sticky news -padx 1 -pady 1
+        grid $fa.kl $fa.kn -sticky news -padx 1 -pady 1
+        Grid $fa row 2 column 1
+        EnableChildren $f.ac [Var xmpp -autoconnect]
+
+        ttk::button $f.ok -text Login -default active \
+            -command [list set [namespace which -variable $dlg] "ok"]
+        ttk::button $f.cancel -text Cancel \
+            -command [list set [namespace which -variable $dlg] "cancel"]
+
+
+        bind $dlg <Return> [list $f.ok invoke]
+        bind $dlg <Escape> [list $f.cancel invoke]
+        wm protocol $dlg WM_DELETE_WINDOW [list $f.cancel invoke]
+        
+        grid $f.fp -     -     -in $g -sticky new -padx 1 -pady 1
+        grid $f.sl $f.se $f.sp -in $g -sticky new -padx 1 -pady 1
+        grid $f.rl $f.re -     -in $g -sticky new -padx 1 -pady 1
+        grid $f.nl $f.nn -     -in $g -sticky new -padx 1 -pady 1
+        grid $f.pl $f.pw -     -in $g -sticky new -padx 1 -pady 1
+        grid $fo   -     -     -in $g -sticky new -padx 1 -pady 1
+        grid $fa   -     -     -in $g -sticky new -padx 1 -pady 1
+        grid columnconfigure $g 1 -weight 1
+        
+        grid $g    -         -sticky news
+        grid $f.ok $f.cancel -sticky e -padx 1 -pady 1
+        grid rowconfigure    $f 0 -weight 1
+        grid columnconfigure $f 0 -weight 1
+        
+        grid $f -sticky news
+        grid rowconfigure $dlg 0 -weight 1
+        grid columnconfigure $dlg 0 -weight 1
+        
+	wm resizable $dlg 0 0
+        raise $dlg
+    }     
+    
+    catch {::tk::PlaceWindow $dlg widget $app}
+    wm deiconify $dlg
+    tkwait visibility $dlg
+    focus -force $dlg.f.ok
+    grab $dlg
+    vwait [namespace which -variable $dlg]
+    grab release $dlg
+    wm withdraw $dlg
+    
+    puts stderr [array get xmpp]
+    if {[set $dlg] eq "ok"} {
+        after idle [linsert [array get xmpp] 0 \
+                        [namespace origin XmppConnect] $app]
+    }
+}
+
+proc Grid {w junk row junk column} {
+    grid rowconfigure $w $row -weight 1
+    grid columnconfigure $w $column -weight 1
+}
+
+proc XmppAddXmlConsole {app} {
+    if {[winfo exists $app.nb.xmlconsole]} { return }
+    set w [ttk::frame $app.nb.xmlconsole -style ChatwidgetFrame]
+    text $w.text -relief flat -borderwidth 0 -wrap char -state disabled \
+        -font DebugFont -yscrollcommand [list $w.vs set] 
+    set m0 [font measure DebugFont {00:00:00mm}]
+    $w.text configure -tabs [list $m0 [expr {$m0 * 2}]]
+    $w.text tag configure read -foreground blue3
+    $w.text tag configure write -foreground red3
+    $w.text tag configure time -foreground "#202020"
+    $w.text tag configure msg -lmargin1 $m0 -lmargin2 $m0 -spacing3 2
+    $w.text tag configure message  -foreground "#000080"
+    $w.text tag configure presence -foreground "#800080"
+    $w.text tag configure iq       -foreground "#008080"
+    ttk::scrollbar $w.vs -command [list $w.text yview]
+    grid $w.text $w.vs -sticky news -padx 1 -pady 1
+    grid rowconfigure $w 0 -weight 1
+    grid columnconfigure $w 0 -weight 1
+    $app.nb add $w -text XML
+    jlib::setdebug 2
+    if {[info commands ::jlib::_Debug] eq {}} {
+        rename ::jlib::Debug ::jlib::_Debug
+        interp alias {} ::jlib::Debug {} ::XmppDebugXml $w.text
+    }
+    set ::jlib::disco::debug 2
+    if {[info commands ::jlib::disco::_Debug] eq {}} {
+        rename ::jlib::disco::Debug ::jlib::disco::_Debug
+        interp alias {} ::jlib::disco::Debug {} ::XmppDebugJlib $app
+    }
+}
+
+# Divert generic jabberlib debug stuff into our debug pane
+proc XmppDebugJlib {app num str} {
+    set w $app.nb.debug.text
+    if {[winfo exists $w]} {
+        set t [clock format [clock seconds] -format "%T"]
+        $w configure -state normal
+        $w insert end "$t\t$str\n" debug
+        $w configure -state disabled
+    }    
+}
+
+# Divert the jabberlib debug function into our tab window.
+proc XmppDebugXml {w num str} {
+    if {[jlib::setdebug] >= $num} {
+        set autoscroll [expr {[lindex [$w yview] 1] == 1.0}]
+        set t [clock format [clock seconds] -format {%H:%M:%S}]
+        set tags {}
+        if {[string match "RECV:*" $str]} {
+            set str [string range $str 6 end]
+            lappend tags read
+            switch -glob -- $str {
+                "<message*" { lappend tags message }
+                "<presence*" { lappend tags presence }
+                "<iq*" { lappend tags iq }
+            }
+        } elseif {[string match "SEND:*" $str]} {
+            set str [string range $str 6 end]
+            if {[string length [string trim $str " \n"]] < 1} {return}
+            lappend tags write
+        }
+        $w configure -state normal
+        $w insert end "$t\t" time "$str\n" [linsert $tags 0 msg]
+        $w configure -state disabled
+        if {$autoscroll} { $w see end }
+    }
+}
+
+# Create the window for this XMPP session then call the xmppplugin to connect.
+proc XmppConnect {app args} {
+    variable xmppuid
+    set id xmpp[incr xmppuid]
+    set Session [namespace current]::$id
+    upvar #0 $Session session
+    #array set a [linsert $args 0 -username "" -server unknown]
+    #set session(server) $a(-server)
+    set session(app) $app
+    set session(type) xmpp
+    if {[set ndx [lsearch -exact $args -server]] != -1} {
+        set session(server) [lindex $args [incr ndx]]
+    } else {
+        set session(server) xmpp
+    }
+    
+    # If debugging, add the Xml console window.
+    XmppAddXmlConsole $app
+
+    # Create a messagewidget and add to the application tabs
+    set session(window) [messagewidget::messagewidget $app.nb.$id]
+    $app.nb add $session(window) -text $session(server)
+    after idle [list $app.nb select $session(window)]
+
+    # Begin the xmpp session
+    set session(xmpp) [eval [linsert $args 0 xmppplugin::connect \
+                                 [list [namespace origin XmppCallback] $Session]]]
+    bind $session(window) <Destroy> "+unset -nocomplain $Session"
+    bind $session(app).nb <<NotebookTabChanged>> \
+        [namespace code "XmppUnalert $Session \[%W select\]"]
+    return $Session
+}
+
+# Add a new chatroom into the gui.
+proc XmppAddChannel {Session channel "-type" type} {
+    upvar #0 $Session session
+    set Channel "${Session}/$channel"
+    upvar #0 $Channel chan
+    array set chan [array get session]
+    Debug $Session "XmppAddChannel $channel -type $type"
+    set chan(channel) $channel
+    set chan(type) $type
+    set chan(session) $Session
+    unset -nocomplain chan(targets)
+    set chan(window) [chatwidget::chatwidget \
+                          $session(window)[string map {. _} $channel]]
+    lappend session(targets) [list $channel $chan(window)]
+    set m0 [font measure ChatwidgetFont {[00:00]m}]
+    set m1 [font measure ChatwidgetFont [string repeat m 10]]
+    set mx [expr {$m0 + $m1}]
+    $chan(window) chat configure -tabs [list $m0 $mx]
+    $chan(window) chat tag configure MSG -lmargin1 $mx -lmargin2 $mx
+    $chan(window) chat tag configure NICK -font ChatwidgetBoldFont
+    $chan(window) chat tag configure TYPE-system -font ChatwidgetItalicFont
+    $chan(window) chat tag bind URL <Enter> [list UrlEnter %W]
+    $chan(window) chat tag bind URL <Leave> [list UrlLeave %W]
+    $chan(window) chat tag bind URL <Button-1> [list UrlClick %W %x %y]
+    if {$type eq "chat"} {
+        $chan(window) names hide
+        $chan(window) hook add chatstate [list XmppChatstate $Channel]
+    } else {
+        $chan(window) names tag bind NICK <Button-3> \
+            [namespace code [list XmppChannelNickMenu $Channel %W %x %y]]
+        $chan(window) names tag bind NICK <Enter> \
+            [list [namespace origin XmppNickTooltip] $Channel enter %W %x %y]
+        $chan(window) names tag bind NICK <Leave> \
+            [list [namespace origin XmppNickTooltip] $Channel leave %W %x %y]
+        $chan(window) hook add names_nick \
+            [namespace code [list XmppNamesHook $Channel]]
+    }
+    $chan(window) hook add post [list ::xmppplugin::post $chan(xmpp) $channel]
+    bind $chan(window) <Destroy> "+unset -nocomplain $Channel"
+    
+    # If the channel domain is a muc then use the resource.
+    upvar #0 $chan(xmpp) xmpp
+    jlib::splitjidex $channel node domain resource
+    if {[$xmpp(jlib) muc isroom $node@$domain]} {
+        set title $resource
+    } elseif {$node ne {}} {
+        set title $node
+    } else { set title $domain }
+    $session(app).nb add $chan(window) -text $title
+    after idle [list $session(app).nb select $chan(window)]
+    return $chan(window)
+}
+
+proc XmppChatstate {Chat chatstate} {
+    upvar #0 $Chat chat
+    upvar #0 $chat(xmpp) xmpp
+    if {![catch {dict get $xmpp(opts) $chat(channel) -chatstate} use]} {
+        if {$use ne {}} {
+            lappend xlist [wrapper::createtag $chatstate \
+                               -attrlist {xmlns http://jabber.org/protocol/chatstates}]
+            set margs [list -type $chat(type) -xlist $xlist]
+            if {![catch {set thread [dict get $xmpp(opts) $chat(channel) -thread]}]} {
+                lappend margs -thread $thread
+            }
+            eval [linsert $margs 0 $xmpp(jlib) send_message $chat(channel)]
+        }
+    }
+}
+
+# Hook called each time the names part of the chatwidget is updated.
+# args are the options for the nick
+proc XmppNamesHook {Chat nick args} {
+    upvar #0 $Chat chat
+    set wclass [winfo class $chat(window)]
+    #puts stderr "names hook: $Chat $nick $args class:$wclass"
+    if {[set ndx [lsearch $args -version]] != -1} {
+        if {$wclass eq "Chatwidget"} {
+            after idle [list ::tooltip::tooltip \
+                            [$chat(window) names] -tag NICK-$nick \
+                            [lindex $args [incr ndx]]]
+        }
+    }
+}
+
+proc XmppChannelNickMenu {Chat w x y} {
+    set nick [string trim [$w get "@$x,$y linestart" "@$x,$y lineend"]]
+    if {$nick eq ""} { return }
+    destroy $w.nickmenupopup
+    set m [menu $w.nickmenupopup -tearoff 0]
+    $m add command -label "$nick" -state disabled
+    $m add separator
+    $m add command -label "Chat" -underline 0 \
+        -command [namespace code [list XmppChannelNickCommand $Chat chat $nick]]
+    $m add command -label "Whois" -underline 0 -state disabled \
+        -command [namespace code [list XmppChannelNickCommand $Chat whois $nick]]
+    $m add command -label "Version" -state normal \
+        -command [namespace code [list XmppChannelNickCommand $Chat version $nick]]
+    tk_popup $m [winfo pointerx $w] [winfo pointery $w]
+}
+
+proc XmppChannelNickCommand {Chat cmd nick} {
+    upvar #0 $Chat ctx
+    upvar #0 $ctx(xmpp) xmpp
+    switch -exact -- $cmd {
+        version { xmppplugin::query_user $Chat $nick version }
+        last    { xmppplugin::query_user $Chat $nick last }
+        chat    {
+            # open a private chat to a MUC user.
+            set w [XmppCreateWindow $ctx(session) $ctx(channel)/$nick -type chat]
+            $ctx(app).nb tab $w -text $nick
+            $ctx(app).nb select $w
+        }
+        send {
+            XmppCreateMessage $ctx(session) $ctx(channel)/$nick
+        }
+    }
+}
+
+proc XmppNickTooltip {Chat type w x y} {
+    return
+    if {[package provide tooltip] eq {}} { return }
+    set nick [string trim [$w get "@$x,$y linestart" "@$x,$y lineend"]]
+    if {$nick eq ""} { return }
+    upvar #0 $Chat chat
+    puts stderr "tooltip: $w name $nick"
+    #return
+    set version [$chat(window) name get $nick -version]
+    if {$version ne {}} {
+        ::tooltip::tooltip $w -tag NICK-$nick $version
+    }
+    return
+}
+
+proc XmppCreateWindow {Session target "-type" type} {
+    upvar #0 $Session session
+    set w [XmppFindWindow $Session $target]
+    if {$w eq $session(window)} {
+        set w [XmppAddChannel $Session $target -type $type]
+    }
+    return $w
+}
+
+proc XmppFindWindow {Session target} {
+    upvar #0 $Session session
+    set result $session(window)
+    if {[info exists session(targets)]} {
+        foreach pair $session(targets) {
+            foreach {name wid} $pair break
+            if {$name eq $target} {
+                # check for detached window
+                if {[lsearch -exact [$session(app).nb tabs] $wid] == -1} {
+                    if {[wm state $wid] eq "withdrawn"} { wm deiconify $wid }
+                } else {
+                    if {[$session(app).nb tab $wid -state] eq "hidden"} {
+                        $session(app).nb tab $wid -state normal
+                    }
+                }
+                set result $wid
+                break
+            }
+        }
+    }
+    return $result
+}
+
+proc XmppRemoveWindow {Session target} {
+    upvar #0 $Session session
+    if {[info exists session(targets)]} {
+        foreach pair $session(targets) {
+            foreach {name wid} $pair break
+            if {$name eq $target} {
+                $session(app).nb hide $wid
+                break
+            }
+        }
+    }
+}
+
+proc XmppAlert {Session target} {
+    set alert 0
+    set w [XmppFindWindow $Session $target]
+    set top [winfo toplevel $w]
+    set focus [focus -displayof $top]
+    set txt [WindowTitle $Session $w]
+    set count 0
+    regexp {^(\d+) - (.*)$} $txt -> count txt
+    if {[string match "${w}*" $focus]} {
+        WindowTitle $Session $w $txt
+    } else {
+        WindowTitle $Session $w "[incr count] - $txt"
+        puts stderr "Alert focus:'$focus' '[focus]' state:[wm state $top]"
+        if {[llength $focus] == 0} {
+            # the focus is in some other app - check its not the console
+            if {[llength [console eval focus]] == 0} {
+                puts stderr "raising and so on"
+                wm deiconify $top
+                raise $top
+            }
+        }
+        set alert 1
+    }
+    return $alert
+}
+
+proc XmppUnalert {Session w} {
+    set title [WindowTitle $Session $w]
+    if {[regexp {^(\d+) - (.*)$} $title -> count tail]} {
+        WindowTitle $Session $w $tail
+    }
+}
+
+proc XmppCallback {Session context state args} {
+    upvar #0 $Session session
+    upvar #0 $context xmpp
+    #puts stderr [list $Session $context $state $args]
+    switch -exact -- $state {
+        init {
+            Status $Session "Attempting to connect to $xmpp(-server)"
+        }
+        connect {
+            XmppCallback $Session $context debug \
+                "Logging into $xmpp(-server) as $xmpp(-username)"
+            Status $Session "Connection to XMPP server established."
+            State $Session connected
+        }
+        disconnect {
+            foreach {reason} $args break
+            if {$reason ne {}} { set reason ": $reason" }
+            Status $Session "Disconnected$reason"
+            State $Session disconnected
+        }
+        close {
+            foreach {target} $args break
+            Debug $Session "closing $target"
+            XmppRemoveWindow $Session $target
+        }
+        addchat {
+            foreach {target type} $args break
+            set w [XmppCreateWindow $Session $target -type $type]
+        }
+        userlist {
+            foreach {type target} $args break
+            switch -exact -- $type {
+                roster {
+                    foreach jid [$xmpp(jlib) roster getusers] {
+                        array set item [linsert [$xmpp(jlib) roster \
+                                                     getrosteritem $jid] 0 -groups {}]
+                        if {![info exists item(-name)]} { set item(-name) $jid }
+                        #$session(window) name add $item(-name) -jid $jid -group $item(-groups)
+                    }
+                }
+                muc {
+                    set colors {black tomato chocolate blue4 green4 pink4 SteelBlue4 SeaGreen4}
+                    set w [XmppFindWindow $Session $target]
+                    puts stderr "userlist: $target $w\
+                       [$xmpp(jlib) muc participants $target]"
+                    set current [$w name list -full]
+                    foreach jid [$xmpp(jlib) muc participants $target] {
+                        jlib::splitjid $jid room nick
+                        set opts [list -status online]
+                        if {[lsearch -index 0 $current $nick] == -1} {
+                            lappend opts -color \
+                                [lindex $colors [expr {int(rand() * [llength $colors])}]]
+                        }
+                        eval [list $w name add $nick] $opts
+                    }
+                }
+                update {
+                    #update tcl@tach.tclers.tk nick -color x -affiliation y -group users -status
+                    set w [XmppFindWindow $Session $target]
+                    if {[winfo class $w] eq "Chatwidget"} {
+                        set nick [lindex $args 2]
+                        eval [list $w name add $nick] [lrange $args 3 end]
+                    }
+                }
+            }
+        }
+        userinfo {
+            foreach {target nick} $args break
+            set w [XmppFindWindow $Session $target]
+            if {[winfo class $w] eq "Chatwidget"} {
+                foreach {what value} [lrange $args 2 end] {
+                    switch -exact -- $what {
+                        -affiliation { set group $value }
+                        -show {}
+                        -status {}
+                        -jid {}
+                        -role { }
+                        -version {
+                            Status $Session "$nick using $value"
+                        }
+                    }
+                }
+                eval [linsert [lrange $args 2 end] 0 $w name add $nick]
+            }
+        }
+        chat {
+            foreach {target nick msg type} $args break
+            if {$type eq ""} {set type normal}
+            set w [XmppCreateWindow $Session $target -type chat]
+            XmppAlert $Session $target
+            switch -exact -- [winfo class $w] {
+                Chatwidget {$w message $msg -nick $nick -type $type}
+                Messagewidget {
+                    $w add -from $nick -to Me -body $msg -date [clock seconds]
+                }
+                default {puts stderr "invalid chat target \"$target\""}
+            }
+        }
+        message {
+            foreach {target from}  $args break
+            jlib::splitjidex $target node domain resource
+            set w $session(window)
+            XmppAlert $Session $domain
+            eval [list $w add -to $target -from $from] [lrange $args 2 end]
+        }
+        system {
+            foreach {target msg} $args break
+            set w [XmppFindWindow $Session $target]
+            XmppAlert $Session $target
+            switch -exact -- [winfo class $w] {
+                Chatwidget {$w message $msg -type system}
+                Messagewidget {
+                    $w add -from SYSTEM -to Me -body $msg -date [clock seconds]
+                }
+                default {
+                    Debug $Session "invalid system target \"$target\"" debug
+                }
+            }
+        }
+        topic {
+            foreach {target topic} $args break
+            set w [XmppFindWindow $Session $target]
+            if {[winfo class $w] eq "Chatwidget"} {
+                $w topic show
+                $w topic set $topic
+            }
+        }
+        traffic {
+            foreach {action target nick new} $args break
+            set w [XmppFindWindow $Session $target]
+            if {[winfo class $w] ne "Chatwidget"} {return}
+            switch -exact -- $action {
+                joining { XmppCreateWindow $Session $target -type groupchat}
+                entered {
+                    eval [linsert $args 0 $w name add $nick]
+                    $w message "$nick $action" -nick $nick -type system
+                }
+                left {
+                    $w name delete $nick
+                    $w message "$nick $action" -nick $nick -type system
+                }
+                nickchange {
+                    $w name delete $nick
+                    eval [linsert $args 0 $w name add $new]
+                    $w message "$nick is now known as $new" -nick $nick -type system
+                }
+                default {
+                    $w message "$nick $action" -nick $nick -type system
+                }
+            }
+        }
+        debug {
+            foreach {type line} $args break
+            Debug $Session $line $type
+        }
+        version { return "" }
+        default {
+            puts stderr "*** unknown xmpp callback \"$state\": $args"
+        }
+    }
+}
diff --git a/bin/bullfrog.tcl b/bin/bullfrog.tcl
new file mode 100644
index 0000000..43d8262
--- /dev/null
+++ b/bin/bullfrog.tcl
@@ -0,0 +1,369 @@
+# bullfrog.tcl -
+#
+#	This is a multi-transport chat application with support for
+#	IRC (using the picoirc package) and Jabber (using the current
+#	jabberlib from the coccinella project).
+#	It makes use of the chatwidget from tklib
+#
+# Copyright (C) 2007 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: picoirc.tcl,v 1.2 2007/10/24 10:35:25 patthoyts Exp $
+
+package require Tk 8.5
+package require chatwidget 1.1;  # tklib 
+package require tooltip 1.4;     # tklib 
+
+if {![catch {package require autoproxy}]} {
+    autoproxy::init
+}
+
+set root [file dirname [info script]]
+source [file join $root message.tcl]
+source [file join $root tab.tcl]
+
+# Load the transport specific files...
+source [file join $root bf_irc.tcl]
+source [file join $root bf_xmpp.tcl]
+
+# -------------------------------------------------------------------------
+
+proc Main {args} {
+    global env
+    array set opts {-debug 1 -nick "" -name ""}
+    if {[info exists env(IRCNICK)]} {set opts(-nick) $env(IRCNICK)}
+    if {[info exists env(IRCNAME)]} {set opts(-nick) $env(IRCNAME)}
+    while {[string match -* [set option [lindex $args 0]]]} {
+        switch -exact -- $option {
+            -nick   { set opts(-nick) [Pop args 1] }
+            -name   { set opts(-name) [Pop args 1] }
+            -debug  { set opts(-debug) 1 }
+            --      { Pop args ; break }
+            default { break }
+        }
+        Pop args
+    }
+    
+    ConfigureFonts
+
+    set app [toplevel .chat -class Bullfrog]
+    wm withdraw $app
+    wm title $app "Bullfrog"
+
+    set imgfile [file join [file dirname [info script]] bullfrog48.gif]
+    if {[file exists $imgfile]} {
+        image create photo bullfrogImage -file $imgfile
+        wm iconphoto $app bullfrogImage
+    }
+    
+    set menu [menu $app.menu -tearoff 0]
+    # File menu
+    $menu add cascade -label Network -menu [menu $menu.file -tearoff 0]
+    $menu.file add command -label "IRC Login..." -underline 0 \
+        -command [namespace code [list IrcLogin $app]]
+    if {[llength [info commands XmppLogin]] != 0} {
+        $menu.file add command -label "Jabber Login..." -underline 0 \
+            -command [namespace code [list XmppLogin $app]]
+    }
+    $menu.file add separator
+    $menu.file add command -label Exit \
+        -command [namespace code [list Exit $app]]
+    # Windows menu
+    $menu add cascade -label Window \
+        -menu [menu $menu.window -tearoff 0 \
+                   -postcommand [namespace code [list OnPostWindow $app $menu.window]]]
+    
+    $app configure -menu $menu
+
+    ttk::notebook $app.nb -style ButtonNotebook
+
+    if {$opts(-debug)} {
+        set debugf [frame $app.nb.debugf -borderwidth 0 -highlightthickness 0]
+        set debug [ttk::frame $app.nb.debugf.debug -style ChatwidgetFrame]
+        text $debug.text -relief flat -borderwidth 0 -wrap word \
+            -state disabled -font DebugFont \
+            -yscrollcommand [list $debug.vs set] 
+        $debug.text tag configure read -foreground blue3
+        $debug.text tag configure write -foreground red3
+        ttk::scrollbar $debug.vs -command [list $debug.text yview]
+        grid $debug.text $debug.vs -sticky news -padx 1 -pady 1
+        grid rowconfigure $debug 0 -weight 1
+        grid columnconfigure $debug 0 -weight 1
+        grid $debug -sticky news
+        grid rowconfigure $debugf 0 -weight 1
+        grid columnconfigure $debugf 0 -weight 1
+        $app.nb add $debugf -text Debug
+    }
+
+    set status [ttk::frame $app.status]
+    ttk::label $status.pane0 -anchor w
+    ttk::separator $status.sep0 -orient vertical
+    ttk::label $status.pane1 -anchor w
+    ttk::separator $status.sep1 -orient vertical
+    ttk::sizegrip $status.sizegrip
+    grid $status.pane0 $status.sep0 $status.pane1\
+        $status.sep1 $status.sizegrip -sticky news
+    grid columnconfigure $status 0 -weight 1
+    grid rowconfigure $status 0 -weight 1
+
+    grid $app.nb -sticky news
+    grid $status -sticky sew
+    grid rowconfigure $app 0 -weight 1
+    grid columnconfigure $app 0 -weight 1
+
+    ttk::notebook::enableTraversal $app.nb
+    bind $app <Control-F2> {console show}
+
+    wm geometry .chat 600x400
+    wm deiconify $app
+
+    set uri [lindex $args 0]
+    if {$opts(-nick) ne "" && $uri ne ""} {
+        foreach {server port channel} [picoirc::splituri $uri] break
+        after idle [list [namespace origin IrcConnect] $app \
+                        -server $server -port $port \
+                        -channel $channel -nick $opts(-nick)]
+    }
+
+    tkwait window $app
+    return
+}
+
+# Configure the fixed fonts for the debug windows
+proc ConfigureFonts {} {
+    if {[lsearch -exact [font names] DebugFont] == -1} {
+        set base [font actual TkDefaultFont]
+        eval font create DebugFont [font actual TkFixedFont]
+    }
+
+    set families [font families]
+    switch -exact -- [tk windowingsystem] {
+        aqua { set preferred {Monaco 10} }
+        win32 { set preferred {ProFontWindows 8 Consolas 8} }
+        default { set preferred {} }
+    }
+    foreach {family size} $preferred {
+        if {[lsearch -exact $families $family] != -1} {
+            font configure DebugFont -family $family -size $size
+            break
+        }
+    }
+}
+
+proc Pop {varname {nth 0}} {
+    upvar $varname args
+    set r [lindex $args $nth]
+    set args [lreplace $args $nth $nth]
+    return $r
+}
+
+proc Exit {app} {
+    destroy $app
+    exit
+}
+
+proc Status {Chat message} {
+    upvar #0 $Chat chat
+    $chat(app).status.pane0 configure -text $message
+}
+
+proc State {Chat message} {
+    upvar #0 $Chat chat
+    $chat(app).status.pane1 configure -text $message
+}
+
+proc Debug {Chat message {type debug}} {
+    upvar #0 $Chat chat
+    set w $chat(app).nb.debugf.debug.text
+    if {[winfo exists $w]} {
+        set t [clock format [clock seconds] -format "%H:%M:%S"]
+        $w configure -state normal
+        $w insert end "$t\t$message\n" $type
+        $w configure -state disabled
+    }
+}
+
+proc bgerror {args} {
+    tk_messageBox -icon error -title "Error" -message $::errorInfo
+}
+
+proc OnPostWindow {app menu} {
+    set ndx 0
+    $menu delete 0 end
+    set mod [expr {[tk windowingsystem] eq "aqua" ? "Cmd" : "Ctrl"}]
+    $menu add command -label "Close tab" -underline 0 \
+        -command [namespace code [list CloseWindow $app]]
+    $menu add command -label "Detach tab" -underline 0 \
+        -command [namespace code [list DetachWindow $app]]
+    $menu add separator
+    set tabs [$app.nb tabs]
+    foreach w [winfo children $app.nb] {
+        set ndx [incr ndx]
+        # children that are forgotten raise a 'not managed' error but we can ignore this
+        catch {
+            if {[winfo toplevel $w] eq $w} {
+                set title [wm title $w]
+            } else {
+                set title [$app.nb tab $w -text]
+            }
+            $menu add command -label "$ndx $title" -underline 0 \
+                -accel "$mod-$ndx" -command [namespace code [list SelectWindow $app $w]]
+        }
+    }
+}
+proc SelectWindow {app w} {
+    if {[lsearch -exact [$app.nb tabs] $w] != -1} {
+        $app.nb select $w
+    } else {
+        wm deiconify $w
+    }
+}
+proc CloseWindow {app} {
+    set tab [$app.nb select]
+    if {[winfo exists $tab]} {
+        $app.nb forget $tab
+        event generate $app.nb <<NotebookClosedTab>>
+    }
+}
+proc DetachWindow {app} {
+    set tab [$app.nb select]
+    if {[winfo exists $tab]} {
+        set title [$app.nb tab $tab -text]
+        set index [$app.nb index $tab]
+        $app.nb forget $tab
+        wm manage $tab
+        wm title $tab $title
+        wm protocol $tab WM_DELETE_WINDOW \
+            [namespace code [list AttachWindow $app $tab $index]]
+    }
+}
+proc AttachWindow {app w {index end}} {
+    set title [wm title $w]
+    wm forget $w
+    if {[catch {
+        if {[catch {$app.nb insert $index $w -text $title} err]} {
+            puts stderr "AttachWindow: ($index) $err"
+            $app.nb add $w -text $title
+        }
+        $app.nb select $w
+    } err]} {
+        puts stderr "AttachWindow: $err"
+        wm manage $w
+        wm title $w $title
+    }
+}
+proc WindowTitle {Session w {title {}}} {
+    upvar #0 $Session session
+    if {[lsearch -exact [$session(app).nb tabs] $w] == -1} {
+        if {$title eq {}} {
+            return [wm title $w]
+        } else {
+            wm title $w $title
+        }
+    } else {
+        if {$title eq {}} {
+            return [$session(app).nb tab $w -text]
+        } else {
+            $session(app).nb tab $w -text $title
+        }
+    }
+}
+
+
+proc UrlEnter {w} {
+    variable cursor:$w
+    set cursor:$w [$w cget -cursor]
+    $w configure -cursor hand2
+}
+
+proc UrlLeave {w} {
+    variable cursor:$w
+    if {![info exists cursor:$w]} {set cursor:$w {}}
+    $w configure -cursor [set cursor:$w]
+}
+
+proc UrlClick {w x y} {
+    set tags [$w tag names @$x,$y]
+    if {[set ndx [lsearch -glob $tags URL-*]] != -1} {
+        set url ""
+        foreach {b e} [$w tag ranges [lindex $tags $ndx]] {
+            append url [$w get $b $e]
+        }
+        if {[string length $url] > 0} {
+            if {[catch {GotoURL $w $url} err]} {
+                tk_messageBox -icon error -type ok -title "An error occurred"\
+                    -message $err
+            }
+        }
+    }
+}
+
+proc GotoURL {w url} {
+    global tcl_platform
+    set dlg [winfo toplevel $w]
+    $dlg configure -cursor watch
+    clipboard clear
+    clipboard append $url
+    switch -- $tcl_platform(platform) {
+        "windows" {
+            # Try using DDE. Escape commas
+            package require dde
+            set url [string map {, %2c} $url]
+            set handled 0
+            foreach app {Firefox Mozilla Netscape Opera IExplore} {
+                if {[set srv [dde services $app WWW_OpenURL]] != {}} {
+                    # We cant actually check for success here.
+                    catch {dde execute $app WWW_OpenURL $url}
+                    set handled 1
+                    break
+                }
+            }
+            # Try the shell exec (quote the & chars)
+            if {!$handled} {
+                if {$tcl_platform(os) eq "Windows NT"} {
+                    set url [string map {& ^&} $url]
+                }
+                if {[catch {
+                    eval exec [auto_execok start] [list $url] &
+                } err]} then {
+                    tk_messageBox -icon error -type ok \
+                        -title "Failed top open url" \
+                        -message "Error displaying \"$url\" in browser\n$err"
+                }
+            }
+        }
+        "unix" {
+            # darwin: open -a $env(BROWSER) $url
+            # gnome-open
+            # kde?
+            # find executable, then exec.
+        }
+        default {
+            tk_messageBox -icon error -type ok \
+                -title "Unsupported platform" \
+                -message "Your platform \"$tcl_platform(platform)\"\
+                    is not supported. Contact the developers."
+        }
+    }
+    $dlg configure -cursor {}
+}
+
+    
+
+# -------------------------------------------------------------------------
+
+if {![info exists initialized] && !$tcl_interactive} {
+    set initialized 1
+    wm withdraw .
+    set r [catch [linsert $argv 0 Main] err]
+    if {$r} {tk_messageBox -icon error -type ok -message $::errorInfo}
+    exit $r
+}
+
+# -------------------------------------------------------------------------
+# Local variables:
+#   mode: tcl
+#   indent-tabs-mode: nil
+# End:
diff --git a/bin/fscrolled.tcl b/bin/fscrolled.tcl
new file mode 100644
index 0000000..26cafc8
--- /dev/null
+++ b/bin/fscrolled.tcl
@@ -0,0 +1,96 @@
+namespace eval ::scrolledframe {}
+
+proc ::scrolledframe::scrolledframe {w args} {
+    eval [linsert $args 0 Create $w]
+    interp hide {} $w
+    interp alias {} $w {} [namespace origin WidgetProc] $w
+    return $w
+}
+
+proc ::scrolledframe::WidgetProc {w args} {
+}
+
+proc ::scrolledframe::Create {w} {
+    set outer [ttk::frame $w\#f]
+    ttk::frame $w
+    set vs [ttk::scrollbar $w\#vs]
+    $vs configure -command [namespace code [list Scroll $vs $w]]
+    
+    place $w -in $outer -anchor nw -x 0 -y 0
+    place $vs -in $outer -anchor nw -y 0 -rely 0 -relheight 1.0 \
+        -relx 1.0 -x -17 ;#-[winfo width $vs]
+
+    bind $w <Configure> [namespace code [list Update $vs $w %w %h]]
+    
+    return $w
+}
+
+proc ::scrolledframe::Update {scrollbar frame width height} {
+    puts stderr "Update $width $height"
+    array set pinfo [place info $frame]
+    set parent [winfo parent $frame]
+    set ratio [expr {1.0 / [winfo height $frame]}]
+    set start [expr {(-$pinfo(-y)) * $ratio}]
+    set end [expr {$start + ($ratio * [winfo height $parent])}]
+    
+    if {$start < 0.0} {
+        set start 0.0
+    }
+    
+    if {$end > 1.0} {
+        set end 1.0
+    }
+    $scrollbar set $start $end 
+}
+
+proc ::scrolledframe::Scroll {scrollbar frame type ratio args} {
+    puts stderr "Scroll $type $ratio $args"
+    switch -exact -- $type {
+        moveto {
+            #Don't allow the frame to scroll beyond the very top
+            if {$ratio < 0.0} {
+                set ratio 0.0
+            }
+            
+            # Don't allow the frame to scroll beyond the frame boundary.
+            set yratio [expr {1.0 / [winfo height $frame]}]
+            set parent [winfo parent $frame]
+            set yratiopeak [expr {$yratio * ([winfo height $frame] - [winfo height $parent])}]
+            if {$ratio > $yratiopeak} {
+                set ratio $yratiopeak
+            }
+            array set pinfo [place info $frame]
+            set pixel [expr {-round([winfo height $frame] * $ratio)}]
+            place $frame -y $pixel
+        }
+        scroll {
+            foreach {count what} $args break
+            # FIX ME
+        }
+        
+        default {
+            puts TYPE:$type
+        }
+    }
+}
+
+proc Main {} {
+    set f [scrolledframe::scrolledframe .f]
+    for {set n 0} {$n < 20} {incr n} {
+        set w [ttk::label $f.l$n -text "Label $n"]
+        grid $w -sticky ew
+    }
+    
+    grid $f\#f -sticky news
+    grid rowconfigure . 0 -weight 1
+    grid columnconfigure . 0 -weight 1
+ 
+    bind . <Control-F2> {console show}
+    tkwait window .
+}
+
+if {!$tcl_interactive} {
+    set r [catch [linsert $argv 0 Main] err]
+    if {$r} {tk_messageBox -message $::errorInfo}
+    exit $r
+}
\ No newline at end of file
diff --git a/bin/history.tcl b/bin/history.tcl
new file mode 100644
index 0000000..d80edae
--- /dev/null
+++ b/bin/history.tcl
@@ -0,0 +1,141 @@
+# history.tcl - Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+#	Get history from tclers.tk for a conference
+#
+#
+
+package require Tcl 8.5 ;# uses dict and {*}
+source [file join [file dirname [info script]] httpredir.tcl]
+if {![catch {package require autoproxy}]} {
+    autoproxy::init
+}
+
+namespace eval ::tclers.tk {
+    #variable url_base http://tclers.tk/conferences
+    variable url_base http://localhost/conferences
+}
+
+proc ::tclers.tk::gethistory {room args} {
+    # -messagecommand
+    # -progress
+}
+
+proc ::tclers.tk::Progress {tok total current} {
+    .htest.f.status.progress configure -value $current -maximum $total
+}
+
+proc ::tclers.tk::GetIndex {room} {
+    variable url_base
+    set url ${url_base}/$room
+    set headers [list Accept-Charset utf-8 Cache-control no-cache]
+    ::http::geturl2 $url -headers $headers \
+        -timeout 120000 \
+        -progress [namespace code [list Progress]] \
+        -command [namespace code [list GotIndex $url]]
+}
+
+proc ::tclers.tk::GotIndex {url tok} {
+    if {[catch {
+        set ncode [::http::ncode $tok]
+        set status [string tolower [::http::status $tok]]
+        array set ::TOK [array get $tok]
+        if {$status eq "ok" && $ncode < 300} {
+            after idle [namespace code [list ProcessIndex $url [::http::data $tok]]]
+        } else {
+            puts stderr "GotIndex Failure: [http::status $tok] [http::code $tok]"
+            if {$status eq "error"} { puts stderr [http::error $tok] }
+        }
+        ::http::cleanup $tok
+    } err]} { puts stderr $err }
+}
+
+proc ::tclers.tk::ProcessIndex {url data} {
+    set RE {<A HREF="([0-9\-%d]+\.tcl)">.*\s([0-9]+) bytes}
+    foreach line [split $data \n] {
+	if { [regexp -- $RE $line -> logname size] } {
+	    set logname [string map {"%2d" -} $logname]
+	    set size [expr { $size / 1024 }]k
+	    lappend loglist $logname $size
+	}
+    }
+
+    ## Only show 7 days worth.
+    set loglist [lrange $loglist end-13 end]
+    #after idle [list after 0 ::tkchat::LoadHistoryFromIndex $loglist]
+    #foreach {name size} $loglist {}
+    GetLog $url/[lindex $loglist end-1]
+}
+
+proc ::tclers.tk::GetLog {url} {
+    set headers [list Accept-Charset utf-8 Cache-control no-cache]
+    set tok [::http::geturl2 $url -headers $headers -timeout 120000 \
+                 -progress [namespace code Progress] \
+                 -command [namespace code GotLog]]
+}
+
+proc ::tclers.tk::GotLog {tok} {
+    upvar #0 $tok state
+    if {[catch {
+        set ncode [::http::ncode $tok]
+        set status [string tolower [::http::status $tok]]
+        if {$status eq "ok" && $ncode < 300} {
+            if {$state(charset) eq "iso8859-1"} {
+                set data [encoding convertfrom utf-8 [::http::data $tok]]
+            } else {
+                set data [::http::data $tok]
+            }
+            after idle [namespace code [list ProcessLog $data]]
+        } else {
+            puts stderr "GotIndex Failure: [http::status $tok] [http::code $tok]"
+            if {$status eq "error"} { puts stderr [http::error $tok] }
+        }
+        ::http::cleanup $tok
+    } err]} { puts stderr $err }
+}
+
+proc ::tclers.tk::ProcessLog {data} {
+    if {[catch {
+        #.htest.f.txt delete 1.0 end
+        set interp [interp create -safe]
+        interp alias $interp m {} [namespace origin Message]
+        interp eval $interp $data
+        interp delete $interp
+    } err]} {
+        puts stderr "error processing log file: $err"
+    }
+}
+
+proc ::tclers.tk::Message {when nick msg {opts ""} args} {
+    if {[catch {clock scan $when -format "%Y-%m-%dT%H:%M:%S%Z" -gmt 1} s]} {
+        set s [clock scan $when -format "%Y%m%dT%H:%M:%S" -gmt 1]
+    }
+    set ts [clock format $s -format "%H:%M"]
+    if {$opts ne ""} {puts stderr "OPTS: '$opts'"}
+    .htest.f.txt insert history "$ts " TIMESTAMP "$nick\t$msg\n" [list NICK-$nick MSG]
+}
+
+# testing
+proc ::tclers.tk::TestGUI {} {
+    set dlg [toplevel .htest -class Dialog]
+    wm withdraw $dlg
+    wm title $dlg "Test history fetch"
+    set f [ttk::frame $dlg.f]
+    text $f.txt -background white -height 8 -width 30 \
+        -yscrollcommand [list $f.vs set] -font TkDefaultFont
+    ttk::scrollbar $f.vs -command [list $f.txt yview]
+    set status [ttk::frame $f.status]
+    ttk::label $status.pane0
+    ttk::progressbar $status.progress
+    ttk::sizegrip $status.sg
+    grid $status.pane0 $status.progress $status.sg -sticky news
+    grid rowconfigure $status 0 -weight 1
+    grid columnconfigure $status 0 -weight 1
+    grid $f.txt $f.vs -sticky news
+    grid $status -    -sticky ew
+    grid rowconfigure $f 0 -weight 1
+    grid columnconfigure $f 0 -weight 1
+    grid $f -sticky news
+    grid rowconfigure $dlg 0 -weight 1
+    grid columnconfigure $dlg 0 -weight 1
+    wm deiconify $dlg
+}
diff --git a/bin/httpredir.tcl b/bin/httpredir.tcl
new file mode 100644
index 0000000..621ee92
--- /dev/null
+++ b/bin/httpredir.tcl
@@ -0,0 +1,66 @@
+# httpredir.tcl - Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+#	This is a wrapper for the http package that handles redirects. If too
+#	many redirections are encountered then it is converted into an error
+#	response and the -command procedure called.
+#
+
+package require Tcl 8.5     ;# uses dict and {*}
+package require http 2.5
+
+namespace eval ::http {
+    # This is the set of additional options we take. They are removed before we
+    # call the http::geturl command but are maintained in this package.
+    variable extrafields {-redirects -maxredirects}
+}
+
+proc ::http::Redirect {opts tok} {
+    upvar #0 $tok state
+    variable extrafields
+    if {[set ndx [lsearch -nocase $state(meta) location]] != -1} {
+        if {[dict incr opts -redirects] > [dict get $opts -maxredirects]} {
+            set state(status) error
+            set state(error) "Too many redirections. Loop detected."
+            uplevel #0 [dict get $opts -command] [list $tok]
+        } else {
+            # RFC 2626:14.30 specifies the location to be absolute url
+            set url [lindex $state(meta) [incr ndx]]
+            # RFC 2616:14.36 if not human generated, include Referer header
+            dict set opts -headers Referer $state(url)
+            set args [dict remove $opts {*}$extrafields]
+            dict set args -command [namespace code [list RedirectCheck $opts]]
+            after idle [list ::http::geturl $url {*}$args]
+        }
+    } else {
+        set state(status) error
+        set state(error) "Received [http::code $tok] but no Location header."
+        uplevel #0 [dict get $opts -command] [list $tok]
+    }
+    return
+}
+proc ::http::RedirectCheck {opts tok} {
+    set ncode [::http::ncode $tok]
+    set status [string tolower [::http::status $tok]]
+    if {$status eq "ok" && $ncode < 400 && $ncode >= 300} {
+        Redirect $opts $tok
+    } else {
+        set state(-command) [dict get $opts -command]
+        uplevel #0 [dict get $opts -command] [list $tok]
+    }
+    ::http::cleanup $tok
+}
+
+proc ::http::geturl2 {url args} {
+    variable extrafields
+    set opts [dict create {*}$args]
+    if {![dict exists $opts -command]} {
+        return -code error "missing -command argument"
+    }
+    if {![dict exists $opts -maxredirects]} {
+        dict set opts -maxredirects 10
+    }
+    # call the http package with _only_ http package options
+    set args [dict remove $opts {*}$extrafields]
+    dict set args -command [namespace code [list RedirectCheck $opts]]
+    return [http::geturl $url {*}$args]
+}
diff --git a/bin/images/bullfrog48.gif b/bin/images/bullfrog48.gif
new file mode 100644
index 0000000..5dcb16b
Binary files /dev/null and b/bin/images/bullfrog48.gif differ
diff --git a/bin/images/chat.gif b/bin/images/chat.gif
new file mode 100644
index 0000000..facea22
Binary files /dev/null and b/bin/images/chat.gif differ
diff --git a/bin/images/dhd.gif b/bin/images/dhd.gif
new file mode 100644
index 0000000..a4041ca
Binary files /dev/null and b/bin/images/dhd.gif differ
diff --git a/bin/images/dhn.gif b/bin/images/dhn.gif
new file mode 100644
index 0000000..a7ac96d
Binary files /dev/null and b/bin/images/dhn.gif differ
diff --git a/bin/images/dhu.gif b/bin/images/dhu.gif
new file mode 100644
index 0000000..2d26475
Binary files /dev/null and b/bin/images/dhu.gif differ
diff --git a/bin/images/mail.gif b/bin/images/mail.gif
new file mode 100644
index 0000000..1bc6358
Binary files /dev/null and b/bin/images/mail.gif differ
diff --git a/bin/images/xhd.gif b/bin/images/xhd.gif
new file mode 100644
index 0000000..0e29de9
Binary files /dev/null and b/bin/images/xhd.gif differ
diff --git a/bin/images/xhn.gif b/bin/images/xhn.gif
new file mode 100644
index 0000000..48ca121
Binary files /dev/null and b/bin/images/xhn.gif differ
diff --git a/bin/images/xhu.gif b/bin/images/xhu.gif
new file mode 100644
index 0000000..23360d0
Binary files /dev/null and b/bin/images/xhu.gif differ
diff --git a/bin/message.tcl b/bin/message.tcl
new file mode 100644
index 0000000..a186c28
--- /dev/null
+++ b/bin/message.tcl
@@ -0,0 +1,193 @@
+# message.tcl - Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+#	Implementation of a composite widget that displays a set of
+#	messages from some storage. This could be e-mail or instant-messaging
+#	or some other source. The upper part shows a summary of each
+#	message and clicking a message triggers the display in the lower
+#	section
+#
+# -------------------------------------------------------------------------
+# TODO:
+#  - delete
+#  - images for type/state
+#
+#  - Should abstract the data storage out so that we could use
+#    sqlite if we have it. Persistence will be simpler as a db.
+#    Data interface is: add, select, delete so it all looks like sql.
+#
+# -------------------------------------------------------------------------
+
+package require Tk 8.5
+
+namespace eval messagewidget {
+    variable version 1.0.0
+
+    namespace export messagewidget
+
+    if {[lsearch -exact [font names] MessagewidgetFont] == -1} {
+        eval [list font create MessagewidgetFont] [font actual TkTextFont]
+        eval [list font create MessagewidgetBoldFont] \
+            [font actual TkTextFont] -weight bold
+        eval [list font create MessagewidgetItalicFont] \
+            [font actual TkTextFont] -slant italic
+    }
+    namespace eval ::img {}
+    set imgdir [file join [file dirname [info script]] images]
+    image create photo ::img::msgnorm -file [file join $imgdir mail.gif]
+    image create photo ::img::msgchat -file [file join $imgdir chat.gif]
+}
+
+proc messagewidget::messagewidget {w args} {
+    Create $w
+    interp hide {} $w
+    interp alias {} $w {} [namespace origin WidgetProc] $w
+    return $w
+}
+
+proc messagewidget::WidgetProc {self cmd args} {
+    upvar #0 [namespace current]::$self state
+    switch -exact -- $cmd {
+        add {
+            return [uplevel 1 [list [namespace origin Add] $self] $args]
+        }
+        summary {
+            return [uplevel 1 [list [namespace origin Summary] $self] $args]
+        }
+        body -
+        default {
+            return [uplevel 1 [list [namespace origin Body] $self] $args]
+        }
+    }
+}
+
+proc messagewidget::Summary {self args} {
+    upvar #0 [namespace current]::$self state
+    if {[llength $args] == 0} {
+        return $state(mlist)
+    }
+    return [uplevel 1 [list $state(mlist)] $args]
+}
+
+proc messagewidget::Body {self args} {
+    upvar #0 [namespace current]::$self state
+    if {[llength $args] == 0} {
+        return $state(body)
+    }
+    return [uplevel 1 [list $state(body)] $args]
+}
+
+proc messagewidget::Create {self} {
+    upvar #0 [set State [namespace current]::$self] state
+    
+    set self [ttk::frame $self -class Messagewidget]
+    set inner [ttk::panedwindow $self.inner -orient vertical]
+    
+    # top part shows subject lines, from, date etc
+    set mlist [ttk::frame $inner.mlist]
+    set state(mcols) {date from subject}
+    set state(summary) [ttk::treeview $mlist.tree -height 4 \
+                            -columns $state(mcols)]
+    ttk::scrollbar $mlist.vs -command [list $mlist.tree yview]
+    $mlist.tree configure -yscrollcommand [list $mlist.vs set]
+    $mlist.tree heading date -anchor w -text Date
+    $mlist.tree heading from -anchor w -text From
+    $mlist.tree heading subject -anchor w -text Subject
+    $mlist.tree column #0 -width 5
+    $mlist.tree column date -width \
+        [font measure TkHeadingFont "31/12 00:00"]
+    $mlist.tree column from -width \
+        [font measure TkHeadingFont "somenames@xyzzy.xyzzy.com"]
+    $mlist.tree column subject -anchor w -stretch 1
+    $mlist.tree tag bind item <Button-1> \
+        [namespace code [list OnSummaryClick $self %W %x %y]]
+    grid $mlist.tree $mlist.vs -sticky news
+    Grid $mlist row 0 column 0
+
+    # lower part displays message 
+    set view [ttk::frame $inner.view]
+    set state(body) [text $view.body -borderwidth 0 -relief flat \
+                         -font MessagewidgetFont]
+    ttk::scrollbar $view.vs -command [list $view.body yview]
+    $view.body configure -yscrollcommand [list $view.vs set]
+    grid $view.body $view.vs -sticky news -padx 1 -pady 1
+    Grid $view row 0 column 0
+    $view.body tag configure header -background LightSteelBlue
+    $view.body tag configure subject -font MessagewidgetBoldFont
+
+    bind $self <Destroy> "+unset -nocomplain $State"
+
+    $inner add $mlist
+    $inner add $view -weight 1
+    grid $inner -sticky news
+    Grid $self row 0 column 0
+    return $self
+}
+
+proc messagewidget::Grid {w junk row junk column} {
+    grid rowconfigure $w $row -weight 1
+    grid columnconfigure $w $column -weight 1
+}
+
+proc messagewidget::DisplayTime {time} {
+    set r $time
+    catch {
+        set delta [expr {[clock seconds] - $time}]
+        if {$delta < 86400} {
+            set format {%H:%M:%S}
+        } else {
+            set format {%a %d %b}
+        }
+        set r [clock format $time -format $format]
+    }
+    return $r
+}
+
+proc messagewidget::Add {self args} {
+    upvar #0 [namespace current]::$self state
+    set msg [eval [linsert $args 0 dict create -state U \
+                       -from "" -to "" -subject "" -body ""]]
+    lappend state(messages) $msg
+    lappend values [DisplayTime [dict get $msg -date]]
+    lappend values [dict get $msg -from]
+    lappend values [dict get $msg -subject]
+    set img ::img::msgnorm
+    set item [$state(summary) insert {} end -image $img -tags item -values $values]
+}
+
+proc messagewidget::OnSummaryClick {self w x y} {
+    upvar #0 [namespace current]::$self state
+    set item [$w identify row $x $y]
+    set M [lindex $state(messages) [$w index $item]]
+    # ? dict set $M -state R
+    $state(summary) item $item -text " "
+    $state(body) delete 1.0 end
+    $state(body) insert end \
+        "From:\t[dict get $M -from]\n" header \
+        "To:\t[dict get $M -to]\n" header \
+        "Date:\t[clock format [dict get $M -date]]\n" header \
+        "Subject:\t[dict get $M -subject]\n\n" header \
+        "[dict get $M -body]\n" body
+}
+
+# -------------------------------------------------------------------------
+
+package provide messagewidget $messagewidget::version
+
+# -------------------------------------------------------------------------
+
+# testing
+
+proc messagewidget::Test {} {
+    destroy .t
+    toplevel .t
+    pack [messagewidget::messagewidget .t.t] -fill both -expand 1
+    .t.t add -from rmax@all.tclers.tk -to patthoyts@all.tclers.tk \
+        -date 1202540181 -subject "Testing message one" \
+        -body [info body [lindex [info procs] [expr {int(rand() * 10)}]]]
+    .t.t add -from kostix@007sp.ru -to patthoyts@all.tclers.tk \
+        -date 1202544181 -subject "Russian testing message" \
+        -body [info body [lindex [info procs] [expr {int(rand() * 10)}]]]
+    .t.t add -from pennythoyts@googlemail.com -to patthoyts@all.tclers.tk \
+        -date 1202550181 -subject "Another test" \
+        -body [info body [lindex [info procs] [expr {int(rand() * 10)}]]]
+}
\ No newline at end of file
diff --git a/bin/tab.tcl b/bin/tab.tcl
new file mode 100644
index 0000000..a4c37aa
--- /dev/null
+++ b/bin/tab.tcl
@@ -0,0 +1,251 @@
+# Replace the standard notebook tab with one that includes a close
+# button. 
+# In future versions of ttk this will be supported more directly when
+# the identify command will be able to identify parts of the tab.
+
+namespace eval ::ButtonNotebook {
+}
+
+# Tk 8.6 has the Visual Styles element engine on windows. If this is
+# available we use it to get proper windows close buttons.
+#
+proc ::ButtonNotebook::CreateElements {} {
+    if {[lsearch -exact [ttk::style element names] close] == -1} {
+        if {[catch {
+            # WINDOW WP_SMALLCLOSEBUTTON (19)
+            # WINDOW WP_MDICLOSEBUTTON (20)
+            # WINDOW WP_MDIRESTOREBUTTON (22)
+            #ttk::style element create close vsapi \
+            #    WINDOW 20 {disabled 4 {active pressed} 3 active 2 {} 1}
+            ttk::style element create close vsapi \
+                EXPLORERBAR 2 {disabled 4 {active pressed} 3 active 2 {} 1}
+            ttk::style element create detach vsapi \
+                WINDOW 22 {disabled 4 {active pressed} 3 active 2 {} 1}
+        }]} then {
+            # No XP element engine - use images...
+            CreateImageElements
+        }
+    }
+}
+
+proc ::ButtonNotebook::CreateImageElements {} {
+    # Create two image based elements to provide buttons to close the
+    # tabs or to detach a tab and turn it into a toplevel.
+    namespace eval ::img {}
+    set imgdir [file join [file dirname [info script]] images]
+    image create photo ::img::close -file [file join $imgdir xhn.gif]
+    image create photo ::img::closepressed -file [file join $imgdir xhd.gif]
+    image create photo ::img::closeactive -file [file join $imgdir xhu.gif]
+    image create photo ::img::detach -file [file join $imgdir dhn.gif]
+    image create photo ::img::detachup -file [file join $imgdir dhu.gif]
+    image create photo ::img::detachdown -file [file join $imgdir dhd.gif]
+    if {[lsearch -exact [ttk::style element names] close] == -1} {
+        if {[catch {
+            ttk::style element create close image \
+                [list ::img::close \
+                     {active pressed !disabled} ::img::closepressed \
+                     {active !disabled} ::img::closeactive] \
+                -border 3 -sticky {}
+            ttk::style element create detach image \
+                [list ::img::detach \
+                     {active pressed !disabled} ::img::detachdown \
+                     {active !disabled} ::img::detachup] \
+                -border 3 -sticky {}
+        } err]} { puts stderr $err }
+    }
+}
+
+proc ::ButtonNotebook::Init {{pertab 0}} {
+    CreateElements
+
+    # This places the buttons on the right end of the tab area -- but in
+    # Tk 8.5 we cannot identify these elements.
+    if {!$pertab} {
+        ttk::style layout ButtonNotebook {
+            ButtonNotebook.client -sticky nswe
+            ButtonNotebook.close -side right -sticky ne
+            ButtonNotebook.detach -side right -sticky ne
+        }
+    }
+
+    # This places the button elements on each tab which uses quite a
+    # lot of space but we can identify the elements. Changes to the 
+    # widget state affect all the button elements though.
+    if {$pertab} {
+        ttk::style layout ButtonNotebook {
+            ButtonNotebook.client -sticky nswe
+        }
+        ttk::style layout ButtonNotebook.Tab {
+            ButtonNotebook.tab -sticky nswe -children {
+                ButtonNotebook.focus -side top -sticky nswe -children {
+                    ButtonNotebook.padding -side right -sticky nswe -children {
+                        ButtonNotebook.close -side right -sticky {}
+                    }
+                    ButtonNotebook.label -side left -sticky {}
+                }
+            }
+        }
+        if {$::ttk::currentTheme eq "xpnative"} {
+            ttk::style configure ButtonNotebook.Tab -width -8
+            ttk::style configure ButtonNotebook.Tab -padding {8 0 0 0}
+        }
+    }
+
+    bind TNotebook <ButtonPress-1> {+::ButtonNotebook::Press %W %x %y}
+    bind TNotebook <Motion> {+::ButtonNotebook::Drag %W %x %y %X %Y}
+    bind TNotebook <ButtonRelease-1> {+::ButtonNotebook::Release %W %x %y %X %Y}
+    bind TNotebook <<ThemeChanged>> [namespace code [list Init $pertab]]
+}
+
+# Hook in some event extras:
+# set the state to pressed if button down over a button element.
+proc ::ButtonNotebook::Press {w x y} {
+    set e [$w identify $x $y]
+    if {[string match "*close" $e] || [string match "*detach" $e]} {
+        $w state pressed
+    } else {
+        upvar #0 [namespace current]::$w state
+        if {![info exists state]} {
+            set state(drag) 1
+            set state(drag_index) [$w index @$x,$y]
+            set state(drag_under)  $state(drag_index)
+            set state(drag_from_x) $x
+            set state(draw_from_y) $y
+            set state(drag_indic) [ttk::label $w._indic -text v]
+        }
+    }
+}
+
+proc ::ButtonNotebook::Drag {w x y rootX rootY} {
+    upvar #0 [namespace current]::$w state
+    if {[info exists state]} {
+        if {[winfo containing $rootX $rootY] eq $w} {
+            set index [$w index @$x,$y]
+            if {$index != $state(drag_under)} {
+                puts "moved to $index"
+                place $state(drag_indic) -anchor nw -x $x -y 0
+                set state(drag_under) $index
+            }
+        }
+    }
+}
+
+# On release, do the button action if any.
+proc ::ButtonNotebook::Release {w x y rootX rootY} {
+    $w state !pressed
+    set e [$w identify $x $y]
+    set index [$w index @$x,$y]
+    if {[string match "*close" $e]} {
+        $w forget $index
+        event generate $w <<NotebookClosedTab>>
+    } elseif {[string match "*detach" $e]} {
+        Detach $w $index
+    } else {
+        upvar #0 [namespace current]::$w state
+        if {[info exists state]} {
+            set dropwin [winfo containing $rootX $rootY]
+            if {$dropwin eq {}} {
+                Detach $w $state(drag_index)
+            } elseif {$dropwin eq $w && $index != $state(drag_index)} {
+                Move $w $state(drag_index) $index
+            }
+            destroy $state(drag_indic)
+            unset state
+        }
+    }
+}
+
+# Move a tab from old index to new index position.
+proc ::ButtonNotebook::Move {notebook old_index new_index} {
+    set tab [lindex [$notebook tabs] $old_index]
+    set title [$notebook tab $old_index -text]
+    $notebook forget $old_index
+    if {[string is integer -strict $new_index]} {
+        incr new_index -1
+        if {$new_index < 0} {set new_index 0}
+        if {$new_index > [llength [$notebook tabs]]} { set new_index end }
+    } else {
+        set new_index end
+    }
+    $notebook insert $new_index $tab -text $title
+}
+
+# Turn a tab into a toplevel (must be a tk::frame)
+proc ::ButtonNotebook::Detach {notebook index} {
+    set tab [lindex [$notebook tabs] $index]
+    set title [$notebook tab $index -text]
+    $notebook forget $index
+    wm manage $tab
+    wm title $tab $title
+    wm protocol $tab WM_DELETE_WINDOW \
+        [namespace code [list Attach $notebook $tab $index]]
+    bind $tab <Configure> \
+        [namespace code [list Debug $notebook "Configure %wx%h %x,%y"]]
+    bind $tab <Expose> [namespace code [list Debug $notebook "Expose"]]
+    bind $tab <Activate> [namespace code [list Debug $notebook "Activate"]]
+    bind $tab <Deactivate> [namespace code [list Debug $notebook "Deactivate"]]
+    bind $tab <ButtonPress> [namespace code [list Debug $notebook "Button"]]
+    bind $tab <Visibility> \
+        [namespace code [list Debug $notebook "Visibility %s"]]
+    
+    event generate $tab <<DetachedTab>>
+}
+proc ::ButtonNotebook::Debug {notebook msg} {
+    $notebook.page0.text insert end $msg\n {}
+    $notebook.page0.text see end
+}
+
+# Attach a toplevel to the notebook
+proc ::ButtonNotebook::Attach {notebook tab {index end}} {
+    set title [wm title $tab]
+    wm forget $tab
+    if {[catch {
+        if {[catch {$notebook insert $index $tab -text $title} err]} {
+            $notebook add $tab -text $title
+        }
+        $notebook select $tab
+    } err]} {
+        puts stderr "AttachWindow: $err"
+        wm manage $w
+        wm title $w $title
+    }
+}
+proc ::ButtonNotebook::Test {} {
+    variable tabtest
+    set dlg [toplevel .test[incr tabtest]]
+    wm title $dlg "Notebook test"
+    wm withdraw $dlg
+    set nb [ttk::notebook $dlg.nb -style ButtonNotebook]
+    frame $nb.page0 -background red -width 100 -height 100
+    frame $nb.page1 -background blue -width 100 -height 100
+    frame $nb.page2 -background green -width 100 -height 100
+    frame $nb.page3 -background tomato -width 100 -height 100
+    $nb add $nb.page0 -text One
+    $nb add $nb.page1 -text Two
+    $nb add $nb.page2 -text Three
+    $nb add $nb.page3 -text "Some really long label."
+
+    set txt [text $nb.page0.text -height 10 -width 10]
+    set vs [scrollbar $nb.page0.vs -command [list $txt yview]]
+    $txt configure -yscrollcommand [list $vs set]
+    grid $txt $vs -sticky news
+    grid rowconfigure $nb.page0 0 -weight 1
+    grid columnconfigure $nb.page0 0 -weight 1
+
+    grid $dlg.nb -sticky news
+    grid rowconfigure $dlg 0 -weight 1
+    grid columnconfigure $dlg 0 -weight 1
+    
+    bind TNotebook <Motion> [string map [list %txt $txt] {
+        %txt insert end [%W identify %x %y] {} "\n" {}
+        %txt see end
+    }]
+    bind $dlg <Control-F2> {console show}
+    wm withdraw .
+    wm protocol $dlg WM_DELETE_WINDOW {exit}
+    wm geometry $dlg 320x240
+    wm deiconify $dlg
+}
+
+::ButtonNotebook::Init 1
+if {[winfo class .] eq "Tab"} {::ButtonNotebook::Test; tkwait window .}
\ No newline at end of file
diff --git a/bin/test/demo.tcl b/bin/test/demo.tcl
new file mode 100644
index 0000000..2d992c6
--- /dev/null
+++ b/bin/test/demo.tcl
@@ -0,0 +1,281 @@
+package require Tk 8.4
+package require http
+package require uri
+package require autoproxy
+package require chatwidget
+
+package require jlib
+package require jlib::connect
+package require jlib::disco
+package require jlib::roster
+package require jlib::muc
+package require jlib::vcard
+
+# Enable proxy-aware TLS sockets.
+if {![catch {package require tls}]} {
+    http::register https 443 ::autoproxy::tls_socket
+}
+
+# Maybe support ipv6 and more efficient sockets on win32
+if {0 && ![catch {package require Iocpsock}]} {
+    http::register http 80 [info command socket2]
+}
+
+# Use either tile 0.8 or the ttk commands in 8.5a6.
+if {[llength [info commands ttk::*]] == 0} {
+    package require tile 0.8
+}
+
+# -------------------------------------------------------------------------
+
+namespace eval Link { }
+
+proc OnNetwork {tok cmd args} {
+    if {[catch {
+        array set a {-body {} -errormsg {}}
+        array set a $args
+        switch -exact -- $cmd {
+            connect { Log "* connected" }
+            disconnect { Log "* disconnected" }
+            networkerror { Log "* Network error: $a(-body)" }
+            xmpp-streams-error-* -
+            streamerror { Log "* Stream error: $a(-errormsg)" }
+            xmlerror { Log "* XML parse error: $a(-errormsg)" }
+            default { Log "* $cmd $args" }
+        }
+    } err]} { Log "OnNetwork: $err" error }
+}
+
+proc OnPresence {tok type args} {
+    if {[catch [linsert $args 0 OnPresence2 $tok $type] err]} {
+        Log "OnPresence: $err" error
+    }
+    return 0
+}
+proc OnPresence2 {tok type args} {
+    array set a {-from {} -to {} -status {}}
+    array set a $args
+    Log "< presence $type $a(-from) $a(-to) $a(-status)"
+}
+
+proc OnIq {tok type args} {
+    if {[catch [linsert $args 0 OnIq2 $tok $type] err]} {
+        Log "OnIq: $err" error
+    }
+    return 0
+}
+
+proc OnIq2 {tok type args} {
+    array set a {-from {} -to {}}
+    array set a $args
+    Log "< iq $type $a(-from) $a(-to)"
+}
+
+proc OnMessage {tok type args} {
+    if {[catch [linsert $args 0 OnMessage2 $tok $type] err]} {
+        Log "OnMessage: $err" error
+    }
+    return 0
+}
+
+proc OnMessage2 {tok type args} {
+    array set a {-from {} -to {} -subject {} -body {}}
+    array set a $args
+    switch -exact -- $type {
+        groupchat -
+        chat {
+            Print "$a(-from) $a(-body)"
+        }
+        headline {
+            Print "$a(-from) \"$a(-subject)\"\n    $a(-body)"
+        }
+        error {
+            Log "Message error: $args" error
+        }
+        normal -
+        default {
+            Print "$a(-from) $a(-body)"
+        }
+    }
+}
+
+proc OnMucEnter {app jlib type args} {
+    if {[catch {
+        array set a {-from {} -to {}}
+        array set a $args
+        set room [jid !resource $a(-from)]
+        
+        if {1} {
+            variable chatuid ; if {![info exists chatuid]} { set chatuid -1 }
+            set id chat[incr chatuid]
+            upvar #0 [set Chat [namespace current]::$id] chat
+            set chat(app) $app
+            set chat(type) jabber
+            set chat(room) $room
+            set chat(nick) [$jlib muc mynick $room]
+            set chat(window) [chatwidget::chatwidget $app.$id]
+            $app.nb add $chat(window) -text $room
+        }
+
+        Log "< MUC $type $a(-from) $a(-to)"
+    } err]} {
+        Log "OnMucEnter $err"
+    }
+}
+
+proc OnConnect {tok type args} {
+    Log "OnConnect $tok $type $args"
+
+    switch -exact -- $type {
+        initnetwork { }
+        initstream  { }
+        authenticate { }
+        ok {
+            $tok send_presence -type available
+            $tok roster send_get
+        }
+        error { }
+    }
+}
+
+# -------------------------------------------------------------------------
+
+# tkjabber::jid --
+#
+#       A helper function for splitting out parts of Jabber IDs.
+#
+proc jid {part jid} {
+    set r {}
+    if {[regexp {^(?:([^@]*)@)?([^/]+)(?:/(.+))?} $jid \
+             -> node domain resource]} {
+        switch -exact -- $part {
+            node      { set r $node }
+            domain    { set r $domain }
+            resource  { set r $resource }
+            !resource { set r ${node}@${domain} }
+            jid       { set r $jid }
+            default {
+                return -code error "invalid part \"$part\":\
+                    must be one of node, domain, resource or jid."
+            }
+        }
+    }
+    return $r
+}
+
+# -------------------------------------------------------------------------
+proc Print {str} {.chat.main insert end $str {} "\n" {}}
+proc Log {str {tag {}}} {
+    .chat.main insert end $str\n [list log $tag]
+    .chat.main see end
+}
+proc Exit {app} { destroy $app }
+
+proc Main {} {
+    autoproxy::init
+    set app [toplevel .chat -class Chat]
+    wm withdraw $app
+    wm title $app "Chat test app"
+    
+    set menu [menu $app.menu -tearoff 0]
+    $menu add cascade -label File -menu [menu $menu.file -tearoff 0]
+    $menu.file add command -label "Connect" \
+        -command [list [namespace origin Connect] $app]
+    $menu.file add command -label "Join tcl chat" \
+        -command [list [namespace origin JoinRoom] $app tcl@tach.tclers.tk]
+    $menu.file add command -label "Join test chat" \
+        -command [list [namespace origin JoinRoom] $app test@tach.tclers.tk]
+    $menu.file add separator
+    $menu.file add command -label Exit \
+        -command [list [namespace origin Exit] $app]
+    $app configure -menu $menu
+
+    ttk::notebook $app.nb
+
+    ttk::frame $app.mainf -style ChatwidgetFrame
+    text $app.main -yscrollcommand [list $app.mainvs set] -borderwidth 0 -relief flat
+    ttk::scrollbar $app.mainvs -command [list $app.main yview]
+    grid $app.main $app.mainvs -in $app.mainf -sticky news -padx 1 -pady 1
+    grid rowconfigure $app.mainf 0 -weight 1
+    grid columnconfigure $app.mainf 0 -weight 1
+
+    $app.main tag configure log -foreground black -background grey80
+    $app.main tag configure error -foreground red -background grey80
+
+    $app.nb add $app.mainf -text "Jabber"
+
+    set status [ttk::frame $app.status]
+    ttk::label $status.pane0 -anchor w
+    ttk::separator $status.sep0
+    ttk::label $status.pane1 -anchor w
+    ttk::separator $status.sep1
+    ttk::sizegrip $status.sizegrip
+    grid $status.pane0 $status.sep0 $status.pane1 $status.sep1 $status.sizegrip -sticky ew
+    grid columnconfigure $status 0 -weight 1
+    grid rowconfigure $status 0 -weight 1
+
+    grid $app.nb -sticky news
+    grid $status -sticky sew
+    grid rowconfigure $app 0 -weight 1
+    grid columnconfigure $app 0 -weight 1
+
+    bind $app <Control-F2> {console show}
+
+    wm geometry .chat 600x400
+    wm deiconify $app
+
+    tkwait window .
+}
+
+proc Connect {app} {
+    set user     $::tcl_platform(user)
+    set server   patthoyts.tk
+    set password SEKRET
+    set resource JDemo
+    set jid [jlib::joinjid $user $server $resource]
+
+    variable conn
+    set conn [jlib::new OnNetwork \
+                  -iqcommand OnIq \
+                  -messagecommand OnMessage \
+                  -presencecommand OnPresence \
+                  -keepalivesecs 0 \
+                  -autodiscocaps 1]
+
+
+    #$conn roster register_cmd RosterProc
+    #$conn iq_register get jabber:iq:version OnGetVersion
+    #$conn presence_register subscribe OnSubscribe
+    #$conn presence_register subscribed OnSubscribed
+    #$conn presence_register unsubscribe OnUnsubscribe
+    #$conn presence_register unsubscribed OnUnsubscribed
+    $conn connect init
+    $conn connect configure -defaultresource "Chatdemo"
+    # -defaultport 5222 -defaultsslport 5223
+
+    $conn connect connect $jid $password -command OnConnect \
+        -secure 1 -method sasl \
+        -ip localhost -port 3128
+    #$conn send_message $jid -type chat -subject Subject -body $text
+}
+
+proc JoinRoom {app room {nick testing}} {
+    variable conn 
+    $conn muc enter $room $nick -command [list OnMucEnter $app]
+}
+
+# -------------------------------------------------------------------------
+
+if {![info exists initialized] && !$tcl_interactive} {
+    set initialized 1
+    wm withdraw .
+    set r [catch [linsert $argv 0 Main] err]
+    if {$r} {puts $::errorInfo} else {puts $err}
+    exit $r
+}
+
+# -------------------------------------------------------------------------
+# Local variables:
+#   mode: tcl
+#   indent-tabs-mode: nil
+# End:
\ No newline at end of file
diff --git a/bin/test/irc.tcl b/bin/test/irc.tcl
new file mode 100644
index 0000000..f3a91c6
--- /dev/null
+++ b/bin/test/irc.tcl
@@ -0,0 +1,347 @@
+# irc.tcl - Copyright (C) 2007 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# This is a Tk GUI for the picoirc package that provides a simple IRC client
+#
+
+package require Tk 8.5
+package require chatwidget
+package require picoirc
+
+variable ircuid
+if {![info exists ircuid]} { set ircuid -1 }
+
+# -------------------------------------------------------------------------
+
+proc Main {} {
+    set app [toplevel .chat -class Chat]
+    wm withdraw $app
+    wm title $app "Chat test app"
+    
+    set menu [menu $app.menu -tearoff 0]
+    $menu add cascade -label Network -menu [menu $menu.file -tearoff 0]
+    $menu.file add command -label "Login..." -underline 0 \
+        -command [list [namespace origin LoginIRC] $app]
+    $menu.file add separator
+    $menu.file add command -label Exit \
+        -command [list [namespace origin Exit] $app]
+    $app configure -menu $menu
+
+    ttk::notebook $app.nb
+
+    set status [ttk::frame $app.status]
+    ttk::label $status.pane0 -anchor w
+    ttk::separator $status.sep0 -orient vertical
+    ttk::label $status.pane1 -anchor w
+    ttk::separator $status.sep1 -orient vertical
+    ttk::sizegrip $status.sizegrip
+    grid $status.pane0 $status.sep0 $status.pane1\
+        $status.sep1 $status.sizegrip -sticky news
+    grid columnconfigure $status 0 -weight 1
+    grid rowconfigure $status 0 -weight 1
+
+    grid $app.nb -sticky news
+    grid $status -sticky sew
+    grid rowconfigure $app 0 -weight 1
+    grid columnconfigure $app 0 -weight 1
+
+    bind $app <Control-F2> {console show}
+
+    wm geometry .chat 600x400
+    wm deiconify $app
+
+    tkwait window $app
+    return
+}
+
+proc LoginIRC {app} {
+    set dlg $app.irclogin
+    variable $dlg {}
+    variable irc
+    if {![info exists irc]} {
+        array set irc {server irc.freenode.net port 6667 channel ""}
+    }
+    if {![winfo exists $dlg]} {
+        set dlg [toplevel $dlg -class Dialog]
+        wm withdraw $dlg
+        wm transient $dlg $app
+        wm title $dlg "IRC Login"
+        
+        set f [ttk::frame $dlg.f]
+        set g [ttk::frame $f.g]
+        ttk::label $f.sl -text Server
+        ttk::entry $f.se -textvariable [namespace which -variable irc](server)
+        ttk::entry $f.sp -textvariable \
+            [namespace which -variable irc](port) -width 5
+        ttk::label $f.cl -text Channel
+        ttk::entry $f.cn -textvariable [namespace which -variable irc](channel)
+        ttk::label $f.nl -text Username
+        ttk::entry $f.nn -textvariable [namespace which -variable irc](nick)
+        ttk::button $f.ok -text Login -default active \
+            -command [list set [namespace which -variable $dlg] "ok"]
+        ttk::button $f.cancel -text Cancel \
+            -command [list set [namespace which -variable $dlg] "cancel"]
+
+        bind $dlg <Return> [list $f.ok invoke]
+        bind $dlg <Escape> [list $f.cancel invoke]
+        wm protocol $dlg WM_DELETE_WINDOW [list $f.cancel invoke]
+        
+        grid $f.sl $f.se $f.sp -in $g -sticky new -padx 1 -pady 1
+        grid $f.cl $f.cn -     -in $g -sticky new -padx 1 -pady 1
+        grid $f.nl $f.nn -     -in $g -sticky new -padx 1 -pady 1
+        grid columnconfigure $g 1 -weight 1
+
+        grid $g    -         -sticky news
+        grid $f.ok $f.cancel -sticky e -padx 1 -pady 1
+        grid rowconfigure    $f 0 -weight 1
+        grid columnconfigure $f 0 -weight 1
+        
+        grid $f -sticky news
+        grid rowconfigure $dlg 0 -weight 1
+        grid columnconfigure $dlg 0 -weight 1
+
+	wm resizable $dlg 0 0
+        raise $dlg
+    }     
+
+    catch {::tk::PlaceWindow $dlg widget $app}
+    wm deiconify $dlg
+    tkwait visibility $dlg
+    focus -force $dlg.f.ok
+    grab $dlg
+    vwait [namespace which -variable $dlg]
+    grab release $dlg
+    wm withdraw $dlg
+
+    if {[set $dlg] eq "ok"} {
+        after idle [list [namespace origin IrcConnect] $app \
+                        -server $irc(server) \
+                        -port $irc(port) \
+                        -channel $irc(channel) \
+                        -nick $irc(nick)]
+    }
+}
+
+proc Exit {app} {
+    destroy $app
+    exit
+}
+
+proc Status {Chat message} {
+    upvar #0 $Chat chat
+    $chat(app).status.pane0 configure -text $message
+}
+
+proc State {Chat message} {
+    upvar #0 $Chat chat
+    $chat(app).status.pane1 configure -text $message
+}
+
+proc bgerror {args} {
+    tk_messageBox -icon error -title "Error" -message $::errorInfo
+}
+
+proc Pop {varname {nth 0}} {
+    upvar $varname args
+    set r [lindex $args $nth]
+    set args [lreplace $args $nth $nth]
+    return $r
+}
+
+# -------------------------------------------------------------------------
+# Handle the IRC transport (using picoirc)
+
+proc IrcConnect {app args} {
+    variable ircuid
+    set id irc[incr ircuid]
+    set Chat [namespace current]::$id
+    upvar #0 $Chat chat
+    set chat(app)  $app
+    set chat(type) irc
+
+    while {[string match -* [set option [lindex $args 0]]]} {
+        switch -exact -- $option {
+            -server   { set chat(server)   [Pop args 1] }
+            -port     { set chat(port)     [Pop args 1] }
+            -channel  { set chat(channel)  [Pop args 1] }
+            -nick     { set chat(nick)     [Pop args 1] }
+            default {
+                return -code error "invalid option \"$option\""
+            }
+        }
+        Pop args
+    }
+    set chat(window) [chatwidget::chatwidget $app.$id]
+    $chat(window) names hide
+    set chat(targets) [list]
+    $app.nb add $chat(window) -text $chat(server)
+    set url irc://$chat(server):$chat(port)
+    set chat(irc) [picoirc::connect \
+                       [list [namespace origin IrcCallback] $Chat] \
+                       $chat(nick) $url]
+    $chat(window) hook add post [list ::picoirc::post $chat(irc) ""]
+    bind $chat(window) <Destroy> "+unset -nocomplain $Chat"
+    return $Chat
+}
+
+proc IrcJoinChannel {Chat args} {
+    variable ircuid
+}
+
+proc IrcAddChannel {Chat channel} {
+    upvar #0 $Chat chat
+    set Channel "${Chat}/$channel"
+    upvar #0 $Channel chan
+    array set chan [array get chat]
+    set chan(channel) $channel
+    set chan(window) [chatwidget::chatwidget $chat(window)$channel]
+    lappend chat(targets) [list $channel $chan(window)]
+    $chat(app).nb add $chan(window) -text $channel
+    $chat(app).nb select $chan(window)
+    $chan(window) hook add post [list ::picoirc::post $chan(irc) $channel]
+    bind $chan(window) <Destroy> "+unset -nocomplain $Channel"
+    return
+}
+
+proc IrcRemoveChannel {Chat target} {
+    upvar #0 $Chat chat
+    Status $Chat "Left channel $target"
+    set w [IrcFindWindow $Chat $target]
+    if {[winfo exists $w]} { destroy $w }
+    if {[set ndx [lsearch -index 0 $chat(targets) $target]] != -1} {
+        set chat(targets) [lreplace $chat(targets) $ndx $ndx]
+    }
+}
+
+proc IrcFindWindow {Chat target} {
+    upvar #0 $Chat chat
+    set w $chat(window)
+    if {[set ndx [lsearch -index 0 $chat(targets) $target]] != -1} {
+        set w [lindex [lindex $chat(targets) $ndx] 1]
+    }
+    return $w
+}
+
+proc IrcCallback {Chat context state args} {
+    upvar #0 $Chat chat
+    upvar #0 $context irc
+    switch -exact -- $state {
+        init {
+            Status $Chat "Attempting to connect to $irc(server)"
+        }
+        connect {
+            $chat(window) message "Logging into $irc(server) as $irc(nick)" -type system
+            Status $Chat "Connection to IRC server established."
+            State $Chat connected
+        }
+        close {
+            if {[llength $args] != 0} {
+                $chat(window) message "Failed to connect: [lindex $args 0]" -type system
+                Status $Chat [lindex $args 0]
+            } else {
+                $chat(window) message "Disconnected from server" -type system
+                Status $Chat "Disconnected."
+            }
+            State $Chat !connected
+        }
+        userlist {
+            foreach {target users} $args break
+            set colors {black SteelBlue4 tomato chocolate SeaGreen4 red4
+                green4 blue4 pink4}
+            set w [IrcFindWindow $Chat $target]
+            set current [$w name list -full]
+            foreach nick $users {
+                set opts [list -status online]
+                if {[string match @* $nick]} {
+                    set nick [string range $nick 1 end]
+                    lappend opts -group operators 
+                } else { lappend opts -group users }
+                if {[lsearch -index 0 $current $nick] == -1} {
+                    lappend opts -color \
+                        [lindex $colors [expr {int(rand() * [llength $colors])}]]
+                }
+                eval [list $w name add $nick] $opts
+            }
+        }
+        userinfo {
+            foreach {nick userinfo} $args break
+            array set info $userinfo
+            $chat(window) message "$nick $userinfo" -type system
+        }
+        chat {
+            foreach {target nick msg type} $args break
+            if {$type eq ""} {set type normal}
+            set w [IrcFindWindow $Chat $target]
+            $w message $msg -nick $nick -type $type
+        }
+        system {
+            foreach {target msg} $args break
+            [IrcFindWindow $Chat $target] message $msg -type system
+        }
+        topic {
+            foreach {target topic} $args break
+            set w [IrcFindWindow $Chat $target]
+            $w topic show
+            $w topic set $topic
+        }
+        traffic {
+            foreach {action target nick new} $args break
+            if {$nick eq $irc(nick)} {
+                switch -exact -- $action {
+                    left    { IrcRemoveChannel $Chat $target }
+                    entered { IrcAddChannel $Chat $target}
+                }
+            }
+            if {$target ne {}} {
+                set w [IrcFindWindow $Chat $target]
+                IrcCallbackNick $w $action $target $nick $new
+            } else {
+                foreach window_target $chat(targets) {
+                    foreach {window_channel w} $window_target break
+                    set current [$w name list -full]
+                    if {[lsearch -index 0 $current $nick] != -1} {
+                        IrcCallbackNick $w $action $target $nick $new
+                    }
+                }
+            }
+        }
+        debug {
+            foreach {type line} $args break
+            if {![info exists chat(log)]} {set chat(log) [open irc.log a]}
+            puts $chat(log) "[string toupper [string range $type 0 0]] $line"
+        }
+        version { return "" }
+        default {
+            $chat(window) message "unknown irc callback \"$state\": $args" -type error
+        }
+    }
+}
+
+proc IrcCallbackNick {w action target nick new} {
+    if {$action eq "nickchange"} {
+        $w name delete $nick
+        $w name add $new -group users
+        $w message "$nick changed to $new" -type system
+    } else {
+        switch -exact -- $action {
+            left    { $w name delete $nick }
+            entered { $w name add $nick -group users }
+        }
+        $w message "$nick $action" -type system
+    }
+}
+
+# -------------------------------------------------------------------------
+
+if {![info exists initialized] && !$tcl_interactive} {
+    set initialized 1
+    wm withdraw .
+    set r [catch [linsert $argv 0 Main] err]
+    if {$r} {tk_messageBox -icon error -type ok -message $::errorInfo}
+    exit $r
+}
+
+# -------------------------------------------------------------------------
+# Local variables:
+#   mode: tcl
+#   indent-tabs-mode: nil
+# End:
diff --git a/bin/test/muc-form.xml b/bin/test/muc-form.xml
new file mode 100644
index 0000000..05c47ed
--- /dev/null
+++ b/bin/test/muc-form.xml
@@ -0,0 +1,10 @@
+<?xml version='1.0'?><stream:stream xmlns:stream='http://etherx.jabber.org/streams' xmlns='jabber:client' from='all.tclers.tk' id='d78gzpp091vzv1ai3kn4r9oak5d7ubb8ijoi8eii'>
+<iq xmlns='jabber:client' type='result' id='1003' to='patthoyts@all.tclers.tk/Frog' from='pat0@tach.tclers.tk'><query xmlns='http://jabber.org/protocol/muc#owner'><x xmlns='jabber:x:data' type='form'><title>Room configuration</title><instructions>Your room "pat0" has been created! The default configuration is as follows:
+- No logging
+- No moderation
+- Up to 30 participants
+- No password required
+- No invitation required
+- Room is not persistent
+- Only admins may change the subject
+To accept the default configuration, click OK. To select a different configuration, please complete this form</instructions><field type='hidden' var='form'><value>config</value></field><field type='text-single' label='Natural-Language Room Name' var='muc#owner_roomname'><value>pat0</value></field><field type='text-multi' label='Short Description of Room' var='muc#owner_roomdesc'><value>pat0</value></field><field type='fixed'><value>The following messages are sent to legacy clients.</value></field><field type='text-single' label='Message for user leaving room' var='leave'><value>has left</value></field><field type='text-single' label='Message for user joining room' var='join'><value>has become available</value></field><field type='text-single' label='Message for user renaming nickname in room' var='rename'><value>is now known as</value></field><field type='boolean' label='Allow Occupants to Change Subject' var='muc#owner_changesubject'><value>0</value></field><field type='list-single' label='Maximum Number of Room Occupants' var='muc#owner_maxusers'><value>30</value><option label='1'><value>1</value></option><option label='10'><value>10</value></option><option label='20'><value>20</value></option><option label='30'><value>30</value></option><option label='40'><value>40</value></option><option label='50'><value>50</value></option><option label='None'><value>0</value></option></field><field type='boolean' label='Allow Occupants to query other Occupants?' var='privacy'><value>1</value></field><field type='boolean' label='Allow Public Searching for Room' var='muc#owner_publicroom'><value>1</value></field><field type='boolean' label='Make Room Persistent' var='muc#owner_persistentroom'><value>0</value></field><field type='boolean' label='Consider all Clients as Legacy (shown messages)' var='legacy'><value>0</value></field><field type='boolean' label='Make Room Moderated' var='muc#owner_moderatedroom'><value>0</value></field><field type='fixed'><value>By default, new users entering a moderated room are only visitors</value></field><field type='boolean' label='Make Occupants in a Moderated Room Default to Participant' var='defaulttype'><value>0</value></field><field type='boolean' label='Ban Private Messages between Occupants' var='privmsg'><value>0</value></field><field type='boolean' label='An Invitation is Required to Enter' var='muc#owner_inviteonly'><value>0</value></field><field type='fixed'><value>By default, only admins can send invites in an invite-only room</value></field><field type='boolean' label='Allow Occupants to Invite Others' var='muc#owner_allowinvites'><value>0</value></field><field type='boolean' label='A Password is required to enter?' var='muc#owner_passwordprotectedroom'><value>0</value></field><field type='fixed'><value>If a password is required to enter this room, you must specify the password below.</value></field><field type='text-private' label='The Room Password' var='muc#owner_roomsecret'><value/></field><field type='list-single' label='Affiliations that May Discover Real JIDs of Occupants' var='muc#owner_whois'><value>admins</value><option label='Room Owner and Admins Only'><value>admins</value></option><option label='Anyone'><value>anyone</value></option></field><field type='boolean' label='Enable Logging of Room Conversations' var='muc#owner_enablelogging'><value>0</value></field><field type='list-single' label='Logfile format' var='logformat'><value>text</value><option label='XML'><value>xml</value></option><option label='XHTML'><value>xhtml</value></option><option label='Tcl Script'><value>tcl</value></option><option label='Plain Text'><value>text</value></option></field></x></query></iq></stream:stream>
\ No newline at end of file
diff --git a/bin/test/test.tcl b/bin/test/test.tcl
new file mode 100644
index 0000000..75e8500
--- /dev/null
+++ b/bin/test/test.tcl
@@ -0,0 +1,55 @@
+proc Grid {w {row 0} {column 0}} {
+    grid rowconfigure $w $row -weight 1
+    grid columnconfigure $w $column -weight 1
+}
+
+proc Test {} {
+    set dlg [toplevel .dlg -class Dialog]
+    wm withdraw $dlg
+    wm title $dlg "Testing sashplacement"
+    set pw [ttk::panedwindow $dlg.pw -orient vertical]
+
+    set lower [ttk::frame $pw.lower]
+    set text [text $lower.text -relief flat -height 10]
+    set textvs [scrollbar $lower.vs -command [list $text yview]]
+    $text configure -yscrollcommand [list scroll_set $textvs $pw]
+    grid $text $textvs -sticky news
+    Grid $lower 0 0
+
+    set upper [ttk::frame $pw.upper]
+    set peer [$text peer create $upper.text -relief flat -height 1]
+    set peervs [scrollbar $upper.vs -command [list $peer yview]]
+    $peer configure -yscrollcommand [list scroll_set $peervs $pw]
+    grid $peer $peervs -sticky news
+    Grid $upper 0 0
+    
+    $pw add $upper
+    $pw add $lower -weight 10
+    bind $peer <Map> [list map_pane %W $pw 0]
+
+    grid $pw -sticky news
+    Grid $dlg 0 0
+    wm deiconify $dlg
+}
+
+proc map_pane {w pw pos} {
+    bind $w <Map> {}
+    if {[llength [$pw panes]] > 1} {
+        after idle [list $pw sashpos 0 $pos]
+    }
+}
+
+proc scroll_set {scrollbar pw f1 f2} {
+    $scrollbar set $f1 $f2
+    if {($f1 == 0) && ($f2 == 1)} {
+	grid remove $scrollbar
+    } else {
+        if {[llength [$pw panes]] > 1} {
+            set pos [$pw sashpos 0]
+            grid $scrollbar
+            after idle [list $pw sashpos 0 $pos]
+        } else {
+            grid $scrollbar
+        }
+    }
+}
diff --git a/bin/test/z_irc.tcl b/bin/test/z_irc.tcl
new file mode 100644
index 0000000..91ea61e
--- /dev/null
+++ b/bin/test/z_irc.tcl
@@ -0,0 +1,227 @@
+# -------------------------------------------------------------------------
+# Handle the IRC transport (using picoirc)
+
+proc IrcConnect {app args} {
+    variable ircuid
+    set id irc[incr ircuid]
+    set Chat [namespace current]::$id
+    upvar #0 $Chat chat
+    array set chat [list app $app type irc passwd "" nick ""]
+    while {[string match -* [set option [lindex $args 0]]]} {
+        switch -exact -- $option {
+            -server   { set chat(server)   [Pop args 1] }
+            -port     { set chat(port)     [Pop args 1] }
+            -channel  { set chat(channel)  [Pop args 1] }
+            -nick     { set chat(nick)     [Pop args 1] }
+            -passwd   { set chat(passwd)   [Pop args 1] }
+            default {
+                return -code error "invalid option \"$option\""
+            }
+        }
+        Pop args
+    }
+    set chat(window) [chatwidget::chatwidget $app.$id]
+    $chat(window) names hide
+    set chat(targets) [list]
+    $app.nb add $chat(window) -text $chat(server)
+    $app.nb select $chat(window)
+    set url irc://$chat(server):$chat(port)
+    if {[info exists chat(channel)] && $chat(channel) ne ""} {
+        append url /$chat(channel)
+    }
+    set chat(irc) [picoirc::connect \
+                       [list [namespace origin IrcCallback] $Chat] \
+                       $chat(nick) $chat(passwd) $url]
+    $chat(window) hook add post [list ::picoirc::post $chat(irc) ""]
+    bind $chat(window) <Destroy> "+unset -nocomplain $Chat"
+    return $Chat
+}
+
+proc IrcJoinChannel {Chat args} {
+    variable ircuid
+}
+
+proc IrcAddChannel {Chat channel} {
+    upvar #0 $Chat chat
+    set Channel "${Chat}/$channel"
+    upvar #0 $Channel chan
+    array set chan [array get chat]
+    set chan(channel) $channel
+    set chan(window) [chatwidget::chatwidget $chat(window)$channel]
+    lappend chat(targets) [list $channel $chan(window)]
+    $chat(app).nb add $chan(window) -text $channel
+    $chat(app).nb select $chan(window)
+    set m0 [font measure ChatwidgetFont {[00:00]m}]
+    set m1 [font measure ChatwidgetFont [string repeat m 10]]
+    set mm [expr {$m0 + $m1}]
+    $chan(window) chat configure -tabs [list $m0 $mm]
+    $chan(window) chat tag configure MSG -lmargin1 $mm -lmargin2 $mm
+    $chan(window) chat tag configure NICK -font ChatwidgetBoldFont
+    $chan(window) chat tag configure TYPE-system -font ChatwidgetItalicFont
+    $chan(window) names tag bind NICK <Button-3> \
+        [list [namespace origin ChannelNickMenu] $Channel %W %x %y]
+    $chan(window) names tag bind NICK <Enter> \
+        [list [namespace origin IrcNickTooltip] $Chat enter %W %x %y]
+    $chan(window) names tag bind NICK <Leave> \
+        [list [namespace origin IrcNickTooltip] $Chat leave %W %x %y]
+    $chan(window) hook add post [list ::picoirc::post $chan(irc) $channel]
+    bind $chan(window) <Destroy> "+unset -nocomplain $Channel"
+    return
+}
+
+proc IrcRemoveChannel {Chat target} {
+    upvar #0 $Chat chat
+    Status $Chat "Left channel $target"
+    set w [IrcFindWindow $Chat $target]
+    if {[winfo exists $w]} { destroy $w }
+    if {[set ndx [lsearch -index 0 $chat(targets) $target]] != -1} {
+        set chat(targets) [lreplace $chat(targets) $ndx $ndx]
+    }
+}
+
+proc IrcNickTooltip {Chat type w x y} {
+    if {[package provide tooltip] eq {}} { return }
+    set nick [string trim [$w get "@$x,$y linestart" "@$x,$y lineend"]]
+    if {$nick eq ""} { return }
+    puts stderr "Tooltip $type $nick"
+    return
+}
+
+proc IrcFindWindow {Chat target} {
+    upvar #0 $Chat chat
+    set w $chat(window)
+    if {[set ndx [lsearch -nocase -index 0 $chat(targets) $target]] != -1} {
+        set w [lindex [lindex $chat(targets) $ndx] 1]
+    }
+    return $w
+}
+
+proc IrcCallback {Chat context state args} {
+    upvar #0 $Chat chat
+    upvar #0 $context irc
+    switch -exact -- $state {
+        init {
+            Status $Chat "Attempting to connect to $irc(server)"
+        }
+        connect {
+            $chat(window) message "Logging into $irc(server) as $irc(nick)" -type system
+            Status $Chat "Connection to IRC server established."
+            State $Chat connected
+        }
+        close {
+            if {[llength $args] != 0} {
+                $chat(window) message "Failed to connect: [lindex $args 0]" -type system
+                Status $Chat [lindex $args 0]
+            } else {
+                $chat(window) message "Disconnected from server" -type system
+                Status $Chat "Disconnected."
+            }
+            State $Chat !connected
+        }
+        userlist {
+            foreach {target users} $args break
+            set colors {black SteelBlue4 tomato chocolate SeaGreen4 red4
+                green4 blue4 pink4}
+            set w [IrcFindWindow $Chat $target]
+            set current [$w name list -full]
+            foreach nick $users {
+                set opts [list -status online]
+                if {[string match @* $nick]} {
+                    set nick [string range $nick 1 end]
+                    lappend opts -group operators 
+                } else { lappend opts -group users }
+                if {[lsearch -index 0 $current $nick] == -1} {
+                    lappend opts -color \
+                        [lindex $colors [expr {int(rand() * [llength $colors])}]]
+                }
+                eval [list $w name add $nick] $opts
+            }
+        }
+        userinfo {
+            foreach {nick userinfo} $args break
+            array set info {name {} host {} channels {} userinfo {}}
+            array set info $userinfo
+            set chat(userinfo,$nick) [array get info]
+        }
+        chat {
+            foreach {target nick msg type} $args break
+            if {$type eq ""} {set type normal}
+            set w [IrcFindWindow $Chat $target]
+            if {$nick eq "tcl@tach.tclers.tk"} {
+                set action ""; set jnick "" ; set jnew ""
+                if {[regexp {^\s*([^ ]+) is now known as (.*)} $msg -> jnick jnew]} {
+                    set action nickchange
+                } elseif {[regexp {^\s*([^ ]+) has left} $msg -> jnick]} {
+                    set action left
+                } elseif {[regexp {^\s*([^ ]+) has become available} $msg -> jnick]} {
+                    set action entered
+                }
+                if {$action ne ""} {
+                    IrcCallbackNick $w $action $target $jnick $jnew jabber
+                    return
+                }
+            }
+            $w message $msg -nick $nick -type $type
+        }
+        system {
+            foreach {target msg} $args break
+            [IrcFindWindow $Chat $target] message $msg -type system
+        }
+        topic {
+            foreach {target topic} $args break
+            set w [IrcFindWindow $Chat $target]
+            $w topic show
+            $w topic set $topic
+        }
+        traffic {
+            foreach {action target nick new} $args break
+            if {$nick eq $irc(nick)} {
+                switch -exact -- $action {
+                    left    { IrcRemoveChannel $Chat $target }
+                    entered { IrcAddChannel $Chat $target}
+                    nickchange { set irc(nick) $new }
+                }
+            }
+            if {$target ne {}} {
+                set w [IrcFindWindow $Chat $target]
+                IrcCallbackNick $w $action $target $nick $new
+            } else {
+                foreach window_target $chat(targets) {
+                    foreach {window_channel w} $window_target break
+                    set current [$w name list -full]
+                    if {[lsearch -index 0 $current $nick] != -1} {
+                        IrcCallbackNick $w $action $target $nick $new
+                    }
+                }
+            }
+        }
+        debug {
+            foreach {type line} $args break
+            if {[winfo exists $chat(app).nb.debug.text]} {
+                $chat(app).nb.debug.text insert end "$line\n" $type
+            }
+            # You can log raw IRC to file by uncommenting the following lines:
+            #if {![info exists chat(log)]} {set chat(log) [open irc.log a]}
+            #puts $chat(log) "[string toupper [string range $type 0 0]] $line"
+        }
+        version { return "" }
+        default {
+            $chat(window) message "unknown irc callback \"$state\": $args" -type error
+        }
+    }
+}
+
+proc IrcCallbackNick {w action target nick new {group users}} {
+    #puts stderr "process traffic $w $nick $action $new $target"
+    if {$action eq "nickchange"} {
+        $w name delete $nick
+        $w name add $new -group $group
+        $w message "$nick changed to $new" -type system
+    } else {
+        switch -exact -- $action {
+            left    { $w name delete $nick }
+            entered { $w name add $nick -group $group }
+        }
+        $w message "$nick $action" -type system
+    }
+}
diff --git a/bullfrog.ico b/bullfrog.ico
new file mode 100644
index 0000000..75f66f8
Binary files /dev/null and b/bullfrog.ico differ
diff --git a/lib/autoproxy/autoproxy.tcl b/lib/autoproxy/autoproxy.tcl
new file mode 100644
index 0000000..a433e7b
--- /dev/null
+++ b/lib/autoproxy/autoproxy.tcl
@@ -0,0 +1,527 @@
+# autoproxy.tcl - Copyright (C) 2002-2008 Pat Thoyts <patthoyts@users.sf.net>
+#
+# On Unix the standard for identifying the local HTTP proxy server
+# seems to be to use the environment variable http_proxy or ftp_proxy and
+# no_proxy to list those domains to be excluded from proxying.
+#
+# On Windows we can retrieve the Internet Settings values from the registry
+# to obtain pretty much the same information.
+#
+# With this information we can setup a suitable filter procedure for the 
+# Tcl http package and arrange for automatic use of the proxy.
+#
+# Example:
+#   package require autoproxy
+#   autoproxy::init
+#   set tok [http::geturl http://wiki.tcl.tk/]
+#   http::data $tok
+#
+# To support https add:
+#   package require tls
+#   http::register https 443 ::autoproxy::tls_socket
+#
+# @(#)$Id: autoproxy.tcl,v 1.13 2008/03/01 00:41:35 andreas_kupries Exp $
+
+package require http;                   # tcl
+package require uri;                    # tcllib
+package require base64;                 # tcllib
+
+namespace eval ::autoproxy {
+    variable rcsid {$Id: autoproxy.tcl,v 1.13 2008/03/01 00:41:35 andreas_kupries Exp $}
+    variable version 1.5.1
+    variable options
+
+    if {! [info exists options]} {
+        array set options {
+            proxy_host ""
+            proxy_port 80
+            no_proxy   {}
+            basic      {} 
+            authProc   {}
+        }
+    }
+
+    variable uid
+    if {![info exists uid]} { set uid 0 }
+
+    variable winregkey
+    set winregkey [join {
+        HKEY_CURRENT_USER
+        Software Microsoft Windows
+        CurrentVersion "Internet Settings"
+    } \\]
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Obtain configuration options for the server.
+#
+proc ::autoproxy::cget {option} {
+    variable options
+    switch -glob -- $option {
+        -host -
+        -proxy_h* { set options(proxy_host) }
+        -port -
+        -proxy_p* { set options(proxy_port) }
+        -no*      { set options(no_proxy) }
+        -basic    { set options(basic) }
+        -authProc { set options(authProc) }
+        default {
+            set err [join [lsort [array names options]] ", -"]
+            return -code error "bad option \"$option\":\
+                       must be one of -$err"
+        }
+    }
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#  Configure the autoproxy package settings.
+#  You may only configure one type of authorisation at a time as once we hit
+#  -basic, -digest or -ntlm - all further args are passed to the protocol
+#  specific script.
+#
+#  Of course, most of the point of this package is to fill as many of these
+#  fields as possible automatically. You should call autoproxy::init to
+#  do automatic configuration and then call this method to refine the details.
+#
+proc ::autoproxy::configure {args} {
+    variable options
+
+    if {[llength $args] == 0} {
+        foreach {opt value} [array get options] {
+            lappend r -$opt $value
+        }
+        return $r
+    }
+
+    while {[string match "-*" [set option [lindex $args 0]]]} {
+        switch -glob -- $option {
+            -host - 
+            -proxy_h* { set options(proxy_host) [Pop args 1]}
+            -port - 
+            -proxy_p* { set options(proxy_port) [Pop args 1]}
+            -no*      { set options(no_proxy) [Pop args 1] }
+            -basic    { Pop args; configure:basic $args ; break }
+            -authProc { set options(authProc) [Pop args] }
+            --        { Pop args; break }
+            default {
+                set opts [join [lsort [array names options]] ", -"]
+                return -code error "bad option \"$option\":\
+                       must be one of -$opts"
+            }
+        }
+        Pop args
+    }
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#  Initialise the http proxy information from the environment or the
+#  registry (Win32)
+#
+#  This procedure will load the http package and re-writes the
+#  http::geturl method to add in the authorisation header.
+#
+#  A better solution will be to arrange for the http package to request the
+#  authorisation key on receiving an authorisation reqest.
+#
+proc ::autoproxy::init {{httpproxy {}} {no_proxy {}}} {
+    global tcl_platform
+    global env
+    variable winregkey
+    variable options
+
+    # Look for standard environment variables.
+    if {[string length $httpproxy] > 0} {
+        
+        # nothing to do
+
+    } elseif {[info exists env(http_proxy)]} {
+        set httpproxy $env(http_proxy)
+        if {[info exists env(no_proxy)]} {
+            set no_proxy $env(no_proxy)
+        }
+    } else {
+        if {$tcl_platform(platform) == "windows"} {
+            #checker -scope block exclude nonPortCmd
+            package require registry 1.0
+            array set reg {ProxyEnable 0 ProxyServer "" ProxyOverride {}}
+            catch {
+                # IE5 changed ProxyEnable from a binary to a dword value.
+                switch -exact -- [registry type $winregkey "ProxyEnable"] {
+                    dword {
+                        set reg(ProxyEnable) [registry get $winregkey "ProxyEnable"]
+                    }
+                    binary {
+                        set v [registry get $winregkey "ProxyEnable"]
+                        binary scan $v i reg(ProxyEnable)
+                    }
+                    default { 
+                        return -code error "unexpected type found for\
+                               ProxyEnable registry item"
+                    }
+                }
+                set reg(ProxyServer) [GetWin32Proxy http]
+                set reg(ProxyOverride) [registry get $winregkey "ProxyOverride"]
+            }
+            if {![string is bool $reg(ProxyEnable)]} {
+                set reg(ProxyEnable) 0
+            }
+            if {$reg(ProxyEnable)} {
+                set httpproxy $reg(ProxyServer)
+                set no_proxy  $reg(ProxyOverride)
+            }
+        }
+    }
+    
+    # If we found something ...
+    if {[string length $httpproxy] > 0} {
+        # The http_proxy is supposed to be a URL - lets make sure.
+        if {![regexp {\w://.*} $httpproxy]} {
+            set httpproxy "http://$httpproxy"
+        }
+        
+        # decompose the string.
+        array set proxy [uri::split $httpproxy]
+
+        # turn the no_proxy value into a tcl list
+        set no_proxy [string map {; " " , " "} $no_proxy]
+
+        # configure ourselves
+        configure -proxy_host $proxy(host) \
+            -proxy_port $proxy(port) \
+            -no_proxy $no_proxy
+
+        # Lift the authentication details from the environment if present.
+        if {[string length $proxy(user)] < 1 \
+                && [info exists env(http_proxy_user)] \
+                && [info exists env(http_proxy_pass)]} {
+            set proxy(user) $env(http_proxy_user)
+            set proxy(pwd)  $env(http_proxy_pass)
+        }
+
+        # Maybe the proxy url has authentication parameters?
+        # At this time, only Basic is supported.
+        if {[string length $proxy(user)] > 0} {
+            configure -basic -username $proxy(user) -password $proxy(pwd)
+        }
+
+        # setup and configure the http package to use our proxy info.
+        http::config -proxyfilter [namespace origin filter]
+    }
+    return $httpproxy
+}
+
+# autoproxy::GetWin32Proxy -- 
+#
+#	Parse the Windows Internet Settings registry key and return the
+#	protocol proxy requested. If the same proxy is in use for all 
+#	protocols, then that will be returned. Otherwise the string is
+#	parsed. Example:
+#	 ftp=proxy:80;http=proxy:80;https=proxy:80
+#
+proc ::autoproxy::GetWin32Proxy {protocol} {
+    variable winregkey
+    #checker exclude nonPortCmd
+    set proxies [split [registry get $winregkey "ProxyServer"] ";"]
+    foreach proxy $proxies {
+        if {[string first = $proxy] == -1} {
+            return $proxy
+        } else {
+            foreach {prot host} [split $proxy =] break
+            if {[string compare $protocol $prot] == 0} {
+                return $host
+            }
+        }
+    }
+    return -code error "failed to identify an '$protocol' proxy"
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#  Pop the nth element off a list. Used in options processing.
+proc ::autoproxy::Pop {varname {nth 0}} {
+    upvar $varname args
+    set r [lindex $args $nth]
+    set args [lreplace $args $nth $nth]
+    return $r
+}
+
+# -------------------------------------------------------------------------
+# Description
+#   An example user authentication procedure.
+# Returns:
+#   A two element list consisting of the users authentication id and 
+#   password. 
+proc ::autoproxy::defAuthProc {{user {}} {passwd {}} {realm {}}} {
+    if {[string length $realm] > 0} {
+        set title "Realm: $realm"
+    } else {
+        set title {}
+    }
+
+    # If you are using BWidgets then the following will do:
+    #
+    #    package require BWidget
+    #    return [PasswdDlg .defAuthDlg -parent {} -transient 0 \
+    #         -title $title -logintext $user -passwdtext $passwd]
+    #
+    # if you just have Tk and no BWidgets --
+    
+    set dlg [toplevel .autoproxy_defAuthProc -class Dialog]
+    wm title $dlg $title
+    wm withdraw $dlg
+    label $dlg.ll -text Login -underline 0 -anchor w
+    entry $dlg.le -textvariable [namespace current]::${dlg}:l
+    label $dlg.pl -text Password -underline 0 -anchor w
+    entry $dlg.pe -show * -textvariable [namespace current]::${dlg}:p
+    button $dlg.ok -text OK -default active -width -11 \
+        -command [list set [namespace current]::${dlg}:ok 1]
+    grid $dlg.ll $dlg.le -sticky news
+    grid $dlg.pl $dlg.pe -sticky news
+    grid $dlg.ok - -sticky e
+    grid columnconfigure $dlg 1 -weight 1
+    bind $dlg <Return> [list $dlg.ok invoke]
+    bind $dlg <Alt-l> [list focus $dlg.le]
+    bind $dlg <Alt-p> [list focus $dlg.pe]
+    variable ${dlg}:l $user; variable ${dlg}:p $passwd
+    variable ${dlg}:ok 0
+    wm deiconify $dlg; focus $dlg.pe; update idletasks
+    set old [::grab current]; grab $dlg
+    tkwait variable [namespace current]::${dlg}:ok
+    grab release $dlg ; if {[llength $old] > 0} {::grab $old}
+    set r [list [set ${dlg}:l] [set ${dlg}:p]]
+    unset ${dlg}:l; unset ${dlg}:p; unset ${dlg}:ok
+    destroy $dlg
+    return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  Implement support for the Basic authentication scheme (RFC 1945,2617).
+# Options:
+#  -user userid  - pass in the user ID (May require Windows NT domain
+#                  as DOMAIN\\username)
+#  -password pwd - pass in the user's password.
+#  -realm realm  - pass in the http realm.
+#
+proc ::autoproxy::configure:basic {arglist} {
+    variable options
+    array set opts {user {} passwd {} realm {}}
+    foreach {opt value} $arglist {
+        switch -glob -- $opt {
+            -u* { set opts(user) $value}
+            -p* { set opts(passwd) $value}
+            -r* { set opts(realm) $value}
+            default {
+                return -code error "invalid option \"$opt\": must be one of\
+                     -username or -password or -realm"
+            }
+        }
+    }
+
+    # If nothing was provided, try calling the authProc
+    if {$options(authProc) != {} \
+            && ($opts(user) == {} || $opts(passwd) == {})} {
+        set r [$options(authProc) $opts(user) $opts(passwd) $opts(realm)]
+        set opts(user) [lindex $r 0]
+        set opts(passwd) [lindex $r 1]
+    }
+
+    # Store the encoded string to avoid re-encoding all the time.
+    set options(basic) [list "Proxy-Authorization" \
+                            [concat "Basic" \
+                                 [base64::encode $opts(user):$opts(passwd)]]]
+    return
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#  An http package proxy filter. This attempts to work out if a request
+#  should go via the configured proxy using a glob comparison against the
+#  no_proxy list items. A typical no_proxy list might be
+#   [list localhost *.my.domain.com 127.0.0.1]
+#
+#  If we are going to use the proxy - then insert the proxy authorization
+#  header.
+#
+proc ::autoproxy::filter {host} {
+    variable options
+
+    if {$options(proxy_host) == {}} {
+        return {}
+    }
+    
+    foreach domain $options(no_proxy) {
+        if {[string match $domain $host]} {
+            return {}
+        }
+    }
+    
+    # Add authorisation header to the request (by Anders Ramdahl)
+    catch {
+        upvar state State
+        if {$options(basic) != {}} {
+            set State(-headers) [concat $options(basic) $State(-headers)]
+        }
+    }
+    return [list $options(proxy_host) $options(proxy_port)]
+}
+
+# -------------------------------------------------------------------------
+# autoproxy::tls_connect --
+#
+#	Create a connection to a remote machine through a proxy
+#	if necessary. This is used by the tls_socket command for 
+#	use with the http package but can also be used more generally
+#	provided your proxy will permit CONNECT attempts to ports
+#	other than port 443 (many will not).
+#	This command defers to 'tunnel_connect' to link to the target
+#	host and then upgrades the link to SSL/TLS
+#
+proc ::autoproxy::tls_connect {args} {
+    variable options
+    if {[string length $options(proxy_host)] > 0} {
+        set s [eval [linsert $args 0 tunnel_connect]]
+        fconfigure $s -blocking 1 -buffering none -translation binary
+        if {[string equal "-async" [lindex $args end-2]]} {
+            eval [linsert [lrange $args 0 end-3] 0 ::tls::import $s]
+        } else {
+            eval [linsert [lrange $args 0 end-2] 0 ::tls::import $s]
+        }
+    } else {
+        set s [eval [linsert $args 0 ::tls::socket]]
+    }
+    return $s
+}
+
+# autoproxy::tunnel_connect --
+#
+#	Create a connection to a remote machine through a proxy
+#	if necessary. This is used by the tls_socket command for 
+#	use with the http package but can also be used more generally
+#	provided your proxy will permit CONNECT attempts to ports
+#	other than port 443 (many will not).
+#	Note: this command just opens the socket through the proxy to
+#	the target machine -- no SSL/TLS negotiation is done yet.
+#
+proc ::autoproxy::tunnel_connect {args} {
+    variable options
+    variable uid
+    set code ok
+    if {[string length $options(proxy_host)] > 0} {
+        set token [namespace current]::[incr uid]
+        upvar #0 $token state
+        set state(endpoint) [lrange $args end-1 end]
+        set state(state) connect
+        set state(data) ""
+        set state(useragent) [http::config -useragent]
+        set state(sock) [::socket $options(proxy_host) $options(proxy_port)]
+        fileevent $state(sock) writable [namespace code [list tunnel_write $token]]
+        vwait [set token](state)
+        
+        if {[string length $state(error)] > 0} {
+            set result $state(error)
+            close $state(sock)
+            unset state
+            set code error
+        } elseif {$state(code) >= 300 || $state(code) < 200} {
+            set result [lindex $state(headers) 0]
+            regexp {HTTP/\d.\d\s+\d+\s+(.*)} $result -> result
+            close $state(sock)
+            set code error
+        } else {
+            set result $state(sock)
+        }
+        unset state
+    } else {
+        set result [eval [linsert $args 0 ::socket]]
+    }
+    return -code $code $result
+}
+
+proc ::autoproxy::tunnel_write {token} {
+    upvar #0 $token state
+    variable options
+    fileevent $state(sock) writable {}
+    if {[catch {set state(error) [fconfigure $state(sock) -error]} err]} {
+        set state(error) $err
+    }
+    if {[string length $state(error)] > 0} {
+        set state(state) error
+        return
+    }
+    fconfigure $state(sock) -blocking 0 -buffering line -translation crlf
+    foreach {host port} $state(endpoint) break
+    puts $state(sock) "CONNECT $host:$port HTTP/1.1"
+    puts $state(sock) "Host: $host"
+    if {[string length $state(useragent)] > 0} {
+        puts $state(sock) "User-Agent: $state(useragent)"
+    }
+    puts $state(sock) "Proxy-Connection: keep-alive"
+    puts $state(sock) "Connection: keep-alive"
+    if {[string length $options(basic)] > 0} {
+        puts $state(sock) [join $options(basic) ": "]
+    }
+    puts $state(sock) ""
+
+    fileevent $state(sock) readable [namespace code [list tunnel_read $token]]
+    return
+}
+    
+proc ::autoproxy::tunnel_read {token} {
+    upvar #0 $token state
+    set len [gets $state(sock) line]
+    if {[eof $state(sock)]} {
+        fileevent $state(sock) readable {}
+        set state(state) eof
+    } elseif {$len == 0} {
+        set state(code) [lindex [split [lindex $state(headers) 0] { }] 1]
+        fileevent $state(sock) readable {}
+        set state(state) ok
+    } else {
+        lappend state(headers) $line
+    }
+}
+
+# autoproxy::tls_socket --
+#
+#	This can be used to handle TLS connections independently of
+#	proxy presence. It can only be used with the Tcl http package
+#	and to use it you must do:
+#	   http::register https 443 ::autoproxy::tls_socket
+#	After that you can use the http::geturl command to access
+#	secure web pages and any proxy details will be handled for you.
+#
+proc ::autoproxy::tls_socket {args} {
+    variable options
+
+    # Look into the http package for the actual target. If a proxy is in use then
+    # The function appends the proxy host and port and not the target.
+
+    upvar host uhost port uport
+    set args [lrange $args 0 end-2]
+    lappend args $uhost $uport
+
+    set s [eval [linsert $args 0 tls_connect]]
+
+    # record the tls connection status in the http state array.
+    upvar state state
+    tls::handshake $s
+    set state(tls_status) [tls::status $s]
+
+    return $s
+}
+
+# -------------------------------------------------------------------------
+
+package provide autoproxy $::autoproxy::version
+
+# -------------------------------------------------------------------------
+#
+# Local variables:
+#   mode: tcl
+#   indent-tabs-mode: nil
+# End:
diff --git a/lib/autoproxy/pkgIndex.tcl b/lib/autoproxy/pkgIndex.tcl
new file mode 100644
index 0000000..6d1c622
--- /dev/null
+++ b/lib/autoproxy/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded autoproxy 1.5.1 [list source [file join $dir autoproxy.tcl]]
diff --git a/lib/autosocks/autosocks.tcl b/lib/autosocks/autosocks.tcl
new file mode 100644
index 0000000..22b7416
--- /dev/null
+++ b/lib/autosocks/autosocks.tcl
@@ -0,0 +1,209 @@
+#  autosocks.tcl ---
+#  
+#      Interface to socks4/5 to make usage of 'socket' transparent.
+#      Can also be used as a wrapper for the 'socket' command without any
+#      proxy configured.
+#
+#  (c) 2007  Mats Bengtsson
+#  
+#  This file is distributed under BSD style license.
+#
+#  This source file is distributed under the BSD license.
+#  
+# $Id: autosocks.tcl,v 1.9 2007/09/21 09:42:48 matben Exp $
+
+package provide autosocks 0.1
+
+namespace eval autosocks {
+    variable options
+    array set options {
+	-proxy          ""
+	-proxyhost      ""
+	-proxyport      ""
+	-proxyusername  ""
+	-proxypassword  ""
+	-proxyno        ""
+	-proxyfilter    autosocks::filter
+    }
+    
+    variable packs
+    foreach name {socks4 socks5} {
+	if {![catch {package require $name}]} {
+	    set packs($name) 1
+	}	
+    }
+}
+
+# autosocks::config --
+# 
+#       Get or set configuration options for the SOCKS proxy.
+#       
+# Arguments:
+#       args:
+#           -proxy            ""|socks4|socks5
+#           -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 autosocks::config {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 autosocks::init {} {    
+    # @@@ Here we should get default settings from some system API.
+}
+
+# autosocks::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)
+
+proc autosocks::socket {host port args} {
+    variable options
+    
+    array set argsA $args
+    array set optsA $args
+    unset -nocomplain optsA(-command)
+    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.
+    if {[info exists argsA(-command)]} {
+	set sock [eval ::socket -async [array get optsA] {$ahost $aport}]
+	
+	# Take some precautions here since WiFi behaves odd.
+	if {[catch {eof $sock} iseof] || $iseof} {
+	    return -code error eof
+	}
+	set err [fconfigure $sock -error]
+	if {$err ne ""} {
+	    return -code error $err
+	}
+	
+	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
+	
+	# There is a potential problem if the socket becomes writable in
+	# this call before we return! Therefore 'after idle'.
+	after idle [list \
+	  fileevent $sock writable [namespace code [list writable $token]]]
+    } else {
+	set sock [eval {::socket $ahost $aport} [array get optsA]]
+	if {[string length $options(-proxy)]} {
+	    eval {${proxy}::init $sock $host $port} [get_opts]
+	}
+    }
+    return $sock
+}
+
+proc autosocks::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)
+    }
+    return $opts
+}
+
+proc autosocks::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} {
+	uplevel #0 $state(cmd) network-failure	        
+	unset -nocomplain state
+    } else {
+	if {[string length $proxy]} {	    
+	    if {[catch {
+		eval {
+		    $options(-proxy)::init $sock $state(host) $state(port) \
+		      -command [namespace code [list socks_cb $token]]
+		} [get_opts]
+	    } err]} {
+		uplevel #0 $state(cmd) $err
+		unset -nocomplain state
+	    }
+	} else {
+	    uplevel #0 $state(cmd) ok
+	    unset -nocomplain state
+	}
+    }
+}
+
+proc autosocks::socks_cb {token stok status} {
+    variable $token
+    upvar 0 $token state
+    variable options
+
+    uplevel #0 $state(cmd) $status
+    $options(-proxy)::free $stok
+    unset -nocomplain state
+}
+
+proc autosocks::filter {host} {
+    variable options
+    if {[llength $options(-proxy)]} {
+	foreach domain $options(-proxyno) {
+	    if {[string match $domain $host]} {
+		return {}
+	    }
+	}
+	return [list $options(-proxyhost) $options(-proxyport)]
+    } else {
+	return [list]
+    }
+}
diff --git a/lib/autosocks/pkgIndex.tcl b/lib/autosocks/pkgIndex.tcl
new file mode 100644
index 0000000..9893df4
--- /dev/null
+++ b/lib/autosocks/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded autosocks 0.1 [list source [file join $dir autosocks.tcl]]
diff --git a/lib/base64/base64.tcl b/lib/base64/base64.tcl
new file mode 100644
index 0000000..3edfd48
--- /dev/null
+++ b/lib/base64/base64.tcl
@@ -0,0 +1,325 @@
+# base64.tcl --
+#
+# Encode/Decode base64 for a string
+# Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems
+# The decoder was done for exmh by Chris Garrigues
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# 
+# RCS: @(#) $Id: base64.tcl,v 1.23 2004/10/03 23:06:55 andreas_kupries Exp $
+
+# Version 1.0   implemented Base64_Encode, Base64_Decode
+# Version 2.0   uses the base64 namespace
+# Version 2.1   fixes various decode bugs and adds options to encode
+# Version 2.2   is much faster, Tcl8.0 compatible
+# Version 2.2.1 bugfixes
+# Version 2.2.2 bugfixes
+# Version 2.3   bugfixes and extended to support Trf
+
+package require Tcl 8.2
+namespace eval ::base64 {
+    namespace export encode decode
+}
+
+if {![catch {package require Trf 2.0}]} {
+    # Trf is available, so implement the functionality provided here
+    # in terms of calls to Trf for speed.
+
+    # ::base64::encode --
+    #
+    #	Base64 encode a given string.
+    #
+    # Arguments:
+    #	args	?-maxlen maxlen? ?-wrapchar wrapchar? string
+    #	
+    #		If maxlen is 0, the output is not wrapped.
+    #
+    # Results:
+    #	A Base64 encoded version of $string, wrapped at $maxlen characters
+    #	by $wrapchar.
+    
+    proc ::base64::encode {args} {
+	# Set the default wrapchar and maximum line length to match the output
+	# of GNU uuencode 4.2.  Various RFCs allow for different wrapping 
+	# characters and wraplengths, so these may be overridden by command line
+	# options.
+	set wrapchar "\n"
+	set maxlen 60
+
+	if { [llength $args] == 0 } {
+	    error "wrong # args: should be \"[lindex [info level 0] 0]\
+		    ?-maxlen maxlen? ?-wrapchar wrapchar? string\""
+	}
+
+	set optionStrings [list "-maxlen" "-wrapchar"]
+	for {set i 0} {$i < [llength $args] - 1} {incr i} {
+	    set arg [lindex $args $i]
+	    set index [lsearch -glob $optionStrings "${arg}*"]
+	    if { $index == -1 } {
+		error "unknown option \"$arg\": must be -maxlen or -wrapchar"
+	    }
+	    incr i
+	    if { $i >= [llength $args] - 1 } {
+		error "value for \"$arg\" missing"
+	    }
+	    set val [lindex $args $i]
+
+	    # The name of the variable to assign the value to is extracted
+	    # from the list of known options, all of which have an
+	    # associated variable of the same name as the option without
+	    # a leading "-". The [string range] command is used to strip
+	    # of the leading "-" from the name of the option.
+	    #
+	    # FRINK: nocheck
+	    set [string range [lindex $optionStrings $index] 1 end] $val
+	}
+    
+	# [string is] requires Tcl8.2; this works with 8.0 too
+	if {[catch {expr {$maxlen % 2}}]} {
+	    error "expected integer but got \"$maxlen\""
+	}
+
+	set string [lindex $args end]
+	set result [::base64 -mode encode -- $string]
+	set result [string map [list \n ""] $result]
+
+	if {$maxlen > 0} {
+	    set res ""
+	    set edge [expr {$maxlen - 1}]
+	    while {[string length $result] > $maxlen} {
+		append res [string range $result 0 $edge]$wrapchar
+		set result [string range $result $maxlen end]
+	    }
+	    if {[string length $result] > 0} {
+		append res $result
+	    }
+	    set result $res
+	}
+
+	return $result
+    }
+
+    # ::base64::decode --
+    #
+    #	Base64 decode a given string.
+    #
+    # Arguments:
+    #	string	The string to decode.  Characters not in the base64
+    #		alphabet are ignored (e.g., newlines)
+    #
+    # Results:
+    #	The decoded value.
+
+    proc ::base64::decode {string} {
+	regsub -all {\s} $string {} string
+	::base64 -mode decode -- $string
+    }
+
+} else {
+    # Without Trf use a pure tcl implementation
+
+    namespace eval base64 {
+	variable base64 {}
+	variable base64_en {}
+
+	# We create the auxiliary array base64_tmp, it will be unset later.
+
+	set i 0
+	foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \
+		a b c d e f g h i j k l m n o p q r s t u v w x y z \
+		0 1 2 3 4 5 6 7 8 9 + /} {
+	    set base64_tmp($char) $i
+	    lappend base64_en $char
+	    incr i
+	}
+
+	#
+	# Create base64 as list: to code for instance C<->3, specify
+	# that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded
+	# ascii chars get a {}. we later use the fact that lindex on a
+	# non-existing index returns {}, and that [expr {} < 0] is true
+	#
+
+	# the last ascii char is 'z'
+	scan z %c len
+	for {set i 0} {$i <= $len} {incr i} {
+	    set char [format %c $i]
+	    set val {}
+	    if {[info exists base64_tmp($char)]} {
+		set val $base64_tmp($char)
+	    } else {
+		set val {}
+	    }
+	    lappend base64 $val
+	}
+
+	# code the character "=" as -1; used to signal end of message
+	scan = %c i
+	set base64 [lreplace $base64 $i $i -1]
+
+	# remove unneeded variables
+	unset base64_tmp i char len val
+
+	namespace export encode decode
+    }
+
+    # ::base64::encode --
+    #
+    #	Base64 encode a given string.
+    #
+    # Arguments:
+    #	args	?-maxlen maxlen? ?-wrapchar wrapchar? string
+    #	
+    #		If maxlen is 0, the output is not wrapped.
+    #
+    # Results:
+    #	A Base64 encoded version of $string, wrapped at $maxlen characters
+    #	by $wrapchar.
+    
+    proc ::base64::encode {args} {
+	set base64_en $::base64::base64_en
+	
+	# Set the default wrapchar and maximum line length to match the output
+	# of GNU uuencode 4.2.  Various RFCs allow for different wrapping 
+	# characters and wraplengths, so these may be overridden by command line
+	# options.
+	set wrapchar "\n"
+	set maxlen 60
+
+	if { [llength $args] == 0 } {
+	    error "wrong # args: should be \"[lindex [info level 0] 0]\
+		    ?-maxlen maxlen? ?-wrapchar wrapchar? string\""
+	}
+
+	set optionStrings [list "-maxlen" "-wrapchar"]
+	for {set i 0} {$i < [llength $args] - 1} {incr i} {
+	    set arg [lindex $args $i]
+	    set index [lsearch -glob $optionStrings "${arg}*"]
+	    if { $index == -1 } {
+		error "unknown option \"$arg\": must be -maxlen or -wrapchar"
+	    }
+	    incr i
+	    if { $i >= [llength $args] - 1 } {
+		error "value for \"$arg\" missing"
+	    }
+	    set val [lindex $args $i]
+
+	    # The name of the variable to assign the value to is extracted
+	    # from the list of known options, all of which have an
+	    # associated variable of the same name as the option without
+	    # a leading "-". The [string range] command is used to strip
+	    # of the leading "-" from the name of the option.
+	    #
+	    # FRINK: nocheck
+	    set [string range [lindex $optionStrings $index] 1 end] $val
+	}
+    
+	# [string is] requires Tcl8.2; this works with 8.0 too
+	if {[catch {expr {$maxlen % 2}}]} {
+	    error "expected integer but got \"$maxlen\""
+	}
+
+	set string [lindex $args end]
+
+	set result {}
+	set state 0
+	set length 0
+
+
+	# Process the input bytes 3-by-3
+
+	binary scan $string c* X
+	foreach {x y z} $X {
+	    # Do the line length check before appending so that we don't get an
+	    # extra newline if the output is a multiple of $maxlen chars long.
+	    if {$maxlen && $length >= $maxlen} {
+		append result $wrapchar
+		set length 0
+	    }
+	
+	    append result [lindex $base64_en [expr {($x >>2) & 0x3F}]] 
+	    if {$y != {}} {
+		append result [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] 
+		if {$z != {}} {
+		    append result \
+			    [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]]
+		    append result [lindex $base64_en [expr {($z & 0x3F)}]]
+		} else {
+		    set state 2
+		    break
+		}
+	    } else {
+		set state 1
+		break
+	    }
+	    incr length 4
+	}
+	if {$state == 1} {
+	    append result [lindex $base64_en [expr {(($x << 4) & 0x30)}]]== 
+	} elseif {$state == 2} {
+	    append result [lindex $base64_en [expr {(($y << 2) & 0x3C)}]]=  
+	}
+	return $result
+    }
+
+    # ::base64::decode --
+    #
+    #	Base64 decode a given string.
+    #
+    # Arguments:
+    #	string	The string to decode.  Characters not in the base64
+    #		alphabet are ignored (e.g., newlines)
+    #
+    # Results:
+    #	The decoded value.
+
+    proc ::base64::decode {string} {
+	if {[string length $string] == 0} {return ""}
+
+	set base64 $::base64::base64
+	set output "" ; # Fix for [Bug 821126]
+
+	binary scan $string c* X
+	foreach x $X {
+	    set bits [lindex $base64 $x]
+	    if {$bits >= 0} {
+		if {[llength [lappend nums $bits]] == 4} {
+		    foreach {v w z y} $nums break
+		    set a [expr {($v << 2) | ($w >> 4)}]
+		    set b [expr {(($w & 0xF) << 4) | ($z >> 2)}]
+		    set c [expr {(($z & 0x3) << 6) | $y}]
+		    append output [binary format ccc $a $b $c]
+		    set nums {}
+		}		
+	    } elseif {$bits == -1} {
+		# = indicates end of data.  Output whatever chars are left.
+		# The encoding algorithm dictates that we can only have 1 or 2
+		# padding characters.  If x=={}, we have 12 bits of input 
+		# (enough for 1 8-bit output).  If x!={}, we have 18 bits of
+		# input (enough for 2 8-bit outputs).
+		
+		foreach {v w z} $nums break
+		set a [expr {($v << 2) | (($w & 0x30) >> 4)}]
+		
+		if {$z == {}} {
+		    append output [binary format c $a ]
+		} else {
+		    set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}]
+		    append output [binary format cc $a $b]
+		}		
+		break
+	    } else {
+		# RFC 2045 says that line breaks and other characters not part
+		# of the Base64 alphabet must be ignored, and that the decoder
+		# can optionally emit a warning or reject the message.  We opt
+		# not to do so, but to just ignore the character. 
+		continue
+	    }
+	}
+	return $output
+    }
+}
+
+package provide base64 2.3.1
diff --git a/lib/base64/pkgIndex.tcl b/lib/base64/pkgIndex.tcl
new file mode 100644
index 0000000..0c6384c
--- /dev/null
+++ b/lib/base64/pkgIndex.tcl
@@ -0,0 +1,14 @@
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script.  It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands.  When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded base64   2.3.1 [list source [file join $dir base64.tcl]]
+#package ifneeded uuencode 1.1.2 [list source [file join $dir uuencode.tcl]]
+#package ifneeded yencode  1.1.1 [list source [file join $dir yencode.tcl]]
diff --git a/lib/chatwidget/ChangeLog b/lib/chatwidget/ChangeLog
new file mode 100644
index 0000000..50b83e1
--- /dev/null
+++ b/lib/chatwidget/ChangeLog
@@ -0,0 +1,26 @@
+2008-02-16  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* pkgIndex.tcl:   Incremented to 1.1.0
+	* chatwidget.tcl: Added support for chatstate notifications. This
+	is a Jabber (XEP-0085) concept that will likely be useful in many
+	chat implementations.
+	Also simpler support for changing the font with a cget/configure
+	override command and access the chatstate via cget -chatstate.
+
+2007-10-23  Andreas Kupries  <andreask@activestate.com>
+
+	* chatwidget.man: Fixed syntax error in documentation.
+
+2007-10-19  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* chatwidget.tcl: Reorganized the widget tree to fix some problems
+	                  when adding scrollbars to the panes. Added
+	                  accessors for all the components.
+
+2007-10-19  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* chatwidget.tcl: Initial checkin of a composite widget for use
+	* chatwidget.man: in chat applications (eg: jabber or irc)
+	* pkgIndex.tcl: 
+
+
diff --git a/lib/chatwidget/chatwidget.man b/lib/chatwidget/chatwidget.man
new file mode 100644
index 0000000..4b5db2b
--- /dev/null
+++ b/lib/chatwidget/chatwidget.man
@@ -0,0 +1,116 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin chatwidget n 1.0.0]
+[moddesc   {Composite widget for chat applications}]
+[titledesc {Provides a multi-paned view suitable for display of chat room or irc channel information}]
+[require Tk 8.5]
+[require chatwidget [opt 1.0.0]]
+[description]
+
+This is a composite widget designed to simplify the construction of
+chat applications. The widget contains display areas for chat
+messages, user names and topic and an entry area. It automatically
+handles colourization of messages per nick and manages nick
+completion. A system of hooks permit the application author to adjust
+display features. The main chat display area may be split for use
+displaying history or for searching.
+
+[para]
+
+The widget is made up of a number of text widget and panedwindow
+widgets so that the size of each part of the display may be adjusted
+by the user. All the text widgets may be accessed via widget
+passthrough commands if fine adjustment is required. The topic and
+names sections can also be hidden if desired.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::chatwidget::chatwidget] [arg path] [opt [arg options]]]
+
+Create a new chatwidget using the Tk window id [arg path]. Any options
+provided are currently passed directly to the main chat text widget.
+
+[list_end]
+
+[section {WIDGET COMMANDS}]
+
+[list_begin definitions]
+
+[call [cmd \$widget] topic [arg command] [arg args]]
+
+The chat widget can display a topic string, for instance the topic or
+name given to a multi-user chatroom or irc channel. 
+[list_begin commands]
+[cmd_def show]
+Enable display of the topic.
+[cmd_def hide]
+Disable display of the topic
+[cmd_def "set [arg topic]"]
+Set the topic text to [arg topic].
+[list_end]
+
+[call [cmd \$widget] name [arg nick] [arg args]]
+
+Control the names and tags associated with names. 
+[list_begin commands]
+[cmd_def "list [opt [arg -full]]"]
+Returns a list of all the user names from the names view. If [opt \
+-full] is given then the list returned is a list of lists where each
+sublist is made up of the nick followed by any options that have been
+set on this nick entry. This may be used to examine any application
+specific options that may be applied to a nick when using the 
+[cmd add] command.
+[cmd_def "add [arg nick] [opt [arg options]]"]
+[cmd_def "delete [arg nick]"]
+[list_end]
+
+[call [cmd \$widget] message [arg text] [arg args]]
+
+Add messages to the display. options are -nick, -time, -type, -mark
+-tags
+
+[call [cmd \$widget] hook [arg command] [arg args]]
+
+Manage hooks. add (message, post names_group, names_nick, chatstate), remove, run
+
+[call [cmd \$widget] names [arg args]]
+
+Passthrough to the name display text widget. See the [cmd text] widget manual
+for all available commands. The chatwidget provides two additional
+commands [cmd show] and [cmd hide] which are used to control the
+display of this element in the widget.
+
+[call [cmd \$widget] entry [arg args]]
+
+Passthrough to the entry text widget. See the [cmd text] widget manual
+for all available commands.
+
+[list_end]
+
+
+[section EXAMPLE]
+
+[example {
+chatwidget::chatwidget .chat
+proc speak {w msg} {$w message $msg -nick user}
+.chat hook add post [list speak .chat]
+pack .chat -side top -fill both -expand 1
+.chat topic show
+.chat topic set "Chat widget demo"
+.chat name add "admin" -group admin
+.chat name add "user" -group users -color tomato
+.chat message "Chatwidget ready" -type system
+.chat message "Hello, user" -nick admin
+.chat message "Hello, admin" -nick user
+}]
+
+[para]
+
+A more extensive example is available by examining the code for the picoirc
+program in the tclapps repository which ties the tcllib [package picoirc] package to this
+[package chatwidget] package to create a simple irc client.
+
+[see_also text(n)]
+[keywords widget {mega-widget} {composite widget} chat irc chatwidget]
+[manpage_end]
diff --git a/lib/chatwidget/chatwidget.tcl b/lib/chatwidget/chatwidget.tcl
new file mode 100644
index 0000000..3fe1bef
--- /dev/null
+++ b/lib/chatwidget/chatwidget.tcl
@@ -0,0 +1,737 @@
+# chatwidget.tcl --
+#
+#	This package provides a composite widget suitable for use in chat
+#	applications. A number of panes managed by panedwidgets are available
+#	for displaying user names, chat text and for entering new comments.
+#	The main display area makes use of text widget peers to enable a split
+#	view for history or searching.
+#
+# Copyright (C) 2007 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: chatwidget.tcl,v 1.3 2007/10/24 10:32:19 patthoyts Exp $
+
+package require Tk 8.5
+
+namespace eval chatwidget {
+    variable version 1.1.0
+
+    namespace export chatwidget
+
+    ttk::style layout ChatwidgetFrame {
+        Entry.field -sticky news -border 1 -children {
+            ChatwidgetFrame.padding -sticky news
+        }
+    }
+    if {[lsearch -exact [font names] ChatwidgetFont] == -1} {
+        eval [list font create ChatwidgetFont] [font configure TkTextFont]
+        eval [list font create ChatwidgetBoldFont] \
+            [font configure ChatwidgetFont] -weight bold
+        eval [list font create ChatwidgetItalicFont] \
+            [font configure ChatwidgetFont] -slant italic
+    }
+}
+
+proc chatwidget::chatwidget {w args} {
+    Create $w
+    interp hide {} $w
+    interp alias {} $w {} [namespace origin WidgetProc] $w
+    return $w
+}
+
+proc chatwidget::WidgetProc {self cmd args} {
+    upvar #0 [namespace current]::$self state
+    switch -- $cmd {
+        hook {
+            if {[llength $args] < 2} {
+                return -code error "wrong \# args: should be\
+                    \"\$widget hook add|remove|list hook_type ?script? ?priority?\""
+            }
+            return [uplevel 1 [list [namespace origin Hook] $self] $args]
+        }
+        cget {
+            return [uplevel 1 [list [namespace origin Cget] $self] $args]
+        }
+        configure {
+            return [uplevel 1 [list [namespace origin Configure] $self] $args]
+        }
+        insert {
+            return [uplevel 1 [list [namespace origin Insert] $self] $args]
+        }
+        message {
+            return [uplevel 1 [list [namespace origin Message] $self] $args]
+        }
+        name {
+            return [uplevel 1 [list [namespace origin Name] $self] $args]
+        }
+        topic {
+            return [uplevel 1 [list [namespace origin Topic] $self] $args]
+        }
+        names {
+            return [uplevel 1 [list [namespace origin Names] $self] $args]
+        }
+        entry {
+            return [uplevel 1 [list [namespace origin Entry] $self] $args]
+        }
+        peer {
+            return [uplevel 1 [list [namespace origin Peer] $self] $args]
+        }
+        chat - 
+        default {
+            return [uplevel 1 [list [namespace origin Chat] $self] $args]
+        }
+    }
+    return
+}
+
+proc chatwidget::Chat {self args} {
+    upvar #0 [namespace current]::$self state
+    if {[llength $args] == 0} {
+        return $state(chat_widget)
+    }
+    return [uplevel 1 [list $state(chat_widget)] $args]
+}
+
+proc chatwidget::Cget {self args} {
+    upvar #0 [namespace current]::$self state
+    switch -exact -- [set what [lindex $args 0]] {
+        -chatstate { return $state(chatstate) }
+        -history { return $state(history) }
+        default {
+            return [uplevel 1 [list $state(chat_widget) cget] $args]
+        }
+    }
+}
+
+proc chatwidget::Configure {self args} {
+    upvar #0 [namespace current]::$self state
+    switch -exact -- [set option [lindex $args 0]] {
+        -chatstate {
+            if {[llength $args] > 1} { set state(chatstate) [Pop args 1] }
+            else { return $state(chatstate) }
+        }
+        -history {
+            if {[llength $args] > 1} { set state(history) [Pop args 1] }
+            else { return $state(history) }
+        }
+        -font {
+            if {[llength $args] > 1} {
+                set font [Pop args 1]
+                set family [font actual $font -family]
+                set size [font actual $font -size]
+                font configure ChatwidgetFont -family $family -size $size
+                font configure ChatwidgetBoldFont -family $family -size $size
+                font configure ChatwidgetItalicFont -family $family -size $size
+            } else { return [$state(chat_widget) cget -font] }
+        }
+        default {
+            return [uplevel 1 [list $state(chat_widget) configure] $args]
+        }
+    }
+}
+
+proc chatwidget::Peer {self args} {
+    upvar #0 [namespace current]::$self state
+    if {[llength $args] == 0} {
+        return $state(chat_peer_widget)
+    }
+    return [uplevel 1 [list $state(chat_peer_widget)] $args]
+}
+
+proc chatwidget::Topic {self cmd args} {
+    upvar #0 [namespace current]::$self state
+    switch -exact -- $cmd {
+        show { grid $self.topic -row 0 -column 0 -sticky new }
+        hide { grid forget $self.topic }
+        set  { set state(topic) [lindex $args 0] }
+        default {
+            return -code error "bad option \"$cmd\":\
+                must be show, hide or set"
+        }
+    }
+}
+
+proc chatwidget::Names {self args} {
+    upvar #0 [namespace current]::$self state
+    set frame [winfo parent $state(names_widget)]
+    set pane [winfo parent $frame]
+    if {[llength $args] == 0} {
+        return $state(names_widget)
+    }
+    if {[llength $args] == 1 && [lindex $args 0] eq "hide"} {
+        return [$pane forget $frame]
+    }
+    if {[llength $args] == 1 && [lindex $args 0] eq "show"} {
+        return [$pane add $frame]
+    }
+    return [uplevel 1 [list $state(names_widget)] $args] 
+}
+
+proc chatwidget::Entry {self args} {
+    upvar #0 [namespace current]::$self state
+    if {[llength $args] == 0} {
+        return $state(entry_widget)
+    }
+    if {[llength $args] == 1 && [lindex $args 0] eq "text"} {
+        return [$state(entry_widget) get 1.0 end-1c]
+    }
+    return [uplevel 1 [list $state(entry_widget)] $args]
+}
+
+proc chatwidget::Message {self text args} {
+    upvar #0 [namespace current]::$self state
+    set chat $state(chat_widget)
+
+    set mark end
+    set type normal
+    set nick Unknown
+    set time [clock seconds]
+    set tags {}
+
+    while {[string match -* [set option [lindex $args 0]]]} {
+        switch -exact -- $option {
+            -nick { set nick [Pop args 1] }
+            -time { set time [Pop args 1] }
+            -type { set type [Pop args 1] }
+            -mark { set type [Pop args 1] }
+            -tags { set tags [Pop args 1] }
+            default {
+                return -code error "unknown option \"$option\""
+            }
+        }
+        Pop args
+    }
+
+    if {[catch {Hook $self run message $text \
+                    -mark $mark -type $type -nick $nick \
+                    -time $time -tags $tags}] == 3} then {
+        return
+    }
+
+    if {$type ne "system"} { lappend tags NICK-$nick }
+    lappend tags TYPE-$type
+    $chat configure -state normal
+    set ts [clock format $time -format "\[%H:%M\]\t"]
+    $chat insert $mark $ts [concat BOOKMARK STAMP $tags]
+    if {$type eq "action"} {
+        $chat insert $mark "   * $nick " [concat BOOKMARK NICK $tags]
+        lappend tags ACTION
+    } elseif {$type eq "system"} {
+    } else {
+        $chat insert $mark "$nick\t" [concat BOOKMARK NICK $tags]
+    }
+    if {$type ne "system"} { lappend tags MSG NICK-$nick }
+    #$chat insert $mark $text $tags
+    Insert $self $mark $text $tags
+    $chat insert $mark "\n" $tags
+    $chat configure -state disabled
+    if {$state(autoscroll)} {
+        $chat see end
+    }
+    return
+}
+
+proc chatwidget::Insert {self mark args} {
+    upvar #0 [namespace current]::$self state
+    if {![info exists state(urluid)]} {set state(urluid) 0}
+    set w $state(chat_widget)
+    set parts {}
+    foreach {s t} $args {
+        while {[regexp -indices {\m(https?://[^\s]+)} $s -> ndx]} {
+            foreach {fr bk} $ndx break
+            lappend parts [string range $s 0 [expr {$fr - 1}]] $t
+            lappend parts [string range $s $fr $bk] \
+                [linsert $t end URL URL-[incr state(urluid)]]
+            set s [string range $s [incr bk] end]
+        }
+        lappend parts $s $t
+    }
+    set ws [$w cget -state]
+    $w configure -state normal
+    eval [list $w insert $mark] $parts
+    $w configure -state $ws
+}
+
+# $w name add ericthered -group admin -color red
+# state(names) {{pat -color red -group admin -thing wilf} {eric ....}}
+proc chatwidget::Name {self cmd args} {
+    upvar #0 [namespace current]::$self state
+    switch -exact -- $cmd {
+        list {
+            switch -exact -- [lindex $args 0] {
+                -full {
+                    return $state(names)
+                }
+                default {
+                    foreach item $state(names) { lappend r [lindex $item 0] }
+                    return $r
+                }
+            }
+        }
+        add {
+            if {[llength $args] < 1 || ([llength $args] % 2) != 1} {
+                return -code error "wrong # args: should be\
+                    \"add nick ?-group group ...?\""
+            }
+            set nick [lindex $args 0]
+            if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] == -1} {
+                array set opts {-group {} -colour black}
+                array set opts [lrange $args 1 end]
+                lappend state(names) [linsert [array get opts] 0 $nick]
+            } else {
+                array set opts [lrange [lindex $state(names) $ndx] 1 end]
+                array set opts [lrange $args 1 end]
+                lset state(names) $ndx [linsert [array get opts] 0 $nick]
+            }
+            UpdateNames $self
+        }
+        delete {
+            if {[llength $args] != 1} {
+                return -code error "wrong # args: should be \"delete nick\""
+            }
+            set nick [lindex $args 0]
+            if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] != -1} {
+                set state(names) [lreplace $state(names) $ndx $ndx]
+                UpdateNames $self
+            }
+        }
+        get {
+            if {[llength $args] < 1} {
+                return -code error "wrong # args:\
+                    should be \"get nick\" ?option?"
+            }
+            set result {}
+            set nick [lindex $args 0]
+            if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] != -1} {
+                set result [lindex $state(names) $ndx]
+                if {[llength $args] > 1} {
+                    if {[set ndx [lsearch $result [lindex $args 1]]] != -1} {
+                        set result [lindex $result [incr ndx]]
+                    } else {
+                        set result {}
+                    }
+                }
+            }
+            return $result
+        }
+        default {
+            return -code error "bad name option \"$cmd\":\
+                must be list, names, add or delete"
+        }
+    }
+}
+
+proc chatwidget::UpdateNames {self} {
+    upvar #0 [namespace current]::$self state
+    if {[info exists state(updatenames)]} {
+        after cancel $state(updatenames)
+    }
+    set state(updatenames) [after idle [list [namespace origin UpdateNamesExec] $self]]
+}
+
+proc chatwidget::UpdateNamesExec {self} {
+    upvar #0 [namespace current]::$self state
+    unset state(updatenames)
+    set names $state(names_widget)
+    set chat  $state(chat_widget)
+    
+    foreach tagname [lsearch -all -inline [$names tag names] NICK-*] {
+        $names tag delete $tagname
+    }
+    foreach tagname [lsearch -all -inline [$names tag names] GROUP-*] {
+        $names tag delete $tagname
+    }
+
+    $names configure -state normal
+    $names delete 1.0 end
+    array set groups {}
+    foreach item $state(names) {
+        set group {}
+        if {[set ndx [lsearch $item -group]] != -1} {
+            set group [lindex $item [incr ndx]]
+        }
+        lappend groups($group) [lindex $item 0]
+    }
+
+    foreach group [lsort [array names groups]] {
+        Hook $self run names_group $group
+        $names insert end "$group\n" [list SUBTITLE GROUP-$group]
+        foreach nick [lsort -dictionary $groups($group)] {
+            $names tag configure NICK-$nick
+            unset -nocomplain opts ; array set opts {}
+            if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] != -1} {
+                array set opts [lrange [lindex $state(names) $ndx] 1 end]
+                if {[info exists opts(-color)]} {
+                    $names tag configure NICK-$nick -foreground $opts(-color)
+                    $chat  tag configure NICK-$nick -foreground $opts(-color)
+                }
+                eval [linsert [lindex $state(names) $ndx] 0 \
+                          Hook $self run names_nick]
+            }
+            $names insert end $nick\n [list NICK NICK-$nick GROUP-$group]
+        }
+    }
+    $names insert end "[llength $state(names)] nicks\n" [list SUBTITLE]
+
+    $names configure -state disabled
+}
+
+proc chatwidget::Pop {varname {nth 0}} {
+    upvar $varname args
+    set r [lindex $args $nth]
+    set args [lreplace $args $nth $nth]
+    return $r
+}
+
+proc chatwidget::Hook {self do type args} {
+    upvar #0 [namespace current]::$self state
+    set valid {message post names_group names_nick chatstate url}
+    if {[lsearch -exact $valid $type] == -1} {
+        return -code error "unknown hook type \"$type\":\
+                must be one of [join $valid ,]"
+    }
+    switch -exact -- $do {
+	add {
+            if {[llength $args] < 1 || [llength $args] > 2} {
+                return -code error "wrong # args: should be \"add hook cmd ?priority?\""
+            }
+            foreach {cmd pri} $args break
+            if {$pri eq {}} { set pri 50 }
+            lappend state(hook,$type) [list $cmd $pri]
+            set state(hook,$type) [lsort -real -index 1 [lsort -unique $state(hook,$type)]]
+	}
+        remove {
+            if {[llength $args] != 1} {
+                return -code error "wrong # args: should be \"remove hook cmd\""
+            }
+            if {![info exists state(hook,$type)]} { return }
+            for {set ndx 0} {$ndx < [llength $state(hook,$type)]} {incr ndx} {
+                set item [lindex $state(hook,$type) $ndx]
+                if {[lindex $item 0] eq [lindex $args 0]} {
+                    set state(hook,$type) [lreplace $state(hook,$type) $ndx $ndx]
+                    break
+                }
+            }
+            set state(hook,$type)
+        }
+        run {
+            if {![info exists state(hook,$type)]} { return }
+            set res ""
+            foreach item $state(hook,$type) {
+                foreach {cmd pri} $item break
+                set code [catch {eval $cmd $args} err]
+                if {$code} {
+                    ::bgerror "error running \"$type\" hook: $err"
+                    break
+                } else {
+                    lappend res $err
+                }
+            }
+            return $res
+        }
+        list {
+            if {[info exists state(hook,$type)]} {
+                return $state(hook,$type)
+            }
+        }
+	default {
+	    return -code error "unknown hook action \"$do\":\
+                must be add, remove, list or run"
+	}
+    }
+}
+
+proc chatwidget::Grid {w {row 0} {column 0}} {
+    grid rowconfigure $w $row -weight 1
+    grid columnconfigure $w $column -weight 1
+}
+
+proc chatwidget::Create {self} {
+    upvar #0 [set State [namespace current]::$self] state
+    set state(history) {}
+    set state(current) 0
+    set state(autoscroll) 1
+    set state(names) {}
+    set state(chatstatetimer) {}
+    set state(chatstate) active
+
+    # NOTE: By using a non-ttk frame as the outermost part we are able
+    # to be [wm manage]d. The outermost frame should be invisible at all times.
+    set self [frame $self -class Chatwidget \
+                  -borderwidth 0 -highlightthickness 0 -relief flat]
+    set outer [ttk::panedwindow $self.outer -orient vertical]
+    set inner [ttk::panedwindow $outer.inner -orient horizontal]
+
+    # Create a topic/subject header
+    set topic [ttk::frame $self.topic]
+    ttk::label $topic.label -anchor w -text Topic
+    ttk::entry $topic.text -state disabled -textvariable [set State](topic)
+    grid $topic.label $topic.text -sticky new -pady {2 0} -padx 1
+    Grid $topic 0 1
+
+    # Create the usernames scrolled text
+    set names [ttk::frame $inner.names -style ChatwidgetFrame]
+    text $names.text -borderwidth 0 -relief flat -font ChatwidgetFont
+    ttk::scrollbar $names.vs -command [list $names.text yview]
+    $names.text configure -width 10 -height 10 -state disabled \
+        -yscrollcommand [list [namespace origin scroll_set] $names.vs $inner 0]
+    bindtags $names.text [linsert [bindtags $names.text] 1 ChatwidgetNames]
+    grid $names.text $names.vs -sticky news -padx 1 -pady 1
+    Grid $names 0 0
+    set state(names_widget) $names.text
+
+    # Create the chat display
+    set chatf [ttk::frame $inner.chat -style ChatwidgetFrame]
+    set peers [ttk::panedwindow $chatf.peers -orient vertical]
+    set upper [ttk::frame $peers.upper]
+    set lower [ttk::frame $peers.lower]
+
+    set chat [text $lower.text -borderwidth 0 -relief flat -wrap word \
+                  -state disabled -font ChatwidgetFont]
+    set chatvs [ttk::scrollbar $lower.vs -command [list $chat yview]]
+    $chat configure -height 10 -state disabled \
+        -yscrollcommand [list [namespace origin scroll_set] $chatvs $peers 1]
+    grid $chat $chatvs -sticky news
+    Grid $lower 0 0
+    set peer [$chat peer create $upper.text -borderwidth 0 -relief flat \
+                  -wrap word -state disabled -font ChatwidgetFont]
+    set peervs [ttk::scrollbar $upper.vs -command [list $peer yview]]
+    $peer configure -height 0 \
+        -yscrollcommand [list [namespace origin scroll_set] $peervs $peers 0]
+    grid $peer $peervs -sticky news
+    Grid $upper 0 0
+    $peers add $upper
+    $peers add $lower -weight 1
+    grid $peers -sticky news -padx 1 -pady 1
+    Grid $chatf 0 0
+    bindtags $chat [linsert [bindtags $chat] 1 ChatwidgetText]
+    set state(chat_widget) $chat
+    set state(chat_peer_widget) $peer
+    
+    # Create the entry widget
+    set entry [ttk::frame $outer.entry -style ChatwidgetFrame]
+    text $entry.text -borderwidth 0 -relief flat -font ChatwidgetFont
+    ttk::scrollbar $entry.vs -command [list $entry.text yview]
+    $entry.text configure -height 1 \
+        -yscrollcommand [list [namespace origin scroll_set] $entry.vs $outer 0]
+    bindtags $entry.text [linsert [bindtags $entry.text] 1 ChatwidgetEntry]
+    grid $entry.text $entry.vs -sticky news -padx 1 -pady 1
+    Grid $entry 0 0
+    set state(entry_widget) $entry.text
+
+    bind ChatwidgetEntry <Return> "[namespace origin Post] \[[namespace origin Self] %W\]"
+    bind ChatwidgetEntry <KP_Enter> "[namespace origin Post] \[[namespace origin Self] %W\]"
+    bind ChatwidgetEntry <Shift-Return> "#"
+    bind ChatwidgetEntry <Control-Return> "#"
+    bind ChatwidgetEntry <Key-Up>   "[namespace origin History] \[[namespace origin Self] %W\] prev"
+    bind ChatwidgetEntry <Key-Down> "[namespace origin History] \[[namespace origin Self] %W\] next"
+    bind ChatwidgetEntry <Key-Tab> "[namespace origin Nickcomplete] \[[namespace origin Self] %W\]"
+    bind ChatwidgetEntry <Key-Prior> "\[[namespace origin Self] %W\] chat yview scroll -1 pages"
+    bind ChatwidgetEntry <Key-Next> "\[[namespace origin Self] %W\] chat yview scroll 1 pages"
+    bind ChatwidgetEntry <Key> "+[namespace origin Chatstate] \[[namespace origin Self] %W\] composing"
+    bind ChatwidgetEntry <FocusIn> "+[namespace origin Chatstate] \[[namespace origin Self] %W\] active"
+    bind $self <Destroy> "+unset -nocomplain [namespace current]::%W"
+    bind $peer       <Map> [list [namespace origin PaneMap] %W $peers 0]
+    bind $names.text <Map> [list [namespace origin PaneMap] %W $inner -90]
+    bind $entry.text <Map> [list [namespace origin PaneMap] %W $outer -28]
+
+    bind ChatwidgetText <<ThemeChanged>> {
+        ttk::style layout ChatwidgetFrame {
+            Entry.field -sticky news -border 1 -children {
+                ChatwidgetFrame.padding -sticky news
+            }
+        }
+    }
+
+    $names.text tag configure SUBTITLE \
+        -background grey80 -font ChatwidgetBoldFont
+    $chat tag configure NICK        -font ChatwidgetBoldFont
+    $chat tag configure TYPE-system -font ChatwidgetItalicFont
+    $chat tag configure URL         -underline 1
+
+    $inner add $chatf -weight 1
+    $inner add $names
+    $outer add $inner -weight 1
+    $outer add $entry
+    
+    grid $outer -row 1 -column 0 -sticky news -padx 1 -pady 1
+    Grid $self 1 0
+    return $self
+}
+
+proc chatwidget::Self {widget} {
+    set class [winfo class [set w $widget]]
+    while {[winfo exists $w] && [winfo class $w] ne "Chatwidget"} {
+        set w [winfo parent $w]
+    }
+    if {![winfo exists $w]} {
+        return -code error "invalid window $widget" 
+    }
+    return $w
+}
+
+# Set initial position of sash
+proc chatwidget::PaneMap {w pane offset} {
+    bind $pane <Map> {}
+    if {[llength [$pane panes]] > 1} {
+        if {$offset < 0} {
+            if {[$pane cget -orient] eq "horizontal"} {
+                set axis width
+            } else {
+                set axis height
+            }
+            #after idle [list $pane sashpos 0 [expr {[winfo $axis $pane] + $offset}]]
+            after idle [namespace code [list PaneMapImpl $pane $axis $offset]]
+        } else {
+            #after idle [list $pane sashpos 0 $offset]
+            after idle [namespace code [list PaneMapImpl $pane {} $offset]]
+        }
+    }
+}
+
+proc chatwidget::PaneMapImpl {pane axis offset} {
+    if {$axis eq {}} {
+        set size 0
+    } else {
+        set size [winfo $axis $pane]
+    }
+    set sashpos [expr {$size + $offset}]
+    puts stderr "PaneMapImpl $pane $axis $offset : size:$size sashpos:$sashpos"
+    after 0 [list $pane sashpos 0 $sashpos]
+}
+
+# Handle auto-scroll smarts. This will cause the scrollbar to be removed if
+# not required and to disable autoscroll for the text widget if we are not
+# tracking the bottom line.
+proc chatwidget::scroll_set {scrollbar pw set f1 f2} {
+    $scrollbar set $f1 $f2
+    if {($f1 == 0) && ($f2 == 1)} {
+	grid remove $scrollbar
+    } else {
+        if {[winfo manager $scrollbar] eq {}} {}
+            if {[llength [$pw panes]] > 1} {
+                set pos [$pw sashpos 0]
+                grid $scrollbar
+                after idle [list $pw sashpos 0 $pos]
+            } else {
+                grid $scrollbar
+            }
+        
+    }
+    if {$set} {
+        upvar #0 [namespace current]::[Self $scrollbar] state
+        set state(autoscroll) [expr {(1.0 - $f2) < 1.0e-6 }]
+    }
+}
+
+proc chatwidget::Post {self} {
+    set msg [$self entry get 1.0 end-1c]
+    if {$msg eq ""} { return -code break "" }
+    if {[catch {Hook $self run post $msg}] != 3} {
+        $self entry delete 1.0 end
+        upvar #0 [namespace current]::$self state
+        set state(history) [lrange [lappend state(history) $msg] end-50 end]
+        set state(current) [llength $state(history)]
+    }
+    return -code break ""
+}
+
+proc chatwidget::History {self dir} {
+    upvar #0 [namespace current]::$self state
+    switch -exact -- $dir {
+        prev {
+            if {$state(current) == 0} { return }
+            if {$state(current) == [llength $state(history)]} {
+                set state(temp) [$self entry get 1.0 end-1c]
+            }
+            if {$state(current)} { incr state(current) -1 }
+            $self entry delete 1.0 end
+            $self entry insert 1.0 [lindex $state(history) $state(current)]
+            return
+        }
+        next {
+            if {$state(current) == [llength $state(history)]} { return }
+            if {[incr state(current)] == [llength $state(history)] && [info exists state(temp)]} {
+                set msg $state(temp)
+            } else {
+                set msg [lindex $state(history) $state(current)]
+            }
+            $self entry delete 1.0 end
+            $self entry insert 1.0 $msg
+        }
+        default {
+            return -code error "invalid direction \"$dir\":
+                must be either prev or next"
+        }
+    }
+}
+
+proc chatwidget::Nickcomplete {self} {
+    upvar #0 [namespace current]::$self state
+    if {[info exists state(nickcompletion)]} {
+        foreach {index matches after} $state(nickcompletion) break
+        after cancel $after
+        incr index
+        if {$index > [llength $matches]} { set index 0 }
+        set delta 2c
+    } else {
+        set delta 1c
+        set partial [$self entry get "insert - $delta wordstart" "insert - $delta wordend"]
+        set matches [lsearch -all -inline -glob -index 0 $state(names) $partial*]
+        set index 0
+    }
+    switch -exact -- [llength $matches] {
+        0 { bell ; return -code break ""}
+        1 { set match [lindex [lindex $matches 0] 0]}
+        default {
+            set match [lindex [lindex $matches $index] 0]
+            set state(nickcompletion) [list $index $matches \
+                [after 2000 [list [namespace origin NickcompleteCleanup] $self]]]
+        }
+    }
+    $self entry delete "insert - $delta wordstart" "insert - $delta wordend"
+    $self entry insert insert "$match "
+    return -code break ""
+}
+
+proc chatwidget::NickcompleteCleanup {self} {
+    upvar #0 [namespace current]::$self state
+    if {[info exists state(nickcompletion)]} {
+        unset state(nickcompletion)
+    }
+}
+
+# Update the widget chatstate (one of active, composing, paused, inactive, gone)
+# These are from XEP-0085 but seem likey useful in many chat-type environments.
+# Note: this state is _per-widget_. This is not the same as [tk inactive]
+# active = got focus and recently active
+#   composing = typing
+#   paused = 5 secs non typing
+# inactive = no activity for 30 seconds
+# gone = no activity for 2 minutes or closed the window
+proc chatwidget::Chatstate {self what} {
+    upvar #0 [namespace current]::$self state
+    after cancel $state(chatstatetimer)
+    switch -exact -- $what {
+        composing - active {
+            set state(chatstatetimer) [after 5000 [namespace code [list Chatstate $self paused]]]
+        }
+        paused {
+            set state(chatstatetimer) [after 25000 [namespace code [list Chatstate $self inactive]]]
+        }
+        inactive {
+            set state(chatstatetimer) [after 120000 [namespace code [list Chatstate $self gone]]]
+        }
+        gone {}
+    }
+    set fire [expr {$state(chatstate) eq $what ? 0 : 1}]
+    set state(chatstate) $what
+    if {$fire} {
+        catch {Hook $self run chatstate $what}
+        event generate $self <<ChatwidgetChatstate>>
+    }
+}
+    
+package provide chatwidget $chatwidget::version
diff --git a/lib/chatwidget/pkgIndex.tcl b/lib/chatwidget/pkgIndex.tcl
new file mode 100644
index 0000000..3685a0e
--- /dev/null
+++ b/lib/chatwidget/pkgIndex.tcl
@@ -0,0 +1 @@
+package ifneeded chatwidget 1.1.0 [list source [file join $dir chatwidget.tcl]]
diff --git a/lib/dns/dns.tcl b/lib/dns/dns.tcl
new file mode 100644
index 0000000..2d742e6
--- /dev/null
+++ b/lib/dns/dns.tcl
@@ -0,0 +1,1422 @@
+# dns.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Provide a Tcl only Domain Name Service client. See RFC 1034 and RFC 1035
+# for information about the DNS protocol. This should insulate Tcl scripts
+# from problems with using the system library resolver for slow name servers.
+#
+# This implementation uses TCP only for DNS queries. The protocol reccommends
+# that UDP be used in these cases but Tcl does not include UDP sockets by
+# default. The package should be simple to extend to use a TclUDP extension
+# in the future.
+#
+# Support for SPF (http://spf.pobox.com/rfcs.html) will need updating
+# if or when the proposed draft becomes accepted.
+#
+# Support added for RFC1886 - DNS Extensions to support IP version 6
+# Support added for RFC2782 - DNS RR for specifying the location of services
+# Support added for RFC1995 - Incremental Zone Transfer in DNS
+#
+# TODO:
+#  - When using tcp we should make better use of the open connection and
+#    send multiple queries along the same connection.
+#
+#  - We must switch to using TCP for truncated UDP packets.
+#
+#  - Read RFC 2136 - dynamic updating of DNS
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+# $Id: dns.tcl,v 1.35 2007/08/26 00:44:34 patthoyts Exp $
+
+package require Tcl 8.2;                # tcl minimum version
+package require logger;                 # tcllib 1.3
+package require uri;                    # tcllib 1.1
+package require uri::urn;               # tcllib 1.2
+package require ip;                     # tcllib 1.7
+
+namespace eval ::dns {
+    variable version 1.3.2
+    variable rcsid {$Id: dns.tcl,v 1.35 2007/08/26 00:44:34 patthoyts Exp $}
+
+    namespace export configure resolve name address cname \
+        status reset wait cleanup errorcode
+
+    variable options
+    if {![info exists options]} {
+        array set options {
+            port       53
+            timeout    30000
+            protocol   tcp
+            search     {}
+            nameserver {localhost}
+            loglevel   warn
+        }
+        variable log [logger::init dns]
+        ${log}::setlevel $options(loglevel)
+    }
+
+    # We can use either ceptcl or tcludp for UDP support.
+    if {![catch {package require udp 1.0.4} msg]} { ;# tcludp 1.0.4+
+        # If TclUDP 1.0.4 or better is available, use it.
+        set options(protocol) udp
+    } else {
+        if {![catch {package require ceptcl} msg]} {
+            set options(protocol) udp
+        }
+    }
+
+    variable types
+    array set types { 
+        A 1  NS 2  MD 3  MF 4  CNAME 5  SOA 6  MB 7  MG 8  MR 9 
+        NULL 10  WKS 11  PTR 12  HINFO 13  MINFO 14  MX 15  TXT 16
+        SPF 16 AAAA 28 SRV 33 IXFR 251 AXFR 252  MAILB 253  MAILA 254
+        ANY 255 * 255
+    } 
+
+    variable classes
+    array set classes { IN 1  CS 2  CH  3  HS 4  * 255}
+
+    variable uid
+    if {![info exists uid]} {
+        set uid 0
+    }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  Configure the DNS package. In particular the local nameserver will need
+#  to be set. With no options, returns a list of all current settings.
+#
+proc ::dns::configure {args} {
+    variable options
+    variable log
+
+    if {[llength $args] < 1} {
+        set r {}
+        foreach opt [lsort [array names options]] {
+            lappend r -$opt $options($opt)
+        }
+        return $r
+    }
+
+    set cget 0
+    if {[llength $args] == 1} {
+        set cget 1
+    }
+   
+    while {[string match -* [lindex $args 0]]} {
+        switch -glob -- [lindex $args 0] {
+            -n* -
+            -ser* {
+                if {$cget} {
+                    return $options(nameserver) 
+                } else {
+                    set options(nameserver) [Pop args 1] 
+                }
+            }
+            -po*  { 
+                if {$cget} {
+                    return $options(port)
+                } else {
+                    set options(port) [Pop args 1] 
+                }
+            }
+            -ti*  { 
+                if {$cget} {
+                    return $options(timeout)
+                } else {
+                    set options(timeout) [Pop args 1]
+                }
+            }
+            -pr*  {
+                if {$cget} {
+                    return $options(protocol)
+                } else {
+                    set proto [string tolower [Pop args 1]]
+                    if {[string compare udp $proto] == 0 \
+                            && [string compare tcp $proto] == 0} {
+                        return -code error "invalid protocol \"$proto\":\
+                            protocol must be either \"udp\" or \"tcp\""
+                    }
+                    set options(protocol) $proto 
+                }
+            }
+            -sea* { 
+                if {$cget} {
+                    return $options(search)
+                } else {
+                    set options(search) [Pop args 1] 
+                }
+            }
+            -log* {
+                if {$cget} {
+                    return $options(loglevel)
+                } else {
+                    set options(loglevel) [Pop args 1]
+                    ${log}::setlevel $options(loglevel)
+                }
+            }
+            --    { Pop args ; break }
+            default {
+                set opts [join [lsort [array names options]] ", -"]
+                return -code error "bad option [lindex $args 0]:\
+                        must be one of -$opts"
+            }
+        }
+        Pop args
+    }
+
+    return
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  Create a DNS query and send to the specified name server. Returns a token
+#  to be used to obtain any further information about this query.
+#
+proc ::dns::resolve {query args} {
+    variable uid
+    variable options
+    variable log
+
+    # get a guaranteed unique and non-present token id.
+    set id [incr uid]
+    while {[info exists [set token [namespace current]::$id]]} {
+        set id [incr uid]
+    }
+    # FRINK: nocheck
+    variable $token
+    upvar 0 $token state
+
+    # Setup token/state defaults.
+    set state(id)          $id
+    set state(query)       $query
+    set state(qdata)       ""
+    set state(opcode)      0;                   # 0 = query, 1 = inverse query.
+    set state(-type)       A;                   # DNS record type (A address)
+    set state(-class)      IN;                  # IN (internet address space)
+    set state(-recurse)    1;                   # Recursion Desired
+    set state(-command)    {};                  # asynchronous handler
+    set state(-timeout)    $options(timeout);   # connection timeout default.
+    set state(-nameserver) $options(nameserver);# default nameserver
+    set state(-port)       $options(port);      # default namerservers port
+    set state(-search)     $options(search);    # domain search list
+    set state(-protocol)   $options(protocol);  # which protocol udp/tcp
+
+    # Handle DNS URL's
+    if {[string match "dns:*" $query]} {
+        array set URI [uri::split $query]
+        foreach {opt value} [uri::split $query] {
+            if {$value != {} && [info exists state(-$opt)]} {
+                set state(-$opt) $value
+            }   
+        }
+        set state(query) $URI(query)
+        ${log}::debug "parsed query: $query"
+    }
+
+    while {[string match -* [lindex $args 0]]} {
+        switch -glob -- [lindex $args 0] {
+            -n* - ns -
+            -ser* { set state(-nameserver) [Pop args 1] }
+            -po*  { set state(-port) [Pop args 1] }
+            -ti*  { set state(-timeout) [Pop args 1] }
+            -co*  { set state(-command) [Pop args 1] }
+            -cl*  { set state(-class) [Pop args 1] }
+            -ty*  { set state(-type) [Pop args 1] }
+            -pr*  { set state(-protocol) [Pop args 1] }
+            -sea* { set state(-search) [Pop args 1] }
+            -re*  { set state(-recurse) [Pop args 1] }
+            -inv* { set state(opcode) 1 }
+            -status {set state(opcode) 2}
+            -data { set state(qdata) [Pop args 1] }
+            default {
+                set opts [join [lsort [array names state -*]] ", "]
+                return -code error "bad option [lindex $args 0]: \
+                        must be $opts"
+            }
+        }
+        Pop args
+    }
+
+    if {$state(-nameserver) == {}} {
+        return -code error "no nameserver specified"
+    }
+
+    if {$state(-protocol) == "udp"} {
+        if {[llength [package provide ceptcl]] == 0 \
+                && [llength [package provide udp]] == 0} {
+            return -code error "udp support is not available,\
+                get ceptcl or tcludp"
+        }
+    }
+    
+    # Check for reverse lookups
+    if {[regexp {^(?:\d{0,3}\.){3}\d{0,3}$} $state(query)]} {
+        set addr [lreverse [split $state(query) .]]
+        lappend addr in-addr arpa
+        set state(query) [join $addr .]
+        set state(-type) PTR
+    }
+
+    BuildMessage $token
+    
+    if {$state(-protocol) == "tcp"} {
+        TcpTransmit $token
+        if {$state(-command) == {}} {
+            wait $token
+        }
+    } else {
+        UdpTransmit $token
+    }
+    
+    return $token
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  Return a list of domain names returned as results for the last query.
+#
+proc ::dns::name {token} {
+    set r {}
+    Flags $token flags
+    array set reply [Decode $token]
+
+    switch -exact -- $flags(opcode) {
+        0 {
+            # QUERY
+            foreach answer $reply(AN) {
+                array set AN $answer
+                if {![info exists AN(type)]} {set AN(type) {}}
+                switch -exact -- $AN(type) {
+                    MX - NS - PTR {
+                        if {[info exists AN(rdata)]} {lappend r $AN(rdata)}
+                    }
+                    default {
+                        if {[info exists AN(name)]} {
+                            lappend r $AN(name)
+                        }
+                    }
+                }
+            }
+        }
+
+        1 {
+            # IQUERY
+            foreach answer $reply(QD) {
+                array set QD $answer
+                lappend r $QD(name)
+            }
+        }
+        default {
+            return -code error "not supported for this query type"
+        }
+    }
+    return $r
+}
+
+# Description:
+#  Return a list of the IP addresses returned for this query.
+#
+proc ::dns::address {token} {
+    set r {}
+    array set reply [Decode $token]
+    foreach answer $reply(AN) {
+        array set AN $answer
+
+        if {[info exists AN(type)]} {
+            switch -exact -- $AN(type) {
+                "A" {
+                    lappend r $AN(rdata)
+                }
+                "AAAA" {
+                    lappend r $AN(rdata)
+                }
+            }
+        }
+    }
+    return $r
+}
+
+# Description:
+#  Return a list of all CNAME results returned for this query.
+#
+proc ::dns::cname {token} {
+    set r {}
+    array set reply [Decode $token]
+    foreach answer $reply(AN) {
+        array set AN $answer
+
+        if {[info exists AN(type)]} {
+            if {$AN(type) == "CNAME"} {
+                lappend r $AN(rdata)
+            }
+        }
+    }
+    return $r
+}
+
+# Description:
+#   Return the decoded answer records. This can be used for more complex
+#   queries where the answer isn't supported byb cname/address/name.
+proc ::dns::result {token args} {
+    array set reply [eval [linsert $args 0 Decode $token]]
+    return $reply(AN)
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  Get the status of the request.
+#
+proc ::dns::status {token} {
+    upvar #0 $token state
+    return $state(status)
+}
+
+# Description:
+#  Get the error message. Empty if no error.
+#
+proc ::dns::error {token} {
+    upvar #0 $token state
+    if {[info exists state(error)]} {
+	return $state(error)
+    }
+    return ""
+}
+
+# Description
+#  Get the error code. This is 0 for a successful transaction.
+#
+proc ::dns::errorcode {token} {
+    upvar #0 $token state
+    set flags [Flags $token]
+    set ndx [lsearch -exact $flags errorcode]
+    incr ndx
+    return [lindex $flags $ndx]
+}
+
+# Description:
+#  Reset a connection with optional reason.
+#
+proc ::dns::reset {token {why reset} {errormsg {}}} {
+    upvar #0 $token state
+    set state(status) $why
+    if {[string length $errormsg] > 0 && ![info exists state(error)]} {
+        set state(error) $errormsg
+    }
+    catch {fileevent $state(sock) readable {}}
+    Finish $token
+}
+
+# Description:
+#  Wait for a request to complete and return the status.
+#
+proc ::dns::wait {token} {
+    upvar #0 $token state
+
+    if {$state(status) == "connect"} {
+        vwait [subst $token](status)
+    }
+
+    return $state(status)
+}
+
+# Description:
+#  Remove any state associated with this token.
+#
+proc ::dns::cleanup {token} {
+    upvar #0 $token state
+    if {[info exists state]} {
+        catch {close $state(sock)}
+        catch {after cancel $state(after)}
+        unset state
+    }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  Dump the raw data of the request and reply packets.
+#
+proc ::dns::dump {args} {
+    if {[llength $args] == 1} {
+        set type -reply
+        set token [lindex $args 0]
+    } elseif { [llength $args] == 2 } {
+        set type [lindex $args 0]
+        set token [lindex $args 1]
+    } else {
+        return -code error "wrong # args:\
+            should be \"dump ?option? methodName\""
+    }
+
+    # FRINK: nocheck
+    variable $token
+    upvar 0 $token state
+    
+    set result {}
+    switch -glob -- $type {
+        -qu*    -
+        -req*   {
+            set result [DumpMessage $state(request)]
+        }
+        -rep*   {
+            set result [DumpMessage $state(reply)]
+        }
+        default {
+            error "unrecognised option: must be one of \
+                    \"-query\", \"-request\" or \"-reply\""
+        }
+    }
+
+    return $result
+}
+
+# Description:
+#  Perform a hex dump of binary data.
+#
+proc ::dns::DumpMessage {data} {
+    set result {}
+    binary scan $data c* r
+    foreach c $r {
+        append result [format "%02x " [expr {$c & 0xff}]]
+    }
+    return $result
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  Contruct a DNS query packet.
+#
+proc ::dns::BuildMessage {token} {
+    # FRINK: nocheck
+    variable $token
+    upvar 0 $token state
+    variable types
+    variable classes
+    variable options
+
+    if {! [info exists types($state(-type))] } {
+        return -code error "invalid DNS query type"
+    }
+
+    if {! [info exists classes($state(-class))] } {
+        return -code error "invalid DNS query class"
+    }
+
+    set qdcount 0
+    set qsection {}
+    set nscount 0
+    set nsdata {}
+
+    # In theory we can send multiple queries. In practice, named doesn't
+    # appear to like that much. If it did work we'd do this:
+    #  foreach domain [linsert $options(search) 0 {}] ...
+
+
+    # Pack the query: QNAME QTYPE QCLASS
+    set qsection [PackName $state(query)]
+    append qsection [binary format SS \
+                         $types($state(-type))\
+                         $classes($state(-class))]
+    incr qdcount
+
+    if {[string length $state(qdata)] > 0} {
+        set nsdata [eval [linsert $state(qdata) 0 PackRecord]]
+        incr nscount
+    }
+
+    switch -exact -- $state(opcode) {
+        0 {
+            # QUERY
+            set state(request) [binary format SSSSSS $state(id) \
+                [expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \
+                                    $qdcount 0 $nscount 0]
+            append state(request) $qsection $nsdata
+        }
+        1 {
+            # IQUERY            
+            set state(request) [binary format SSSSSS $state(id) \
+                [expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \
+                0 $qdcount 0 0 0]
+            append state(request) \
+                [binary format cSSI 0 \
+                     $types($state(-type)) $classes($state(-class)) 0]
+            switch -exact -- $state(-type) {
+                A {
+                    append state(request) \
+                        [binary format Sc4 4 [split $state(query) .]]
+                }
+                PTR {
+                    append state(request) \
+                        [binary format Sc4 4 [split $state(query) .]]
+                }
+                default {
+                    return -code error "inverse query not supported for this type"
+                }
+            }
+        }
+        default {
+            return -code error "operation not supported"
+        }
+    }
+
+    return
+}
+
+# Pack a human readable dns name into a DNS resource record format.
+proc ::dns::PackName {name} {
+    set data ""
+    foreach part [split [string trim $name .] .] {
+        set len [string length $part]
+        append data [binary format ca$len $len $part]
+    }
+    append data \x00
+    return $data
+}
+
+# Pack a character string - byte length prefixed
+proc ::dns::PackString {text} {
+    set len [string length $text]
+    set data [binary format ca$len $len $text]
+    return $data
+}
+
+# Pack up a single DNS resource record. See RFC1035: 3.2 for the format
+# of each type.
+# eg: PackRecord name wiki.tcl.tk type MX class IN rdata {10 mail.example.com}
+#
+proc ::dns::PackRecord {args} {
+    variable types
+    variable classes
+    array set rr {name "" type A class IN ttl 0 rdlength 0 rdata ""}
+    array set rr $args
+    set data [PackName $rr(name)]
+
+    switch -exact -- $rr(type) {
+        CNAME - MB - MD - MF - MG - MR - NS - PTR {
+            set rr(rdata) [PackName $rr(rdata)] 
+        }
+        HINFO { 
+            array set r {CPU {} OS {}}
+            array set r $rr(rdata)
+            set rr(rdata) [PackString $r(CPU)]
+            append rr(rdata) [PackString $r(OS)]
+        }
+        MINFO {
+            array set r {RMAILBX {} EMAILBX {}}
+            array set r $rr(rdata)
+            set rr(rdata) [PackString $r(RMAILBX)]
+            append rr(rdata) [PackString $r(EMAILBX)]
+        }
+        MX {
+            foreach {pref exch} $rr(rdata) break
+            set rr(rdata) [binary format S $pref]
+            append rr(rdata) [PackName $exch]
+        }
+        TXT {
+            set str $rr(rdata)
+            set len [string length [set str $rr(rdata)]]
+            set rr(rdata) ""
+            for {set n 0} {$n < $len} {incr n} {
+                set s [string range $str $n [incr n 253]]
+                append rr(rdata) [PackString $s]
+            }
+        }          
+        NULL {}
+        SOA {
+            array set r {MNAME {} RNAME {}
+                SERIAL 0 REFRESH 0 RETRY 0 EXPIRE 0 MINIMUM 0}
+            array set r $rr(rdata)
+            set rr(rdata) [PackName $r(MNAME)]
+            append rr(rdata) [PackName $r(RNAME)]
+            append rr(rdata) [binary format IIIII $r(SERIAL) \
+                                  $r(REFRESH) $r(RETRY) $r(EXPIRE) $r(MINIMUM)]
+        }
+    }
+
+    # append the root label and the type flag and query class.
+    append data [binary format SSIS $types($rr(type)) \
+                     $classes($rr(class)) $rr(ttl) [string length $rr(rdata)]]
+    append data $rr(rdata)
+    return $data
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  Transmit a DNS request over a tcp connection.
+#
+proc ::dns::TcpTransmit {token} {
+    # FRINK: nocheck
+    variable $token
+    upvar 0 $token state
+
+    # setup the timeout
+    if {$state(-timeout) > 0} {
+        set state(after) [after $state(-timeout) \
+                              [list [namespace origin reset] \
+                                   $token timeout\
+                                   "operation timed out"]]
+    }
+
+    # Sometimes DNS servers drop TCP requests. So it's better to
+    # use asynchronous connect
+    set s [socket -async $state(-nameserver) $state(-port)]
+    fileevent $s writable [list [namespace origin TcpConnected] $token $s]
+    set state(sock) $s
+    set state(status) connect
+
+    return $token
+}
+
+proc ::dns::TcpConnected {token s} {
+    variable $token
+    upvar 0 $token state
+
+    fileevent $s writable {}
+    if {[catch {fconfigure $s -peername}]} {
+	# TCP connection failed
+        Finish $token "can't connect to server"
+	return
+    }
+
+    fconfigure $s -blocking 0 -translation binary -buffering none
+
+    # For TCP the message must be prefixed with a 16bit length field.
+    set req [binary format S [string length $state(request)]]
+    append req $state(request)
+
+    puts -nonewline $s $req
+
+    fileevent $s readable [list [namespace current]::TcpEvent $token]
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#  Transmit a DNS request using UDP datagrams
+#
+# Note:
+#  This requires a UDP implementation that can transmit binary data.
+#  As yet I have been unable to test this myself and the tcludp package
+#  cannot do this.
+#
+proc ::dns::UdpTransmit {token} {
+    # FRINK: nocheck
+    variable $token
+    upvar 0 $token state
+
+    # setup the timeout
+    if {$state(-timeout) > 0} {
+        set state(after) [after $state(-timeout) \
+                              [list [namespace origin reset] \
+                                   $token timeout\
+                                  "operation timed out"]]
+    }
+    
+    if {[llength [package provide ceptcl]] > 0} {
+        # using ceptcl
+        set state(sock) [cep -type datagram $state(-nameserver) $state(-port)]
+        fconfigure $state(sock) -blocking 0
+    } else {
+        # using tcludp
+        set state(sock) [udp_open]
+        udp_conf $state(sock) $state(-nameserver) $state(-port)
+    }
+    fconfigure $state(sock) -translation binary -buffering none
+    set state(status) connect
+    puts -nonewline $state(sock) $state(request)
+    
+    fileevent $state(sock) readable [list [namespace current]::UdpEvent $token]
+    
+    return $token
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  Tidy up after a tcp transaction.
+#
+proc ::dns::Finish {token {errormsg ""}} {
+    # FRINK: nocheck
+    variable $token
+    upvar 0 $token state
+    global errorInfo errorCode
+
+    if {[string length $errormsg] != 0} {
+	set state(error) $errormsg
+	set state(status) error
+    }
+    catch {close $state(sock)}
+    catch {after cancel $state(after)}
+    if {[info exists state(-command)] && $state(-command) != {}} {
+	if {[catch {eval $state(-command) {$token}} err]} {
+	    if {[string length $errormsg] == 0} {
+		set state(error) [list $err $errorInfo $errorCode]
+		set state(status) error
+	    }
+	}
+        if {[info exists state(-command)]} {
+            unset state(-command)
+        }
+    }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  Handle end-of-file on a tcp connection.
+#
+proc ::dns::Eof {token} {
+    # FRINK: nocheck
+    variable $token
+    upvar 0 $token state
+    set state(status) eof
+    Finish $token
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  Process a DNS reply packet (protocol independent)
+#
+proc ::dns::Receive {token} {
+    # FRINK: nocheck
+    variable $token
+    upvar 0 $token state
+
+    binary scan $state(reply) SS id flags
+    set status [expr {$flags & 0x000F}]
+
+    switch -- $status {
+        0 {
+            set state(status) ok
+            Finish $token 
+        }
+        1 { Finish $token "Format error - unable to interpret the query." }
+        2 { Finish $token "Server failure - internal server error." }
+        3 { Finish $token "Name Error - domain does not exist" }
+        4 { Finish $token "Not implemented - the query type is not available." }
+        5 { Finish $token "Refused - your request has been refused by the server." }
+        default {
+            Finish $token "unrecognised error code: $err"
+        }
+    }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  file event handler for tcp socket. Wait for the reply data.
+#
+proc ::dns::TcpEvent {token} {
+    variable log
+    # FRINK: nocheck
+    variable $token
+    upvar 0 $token state
+    set s $state(sock)
+
+    if {[eof $s]} {
+        Eof $token
+        return
+    }
+
+    set status [catch {read $state(sock)} result]
+    if {$status != 0} {
+        ${log}::debug "Event error: $result"
+        Finish $token "error reading data: $result"
+    } elseif { [string length $result] >= 0 } {
+        if {[catch {
+            # Handle incomplete reads - check the size and keep reading.
+            if {![info exists state(size)]} {
+                binary scan $result S state(size)
+                set result [string range $result 2 end]            
+            }
+            append state(reply) $result
+            
+            # check the length and flags and chop off the tcp length prefix.
+            if {[string length $state(reply)] >= $state(size)} {
+                binary scan $result S id
+                set id [expr {$id & 0xFFFF}]
+                if {$id != [expr {$state(id) & 0xFFFF}]} {
+                    ${log}::error "received packed with incorrect id"
+                }
+                # bug #1158037 - doing this causes problems > 65535 requests!
+                #Receive [namespace current]::$id
+                Receive $token
+            } else {
+                ${log}::debug "Incomplete tcp read:\
+                   [string length $state(reply)] should be $state(size)"
+            }
+        } err]} {
+            Finish $token "Event error: $err"
+        }
+    } elseif { [eof $state(sock)] } {
+        Eof $token
+    } elseif { [fblocked $state(sock)] } {
+        ${log}::debug "Event blocked"
+    } else {
+        ${log}::critical "Event error: this can't happen!"
+        Finish $token "Event error: this can't happen!"
+    }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  file event handler for udp sockets.
+proc ::dns::UdpEvent {token} {
+    # FRINK: nocheck
+    variable $token
+    upvar 0 $token state
+    set s $state(sock)
+
+    set payload [read $state(sock)]
+    append state(reply) $payload
+
+    binary scan $payload S id
+    set id [expr {$id & 0xFFFF}]
+    if {$id != [expr {$state(id) & 0xFFFF}]} {
+        ${log}::error "received packed with incorrect id"
+    }
+    # bug #1158037 - doing this causes problems > 65535 requests!
+    #Receive [namespace current]::$id
+    Receive $token
+}
+    
+# -------------------------------------------------------------------------
+
+proc ::dns::Flags {token {varname {}}} {
+    # FRINK: nocheck
+    variable $token
+    upvar 0 $token state
+    
+    if {$varname != {}} {
+        upvar $varname flags
+    }
+
+    array set flags {query 0 opcode 0 authoritative 0 errorcode 0
+        truncated 0 recursion_desired 0 recursion_allowed 0}
+
+    binary scan $state(reply) SSSSSS mid hdr nQD nAN nNS nAR
+
+    set flags(response)           [expr {($hdr & 0x8000) >> 15}]
+    set flags(opcode)             [expr {($hdr & 0x7800) >> 11}]
+    set flags(authoritative)      [expr {($hdr & 0x0400) >> 10}]
+    set flags(truncated)          [expr {($hdr & 0x0200) >> 9}]
+    set flags(recursion_desired)  [expr {($hdr & 0x0100) >> 8}]
+    set flafs(recursion_allowed)  [expr {($hdr & 0x0080) >> 7}]
+    set flags(errorcode)          [expr {($hdr & 0x000F)}]
+
+    return [array get flags]
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  Decode a DNS packet (either query or response).
+#
+proc ::dns::Decode {token args} {
+    variable log
+    # FRINK: nocheck
+    variable $token
+    upvar 0 $token state
+
+    array set opts {-rdata 0 -query 0}
+    while {[string match -* [set option [lindex $args 0]]]} {
+        switch -exact -- $option {
+            -rdata { set opts(-rdata) 1 }
+            -query { set opts(-query) 1 }
+            default {
+                return -code error "bad option \"$option\":\
+                    must be -rdata"
+            }
+        }
+        Pop args
+    }
+
+    if {$opts(-query)} {
+        binary scan $state(request) SSSSSSc* mid hdr nQD nAN nNS nAR data
+    } else {
+        binary scan $state(reply) SSSSSSc* mid hdr nQD nAN nNS nAR data
+    }
+
+    set fResponse      [expr {($hdr & 0x8000) >> 15}]
+    set fOpcode        [expr {($hdr & 0x7800) >> 11}]
+    set fAuthoritative [expr {($hdr & 0x0400) >> 10}]
+    set fTrunc         [expr {($hdr & 0x0200) >> 9}]
+    set fRecurse       [expr {($hdr & 0x0100) >> 8}]
+    set fCanRecurse    [expr {($hdr & 0x0080) >> 7}]
+    set fRCode         [expr {($hdr & 0x000F)}]
+    set flags ""
+
+    if {$fResponse} {set flags "QR"} else {set flags "Q"}
+    set opcodes [list QUERY IQUERY STATUS]
+    lappend flags [lindex $opcodes $fOpcode]
+    if {$fAuthoritative} {lappend flags "AA"}
+    if {$fTrunc} {lappend flags "TC"}
+    if {$fRecurse} {lappend flags "RD"}
+    if {$fCanRecurse} {lappend flags "RA"}
+
+    set info "ID: $mid\
+              Fl: [format 0x%02X [expr {$hdr & 0xFFFF}]] ($flags)\
+              NQ: $nQD\
+              NA: $nAN\
+              NS: $nNS\
+              AR: $nAR"
+    ${log}::debug $info
+
+    set ndx 12
+    set r {}
+    set QD [ReadQuestion $nQD $state(reply) ndx]
+    lappend r QD $QD
+    set AN [ReadAnswer $nAN $state(reply) ndx $opts(-rdata)]
+    lappend r AN $AN
+    set NS [ReadAnswer $nNS $state(reply) ndx $opts(-rdata)]
+    lappend r NS $NS
+    set AR [ReadAnswer $nAR $state(reply) ndx $opts(-rdata)]
+    lappend r AR $AR
+    return $r
+}
+
+# -------------------------------------------------------------------------
+
+proc ::dns::Expand {data} {
+    set r {}
+    binary scan $data c* d
+    foreach c $d {
+        lappend r [expr {$c & 0xFF}]
+    }
+    return $r
+}
+
+
+# -------------------------------------------------------------------------
+# Description:
+#  Pop the nth element off a list. Used in options processing.
+#
+proc ::dns::Pop {varname {nth 0}} {
+    upvar $varname args
+    set r [lindex $args $nth]
+    set args [lreplace $args $nth $nth]
+    return $r
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Reverse a list. Code from http://wiki.tcl.tk/tcl/43
+#
+proc ::dns::lreverse {lst} {
+    set res {}
+    set i [llength $lst]
+    while {$i} {lappend res [lindex $lst [incr i -1]]}
+    return $res
+}
+
+# -------------------------------------------------------------------------
+
+proc ::dns::KeyOf {arrayname value {default {}}} {
+    upvar $arrayname array
+    set lst [array get array]
+    set ndx [lsearch -exact $lst $value]
+    if {$ndx != -1} {
+        incr ndx -1
+        set r [lindex $lst $ndx]
+    } else {
+        set r $default
+    }
+    return $r
+}
+
+
+# -------------------------------------------------------------------------
+# Read the question section from a DNS message. This always starts at index
+# 12 of a message but may be of variable length.
+#
+proc ::dns::ReadQuestion {nitems data indexvar} {
+    variable types
+    variable classes
+    upvar $indexvar index
+    set result {}
+
+    for {set cn 0} {$cn < $nitems} {incr cn} {
+        set r {}
+        lappend r name [ReadName data $index offset]
+        incr index $offset
+        
+        # Read off QTYPE and QCLASS for this query.
+        set ndx $index
+        incr index 3
+        binary scan [string range $data $ndx $index] SS qtype qclass
+        set qtype [expr {$qtype & 0xFFFF}]
+        set qclass [expr {$qclass & 0xFFFF}]
+        incr index
+        lappend r type [KeyOf types $qtype $qtype] \
+                  class [KeyOf classes $qclass $qclass]
+        lappend result $r
+    }
+    return $result
+}
+        
+# -------------------------------------------------------------------------
+
+# Read an answer section from a DNS message. 
+#
+proc ::dns::ReadAnswer {nitems data indexvar {raw 0}} {
+    variable types
+    variable classes
+    upvar $indexvar index
+    set result {}
+
+    for {set cn 0} {$cn < $nitems} {incr cn} {
+        set r {}
+        lappend r name [ReadName data $index offset]
+        incr index $offset
+        
+        # Read off TYPE, CLASS, TTL and RDLENGTH
+        binary scan [string range $data $index end] SSIS type class ttl rdlength
+
+        set type [expr {$type & 0xFFFF}]
+        set type [KeyOf types $type $type]
+
+        set class [expr {$class & 0xFFFF}]
+        set class [KeyOf classes $class $class]
+
+        set ttl [expr {$ttl & 0xFFFFFFFF}]
+        set rdlength [expr {$rdlength & 0xFFFF}]
+        incr index 10
+        set rdata [string range $data $index [expr {$index + $rdlength - 1}]]
+
+        if {! $raw} {
+            switch -- $type {
+                A {
+                    set rdata [join [Expand $rdata] .]
+                }
+                AAAA {
+                    set rdata [ip::contract [ip::ToString $rdata]]
+                }
+                NS - CNAME - PTR {
+                    set rdata [ReadName data $index off] 
+                }
+                MX {
+                    binary scan $rdata S preference
+                    set exchange [ReadName data [expr {$index + 2}] off]
+                    set rdata [list $preference $exchange]
+                }
+                SRV {
+                    set x $index
+                    set rdata [list priority [ReadUShort data $x off]]
+                    incr x $off
+                    lappend rdata weight [ReadUShort data $x off]
+                    incr x $off
+                    lappend rdata port [ReadUShort data $x off]
+                    incr x $off
+                    lappend rdata target [ReadName data $x off]
+                    incr x $off
+                }
+                TXT {
+                    set rdata [ReadString data $index $rdlength]
+                }
+                SOA {
+                    set x $index
+                    set rdata [list MNAME [ReadName data $x off]]
+                    incr x $off 
+                    lappend rdata RNAME [ReadName data $x off]
+                    incr x $off
+                    lappend rdata SERIAL [ReadULong data $x off]
+                    incr x $off
+                    lappend rdata REFRESH [ReadLong data $x off]
+                    incr x $off
+                    lappend rdata RETRY [ReadLong data $x off]
+                    incr x $off
+                    lappend rdata EXPIRE [ReadLong data $x off]
+                    incr x $off
+                    lappend rdata MINIMUM [ReadULong data $x off]
+                    incr x $off
+                }
+            }
+        }
+
+        incr index $rdlength
+        lappend r type $type class $class ttl $ttl rdlength $rdlength rdata $rdata
+        lappend result $r
+    }
+    return $result
+}
+
+
+# Read a 32bit integer from a DNS packet. These are compatible with
+# the ReadName proc. Additionally - ReadULong takes measures to ensure 
+# the unsignedness of the value obtained.
+#
+proc ::dns::ReadLong {datavar index usedvar} {
+    upvar $datavar data
+    upvar $usedvar used
+    set r {}
+    set used 0
+    if {[binary scan $data @${index}I r]} {
+        set used 4
+    }
+    return $r
+}
+
+proc ::dns::ReadULong {datavar index usedvar} {
+    upvar $datavar data
+    upvar $usedvar used
+    set r {}
+    set used 0
+    if {[binary scan $data @${index}cccc b1 b2 b3 b4]} {
+        set used 4
+        # This gets us an unsigned value.
+        set r [expr {($b4 & 0xFF) + (($b3 & 0xFF) << 8) 
+                     + (($b2 & 0xFF) << 16) + ($b1 << 24)}] 
+    }
+    return $r
+}
+
+proc ::dns::ReadUShort {datavar index usedvar} {
+    upvar $datavar data
+    upvar $usedvar used
+    set r {}
+    set used 0
+    if {[binary scan [string range $data $index end] cc b1 b2]} {
+        set used 2
+        # This gets us an unsigned value.
+        set r [expr {(($b2 & 0xff) + (($b1 & 0xff) << 8)) & 0xffff}] 
+    }
+    return $r
+}
+
+# Read off the NAME or QNAME element. This reads off each label in turn, 
+# dereferencing pointer labels until we have finished. The length of data
+# used is passed back using the usedvar variable.
+#
+proc ::dns::ReadName {datavar index usedvar} {
+    upvar $datavar data
+    upvar $usedvar used
+    set startindex $index
+
+    set r {}
+    set len 1
+    set max [string length $data]
+    
+    while {$len != 0 && $index < $max} {
+        # Read the label length (and preread the pointer offset)
+        binary scan [string range $data $index end] cc len lenb
+        set len [expr {$len & 0xFF}]
+        incr index
+        
+        if {$len != 0} {
+            if {[expr {$len & 0xc0}]} {
+                binary scan [binary format cc [expr {$len & 0x3f}] [expr {$lenb & 0xff}]] S offset
+                incr index
+                lappend r [ReadName data $offset junk]
+                set len 0
+            } else {
+                lappend r [string range $data $index [expr {$index + $len - 1}]]
+                incr index $len
+            }
+        }
+    }
+    set used [expr {$index - $startindex}]
+    return [join $r .]
+}
+
+proc ::dns::ReadString {datavar index length} {
+    upvar $datavar data
+    set startindex $index
+
+    set r {}
+    set max [expr {$index + $length}]
+
+    while {$index < $max} {
+        binary scan [string range $data $index end] c len
+        set len [expr {$len & 0xFF}]
+        incr index
+
+        if {$len != 0} {
+            append r [string range $data $index [expr {$index + $len - 1}]]
+            incr index $len
+        }
+    }
+    return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Support for finding the local nameservers
+#
+# For unix we can just parse the /etc/resolv.conf if it exists.
+# Of course, some unices use /etc/resolver and other things (NIS for instance)
+# On Windows, we can examine the Internet Explorer settings from the registry.
+#
+switch -exact $::tcl_platform(platform) {
+    windows {
+        proc ::dns::nameservers {} {
+            package require registry
+            set base {HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services}
+            set param "$base\\Tcpip\\Parameters"
+            set interfaces "$param\\Interfaces"
+            set nameservers {}
+            if {[string equal $::tcl_platform(os) "Windows NT"]} {
+                AppendRegistryValue $param NameServer nameservers
+                AppendRegistryValue $param DhcpNameServer nameservers
+                foreach i [registry keys $interfaces] {
+                    AppendRegistryValue "$interfaces\\$i" NameServer nameservers
+                    AppendRegistryValue "$interfaces\\$i" DhcpNameServer nameservers
+                }
+            } else {
+                set param "$base\\VxD\\MSTCP"
+                AppendRegistryValue $param NameServer nameservers
+            }
+            return $nameservers
+        }
+        proc ::dns::AppendRegistryValue {key val listName} {
+            upvar $listName lst
+            if {![catch {registry get $key $val} v]} {
+                foreach ns [split $v ", "] {
+                    if {[lsearch -exact $lst $ns] == -1} {
+                        lappend lst $ns
+                    }
+                }
+            }
+        }
+    }
+    unix {
+        proc ::dns::nameservers {} {
+            set nameservers {}
+            if {[file readable /etc/resolv.conf]} {
+                set f [open /etc/resolv.conf r]
+                while {![eof $f]} {
+                    gets $f line
+                    if {[regexp {^\s*nameserver\s+(.*)$} $line -> ns]} {
+                        lappend nameservers $ns
+                    }
+                }
+                close $f
+            }
+            if {[llength $nameservers] < 1} {
+                lappend nameservers 127.0.0.1
+            }
+            return $nameservers
+        }
+    }
+    default {
+        proc ::dns::nameservers {} {
+            return -code error "command not supported for this platform."
+        }
+    }
+}
+
+# -------------------------------------------------------------------------
+# Possible support for the DNS URL scheme.
+# Ref: http://www.ietf.org/internet-drafts/draft-josefsson-dns-url-04.txt
+# eg: dns:target?class=IN;type=A
+#     dns://nameserver/target?type=A
+#
+# URI quoting to be accounted for.
+#
+
+catch {
+    uri::register {dns} {
+        set escape     [set [namespace parent [namespace current]]::basic::escape]
+        set host       [set [namespace parent [namespace current]]::basic::host]
+        set hostOrPort [set [namespace parent [namespace current]]::basic::hostOrPort]
+
+        set class [string map {* \\\\*} \
+                       "class=([join [array names ::dns::classes] {|}])"]
+        set type  [string map {* \\\\*} \
+                       "type=([join [array names ::dns::types] {|}])"]
+        set classOrType "(?:${class}|${type})"
+        set classOrTypeSpec "(?:${class}|${type})(?:;(?:${class}|${type}))?"
+
+        set query "${host}(${classOrTypeSpec})?"
+        variable schemepart "(//${hostOrPort}/)?(${query})"
+        variable url "dns:$schemepart"
+    }
+}
+
+namespace eval ::uri {} ;# needed for pkg_mkIndex.
+
+proc ::uri::SplitDns {uri} {
+    upvar \#0 [namespace current]::dns::schemepart schemepart
+    upvar \#0 [namespace current]::dns::class classOrType
+    upvar \#0 [namespace current]::dns::class classRE
+    upvar \#0 [namespace current]::dns::type typeRE
+    upvar \#0 [namespace current]::dns::classOrTypeSpec classOrTypeSpec
+
+    array set parts {nameserver {} query {} class {} type {} port {}}
+
+    # validate the uri
+    if {[regexp -- $dns::schemepart $uri r] == 1} {
+
+        # deal with the optional class and type specifiers
+        if {[regexp -indices -- "${classOrTypeSpec}$" $uri range]} {
+            set spec [string range $uri [lindex $range 0] [lindex $range 1]]
+            set uri [string range $uri 0 [expr {[lindex $range 0] - 2}]]
+
+            if {[regexp -- "$classRE" $spec -> class]} {
+                set parts(class) $class
+            }
+            if {[regexp -- "$typeRE" $spec -> type]} {
+                set parts(type) $type
+            }
+        }
+
+        # Handle the nameserver specification
+        if {[string match "//*" $uri]} {
+            set uri [string range $uri 2 end]
+            array set tmp [GetHostPort uri]
+            set parts(nameserver) $tmp(host)
+            set parts(port) $tmp(port)
+        }
+        
+        # what's left is the query domain name.
+        set parts(query) [string trimleft $uri /]
+    }
+
+    return [array get parts]
+}
+
+proc ::uri::JoinDns {args} {
+    array set parts {nameserver {} port {} query {} class {} type {}}
+    array set parts $args
+    set query [::uri::urn::quote $parts(query)]
+    if {$parts(type) != {}} {
+        append query "?type=$parts(type)"
+    }
+    if {$parts(class) != {}} {
+        if {$parts(type) == {}} {
+            append query "?class=$parts(class)"
+        } else {
+            append query ";class=$parts(class)"
+        }
+    }
+    if {$parts(nameserver) != {}} {
+        set ns "$parts(nameserver)"
+        if {$parts(port) != {}} {
+            append ns ":$parts(port)"
+        }
+        set query "//${ns}/${query}"
+    }
+    return "dns:$query"
+}
+
+# -------------------------------------------------------------------------
+
+catch {dns::configure -nameserver [lindex [dns::nameservers] 0]}
+
+package provide dns $dns::version
+
+# -------------------------------------------------------------------------
+# Local Variables:
+#   indent-tabs-mode: nil
+# End:
diff --git a/lib/dns/ip.tcl b/lib/dns/ip.tcl
new file mode 100644
index 0000000..1efb4d2
--- /dev/null
+++ b/lib/dns/ip.tcl
@@ -0,0 +1,369 @@
+# ip.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Internet address manipulation.
+#
+# RFC 3513: IPv6 addressing.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+# $Id: ip.tcl,v 1.12 2007/08/20 20:03:04 andreas_kupries Exp $
+
+# @mdgen EXCLUDE: ipMoreC.tcl
+
+package require Tcl 8.2;                # tcl minimum version
+
+namespace eval ip {
+    variable version 1.1.2
+    variable rcsid {$Id: ip.tcl,v 1.12 2007/08/20 20:03:04 andreas_kupries Exp $}
+
+    namespace export is version normalize equal type contract mask
+    #catch {namespace ensemble create}
+
+    variable IPv4Ranges
+    if {![info exists IPv4Ranges]} {
+        array set IPv4Ranges {
+            0/8        private
+            10/8       private
+            127/8      private
+            172.16/12  private
+            192.168/16 private
+            223/8      reserved
+            224/3      reserved
+        }
+    }
+
+    variable IPv6Ranges
+    if {![info exists IPv6Ranges]} {
+        # RFC 3513: 2.4
+        # RFC 3056: 2
+        array set IPv6Ranges {
+            2002::/16 "6to4 unicast"
+            fe80::/10 "link local"
+            fec0::/10 "site local"
+            ff00::/8  "multicast"
+            ::/128    "unspecified"
+            ::1/128   "localhost"
+        }
+    }
+}
+
+proc ::ip::is {class ip} {
+    foreach {ip mask} [split $ip /] break
+    switch -exact -- $class {
+        ipv4 - IPv4 - 4 {
+            return [IPv4? $ip]
+        }
+        ipv6 - IPv6 - 6 {
+            return [IPv6? $ip]
+        }
+        default {
+            return -code error "bad class \"$class\": must be ipv4 or ipv6"
+        }
+    }
+}
+
+proc ::ip::version {ip} {
+    set version -1
+    foreach {addr mask} [split $ip /] break
+    if {[string first $addr :] < 0 && [IPv4? $addr]} {
+        set version 4
+    } elseif {[IPv6? $addr]} {
+        set version 6
+    }
+    return $version
+}
+        
+proc ::ip::equal {lhs rhs} {
+    foreach {LHS LM} [SplitIp $lhs] break
+    foreach {RHS RM} [SplitIp $rhs] break
+    if {[set version [version $LHS]] != [version $RHS]} {
+        return -code error "type mismatch:\
+            cannot compare different address types"
+    }
+    if {$version == 4} {set fmt I} else {set fmt I4}
+    set LHS [Mask$version [Normalize $LHS $version] $LM]
+    set RHS [Mask$version [Normalize $RHS $version] $RM]
+    binary scan $LHS $fmt LLL
+    binary scan $RHS $fmt RRR
+    foreach L $LLL R $RRR {
+        if {$L != $R} {return 0}
+    }
+    return 1
+}
+
+proc ::ip::normalize {ip {Ip4inIp6 0}} {
+    foreach {ip mask} [SplitIp $ip] break
+    set version [version $ip]
+    set s [ToString [Normalize $ip $version] $Ip4inIp6]
+    if {($version == 6 && $mask != 128) || ($version == 4 && $mask != 32)} {
+        append s /$mask
+    }
+    return $s
+}
+
+proc ::ip::contract {ip} {
+    foreach {ip mask} [SplitIp $ip] break
+    set version [version $ip]
+    set s [ToString [Normalize $ip $version]]
+    if {$version == 6} {
+        set r ""
+        foreach o [split $s :] { 
+            append r [format %x: 0x$o] 
+        }
+        set r [string trimright $r :]
+        regsub {(?:^|:)0(?::0)+(?::|$)} $r {::} r
+    } else {
+        set r [string trimright $s .0]
+    }
+    return $r
+}
+
+# Returns an IP address prefix.
+# For instance: 
+#  prefix 192.168.1.4/16 => 192.168.0.0
+#  prefix fec0::4/16     => fec0:0:0:0:0:0:0:0
+#  prefix fec0::4/ffff:: => fec0:0:0:0:0:0:0:0
+#
+proc ::ip::prefix {ip} {
+    foreach {addr mask} [SplitIp $ip] break
+    set version [version $addr]
+    set addr [Normalize $addr $version]
+    return [ToString [Mask$version $addr $mask]]
+}
+
+# Return the address type. For IPv4 this is one of private, reserved 
+# or normal
+# For IPv6 it is one of site local, link local, multicast, unicast,
+# unspecified or loopback.
+proc ::ip::type {ip} {
+    set version [version $ip]
+    upvar [namespace current]::IPv${version}Ranges types
+    set ip [prefix $ip]
+    foreach prefix [array names types] {
+        set mask [mask $prefix]
+        if {[equal $ip/$mask $prefix]} {
+            return $types($prefix)
+        }
+    }
+    if {$version == 4} {
+        return "normal"
+    } else {
+        return "unicast"
+    }
+}
+
+proc ::ip::mask {ip} {
+    foreach {addr mask} [split $ip /] break
+    return $mask
+}
+
+# -------------------------------------------------------------------------
+
+# Returns true is the argument can be converted into an IPv4 address.
+#
+proc ::ip::IPv4? {ip} {
+    if {[catch {Normalize4 $ip}]} {
+        return 0
+    }
+    return 1
+}
+
+proc ::ip::IPv6? {ip} {
+    set octets [split $ip :]
+    if {[llength $octets] < 3 || [llength $octets] > 8} {
+        return 0
+    }
+    set ndx 0
+    foreach octet $octets {
+        incr ndx
+        if {[string length $octet] < 1} continue
+        if {[regexp {^[a-fA-F\d]{1,4}$} $octet]} continue
+        if {$ndx >= [llength $octets] && [IPv4? $octet]} continue
+        if {$ndx == 2 && [lindex $octets 0] == 2002 && [IPv4? $octet]} continue
+        #"Invalid IPv6 address \"$ip\""
+        return 0
+    }
+    if {[regexp {^:[^:]} $ip]} {
+        #"Invalid ipv6 address \"$ip\" (starts with :)"
+        return 0
+    }
+    if {[regexp {[^:]:$} $ip]} {
+        # "Invalid IPv6 address \"$ip\" (ends with :)"
+        return 0
+    }
+    if {[regsub -all :: $ip "|" junk] > 1} {
+        # "Invalid IPv6 address \"$ip\" (more than one :: pattern)"
+        return 0
+    }
+    return 1
+}
+
+proc ::ip::Mask4 {ip {bits {}}} {
+    if {[string length $bits] < 1} { set bits 32 }
+    binary scan $ip I ipx
+    if {[string is integer $bits]} {
+        set mask [expr {(0xFFFFFFFF << (32 - $bits)) & 0xFFFFFFFF}]
+    } else {
+        binary scan [Normalize4 $bits] I mask
+    }
+    return [binary format I [expr {$ipx & $mask}]]
+}
+
+proc ::ip::Mask6 {ip {bits {}}} {
+    if {[string length $bits] < 1} { set bits 128 }
+    if {[string is integer $bits]} {
+        set mask [binary format B128 [string repeat 1 $bits]]
+    } else {
+        binary scan [Normalize6 $bits] I4 mask
+    }
+    binary scan $ip I4 Addr
+    binary scan $mask I4 Mask
+    foreach A $Addr M $Mask {
+        lappend r [expr {$A & $M}]
+    }
+    return [binary format I4 $r]
+}
+
+        
+
+# A network address specification is an IPv4 address with an optional bitmask
+# Split an address specification into a IPv4 address and a network bitmask.
+# This doesn't validate the address portion.
+# If a spec with no mask is provided then the mask will be 32
+# (all bits significant).
+# Masks may be either integer number of significant bits or dotted-quad
+# notation.
+#
+proc ::ip::SplitIp {spec} {
+    set slash [string last / $spec]
+    if {$slash != -1} {
+        incr slash -1
+        set ip [string range $spec 0 $slash]
+        incr slash 2
+        set bits [string range $spec $slash end]
+    } else {
+        set ip $spec
+        if {[string length $ip] > 0 && [version $ip] == 6} {
+            set bits 128
+        } else {
+            set bits 32
+        }
+    }
+    return [list $ip $bits]
+}
+
+# Given an IP string from the user, convert to a normalized internal rep.
+# For IPv4 this is currently a hex string (0xHHHHHHHH).
+# For IPv6 this is a binary string or 16 chars.
+proc ::ip::Normalize {ip {version 0}} {
+    if {$version < 0} {
+        set version [version $ip]
+        if {$version < 0} {
+            return -code error "invalid address \"$ip\":\
+                value must be a valid IPv4 or IPv6 address"
+        }
+    }
+    return [Normalize$version $ip]
+}
+
+proc ::ip::Normalize4 {ip} {
+    set octets [split $ip .]
+    if {[llength $octets] > 4} {
+        return -code error "invalid ip address \"$ip\""
+    } elseif {[llength $octets] < 4} {
+        set octets [lrange [concat $octets 0 0 0] 0 3]
+    }
+    foreach oct $octets {
+        if {$oct < 0 || $oct > 255} {
+            return -code error "invalid ip address"
+        }
+    }
+    return [binary format c4 $octets]
+}
+
+proc ::ip::Normalize6 {ip} {
+    set octets [split $ip :]
+    set ip4embed [string first . $ip]
+    set len [llength $octets]
+    if {$len < 0 || $len > 8} {
+        return -code error "invalid address: this is not an IPv6 address"
+    }
+    set result ""
+    for {set n 0} {$n < $len} {incr n} {
+        set octet [lindex $octets $n]
+        if {$octet == {}} {
+            if {$n == 0 || $n == ($len - 1)} {
+                set octet \0\0
+            } else {
+                set missing [expr {9 - $len}]
+                if {$ip4embed != -1} {incr missing -1}
+                set octet [string repeat \0\0 $missing]
+            }
+        } elseif {[string first . $octet] != -1} {
+            set octet [Normalize4 $octet]
+        } else {
+            set m [expr {4 - [string length $octet]}]
+            if {$m != 0} {
+                set octet [string repeat 0 $m]$octet
+            }
+            set octet [binary format H4 $octet]
+        }
+        append result $octet
+    }
+    if {[string length $result] != 16} {
+        return -code error "invalid address: \"$ip\" is not an IPv6 address"
+    }
+    return $result
+}
+
+
+# This will convert a full ipv4/ipv6 in binary format into a normal
+# expanded string rep.
+proc ::ip::ToString {bin {Ip4inIp6 0}} {
+    set len [string length $bin]
+    set r ""
+    if {$len == 4} {
+        binary scan $bin c4 octets
+        foreach octet $octets {
+            lappend r [expr {$octet & 0xff}]
+        }
+        return [join $r .]
+    } elseif {$len == 16} {
+        if {$Ip4inIp6 == 0} {
+            binary scan $bin H32 hex
+            for {set n 0} {$n < 32} {incr n} {
+                append r [string range $hex $n [incr n 3]]:
+            }
+            return [string trimright $r :]
+        } else {
+            binary scan $bin H24c4 hex octets
+            for {set n 0} {$n < 24} {incr n} {
+                append r [string range $hex $n [incr n 3]]:
+            }
+            foreach octet $octets {
+                append r [expr {$octet & 0xff}].
+            }
+            return [string trimright $r .]
+        }
+    } else {
+        return -code error "invalid binary address:\
+            argument is neither an IPv4 nor an IPv6 address"
+    }
+}
+
+# -------------------------------------------------------------------------
+# Load extended command set.
+
+source [file join [file dirname [info script]] ipMore.tcl]
+
+# -------------------------------------------------------------------------
+
+package provide ip $::ip::version
+
+# -------------------------------------------------------------------------
+# Local Variables:
+#   indent-tabs-mode: nil
+# End:
diff --git a/lib/dns/ipMore.tcl b/lib/dns/ipMore.tcl
new file mode 100644
index 0000000..2532656
--- /dev/null
+++ b/lib/dns/ipMore.tcl
@@ -0,0 +1,1217 @@
+#temporary home until this gets cleaned up for export to tcllib ip module
+# $Id: ipMore.tcl,v 1.4 2006/01/22 00:27:22 andreas_kupries Exp $
+
+
+##Library Header
+#
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+#       ipMore
+#
+# Purpose:
+#       Additional commands for the tcllib ip package.
+#
+# Author:
+#        Aamer Akhter / aakhter@cisco.com
+#
+# Support Alias:
+#       aakhter@cisco.com
+#
+# Usage:
+#       package require ip
+#       (The command are loaded from the regular package).
+#
+# Description:
+#       A detailed description of the functionality provided by the library.
+#      
+# Requirements:
+#
+# Variables:
+#       namespace   ::ip
+#
+# Notes:
+#       1.
+#
+# Keywords:
+#
+#
+# Category: 
+#       
+#
+# End of Header
+
+package require msgcat
+
+# Try to load various C based accelerato packages for two of the
+# commands.
+
+if {[catch {package require ipMorec}]} {
+    catch {package require tcllibc}
+}
+
+if {[llength [info commands ::ip::prefixToNativec]]} {
+    # An accelerator is present, providing the C variants
+    interp alias {} ::ip::prefixToNative  {} ::ip::prefixToNativec
+    interp alias {} ::ip::isOverlapNative {} ::ip::isOverlapNativec
+} else {
+    # Link API to the Tcl variants, no accelerators are available.
+    interp alias {} ::ip::prefixToNative  {} ::ip::prefixToNativeTcl
+    interp alias {} ::ip::isOverlapNative {} ::ip::isOverlapNativeTcl
+}
+
+namespace eval ::ip {
+    ::msgcat::mcload [file join [file dirname [info script]] msgs]
+}
+
+if {![llength [info commands lassign]]} {
+    # Either an older tcl version, or tclx not loaded; have to use our
+    # internal lassign from http://wiki.tcl.tk/1530 by Schelte Bron
+
+    proc ::ip::lassign {values args} {
+        uplevel 1 [list foreach $args $values break]
+        lrange $values [llength $args] end
+    }
+}
+if {![llength [info commands lvarpop]]} {
+    # Define an emulation of Tclx's lvarpop if the command
+    # is not present already.
+
+    proc ::ip::lvarpop {upVar {index 0}} {
+	upvar $upVar list;
+	set top [lindex $list $index];
+	set list [concat [lrange $list 0 [expr $index - 1]] \
+		      [lrange $list [expr $index +1] end]];
+	return $top;
+    }
+}
+
+# Some additional aliases for backward compatability. Not
+# documented. The old names ar from previous versions while at Cisco.
+#
+#               Old command name -->      Documented command name
+interp alias {} ::ip::ToInteger           {} ::ip::toInteger
+interp alias {} ::ip::ToHex               {} ::ip::toHex
+interp alias {} ::ip::MaskToInt           {} ::ip::maskToInt
+interp alias {} ::ip::MaskToLength        {} ::ip::maskToLength
+interp alias {} ::ip::LengthToMask        {} ::ip::lengthToMask
+interp alias {} ::ip::IpToLayer2Multicast {} ::ip::ipToLayer2Multicast
+interp alias {} ::ip::IpHostFromPrefix    {} ::ip::ipHostFromPrefix
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::prefixToNative
+#
+# Purpose:
+#        convert from dotted from to native (hex) form
+#
+# Synopsis:
+#       prefixToNative <prefix>
+#
+# Arguments:
+#        <prefix>
+#            string in the <ipaddr>/<mask> format
+#
+# Return Values:
+#        <prefix> in native format {<hexip> <hexmask>}
+#
+# Description:
+#       
+# Examples:
+#   % ip::prefixToNative 1.1.1.0/24
+#   0x01010100 0xffffff00
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#   fixed bug in C extension that modified 
+#    calling context variable
+# See Also:
+#
+# End of Header
+
+proc ip::prefixToNativeTcl {prefix} {
+    set plist {}
+    foreach p $prefix {
+	set newPrefix [ip::toHex [ip::prefix $p]]
+	if {[string equal [set mask [ip::mask $p]] ""]} {
+	    set newMask 0xffffffff
+	} else {
+	    set newMask [format "0x%08x" [ip::maskToInt $mask]]
+	}
+	lappend plist [list $newPrefix $newMask]
+    }
+    if {[llength $plist]==1} {return [lindex $plist 0]}
+    return $plist
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::nativeToPrefix
+#
+# Purpose:
+#        convert from native (hex) form to dotted form
+#
+# Synopsis:
+#       nativeToPrefix <nativeList>|<native> [-ipv4]
+#
+# Arguments:
+#        <nativeList> 
+#            list of native form ip addresses native form is:
+#        <native>
+#            tcllist in format {<hexip> <hexmask>}
+#        -ipv4
+#            the provided native format addresses are in ipv4 format (default)
+#
+# Return Values:
+#        if nativeToPrefix is called with <native> a single (non-listified) address
+#            is returned
+#        if nativeToPrefix is called with a <nativeList> address list, then 
+#            a list of addresses is returned
+#
+#        return form is: <ipaddr>/<mask>
+#
+# Description:
+#       
+# Examples:
+#   % ip::nativeToPrefix {0x01010100 0xffffff00} -ipv4
+#   1.1.1.0/24
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::nativeToPrefix {nativeList args} {
+    set pList 1
+    set ipv4 1
+    while {[llength $args]} {
+	switch -- [lindex $args 0] {
+	    -ipv4 {set args [lrange $args 1 end]}
+	    default {
+		return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+	    }
+	}
+    }
+
+    # if a single native element is passed eg {0x01010100 0xffffff00}
+    # instead of {{0x01010100 0xffffff00} {0x01010100 0xffffff00}...}
+    # then return a (non-list) single entry
+    if {[llength [lindex $nativeList 0]]==1} {set pList 0; set nativeList [list $nativeList]}
+    foreach native $nativeList {
+	lassign $native ip mask
+	if {[string equal $mask ""]} {set mask 32}
+	set pString ""
+	append pString [ip::ToString [binary format I [expr {$ip}]]]
+	append pString  "/"
+	append pString [ip::maskToLength $mask]
+	lappend rList $pString
+    }
+    # a multi (listified) entry was given
+    # return the listified entry
+    if {$pList} { return $rList }
+    return $pString
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::intToString
+#
+# Purpose:
+#        convert from an integer/hex to dotted form
+#
+# Synopsis:
+#       intToString <integer/hex> [-ipv4]
+#
+# Arguments:
+#        <integer>
+#            ip address in integer form
+#        -ipv4
+#            the provided integer addresses is ipv4 (default)
+#
+# Return Values:
+#        ip address in dotted form
+#
+# Description:
+#       
+# Examples:
+#       ip::intToString 4294967295
+#       255.255.255.255
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::intToString {int args} {
+    set ipv4 1
+    while {[llength $args]} {
+	switch -- [lindex $args 0] {
+	    -ipv4 {set args [lrange $args 1 end]}
+	    default {
+		return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+	    }
+	}
+    }
+    return [ip::ToString [binary format I [expr {$int}]]]
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::toInteger
+#
+# Purpose:
+#        convert dotted form ip to integer
+#
+# Synopsis:
+#       toInteger <ipaddr>
+#
+# Arguments:
+#        <ipaddr>
+#            decimal dotted from ip address
+#
+# Return Values:
+#        integer form of <ipaddr>
+#
+# Description:
+#       
+# Examples:
+#   % ::ip::toInteger 1.1.1.0
+#   16843008
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::toInteger {ip} {
+    binary scan [ip::Normalize4 $ip] I out
+    return $out
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::toHex
+#
+# Purpose:
+#        convert dotted form ip to hex
+#
+# Synopsis:
+#       toHex <ipaddr>
+#
+# Arguments:
+#        <ipaddr>
+#            decimal dotted from ip address
+#
+# Return Values:
+#        hex form of <ipaddr>
+#
+# Description:
+#       
+# Examples:
+#   % ::ip::toHex 1.1.1.0
+#   0x01010100
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::toHex {ip} {
+    binary scan [ip::Normalize4 $ip] H8 out
+    return "0x$out"
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::maskToInt
+#
+# Purpose:
+#        convert mask to integer
+#
+# Synopsis:
+#       maskToInt <mask>
+#
+# Arguments:
+#        <mask>
+#            mask in either dotted form or mask length form (255.255.255.0 or 24)
+#
+# Return Values:
+#        integer form of mask
+#
+# Description:
+#       
+# Examples:
+#   ::ip::maskToInt 24
+#   4294967040
+#
+#   
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::maskToInt {mask} {
+    if {[string is integer -strict $mask]} {
+        set maskInt [expr {(0xFFFFFFFF << (32 - $mask))}]
+    } else {
+        binary scan [Normalize4 $mask] I maskInt
+    }
+    set maskInt [expr {$maskInt & 0xFFFFFFFF}]
+    return [format %u $maskInt]
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::broadcastAddress
+#
+# Purpose:
+#        return broadcast address given prefix
+#
+# Synopsis:
+#       broadcastAddress <prefix> [-ipv4]
+#
+# Arguments:
+#        <prefix>
+#            route in the form of <ipaddr>/<mask> or native form {<hexip> <hexmask>}
+#        -ipv4
+#            the provided native format addresses are in ipv4 format (default)
+#            note: broadcast addresses are not valid in ipv6
+#            
+#
+# Return Values:
+#        ipaddress of broadcast
+#
+# Description:
+#       
+# Examples:
+#   ::ip::broadcastAddress 1.1.1.0/24
+#   1.1.1.255
+#   
+#   ::ip::broadcastAddress {0x01010100 0xffffff00}
+#   0x010101ff
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::broadcastAddress {prefix args} {
+    set ipv4 1
+    while {[llength $args]} {
+	switch -- [lindex $args 0] {
+	    -ipv4 {set args [lrange $args 1 end]}
+	    default {
+		return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+	    }
+	}
+    }
+    if {[llength $prefix] == 2} {
+	lassign $prefix net mask
+    } else {
+	set net [maskToInt [ip::prefix $prefix]]
+	set mask [maskToInt [ip::mask $prefix]]
+    }
+    set ba [expr {$net  | ((~$mask)&0xffffffff)}]
+    
+    if {[llength $prefix]==2} {
+	return [format "0x%08x" $ba]
+    }
+    return [ToString [binary format I $ba]]
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::maskToLength
+#
+# Purpose:
+#        converts dotted or integer form of mask to length
+#
+# Synopsis:
+#       maskToLength <dottedMask>|<integerMask>|<hexMask> [-ipv4]
+#
+# Arguments:
+#        <dottedMask>
+#        <integerMask>
+#        <hexMask>
+#            mask to convert to prefix length format (eg /24)
+#         -ipv4
+#            the provided integer/hex format masks are ipv4 (default)
+#
+# Return Values:
+#        prefix length
+#
+# Description:
+#       
+# Examples:
+#   ::ip::maskToLength 0xffffff00 -ipv4
+#   24
+#
+#   % ::ip::maskToLength 255.255.255.0
+#   24
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::maskToLength {mask args} {
+    set ipv4 1
+    while {[llength $args]} {
+	switch -- [lindex $args 0] {
+	    -ipv4 {set args [lrange $args 1 end]}
+	    default {
+		return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+	    }
+	}
+    }
+    #pick the fastest method for either format
+    if {[string is integer -strict $mask]} {
+	binary scan [binary format I [expr {$mask}]] B32 maskB
+	if {[regexp -all {^1+} $maskB ones]} {
+	    return [string length $ones]
+	} else {
+	    return 0
+	}
+    } else {
+	regexp {\/(.+)} $mask dumb mask
+	set prefix 0
+	foreach ipByte [split $mask {.}] {
+	    switch $ipByte {
+		255 {incr prefix 8; continue}
+		254 {incr prefix 7}
+		252 {incr prefix 6}
+		248 {incr prefix 5}
+		240 {incr prefix 4}
+		224 {incr prefix 3}
+		192 {incr prefix 2}
+		128 {incr prefix 1}
+		0   {}
+		default { 
+		    return -code error [msgcat::mc "not an ip mask: %s" $mask]
+		}
+	    }
+	    break
+	}
+	return $prefix
+    }
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::lengthToMask
+#
+# Purpose:
+#        converts mask length to dotted mask form
+#
+# Synopsis:
+#       lengthToMask <maskLength> [-ipv4]
+#
+# Arguments:
+#        <maskLength>
+#            mask length   
+#        -ipv4
+#            the provided mask length is ipv4 (default)  
+#
+# Return Values:
+#        mask in dotted form
+#
+# Description:
+#       
+# Examples:
+#   ::ip::lengthToMask 24
+#   255.255.255.0
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::lengthToMask {masklen args} {
+    while {[llength $args]} {
+	switch -- [lindex $args 0] {
+	    -ipv4 {set args [lrange $args 1 end]}
+	    default {
+		return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+	    }
+	}
+    }
+    # the fastest method is just to look
+    # thru an array
+    return $::ip::maskLenToDotted($masklen)
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::nextNet
+#
+# Purpose:
+#        returns next an ipaddress in same position in next network
+#
+# Synopsis:
+#       nextNet <ipaddr> <mask> [<count>] [-ipv4]
+#
+# Arguments:
+#        <ipaddress>
+#            in hex/integer/dotted format
+#        <mask>
+#            mask in hex/integer/dotted/maskLen format
+#        <count>
+#            number of nets to skip over (default is 1)
+#        -ipv4
+#            the provided hex/integer addresses are in ipv4 format (default)
+#
+# Return Values:
+#        ipaddress in same position in next network in hex
+#
+# Description:
+#       
+# Examples:
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::nextNet {prefix mask args} {
+    set count 1
+    while {[llength $args]} {
+	switch -- [lindex $args 0] {
+	    -ipv4 {set args [lrange $args 1 end]}
+	    default {
+		set count [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	}
+    }
+    if {![string is integer -strict $prefix]} { 
+	set prefix [toInteger $prefix]
+    }
+    if {![string is integer -strict $mask] || ($mask < 33 && $mask > 0)} {
+	set mask [maskToInt $mask]
+    } 
+    
+    set prefix [expr $prefix + ($mask ^ 0xFFffFFff) + $count ]
+    return [format "0x%08x" $prefix]
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::isOverlap
+#
+# Purpose:
+#        checks to see if prefixes overlap
+#
+# Synopsis:
+#       isOverlap <prefix> <prefix1> <prefix2>...
+#
+# Arguments:
+#        <prefix>
+#            in form <ipaddr>/<mask> prefix to compare <prefixN> against
+#        <prefixN>
+#            in form <ipaddr>/<mask> prefixes to compare against
+#
+# Return Values:
+#        1 if there is an overlap
+#
+# Description:
+#       
+# Examples:
+#        % ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32
+#        0
+#
+#        ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32 1.1.1.1/32
+#        1
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::isOverlap {ip args} {
+    lassign [SplitIp $ip] ip1 mask1
+    set ip1int [toInteger $ip1]
+    set mask1int [maskToInt $mask1]
+
+    set overLap 0
+    foreach prefix $args {
+	lassign [SplitIp $prefix] ip2 mask2
+	set ip2int [toInteger $ip2]
+	set mask2int [maskToInt $mask2]
+	set mask1mask2 [expr {$mask1int & $mask2int}]
+	if {[expr {$ip1int & $mask1mask2}] ==  [expr {$ip2int & $mask1mask2}]} {
+	    set overLap 1
+	    break
+	}
+    }
+    return $overLap
+}
+
+
+#optimized overlap, that accepts native format
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::isOverlapNative
+#
+# Purpose:
+#        checks to see if prefixes overlap (optimized native form)
+#
+# Synopsis:
+#       isOverlap <hexipaddr> <hexmask> {{<hexipaddr1> <hexmask1>} {<hexipaddr2> <hexmask2>...}
+#
+# Arguments:
+#        -all
+#            return all overlaps rather than the first one
+#        -inline
+#            rather than returning index values, return the actual overlap prefixes
+#        <hexipaddr>
+#            ipaddress in hex/integer form
+#        <hexMask>
+#            mask in hex/integer form
+#        -ipv4
+#            the provided native format addresses are in ipv4 format (default)
+#
+# Return Values:
+#        non-zero if there is an overlap, value is element # in list with overlap
+#
+# Description:
+#        isOverlapNative is avaliabel both as a C extension and in a native tcl form
+#        if the extension is loaded (tried automatically), isOverlapNative will be
+#        linked to isOverlapNativeC. If an extension is not loaded, then isOverlapNative
+#        will be linked to the native tcl proc: ipOverlapNativeTcl.
+#
+# Examples:
+#        % ::ip::isOverlapNative 0x01010100 0xffffff00 {{0x02010001 0xffffffff}}
+#        0
+#
+#        %::ip::isOverlapNative 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}}
+#        2
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::isOverlapNativeTcl {args} {
+    set all 0
+    set inline 0
+    set notOverlap 0
+    set ipv4 1
+    foreach sw [lrange $args 0 end-3] {
+	switch -exact -- $sw {
+	    -all {
+		set all 1
+		set allList [list]
+	    }
+	    -inline {set inline 1}
+	    -ipv4 {}
+	}
+    }
+    set args [lassign [lrange $args end-2 end] ip1int mask1int prefixList]
+    if {$inline} { 
+	set overLap [list]
+    } else {
+	set overLap 0
+    }
+    set count 0
+    foreach prefix $prefixList {
+	incr count
+	lassign $prefix ip2int mask2int
+	set mask1mask2 [expr {$mask1int & $mask2int}]
+	if {[expr {$ip1int & $mask1mask2}] ==  [expr {$ip2int & $mask1mask2}]} {
+	    if {$inline} {
+		set overLap [list $prefix]
+	    } else {
+		set overLap $count
+	    }
+	    if {$all} {
+		if {$inline} {
+		    lappend allList $prefix
+		} else {
+		    lappend allList $count
+		}
+	    } else {
+		break
+	    }
+	}
+    }
+    if {$all} {return $allList}
+    return $overLap
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::ipToLayer2Multicast
+#
+# Purpose:
+#        converts ipv4 address to a layer 2 multicast address
+#
+# Synopsis:
+#       ipToLayer2Multicast <ipaddr>
+#
+# Arguments:
+#        <ipaddr>
+#            ipaddress in dotted form
+#
+# Return Values:
+#        mac address in xx.xx.xx.xx.xx.xx form
+#
+# Description:
+#
+# Examples:
+#        % ::ip::ipToLayer2Multicast 224.0.0.2
+#        01.00.5e.00.00.02
+# Sample Input:
+#        
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::ipToLayer2Multicast { ipaddr } {
+    regexp "\[0-9\]+\.(\[0-9\]+)\.(\[0-9\]+)\.(\[0-9\]+)" $ipaddr junk ip2 ip3 ip4
+    #remove MSB of 2nd octet of IP address for mcast L2 addr
+    set mac2 [expr {$ip2 & 127}]
+    return [format "01.00.5e.%02x.%02x.%02x" $mac2 $ip3 $ip4]
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::ipHostFromPrefix
+#
+# Purpose:
+#        gives back a host address from a prefix
+#
+# Synopsis:
+#       ::ip::ipHostFromPrefix <prefix> [-exclude <list of prefixes>]
+#
+# Arguments:
+#        <prefix>
+#            prefix is <ipaddr>/<masklen>
+#        -exclude <list of prefixes>
+#            list if ipprefixes that host should not be in
+# Return Values:
+#        ip address 
+#
+# Description:
+#
+# Examples:
+# %::ip::ipHostFromPrefix  1.1.1.5/24
+# 1.1.1.1
+#
+# %::ip::ipHostFromPrefix  1.1.1.1/32
+# 1.1.1.1
+#
+#
+# Sample Input:
+#        
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::ipHostFromPrefix { prefix args } {
+    set mask [mask $prefix]
+    set ipaddr [prefix $prefix]
+    if {[llength $args]} {
+	array set opts $args
+    } else {
+	if {$mask==32} {
+	    return $ipaddr
+	} else {
+	    return [intToString [expr {[toHex $ipaddr] + 1} ]]
+	}
+    }
+    set format {-ipv4}
+    # if we got here, then options were set
+    if {[info exists opts(-exclude)]} {
+	#basic algo is:
+	# 1. throw away prefixes that are less specific that $prefix
+	# 2. of remaining pfx, throw away prefixes that do not overlap
+	# 3. run reducetoAggregates on specific nets
+	# 4. 
+	
+	# 1. convert to hex format
+	set currHex [prefixToNative $prefix ]
+	set exclHex [prefixToNative $opts(-exclude) ]
+	# sort the prefixes by their mask, include the $prefix as a marker
+	#  so we know from where to throw away prefixes
+	set sortedPfx [lsort -integer -index 1 [concat [list $currHex]  $exclHex]]
+	# throw away prefixes that are less specific than $prefix
+	set specPfx [lrange $sortedPfx [expr {[lsearch -exact $sortedPfx $currHex] +1} ] end]
+	
+	#2. throw away non-overlapping prefixes
+	set specPfx [isOverlapNative -all -inline \
+			 [lindex $currHex 0 ] \
+			 [lindex $currHex 1 ] \
+			 $specPfx ]
+	#3. run reduce aggregates 
+	set specPfx [reduceToAggregates $specPfx]
+
+	#4 now have to pick an address that overlaps with $currHex but not with
+	#   $specPfx
+	# 4.1 find the largest prefix w/ most specific mask and go to the next net
+	
+
+	# current ats tcl does not allow this in one command, so 
+	#  for now just going to grab the last prefix (list is already sorted)
+	set sPfx [lindex $specPfx end]
+	set startPfx $sPfx
+	# add currHex to specPfx
+	set oChkPfx [concat $specPfx [list $currHex]]
+
+
+	set notcomplete 1
+	set overflow 0
+	while {$notcomplete} {
+	    #::ipMore::log::debug "doing nextnet on $sPfx"
+	    set nextNet [nextNet [lindex $sPfx 0] [lindex $sPfx 1]]
+	    #::ipMore::log::debug "trying $nextNet"
+	    if {$overflow && ($nextNet > $startPfx)} {
+		#we've gone thru the entire net and didn't find anything.
+		return -code error [msgcat::mc "ip host could not be found in %s" $prefix]
+		break
+	    }
+	    set oPfx [isOverlapNative -all -inline \
+			  $nextNet -1 \
+			  $oChkPfx
+		     ]
+	    switch -exact [llength $oPfx] {
+		0 {
+		    # no overlap at all. meaning we have gone beyond the bounds of
+		    # $currHex. need to overlap and try again
+		    #::ipMore::log::debug {ipHostFromPrefix: overlap done}
+		    set overflow 1
+		}
+		1 {
+		    #we've found what we're looking for. pick this address and exit
+		    return [intToString $nextNet]
+		}
+		default {
+		    # 2 or more overlaps, need to increment again
+		    set sPfx [lindex $oPfx 0]
+		}
+	    }
+	}
+    }
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::reduceToAggregates
+#
+# Purpose:
+#        finds nets that overlap and filters out the more specifc nets
+#
+# Synopsis:
+#       ::ip::reduceToAggregates <prefixList>
+#
+# Arguments:
+#        <prefixList>
+#            prefixList a list in the from of
+#            is <ipaddr>/<masklen> or native format
+#
+# Return Values:
+#        non-overlapping ip prefixes
+#
+# Description:
+#
+# Examples:
+#
+#  % ::ip::reduceToAggregates {1.1.1.0/24 1.1.0.0/8  2.1.1.0/24 1.1.1.1/32 }
+#  1.0.0.0/8 2.1.1.0/24
+#
+# Sample Input:
+#        
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::reduceToAggregates { prefixList } {
+    #find out format of $prefixeList
+    set dotConv 0
+    if {[llength [lindex $prefixList 0]]==1} {
+	#format is dotted form convert all prefixes to native form
+	set prefixList [ip::prefixToNative $prefixList]
+	set dotConv 1
+    }
+    
+    set nonOverLapping $prefixList
+    while {1==1} {
+	set overlapFound 0
+	set remaining $nonOverLapping
+	set nonOverLapping {}
+	while {[llength $remaining]} {
+	    set current [lvarpop remaining]
+	    set overLap [ip::isOverlapNative [lindex $current 0] [lindex $current 1] $remaining]
+	    if {$overLap} {
+		#there was a overlap find out which prefix has a the smaller mask, and keep that one
+		if {[lindex $current 1] > [lindex [lindex $remaining [expr {$overLap -1}]] 1]} {
+		    #current has more restrictive mask, throw that prefix away
+		    # keep other prefix
+		    lappend nonOverLapping [lindex $remaining [expr {$overLap -1}]]
+		} else {
+		    lappend nonOverLapping $current
+		}
+		lvarpop remaining [expr {$overLap -1}]
+		set overlapFound 1
+	    } else {
+		#no overlap, keep all prefixes, don't touch the stuff in 
+		# remaining, it is needed for other overlap checking
+		lappend nonOverLapping $current
+	    }
+	}
+	if {$overlapFound==0} {break}
+    }
+    if {$dotConv} {return [nativeToPrefix $nonOverLapping]}
+    return $nonOverLapping
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::longestPrefixMatch
+#
+# Purpose:
+#        given host IP finds longest prefix match from set of prefixes
+#
+# Synopsis:
+#       ::ip::longestPrefixMatch <ipaddr> <prefixList> [-ipv4]
+#
+# Arguments:
+#        <prefixList>
+#            is list of <ipaddr> in native or dotted form
+#        <ipaddr>
+#            ip address in <ipprefix> format, dotted form, or integer form
+#        -ipv4
+#            the provided integer format addresses are in ipv4 format (default)
+#
+# Return Values:
+#        <ipprefix> that is the most specific match to <ipaddr>
+#
+# Description:
+#
+# Examples:
+#        % ::ip::longestPrefixMatch 1.1.1.1 {1.1.1.0/24 1.0.0.0/8  2.1.1.0/24 1.1.1.0/28 }
+#        1.1.1.0/28
+#
+# Sample Input:
+#        
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::longestPrefixMatch { ipaddr prefixList args} {
+    set ipv4 1
+    while {[llength $args]} {
+	switch -- [lindex $args 0] {
+	    -ipv4 {set args [lrange $args 1 end]}
+	    default {
+		return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+	    }
+	}
+    }
+    #find out format of prefixes
+    set dotConv 0
+    if {[llength [lindex $prefixList 0]]==1} {
+	#format is dotted form convert all prefixes to native form
+	set prefixList [ip::prefixToNative $prefixList]
+	set dotConv 1
+    }
+    #sort so that most specific prefix is in the front
+    if {[llength [lindex [lindex $prefixList 0] 1]]} {
+	set prefixList [lsort -decreasing -integer -index 1 $prefixList]
+    } else {
+	set prefixList [list $prefixList]
+    }
+    if {![string is integer -strict $ipaddr]} {
+	set ipaddr [prefixToNative $ipaddr]
+    }
+    set best [ip::isOverlapNative -inline \
+		  [lindex $ipaddr 0] [lindex $ipaddr 1] $prefixList]
+    if {$dotConv && [llength $best]} {
+	return [nativeToPrefix $best]
+    }
+    return $best
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::cmpDotIP
+#
+# Purpose:
+#        helper function for dotted ip address for use in lsort
+#
+# Synopsis:
+#       ::ip::cmpDotIP <ipaddr1> <ipaddr2>
+#
+# Arguments:
+#        <ipaddr1> <ipaddr2>
+#            prefix is in dotted ip address format
+#
+# Return Values:
+#        -1 if ipaddr1 is less that ipaddr2
+#         1 if ipaddr1 is more that ipaddr2
+#         0 if ipaddr1 and ipaddr2 are equal
+#
+# Description:
+#
+# Examples:
+#        % lsort -command ip::cmpDotIP {1.0.0.0 2.2.0.0 128.0.0.0 3.3.3.3}
+#        1.0.0.0 2.2.0.0 3.3.3.3 128.0.0.0
+#
+# Sample Input:
+#        
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+#            ip address in <ipprefix> format, dotted form, or integer form
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {
+    # 8.3+
+    proc ip::cmpDotIP {ipaddr1 ipaddr2} {
+	# convert dotted to list of integers
+	set ipaddr1 [split $ipaddr1 .]
+	set ipaddr2 [split $ipaddr2 .]
+	foreach a $ipaddr1 b $ipaddr2 {
+	    #ipMore::log::debug "$ipInt1 $ipInt2"
+	    if { $a < $b}  {
+		return -1
+	    } elseif {$a >$b} {
+		return 1
+	    }
+	}
+	return 0
+    }
+} else {
+    # 8.4+
+    proc ip::cmpDotIP {ipaddr1 ipaddr2} {
+	# convert dotted to decimal
+	set ipInt1 [::ip::toHex $ipaddr1]
+	set ipInt2 [::ip::toHex $ipaddr2]
+	#ipMore::log::debug "$ipInt1 $ipInt2"
+	if { $ipInt1 < $ipInt2}  {
+	    return -1
+	} elseif {$ipInt1 >$ipInt2 } {
+	    return 1
+	} else {
+	    return 0
+	}
+    }
+}
+
+# Populate the array "maskLenToDotted" for fast lookups of mask to
+# dotted form.
+
+namespace eval ::ip {
+    variable maskLenToDotted
+    variable x
+
+    for {set x 0} {$x <33} {incr x} {
+	set maskLenToDotted($x) [intToString [maskToInt $x]]
+    }
+    unset x
+}
diff --git a/lib/dns/ipMoreC.tcl b/lib/dns/ipMoreC.tcl
new file mode 100644
index 0000000..b28903e
--- /dev/null
+++ b/lib/dns/ipMoreC.tcl
@@ -0,0 +1,242 @@
+# Skip this for window and a specific version of Solaris
+# 
+# This could do with an explanation -- why are we avoiding these platforms
+# and perhaps using critcl's platform::platform command might be better?
+#
+if {[string equal $::tcl_platform(platform) windows] ||
+    ([string equal $::tcl_platform(os)      SunOS] &&
+     [string equal $::tcl_platform(osVersion) 5.6])
+} {
+    # avoid warnings about nothing to compile
+    critcl::ccode {
+        /* nothing to do */
+    }
+    return
+}
+
+package require critcl;
+
+namespace eval ::ip {
+
+critcl::ccode {
+#include <stdlib.h>
+#include <stdio.h>
+#include <tcl.h>
+#include <inttypes.h>
+#include <arpa/inet.h>
+#include <string.h>
+#include <sys/socket.h>
+}
+
+critcl::ccommand prefixToNativec {clientData interp objc objv} { 
+    int elemLen, maskLen, ipLen, mask;
+	int rval,convertListc,i;
+	Tcl_Obj **convertListv;
+	Tcl_Obj *listPtr,*returnPtr, *addrList;
+	char *stringIP, *slashPos, *stringMask;
+	char v4HEX[11];
+	
+	uint32_t inaddr;
+	listPtr = NULL;
+
+	/* printf ("\n in prefixToNativeC"); */
+	/* printf ("\n objc = %d",objc); */
+
+	if (objc != 2) {
+		Tcl_WrongNumArgs(interp, 1, objv, "<ipaddress>/<mask>");
+		return TCL_ERROR;
+	}
+
+
+	if (Tcl_ListObjGetElements (interp, objv[1], 
+								&convertListc, &convertListv) != TCL_OK) {
+		return TCL_ERROR;
+	}
+	returnPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+	for (i = 0; i < convertListc; i++) {
+		/*  need to create a duplicate here because when we modify */
+		/*  the stringIP it'll mess up the original in the calling */
+		/*  context */
+		addrList = Tcl_DuplicateObj(convertListv[i]);
+		stringIP = Tcl_GetStringFromObj(addrList, &elemLen);
+		listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+		/* printf ("\n  ### %s ### string \n", stringIP); */
+		/*  split the ip address and mask */
+		slashPos = strchr(stringIP, (int) '/');
+		if (slashPos == NULL) {
+			/*  straight ip address without mask */
+			mask = 0xffffffff;
+			ipLen = strlen(stringIP);
+		} else {
+			/* ipaddress has the mask, handle the mask and seperate out the  */
+			/*  ip address */
+			/* printf ("\n ** %d ",(uintptr_t)slashPos); */
+			stringMask = slashPos +1;
+			maskLen =strlen(stringMask);
+			/* put mask in hex form */
+			if (maskLen < 3) {
+				mask = atoi(stringMask);
+				mask = (0xFFFFFFFF << (32 - mask)) & 0xFFFFFFFF;
+			} else {
+				/* mask is in dotted form */
+				if ((rval = inet_pton(AF_INET,stringMask,&mask)) < 1 ) {
+					Tcl_AddErrorInfo(interp, "\n    bad format encountered in mask conversion");
+					return TCL_ERROR;	
+				}
+				mask = htonl(mask);
+			}
+			ipLen = (uintptr_t)slashPos  - (uintptr_t)stringIP;
+			/* divide the string into ip and mask portion */
+			*slashPos = '\0';
+			/* printf("\n %d %d %d %d", (uintptr_t)stringMask, maskLen, (uintptr_t)stringIP, ipLen); */
+		}
+		if ( (rval = inet_pton(AF_INET,stringIP,&inaddr)) < 1) {
+			Tcl_AddErrorInfo(interp, 
+							 "\n    bad format encountered in ip conversion");
+			return TCL_ERROR;
+		};
+		inaddr = htonl(inaddr);
+		/* apply the mask the to the ip portion, just to make sure  */
+		/*  what we return is cleaned up */
+		inaddr = inaddr & mask;
+		sprintf(v4HEX,"0x%08X",inaddr);
+		/* printf ("\n\n ### %s",v4HEX); */
+		Tcl_ListObjAppendElement(interp, listPtr,
+								 Tcl_NewStringObj(v4HEX,-1));
+		sprintf(v4HEX,"0x%08X",mask);
+		Tcl_ListObjAppendElement(interp, listPtr,
+								 Tcl_NewStringObj(v4HEX,-1));
+		Tcl_ListObjAppendElement(interp, returnPtr, listPtr);
+		Tcl_DecrRefCount(addrList);
+	}
+	
+	if (convertListc==1) {
+		Tcl_SetObjResult(interp,listPtr);
+	} else {
+		Tcl_SetObjResult(interp,returnPtr);
+	}
+	
+	return TCL_OK;
+}
+
+critcl::ccommand isOverlapNativec {clientData interp objc objv} {
+        int i; 
+        unsigned int ipaddr,ipMask, mask1mask2;
+        unsigned int ipaddr2,ipMask2;
+        int compareListc,comparePrefixMaskc;
+        int allSet,inlineSet,index;
+        Tcl_Obj **compareListv,**comparePrefixMaskv, *listPtr;
+        Tcl_Obj *result;
+    static CONST char *options[] = {
+                "-all",     "-inline", "-ipv4", NULL
+    };
+    enum options {
+		OVERLAP_ALL, OVERLAP_INLINE, OVERLAP_IPV4
+    };
+
+        allSet = 0;
+        inlineSet = 0;
+        listPtr = NULL;
+
+        /* printf ("\n objc = %d",objc); */
+        if (objc < 3) {
+                Tcl_WrongNumArgs(interp, 1, objv, "?options? <hexIP> <hexMask> <hexList>");
+                return TCL_ERROR;
+        }
+        for (i = 1; i < objc-3; i++) {
+           if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
+                   != TCL_OK) {
+                   return TCL_ERROR;
+           }
+           switch (index) {
+           case OVERLAP_ALL:
+                   allSet = 1;
+                   /* printf ("\n all selected"); */
+                   break;
+           case OVERLAP_INLINE:
+                   inlineSet = 1;
+                   /* printf ("\n inline selected"); */
+                   break;
+		   case OVERLAP_IPV4:
+			   break;
+           }
+        }
+        /* options are parsed */
+
+        /* create return obj */
+        result = Tcl_GetObjResult (interp);
+
+        /* set ipaddr and ipmask */
+        Tcl_GetIntFromObj(interp,objv[objc-3],&ipaddr);
+        Tcl_GetIntFromObj(interp,objv[objc-2],&ipMask);
+
+        /* split the 3rd argument into <ipaddr> <mask> pairs */
+        if (Tcl_ListObjGetElements (interp, objv[objc-1], &compareListc, &compareListv) != TCL_OK) {
+                return TCL_ERROR;
+        }
+/*       printf("comparing %x/%x \n",ipaddr,ipMask); */
+
+        if (allSet || inlineSet) {
+                listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+        }
+
+        for (i = 0; i < compareListc; i++) {
+					    /* split the ipaddr2 and ipmask2  */
+                if (Tcl_ListObjGetElements (interp, 
+					    compareListv[i], 
+					    &comparePrefixMaskc, 
+					    &comparePrefixMaskv) != TCL_OK) {
+		    return TCL_ERROR;
+                }
+                if (comparePrefixMaskc != 2) {
+		    Tcl_AddErrorInfo(interp,"need format {{<ipaddr> <mask>} {<ipad..}}");
+                        return TCL_ERROR;
+                }
+                Tcl_GetIntFromObj(interp,comparePrefixMaskv[0],&ipaddr2);
+                Tcl_GetIntFromObj(interp,comparePrefixMaskv[1],&ipMask2);
+/*               printf(" with %x/%x \n",ipaddr2,ipMask2); */
+                mask1mask2 = ipMask & ipMask2;
+/*               printf("  mask1mask2 %x \n",mask1mask2); */
+/*               printf("  ipaddr & mask1mask2  %x\n",ipaddr & mask1mask2); */
+/*               printf("  ipaddr2 & mask1mask2 %x\n",ipaddr2 & mask1mask2); */
+                if ((ipaddr & mask1mask2) == (ipaddr2 & mask1mask2)) {
+		    if (allSet) {
+			if (inlineSet) {
+			    Tcl_ListObjAppendElement(interp, listPtr,
+						     compareListv[i]);
+			} else {
+			    /* printf("\n appending %d",i+1); */
+			    Tcl_ListObjAppendElement(interp, listPtr,
+						     Tcl_NewIntObj(i+1));
+			};
+		    } else {
+			if (inlineSet) {
+			    Tcl_ListObjAppendElement(interp, listPtr,
+						     compareListv[i]);
+			    Tcl_SetObjResult(interp,listPtr);
+			} else {
+			    Tcl_SetIntObj (result, i+1);
+			}
+			return TCL_OK;
+		    };
+                };
+					};
+
+        if (allSet || inlineSet) {
+                Tcl_SetObjResult(interp, listPtr);
+                return TCL_OK;
+        } else {
+                Tcl_SetIntObj (result, 0);
+                return TCL_OK;
+        }
+        return TCL_OK;
+
+
+
+}
+
+
+}
+
+# @sak notprovided ipMorec
+package provide ipMorec 1.0
diff --git a/lib/dns/msgs/en.msg b/lib/dns/msgs/en.msg
new file mode 100644
index 0000000..813cb9e
--- /dev/null
+++ b/lib/dns/msgs/en.msg
@@ -0,0 +1,8 @@
+# -*- tcl -*-
+package require    msgcat
+namespace import ::msgcat::*
+
+mcset en "option %s not supported"          "option %s not supported"	   
+mcset en "option %s not supported"	    "option %s not supported"	   
+mcset en "not an ip mask: %s"		    "not an ip mask: %s"		   
+mcset en "ip host could not be found in %s" "ip host could not be found in %s"
diff --git a/lib/dns/pkgIndex.tcl b/lib/dns/pkgIndex.tcl
new file mode 100644
index 0000000..fad685b
--- /dev/null
+++ b/lib/dns/pkgIndex.tcl
@@ -0,0 +1,9 @@
+# pkgIndex.tcl -
+#
+# $Id: pkgIndex.tcl,v 1.18 2008/03/14 21:21:12 andreas_kupries Exp $
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded dns    1.3.2 [list source [file join $dir dns.tcl]]
+package ifneeded resolv 1.0.3 [list source [file join $dir resolv.tcl]]
+package ifneeded ip     1.1.2 [list source [file join $dir ip.tcl]]
+package ifneeded spf    1.1.1 [list source [file join $dir spf.tcl]]
diff --git a/lib/dns/resolv.tcl b/lib/dns/resolv.tcl
new file mode 100644
index 0000000..d570f42
--- /dev/null
+++ b/lib/dns/resolv.tcl
@@ -0,0 +1,254 @@
+# resolv.tcl - Copyright (c) 2002 Emmanuel Frecon <emmanuel@sics.se>
+#
+# Original Author --  Emmanuel Frecon - emmanuel@sics.se
+# Modified by Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+#  A super module on top of the dns module for host name resolution.
+#  There are two services provided on top of the regular Tcl library:
+#  Firstly, this module attempts to automatically discover the default
+#  DNS server that is setup on the machine that it is run on.  This
+#  server will be used in all further host resolutions.  Secondly, this
+#  module offers a rudimentary cache.  The cache is rudimentary since it
+#  has no expiration on host name resolutions, but this is probably
+#  enough for short lived applications.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+# $Id: resolv.tcl,v 1.9 2004/01/25 07:29:39 andreas_kupries Exp $
+
+package require dns 1.0;                # tcllib 1.3
+
+namespace eval ::resolv {
+    variable version 1.0.3
+    variable rcsid {$Id: resolv.tcl,v 1.9 2004/01/25 07:29:39 andreas_kupries Exp $}
+
+    namespace export resolve init ignore hostname
+
+    variable R
+    if {![info exists R]} {
+        array set R {
+            initdone   0
+            dns        ""
+            dnsdefault ""
+            ourhost    ""
+            search     {}
+        }
+    }
+}
+
+# -------------------------------------------------------------------------
+# Command Name     --  ignore
+# Original Author  --  Emmanuel Frecon - emmanuel@sics.se
+#
+# Remove a host name resolution from the cache, if present, so that the
+# next resolution will query the DNS server again.
+#
+# Arguments:
+#    hostname	- Name of host to remove from the cache.
+#
+proc ::resolv::ignore { hostname } {
+    variable Cache
+    catch {unset Cache($hostname)}
+    return
+}
+
+# -------------------------------------------------------------------------
+# Command Name     --  init
+# Original Author  --  Emmanuel Frecon - emmanuel@sics.se
+#
+# Initialise this module with a known host name.  This host (not mandatory)
+# will become the default if the library was not able to find a DNS server.
+# This command can be called several times, its effect is double: actively
+# looking for the default DNS server setup on the running machine; and
+# emptying the host name resolution cache.
+#
+# Arguments:
+#    defaultdns	- Default DNS server
+#
+proc ::resolv::init { {defaultdns ""} {search {}}} {
+    variable R
+    variable Cache
+
+    # Clean the resolver cache
+    catch {unset Cache}
+
+    # Record the default DNS server and search list.
+    set R(dnsdefault) $defaultdns
+    set R(search) $search
+
+    # Now do some intelligent lookup.  We do this on the current
+    # hostname to get a chance to get back some (full) information on
+    # ourselves.  A previous version was using 127.0.0.1, not sure
+    # what is best.
+    set res [catch [list exec nslookup [info hostname]] lkup]
+    if { $res == 0 } {
+	set l [split $lkup]
+	set nl ""
+	foreach e $l {
+	    if { [string length $e] > 0 } {
+		lappend nl $e
+	    }
+	}
+
+        # Now, a lot of mixture to arrange so that hostname points at the
+        # DNS server that we should use for any further request.  This
+        # code is complex, but was actually tested behind a firewall
+        # during the SITI Winter Conference 2003.  There, strangly,
+        # nslookup returned an error but a DNS server was actually setup
+        # correctly...
+        set hostname ""
+	set len [llength $nl]
+	for { set i 0 } { $i < $len } { incr i } {
+	    set e [lindex $nl $i]
+	    if { [string match -nocase "*server*" $e] } {
+		set hostname [lindex $nl [expr {$i + 1}]]
+                if { [string match -nocase "UnKnown" $hostname] } {
+                    set hostname ""
+                }
+		break
+	    }
+	}
+
+	if { $hostname != "" } {
+	    set R(dns) $hostname
+	} else {
+            for { set i 0 } { $i < $len } { incr i } {
+                set e [lindex $nl $i]
+                if { [string match -nocase "*address*" $e] } {
+                    set hostname [lindex $nl [expr {$i + 1}]]
+                    break
+                }
+            }
+            if { $hostname != "" } {
+                set R(dns) $hostname
+            }
+	}
+    }
+
+    if {$R(dns) == ""} {
+        set R(dns) $R(dnsdefault)
+    }
+
+
+    # Start again to find our full name
+    set ourhost ""
+    if {$res == 0} {
+        set dot [string first "." [info hostname]]
+        if { $dot < 0 } {
+            for { set i 0 } { $i < $len } { incr i } {
+                set e [lindex $nl $i]
+                if { [string match -nocase "*name*" $e] } {
+                    set ourhost [lindex $nl [expr {$i + 1}]]
+                    break
+                }
+            }
+            if { $ourhost == "" } {
+                if { ! [regexp {\d+\.\d+\.\d+\.\d+} $hostname] } {
+                    set dot [string first "." $hostname]
+                    set ourhost [format "%s%s" [info hostname] \
+                                     [string range $hostname $dot end]]
+                }
+            }
+        } else {
+            set ourhost [info hostname]
+        }
+    }
+
+    if {$ourhost == ""} {
+        set R(ourhost) [info hostname]
+    } else {
+        set R(ourhost) $ourhost
+    }
+
+
+    set R(initdone) 1
+
+    return $R(dns)
+}
+
+# -------------------------------------------------------------------------
+# Command Name     --  resolve
+# Original Author  --  Emmanuel Frecon - emmanuel@sics.se
+#
+# Resolve a host name to an IP address.  This is a wrapping procedure around
+# the basic services of the dns library.
+#
+# Arguments:
+#    hostname	- Name of host
+#
+proc ::resolv::resolve { hostname } {
+    variable R
+    variable Cache
+
+    # Initialise if not already done. Auto initialisation cannot take
+    # any known DNS server (known to the caller)
+    if { ! $R(initdone) } { init }
+
+    # Check whether this is not simply a raw IP address. What about
+    # IPv6 ??
+    # - We don't have sockets in Tcl for IPv6 protocols - [PT]
+    #
+    if { [regexp {\d+\.\d+\.\d+\.\d+} $hostname] } {
+	return $hostname
+    }
+
+    # Look for hostname in the cache, if found return.
+    if { [array names ::resolv::Cache $hostname] != "" } {
+	return $::resolv::Cache($hostname)
+    }
+
+    # Scream if we don't have any DNS server setup, since we cannot do
+    # anything in that case.
+    if { $R(dns) == "" } {
+	return -code error "No dns server provided"
+    }
+
+    set R(retries) 0
+    set ip [Resolve $hostname]
+
+    # And store the result of resolution in our cache for further use.
+    set Cache($hostname) $ip
+
+    return $ip
+}
+
+# Description:
+#  Attempt to resolve hostname via DNS. If the name cannot be resolved then
+#  iterate through the search list appending each domain in turn until we
+#  get one that succeeds.
+#
+proc ::resolv::Resolve {hostname} {
+    variable R
+    set t [::dns::resolve $hostname -server $R(dns)]
+    ::dns::wait $t;                       # wait with event processing
+    set status [dns::status $t]
+    if {$status == "ok"} {
+        set ip [lindex [::dns::address $t] 0]
+        ::dns::cleanup $t
+    } elseif {$status == "error"
+              && [::dns::errorcode $t] == 3 
+              && $R(retries) < [llength $R(search)]} {
+        ::dns::cleanup $t
+        set suffix [lindex $R(search) $R(retries)]
+        incr R(retries)
+        set new [lindex [split $hostname .] 0].[string trim $suffix .]
+        set ip [Resolve $new]
+    } else {
+        set err [dns::error $t]
+        ::dns::cleanup $t
+        return -code error "dns error: $err"
+    }
+    return $ip
+}
+
+# -------------------------------------------------------------------------
+
+package provide resolv $::resolv::version
+
+# -------------------------------------------------------------------------
+# Local Variables:
+#   indent-tabs-mode: nil
+# End:
diff --git a/lib/dns/spf.tcl b/lib/dns/spf.tcl
new file mode 100644
index 0000000..cf5e10a
--- /dev/null
+++ b/lib/dns/spf.tcl
@@ -0,0 +1,533 @@
+# spf.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+#                         Sender Policy Framework
+#
+#    http://www.ietf.org/internet-drafts/draft-ietf-marid-protocol-00.txt
+#    http://spf.pobox.com/
+#
+# Some domains using SPF:
+#   pobox.org       - mx, a, ptr
+#   oxford.ac.uk    - include
+#   gnu.org         - ip4
+#   aol.com         - ip4, ptr
+#   sourceforge.net - mx, a
+#   altavista.com   - exists,  multiple TXT replies.
+#   oreilly.com     - mx, ptr, include
+#   motleyfool.com  - include (looping includes)
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+# $Id: spf.tcl,v 1.5 2008/03/14 21:21:12 andreas_kupries Exp $
+
+package require Tcl 8.2;                # tcl minimum version
+package require dns;                    # tcllib 1.3
+package require logger;                 # tcllib 1.3
+package require ip;                     # tcllib 1.7
+package require struct::list;           # tcllib 1.7
+package require uri::urn;               # tcllib 1.3
+
+namespace eval spf {
+    variable version 1.1.1
+    variable rcsid {$Id: spf.tcl,v 1.5 2008/03/14 21:21:12 andreas_kupries Exp $}
+
+    namespace export spf
+
+    variable uid
+    if {![info exists uid]} {set uid 0}
+
+    variable log
+    if {![info exists log]} { 
+        set log [logger::init spf]
+        ${log}::setlevel warn
+        proc ${log}::stdoutcmd {level text} {
+            variable service
+            puts "\[[clock format [clock seconds] -format {%H:%M:%S}]\
+                $service $level\] $text"
+        }
+    }
+}
+
+# -------------------------------------------------------------------------
+# ip     : ip address of the connecting host
+# domain : the domain to match
+# sender : full sender email address
+#
+proc ::spf::spf {ip domain sender} {
+    variable log
+
+    # 3.3: Initial processing
+    # If the sender address has no local part, set it to postmaster
+    set addr [split $sender @]
+    if {[set len [llength $addr]] == 0} {
+        return -code error -errorcode permanent "invalid sender address"
+    } elseif {$len == 1} {
+        set sender "postmaster@$sender"
+    }
+
+    # 3.4: Record lookup
+    set spf [SPF $domain]
+    if {[string equal $spf none]} {
+        return $spf
+    }
+
+    return [Spf $ip $domain $sender $spf]
+}
+
+proc ::spf::Spf {ip domain sender spf} {
+    variable log
+
+    # 3.4.1: Matching Version
+    if {![regexp {^v=spf(\d)\s+} $spf -> version]} {
+        return none
+    }
+
+    ${log}::debug "$spf"
+
+    if {$version != 1} {
+        return -code error -errorcode permanent \
+            "version mismatch: we only understand SPF 1\
+            this domain has provided version \"$version\""
+    }
+
+    set result ?
+    set seen_domains $domain
+    set explanation {denied}
+
+    set directives [lrange [split $spf { }] 1 end]
+    foreach directive $directives {
+        set prefix [string range $directive 0 0]
+        if {[string equal $prefix "+"] || [string equal $prefix "-"]
+            || [string equal $prefix "?"] || [string equal $prefix "~"]} {
+            set directive [string range $directive 1 end]
+        } else {
+            set prefix "+"
+        }
+
+        set cmd [string tolower [lindex [split $directive {:/=}] 0]]
+        set param [string range $directive [string length $cmd] end]
+
+        if {[info command ::spf::_$cmd] == {}} {
+            # 6.1 Unrecognised directives terminate processing
+            #     but unknown modifiers are ignored.
+            if {[string match "=*" $param]} {
+                continue
+            } else {
+                set result unknown
+                break
+            }
+        } else {
+            set r [catch {::spf::_$cmd $ip $domain $sender $param} res]
+            if {$r} {
+                if {$r == 2} {return $res};# deal with return -code return
+                if {[string equal $res "none"] 
+                    || [string equal $res "error"]
+                    || [string equal $res "unknown"]} {
+                    return $res
+                }
+                return -code error "error in \"$cmd\": $res"
+            }            
+            if {$res} { set result $prefix }
+        }
+        
+        ${log}::debug "$prefix $cmd\($param) -> $result"
+        if {[string equal $result "+"]} break
+    }
+    
+    return $result
+}
+
+proc ::spf::loglevel {level} {
+    variable log
+    ${log}::setlevel $level
+}
+
+# get a guaranteed unique and non-present token id.
+proc ::spf::create_token {} {
+    variable uid
+    set id [incr uid]
+    while {[info exists [set token [namespace current]::$id]]} {
+        set id [incr uid]
+    }
+    return $token
+}
+
+# -------------------------------------------------------------------------
+#
+#                      SPF MECHANISM HANDLERS
+#
+# -------------------------------------------------------------------------
+
+# 4.1:	The "all" mechanism is a test that always matches.  It is used as the
+#	rightmost mechanism in an SPF record to provide an explicit default
+#
+proc ::spf::_all {ip domain sender param} {
+    return 1
+}
+
+# 4.2:	The "include" mechanism triggers a recursive SPF query.
+#	The domain-spec is expanded as per section 8.
+proc ::spf::_include {ip domain sender param} {
+    variable log
+    upvar seen_domains Seen
+
+    if {![string equal [string range $param 0 0] ":"]} {
+        return -code error "dubious parameters for \"include\""
+    }
+    set r ?
+    set new_domain [Expand [string range $param 1 end] $ip $domain $sender]
+    if {[lsearch $Seen $new_domain] == -1} {
+        lappend Seen $new_domain
+        set spf [SPF $new_domain]
+        if {[string equal $spf none]} {
+            return $spf
+        } 
+        set r [Spf $ip $new_domain $sender $spf]
+    }
+    return [string equal $r "+"]
+}
+
+# 4.4:	This mechanism matches if <ip> is one of the target's
+#	IP addresses.
+#	e.g: a:smtp.example.com a:mail.%{d} a
+#
+proc ::spf::_a {ip domain sender param} {
+    variable log
+    foreach {testdomain bits} [ip::SplitIp [string trimleft $param :]] {}
+    if {[string length $testdomain] < 1} {
+        set testdomain $domain
+    } else {
+        set testdomain [Expand $testdomain $ip $domain $sender]
+    }
+    ${log}::debug "  fetching A for $testdomain"
+    set dips [A $testdomain];           # get the IPs for the testdomain
+    foreach dip $dips {
+        ${log}::debug "  compare: ${ip}/${bits} with ${dip}/${bits}"
+        if {[ip::equal $ip/$bits $dip/$bits]} {
+            return 1
+        }
+    }
+    return 0
+}
+
+# 4.5: This mechanism matches if the <sending-host> is one of the MX hosts
+#      for a domain name.
+#
+proc ::spf::_mx {ip domain sender param} {
+    variable log
+    foreach {testdomain bits} [ip::SplitIp [string trimleft $param :]] {}
+    if {[string length $testdomain] < 1} {
+        set testdomain $domain
+    } else {
+        set testdomain [Expand $testdomain $ip $domain $sender]
+    }
+    ${log}::debug "  fetching MX for $testdomain"
+    set mxs [MX $testdomain]
+
+    foreach mx $mxs {
+        set mx [lindex $mx 1]
+        set mxips [A $mx]
+        foreach mxip $mxips {
+            ${log}::debug "  compare: ${ip}/${bits} with ${mxip}/${bits}"
+            if {[ip::equal $ip/$bits $mxip/$bits]} {
+                return 1
+            }
+        }
+    }
+    return 0
+}
+
+# 4.6: This mechanism tests if the <sending-host>'s name is within a
+#      particular domain.
+#
+proc ::spf::_ptr {ip domain sender param} {
+    variable log
+    set validnames {}
+    if {[catch { set names [PTR $ip] } msg]} {
+        ${log}::debug "  \"$ip\" $msg"
+        return 0
+    }
+    foreach name $names {
+        set addrs [A $name]
+        foreach addr $addrs {
+            if {[ip::equal $ip $addr]} {
+                lappend validnames $name
+                continue
+            }
+        }
+    }
+
+    ${log}::debug "  validnames: $validnames"
+    set testdomain [Expand [string trimleft $param :] $ip $domain $sender]
+    if {$testdomain == {}} {
+        set testdomain $domain
+    }
+    foreach name $validnames {
+        if {[string match "*$testdomain" $name]} {
+            return 1
+        }
+    }
+
+    return 0
+}
+
+# 4.7: These mechanisms test if the <sending-host> falls into a given IP
+#      network.
+#
+proc ::spf::_ip4 {ip domain sender param} {
+    variable log
+    foreach {network bits} [ip::SplitIp [string range $param 1 end]] {}
+    ${log}::debug "  compare ${ip}/${bits} to ${network}/${bits}"
+    if {[ip::equal $ip/$bits $network/$bits]} {
+        return 1
+    }
+    return 0
+}
+
+# 4.6: These mechanisms test if the <sending-host> falls into a given IP
+#      network.
+#
+proc ::spf::_ip6 {ip domain sender param} {
+    variable log
+    foreach {network bits} [ip::SplitIp [string range $param 1 end]] {}
+    ${log}::debug "  compare ${ip}/${bits} to ${network}/${bits}"
+    if {[ip::equal $ip/$bits $network/$bits]} {
+        return 1
+    }
+    return 0
+}
+
+# 4.7: This mechanism is used to construct an arbitrary host name that is
+#      used for a DNS A record query.  It allows for complicated schemes
+#      involving arbitrary parts of the mail envelope to determine what is
+#      legal.
+#
+proc ::spf::_exists {ip domain sender param} {
+    variable log
+    set testdomain [Expand [string range $param 1 end] $ip $domain $sender]
+    ${log}::debug "   checking existence of '$testdomain'"
+    if {[catch {A $testdomain}]} {
+        return 0
+    }
+    return 1
+}
+
+# 5.1: Redirected query
+#
+proc ::spf::_redirect {ip domain sender param} {
+    variable log
+    set new_domain [Expand [string range $param 1 end] $ip $domain $sender]
+    ${log}::debug ">> redirect to '$new_domain'"
+    set spf [SPF $new_domain]
+    if {![string equal $spf none]} {
+        set spf [Spf $ip $new_domain $sender $spf]
+    }
+    ${log}::debug "<< redirect returning '$spf'"
+    return -code return $spf
+}
+
+# 5.2: Explanation
+#
+proc ::spf::_exp {ip domain sender param} {
+    variable log
+    set new_domain [string range $param 1 end]
+    set exp [TXT $new_domain]
+    set exp [Expand $exp $ip $domain $sender]
+    ${log}::debug "exp expanded to \"$exp\""
+    # FIX ME: need to store this somehow.
+}
+
+# 5.3: Sender accreditation
+#
+proc ::spf::_accredit {ip domain sender param} {
+    variable log
+    set accredit [Expand [string range $param 1 end] $ip $domain $sender]
+    ${log}::debug "  accreditation '$accredit'"
+    # We are not using this at the moment.
+    return 0
+}
+
+
+# 7: Macro expansion
+#
+proc ::spf::Expand {txt ip domain sender} {
+    variable log
+    set re {%\{[[:alpha:]](?:\d+)?r?[\+\-\.,/_=]*\}}
+    set txt [string map {\[ \\\[ \] \\\]} $txt]
+    regsub -all $re $txt {[ExpandMacro & $ip $domain $sender]} cmd
+    set cmd [string map {%% % %_ \  %- %20} $cmd]
+    return [subst -novariables $cmd]
+}
+
+proc ::spf::ExpandMacro {macro ip domain sender} {
+    variable log
+    set re {%\{([[:alpha:]])(\d+)?(r)?([\+\-\.,/_=]*)\}}
+    set C {} ; set T {} ; set R {}; set D {}
+    set r [regexp $re $macro -> C T R D]
+    if {$R == {}} {set R 0} else {set R 1}
+    set res $macro
+    if {$r} {
+        set enc [string is upper $C]
+        switch -exact -- [string tolower $C] {
+            s { set res $sender }
+            l {
+                set addr [split $sender @]
+                if {[llength $addr] < 2} {
+                    set res postmaster
+                } else {
+                    set res [lindex $addr 0]
+                }
+            }
+            o {
+                set addr [split $sender @]
+                if {[llength $addr] < 2} {
+                    set res $sender
+                } else {
+                    set res [lindex $addr 1]
+                }
+            }
+            h - d { set res $domain }
+            i { 
+                set res [ip::normalize $ip]
+                if {[ip::is ipv6 $res]} {
+                    # Convert 0000:0001 to 0.1
+                    set t {}
+                    binary scan [ip::Normalize $ip 6] c* octets
+                    foreach octet $octets {
+                        set hi [expr {($octet & 0xF0) >> 4}]
+                        set lo [expr {$octet & 0x0F}]
+                        lappend t [format %x $hi] [format %x $lo]
+                    }
+                    set res [join $t .]
+                }
+            }
+            v { 
+                if {[ip::is ipv6 $ip]} {
+                    set res ip6
+                } else {
+                    set res "in-addr"
+                }
+            }
+            c { 
+                set res [ip::normalize $ip]
+                if {[ip::is ipv6 $res]} {
+                    set res [ip::contract $res]
+                }
+            }
+            r { 
+                set s [socket -server {} -myaddr [info host] 0]
+                set res [lindex [fconfigure $s -sockname] 1]
+                close $s
+            }
+            t { set res [clock seconds] }
+        }
+        if {$T != {} || $R || $D != {}} {
+            if {$D == {}} {set D .}
+            set res [split $res $D]
+            if {$R} {
+                set res [struct::list::Lreverse $res]
+            }
+            if {$T != {}} {
+                incr T -1
+                set res [join [lrange $res end-$T end] $D]
+            }
+            set res [join $res .]
+        }
+        if {$enc} {
+            # URI encode the result.
+            set res [uri::urn::quote $res]
+        }
+    }
+    return $res
+}
+
+# -------------------------------------------------------------------------
+#
+# DNS helper procedures.
+#
+# -------------------------------------------------------------------------
+
+proc ::spf::Resolve {domain type resultproc} {
+    if {[info command $resultproc] == {}} {
+        return -code error "invalid arg: \"$resultproc\" must be a command"
+    }
+    set tok [dns::resolve $domain -type $type]
+    dns::wait $tok
+    set errorcode NONE
+    if {[string equal [dns::status $tok] "ok"]} {
+        set result [$resultproc $tok]
+        set code   ok
+    } else {
+        set result    [dns::error $tok]
+        set errorcode [dns::errorcode $tok]
+        set code      error
+    }
+    dns::cleanup $tok
+    return -code $code -errorcode $errorcode $result
+}
+
+# 3.4: Record lookup
+proc ::spf::SPF {domain} {
+    set txt ""
+    if {[catch {Resolve $domain SPF ::dns::result} spf]} {
+        set code $::errorCode
+        ${log}::debug "error fetching SPF record: $r"
+        switch -exact -- $code {
+            3 { return -code return [list - "Domain Does Not Exist"] }
+            2 { return -code error -errorcode temporary $spf }
+        }
+        set txt none
+    } else {
+        foreach res $spf {
+            set ndx [lsearch $res rdata]
+            incr ndx
+            if {$ndx != 0} {
+                append txt [string range [lindex $res $ndx] 1 end]
+            }
+        }
+    }
+    return $txt
+}
+
+proc ::spf::TXT {domain} {
+    set r [Resolve $domain TXT ::dns::result]
+    set txt ""
+    foreach res $r {
+        set ndx [lsearch $res rdata]
+        incr ndx
+        if {$ndx != 0} {
+            append txt [string range [lindex $res $ndx] 1 end]
+        }
+    }
+    return $txt
+}
+
+proc ::spf::A {name} {
+    return [Resolve $name A ::dns::address]
+}
+
+
+proc ::spf::AAAA {name} {
+    return [Resolve $name AAAA ::dns::address]
+}
+
+proc ::spf::PTR {addr} {
+    return [Resolve $addr A ::dns::name]
+}
+
+proc ::spf::MX {domain} {
+    set r [Resolve $domain MX ::dns::name]
+    return [lsort -index 0 $r]
+}
+
+    
+# -------------------------------------------------------------------------
+
+package provide spf $::spf::version
+
+# -------------------------------------------------------------------------
+# Local Variables:
+#   indent-tabs-mode: nil
+# End:
diff --git a/lib/irc/irc.tcl b/lib/irc/irc.tcl
new file mode 100644
index 0000000..f3ee41d
--- /dev/null
+++ b/lib/irc/irc.tcl
@@ -0,0 +1,521 @@
+# irc.tcl --
+#
+#	irc implementation for Tcl.
+#
+# Copyright (c) 2001-2003 by David N. Welton <davidw@dedasys.com>.
+# This code may be distributed under the same terms as Tcl.
+#
+# $Id: irc.tcl,v 1.26 2006/04/23 22:35:57 patthoyts Exp $
+
+package require Tcl 8.3
+
+namespace eval ::irc {
+    variable version 0.6
+
+    # counter used to differentiate connections
+    variable conn 0
+    variable config
+    variable irctclfile [info script]
+    array set config {
+        debug 0
+        logger 0
+    }
+}
+
+# ::irc::config --
+#
+# Set global configuration options.
+#
+# Arguments:
+#
+# key	name of the configuration option to change.
+#
+# value	value of the configuration option.
+
+proc ::irc::config { args } {
+    variable config
+    if { [llength $args] == 0 } {
+        return [array get config]
+    } elseif { [llength $args] == 1 } {
+        return $config($key)
+    } elseif { [llength $args] > 2 } {
+        error "wrong # args: should be \"config key ?val?\""
+    }
+    set key [lindex $args 0]
+    set value [lindex $args 1]
+    foreach ns [namespace children] {
+        if { [info exists config($key)] && [info exists ${ns}::config($key)] \
+                && [set ${ns}::config($key)] == $config($key)} {
+            ${ns}::cmd-config $key $value
+        }
+    }
+    set config($key) $value
+}
+
+
+# ::irc::connections --
+#
+# Return a list of handles to all existing connections
+
+proc ::irc::connections { } {
+    set r {}
+    foreach ns [namespace children] {
+        lappend r ${ns}::network
+    }
+    return $r
+}
+
+# ::irc::reload --
+#
+# Reload this file, and merge the current connections into
+# the new one.
+
+proc ::irc::reload { } {
+    variable conn
+    set oldconn $conn
+    namespace eval :: {
+	source [set ::irc::irctclfile]
+    }
+    foreach ns [namespace children] {
+        foreach var {sock logger host port} {
+            set $var [set ${ns}::$var]
+        }
+        array set dispatch [array get ${ns}::dispatch]
+        array set config [array get ${ns}::config]
+        # make sure our new connection uses the same namespace
+        set conn [string range $ns 10 end]
+        ::irc::connection
+        foreach var {sock logger host port} {
+            set ${ns}::$var [set $var]
+        }
+        array set ${ns}::dispatch [array get dispatch]
+        array set ${ns}::config [array get config]
+    }
+    set conn $oldconn
+}
+
+# ::irc::connection --
+#
+# Create an IRC connection namespace and associated commands.
+
+proc ::irc::connection { args } {
+    variable conn
+    variable config
+
+    # Create a unique namespace of the form irc$conn::$host
+
+    set name [format "%s::irc%s" [namespace current] $conn]
+
+    namespace eval $name {
+	set sock {}
+	array set dispatch {}
+	array set linedata {}
+	array set config [array get ::irc::config]
+	if { $config(logger) || $config(debug)} {
+	    package require logger
+            set logger [logger::init [namespace tail [namespace current]]]
+            if { !$config(debug) } { ${logger}::disable debug }
+        }
+	
+
+	# ircsend --
+	# send text to the IRC server
+
+	proc ircsend { msg } {
+	    variable sock
+	    variable dispatch
+	    if { $sock == "" } { return }
+	    cmd-log debug "ircsend: '$msg'"
+	    if { [catch {puts $sock $msg} err] } {
+	        catch { close $sock }
+	        set sock {}
+		if { [info exists dispatch(EOF)] } {
+		    eval $dispatch(EOF)
+		}
+		cmd-log error "Error in ircsend: $err"
+	    }
+	}
+
+
+	#########################################################
+	# Implemented user-side commands, meaning that these commands
+	# cause the calling user to perform the given action.
+	#########################################################
+
+
+        # cmd-config --
+        #
+        # Set or return per-connection configuration options.
+        #
+        # Arguments:
+        #
+        # key	name of the configuration option to change.
+        #
+        # value	value (optional) of the configuration option.
+
+        proc cmd-config { args } {
+            variable config
+	    variable logger
+	    
+	    if { [llength $args] == 0 } {
+		return [array get config]
+	    } elseif { [llength $args] == 1 } {
+		return $config($key)
+	    } elseif { [llength $args] > 2 } {
+		error "wrong # args: should be \"config key ?val?\""
+	    }
+	    set key [lindex $args 0]
+	    set value [lindex $args 1]
+            if { $key == "debug" } {
+                if {$value} {
+                    if { !$config(logger) } { cmd-config logger 1 }
+                    ${logger}::enable debug
+                } elseif { [info exists logger] } {
+                    ${logger}::disable debug
+	        }
+            }
+            if { $key == "logger" } {
+                if { $value && !$config(logger)} {
+                    package require logger
+                    set logger [logger::init [namespace tail [namespace current]]]
+                } elseif { [info exists logger] } {
+                    ${logger}::delete
+                    unset logger
+	        }
+            }
+            set config($key) $value
+        }
+        
+        proc cmd-log {level text} {
+	    variable logger
+            if { ![info exists logger] } return
+            ${logger}::$level $text
+        }
+        
+        proc cmd-logname { } {
+            variable logger
+            if { ![info exists logger] } return
+            return $logger
+        }
+
+        # cmd-destroy --
+        #
+        # destroys the current connection and its namespace
+
+        proc cmd-destroy { } {
+            variable logger
+            variable sock
+            if { [info exists logger] } { ${logger}::delete }
+            catch {close $sock}
+            namespace delete [namespace current]
+        }
+
+        proc cmd-connected { } {
+            variable sock
+            if { $sock == "" } { return 0 }
+            return 1
+        }
+
+	proc cmd-user { username hostname servername {userinfo ""} } {
+	    if { $userinfo == "" } {
+		ircsend "USER $username $hostname server :$servername"
+	    } else {
+		ircsend "USER $username $hostname $servername :$userinfo"
+	    }
+	}
+
+	proc cmd-nick { nk } {
+	    ircsend "NICK $nk"
+	}
+
+	proc cmd-ping { target } {
+	    ircsend "PRIVMSG $target :\001PING [clock seconds]\001"
+	}
+
+	proc cmd-serverping { } {
+	    ircsend "PING [clock seconds]"
+	}
+
+	proc cmd-ctcp { target line } {
+	    ircsend "PRIVMSG $target :\001$line\001"
+	}
+
+	proc cmd-join { chan {key {}} } {
+	    ircsend "JOIN $chan $key"
+	}
+
+	proc cmd-part { chan {msg ""} } {
+	    if { $msg == "" } {
+		ircsend "PART $chan"
+	    } else {
+		ircsend "PART $chan :$msg"
+	    }
+	}
+
+	proc cmd-quit { {msg {tcllib irc module - http://tcllib.sourceforge.net/}} } {
+	    ircsend "QUIT :$msg"
+	}
+
+	proc cmd-privmsg { target msg } {
+	    ircsend "PRIVMSG $target :$msg"
+	}
+
+	proc cmd-notice { target msg } {
+	    ircsend "NOTICE $target :$msg"
+	}
+
+	proc cmd-kick { chan target {msg {}} } {
+	    ircsend "KICK $chan $target :$msg"
+	}
+
+	proc cmd-mode { target args } {
+	    ircsend "MODE $target [join $args]"
+	}
+
+	proc cmd-topic { chan msg } {
+	    ircsend "TOPIC $chan :$msg"
+	}
+
+	proc cmd-invite { chan target } {
+	    ircsend "INVITE $target $chan"
+	}
+
+	proc cmd-send { line } {
+	    ircsend $line
+	}
+
+	proc cmd-peername { } {
+	    variable sock
+	    if { $sock == "" } { return {} }
+	    return [fconfigure $sock -peername]
+	}
+
+	proc cmd-sockname { } {
+	    variable sock
+	    if { $sock == "" } { return {} }
+	    return [fconfigure $sock -sockname]
+	}
+
+        proc cmd-socket { } {
+            variable sock
+            return $sock
+        }
+        
+	proc cmd-disconnect { } {
+	    variable sock
+	    if { $sock == "" } { return -1 }
+	    catch { close $sock }
+	    set sock {}
+	    return 0
+	}
+
+	# Connect --
+	# Create the actual tcp connection.
+
+	proc cmd-connect { h {p 6667} } {
+	    variable sock
+	    variable host
+	    variable port
+
+	   set host $h
+	   set port $p
+
+	    if { $sock == "" } {
+		set sock [socket $host $port]
+		fconfigure $sock -translation crlf -buffering line
+		fileevent $sock readable [namespace current]::GetEvent
+	    }
+	    return 0
+	}
+
+	# Callback API:
+
+	# These are all available from within callbacks, so as to
+	# provide an interface to provide some information on what is
+	# coming out of the server.
+
+	# action --
+
+	# Action returns the action performed, such as KICK, PRIVMSG,
+	# MODE etc, including numeric actions such as 001, 252, 353,
+	# and so forth.
+
+	proc action { } {
+	    variable linedata
+	    return $linedata(action)
+	}
+
+	# msg --
+
+	# The last argument of the line, after the last ':'.
+
+	proc msg { } {
+	    variable linedata
+	    return $linedata(msg)
+	}
+
+	# who --
+
+	# Who performed the action.  If the command is called as [who address],
+	# it returns the information in the form
+	# nick!ident@host.domain.net
+
+	proc who { {address 0} } {
+	    variable linedata
+	    if { $address == 0 } {
+		return [lindex [split $linedata(who) !] 0]
+	    } else {
+		return $linedata(who)
+	    }
+	}
+
+	# target --
+
+	# To whom was this action done.
+
+	proc target { } {
+	    variable linedata
+	    return $linedata(target)
+	}
+
+	# additional --
+
+	# Returns any additional header elements beyond the target as a list.
+
+	proc additional { } {
+	    variable linedata
+	    return $linedata(additional)
+	}
+
+	# header --
+
+	# Returns the entire header in list format.
+
+	proc header { } {
+	    variable linedata
+	    return [concat [list $linedata(who) $linedata(action) \
+				$linedata(target)] $linedata(additional)]
+	}
+
+	# GetEvent --
+
+	# Get a line from the server and dispatch it.
+
+	proc GetEvent { } {
+	    variable linedata
+	    variable sock
+	    variable dispatch
+	    array set linedata {}
+	    set line "eof"
+	    if { [eof $sock] || [catch {gets $sock} line] } {
+		close $sock
+		set sock {}
+		cmd-log error "Error receiving from network: $line"
+		if { [info exists dispatch(EOF)] } {
+		    eval $dispatch(EOF)
+		}
+		return
+	    }
+	    cmd-log debug "Recieved: $line"
+	    if { [set pos [string first " :" $line]] > -1 } {
+		set header [string range $line 0 [expr {$pos - 1}]]
+		set linedata(msg) [string range $line [expr {$pos + 2}] end]
+	    } else {
+		set header [string trim $line]
+		set linedata(msg) {}
+	    }
+
+	    if { [string match :* $header] } {
+		set header [split [string trimleft $header :]]
+	    } else {
+		set header [linsert [split $header] 0 {}]
+	    }
+	    set linedata(who) [lindex $header 0]
+	    set linedata(action) [lindex $header 1]
+	    set linedata(target) [lindex $header 2]
+	    set linedata(additional) [lrange $header 3 end]
+	    if { [info exists dispatch($linedata(action))] } {
+		eval $dispatch($linedata(action))
+	    } elseif { [string match {[0-9]??} $linedata(action)] } {
+		eval $dispatch(defaultnumeric)
+	    } elseif { $linedata(who) == "" } {
+		eval $dispatch(defaultcmd)
+	    } else {
+		eval $dispatch(defaultevent)
+	    }
+	}
+
+	# registerevent --
+
+	# Register an event in the dispatch table.
+
+	# Arguments:
+	# evnt: name of event as sent by IRC server.
+	# cmd: proc to register as the event handler
+
+	proc cmd-registerevent { evnt cmd } {
+	    variable dispatch
+	    set dispatch($evnt) $cmd
+	    if { $cmd == "" } {
+		unset dispatch($evnt)
+	    }
+	}
+
+	# getevent --
+
+	# Return the currently registered handler for the event.
+
+	# Arguments:
+	# evnt: name of event as sent by IRC server.
+
+	proc cmd-getevent { evnt } {
+	    variable dispatch
+	    if { [info exists dispatch($evnt)] } {
+		return $dispatch($evnt)
+	    }
+	    return {}
+	}
+
+	# eventexists --
+
+	# Return a boolean value indicating if there is a handler
+	# registered for the event.
+
+	# Arguments:
+	# evnt: name of event as sent by IRC server.
+
+	proc cmd-eventexists { evnt } {
+	    variable dispatch
+	    return [info exists dispatch($evnt)]
+	}
+
+	# network --
+
+	# Accepts user commands and dispatches them.
+
+	# Arguments:
+	# cmd: command to invoke
+	# args: arguments to the command
+
+	proc network { cmd args } {
+	    eval [linsert $args 0 [namespace current]::cmd-$cmd]
+	}
+
+	# Create default handlers.
+
+	set dispatch(PING) {network send "PONG :[msg]"}
+	set dispatch(defaultevent) #
+	set dispatch(defaultcmd) #
+	set dispatch(defaultnumeric) #
+    }
+
+    set returncommand [format "%s::irc%s::network" [namespace current] $conn]
+    incr conn
+    return $returncommand
+}
+
+# -------------------------------------------------------------------------
+
+package provide irc $::irc::version
+
+# -------------------------------------------------------------------------
diff --git a/lib/irc/picoirc.tcl b/lib/irc/picoirc.tcl
new file mode 100644
index 0000000..75c1d05
--- /dev/null
+++ b/lib/irc/picoirc.tcl
@@ -0,0 +1,261 @@
+# Based upon the picoirc code by Salvatore Sanfillipo and Richard Suchenwirth
+# See http://wiki.tcl.tk/13134 for the original standalone version.
+# 
+#	This package provides a general purpose minimal IRC client suitable for
+#	embedding in other applications. All communication with the parent
+#	application is done via an application provided callback procedure.
+#
+# Copyright (c) 2004 Salvatore Sanfillipo
+# Copyright (c) 2004 Richard Suchenwirth
+# Copyright (c) 2007 Patrick Thoyts
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+# $Id: picoirc.tcl,v 1.3 2007/10/24 10:38:57 patthoyts Exp $
+
+namespace eval ::picoirc {
+    variable version 0.5
+    variable uid; if {![info exists uid]} { set uid 0 }
+    variable defaults {
+        server   "irc.freenode.net"
+        port     6667
+        channel  ""
+        callback ""
+        motd     {}
+        users    {}
+    }
+    namespace export connect send post splituri
+}
+
+proc ::picoirc::splituri {uri} {
+    foreach {server port channel} {{} {} {}} break
+    if {![regexp {^irc://([^:/]+)(?::([^/]+))?(?:/([^,]+))?} $uri -> server port channel]} {
+        regexp {^(?:([^@]+)@)?([^:]+)(?::(\d+))?} $uri -> channel server port
+    }
+    if {$port eq {}} { set port 6667 }
+    return [list $server $port $channel]
+}
+
+proc ::picoirc::connect {callback nick args} {
+    if {[llength $args] > 2} {
+        return -code error "wrong # args: must be \"callback nick ?passwd? url\""
+    } elseif {[llength $args] == 1} {
+        set url [lindex $args 0]
+    } else {
+        foreach {passwd url} $args break 
+    }
+    variable defaults
+    variable uid
+    set context [namespace current]::irc[incr uid]
+    upvar #0 $context irc
+    array set irc $defaults
+    foreach {server port channel} [splituri $url] break
+    if {[info exists channel] && $channel ne ""} {set irc(channel) $channel}
+    if {[info exists server] && $server ne ""} {set irc(server) $server}
+    if {[info exists port] && $port ne ""} {set irc(port) $port}
+    if {[info exists passwd] && $passwd ne ""} {set irc(passwd) $passwd}
+    set irc(callback) $callback
+    set irc(nick) $nick
+    Callback $context init
+    set irc(socket) [socket -async $irc(server) $irc(port)]
+    fileevent $irc(socket) readable [list [namespace origin Read] $context]
+    fileevent $irc(socket) writable [list [namespace origin Write] $context]
+    return $context
+}
+
+proc ::picoirc::Callback {context state args} {
+    upvar #0 $context irc
+    if {[llength $irc(callback)] > 0
+        && [llength [info commands [lindex $irc(callback) 0]]] == 1} {
+        if {[catch {eval $irc(callback) [list $context $state] $args} err]} {
+            puts stderr "callback error: $err"
+        }
+    }
+}
+
+proc ::picoirc::Version {context} {
+    if {[catch {Callback $context version} ver]} { set ver {} }
+    if {$ver eq {}} {
+        set ver "PicoIRC:[package provide picoirc]:Tcl [info patchlevel]"
+    }
+    return $ver
+}
+
+proc ::picoirc::Write {context} {
+    upvar #0 $context irc
+    fileevent $irc(socket) writable {}
+    if {[set err [fconfigure $irc(socket) -error]] ne ""} {
+        Callback $context close $err
+        close $irc(socket)
+        unset irc
+        return
+    }
+    fconfigure $irc(socket) -blocking 0 -buffering line -translation crlf -encoding utf-8
+    Callback $context connect
+    if {[info exists irc(passwd)]} {
+        send $context "PASS $irc(passwd)"
+    }
+    set ver [join [lrange [split [Version $context] :] 0 1] " "]
+    send $context "NICK $irc(nick)"
+    send $context "USER $::tcl_platform(user) 0 * :$ver user"
+    if {$irc(channel) ne {}} {
+        after idle [list [namespace origin send] $context "JOIN $irc(channel)"]
+    }
+    return
+}
+
+proc ::picoirc::Splitirc {s} {
+    foreach v {nick flags user host} {set $v {}}
+    regexp {^([^!]*)!([^=]*)=([^@]+)@(.*)} $s -> nick flags user host
+    return [list $nick $flags $user $host]
+}
+
+proc ::picoirc::Read {context} {
+    upvar #0 $context irc
+    if {[eof $irc(socket)]} {
+        fileevent $irc(socket) readable {}
+        Callback $context close
+        close $irc(socket)
+        unset irc
+        return
+    }
+    if {[gets $irc(socket) line] != -1} {
+        if {[string match "PING*" $line]} {
+            send $context "PONG [info hostname] [lindex [split $line] 1]"
+            return
+        }
+        # the callback can return -code break to prevent processing the read
+        if {[catch {Callback $context debug read $line}] == 3} {
+            return
+        }
+        if {[regexp {:([^!]*)![^ ].* +PRIVMSG ([^ :]+) +:(.*)} $line -> \
+                 nick target msg]} {
+            set type ""
+            if {[regexp {\001(\S+)(.*)?\001} $msg -> ctcp data]} {
+                switch -- $ctcp {
+                    ACTION { set type ACTION ; set msg $data }
+                    VERSION {
+                        send $context "PRIVMSG $nick :\001VERSION [Version $context]\001"
+                        return 
+                    }
+                    default {
+                        send $context "PRIVMSG $nick :\001ERRMSG $msg : unknown query"
+                        return
+                    }
+                }
+            }
+            if {[lsearch -exact {azbridge ijchain} $nick] != -1} {
+                if {$type eq "ACTION"} {
+                    regexp {(\S+) (.+)} $msg -> nick msg 
+                } else {
+                    regexp {<([^>]+)> (.+)} $msg -> nick msg
+                }
+            }
+            Callback $context chat $target $nick $msg $type
+        } elseif {[regexp {^:((?:([^ ]+) +){1,}?):(.*)$} $line -> parts junk rest]} {
+            foreach {server code target fourth fifth} [split $parts] break
+            switch -- $code {
+                001 - 002 - 003 - 004 - 005 - 250 - 251 - 252 - 
+                254 - 255 - 265 - 266 { return }
+                433 {
+                    variable nickid ; if {![info exists nickid]} {set nickid 0}
+                    set seqlen [string length [incr nickid]]
+                    set irc(nick) [string range $irc(nick) 0 [expr 8-$seqlen]]$nickid
+                    send $context "NICK $irc(nick)"
+                }
+                353 { set irc(users) [concat $irc(users) $rest]; return }
+                366 {
+                    Callback $context userlist $fourth $irc(users)
+                    set irc(users) {}
+                    return
+                }
+                332 { Callback $context topic $fourth $rest; return }
+                333 { return }
+                375 { set irc(motd) {} ; return }
+                372 { append irc(motd) $rest ; return}
+                376 { return }
+                311 {
+                    foreach {server code target nick name host x} [split $parts] break
+                    set irc(whois,$fourth) [list name $name host $host userinfo $rest]
+                    return
+                }
+                301 - 312 - 317 - 320 { return }
+                319 { lappend irc(whois,$fourth) channels $rest; return }
+                318 {
+                    if {[info exists irc(whois,$fourth)]} {
+                        Callback $context userinfo $fourth $irc(whois,$fourth)
+                        unset irc(whois,$fourth)
+                    }
+                    return
+                }
+                JOIN {
+                    foreach {n f u h} [Splitirc $server] break
+                    Callback $context traffic entered $rest $n
+                    return
+                }
+                NICK {
+                    foreach {n f u h} [Splitirc $server] break
+                    Callback $context traffic nickchange {} $n $rest
+                    return
+                }
+                QUIT - PART {
+                    foreach {n f u h} [Splitirc $server] break
+                    Callback $context traffic left $target $n
+                    return
+                }
+            }
+            Callback $context system "" "[lrange [split $parts] 1 end] $rest"
+        } else {
+            Callback $context system "" $line
+        }
+    }
+}
+
+proc ::picoirc::post {context channel msg} {
+    upvar #0 $context irc
+    set type ""
+    if [regexp {^/([^ ]+) *(.*)} $msg -> cmd msg] {
+        regexp {^([^ ]+)?(?: +(.*))?} $msg -> first rest
+ 	switch -- $cmd {
+ 	    me {set msg "\001ACTION $msg\001";set type ACTION}
+ 	    nick {send $context "NICK $msg"; set $irc(nick) $msg}
+ 	    quit {send $context "QUIT" }
+            part {send $context "PART $channel" }
+ 	    names {send $context "NAMES $channel"}
+            whois {send $context "WHOIS $channel $msg"}
+            kick {send $context "KICK $channel $first :$rest"}
+            mode {send $context "MODE $msg"}
+            topic {send $context "TOPIC $channel :$msg" }
+ 	    quote {send $context $msg}
+ 	    join {send $context "JOIN $msg" }
+            version {send $context "PRIVMSG $first :\001VERSION\001"}
+ 	    msg {
+ 		if {[regexp {([^ ]+) +(.*)} $msg -> target querymsg]} {
+ 		    send $context "PRIVMSG $target :$msg"
+ 		    Callback $context chat $target $target $querymsg ""
+ 		}
+ 	    }
+ 	    default {Callback $context system $channel "unknown command /$cmd"}
+ 	}
+ 	if {$cmd ne {me} || $cmd eq {msg}} return
+    }
+    foreach line [split $msg \n] {send $context "PRIVMSG $channel :$line"}
+    Callback $context chat $channel $irc(nick) $msg $type
+}
+
+proc ::picoirc::send {context line} {
+    upvar #0 $context irc
+    # the callback can return -code break to prevent writing to socket
+    if {[catch {Callback $context debug write $line}] != 3} {
+        puts $irc(socket) $line
+    }
+}
+
+# -------------------------------------------------------------------------
+
+package provide picoirc $::picoirc::version
+
+# -------------------------------------------------------------------------
diff --git a/lib/irc/pkgIndex.tcl b/lib/irc/pkgIndex.tcl
new file mode 100644
index 0000000..117eb32
--- /dev/null
+++ b/lib/irc/pkgIndex.tcl
@@ -0,0 +1,8 @@
+# pkgIndex.tcl                                                    -*- tcl -*-
+# $Id: pkgIndex.tcl,v 1.8 2007/10/19 21:17:13 patthoyts Exp $
+if { ![package vsatisfies [package provide Tcl] 8.3] } {
+    # PRAGMA: returnok
+    return 
+}
+package ifneeded irc 0.6 [list source [file join $dir irc.tcl]]
+package ifneeded picoirc 0.5 [list source [file join $dir picoirc.tcl]]
diff --git a/lib/jabberlib/XMLFormat.tcl b/lib/jabberlib/XMLFormat.tcl
new file mode 100644
index 0000000..feea267
--- /dev/null
+++ b/lib/jabberlib/XMLFormat.tcl
@@ -0,0 +1,41 @@
+package require xml
+
+set _wspc {[ \t\n\r]*}
+proc CData {data args} {
+    global indent _wspc
+
+    if {![regexp "^${_wspc}$" $data]} {
+	puts "$indent  $data"
+    }
+}
+proc EStart {name attlist args} {
+    global indent
+
+    set attrs {}
+    foreach {key value} $attlist {
+	lappend attrs "$key='$value'"
+    }
+    puts "${indent}<$name $attrs>"
+    append indent {    }
+}
+proc EEnd {name args} {
+    global indent
+
+    set indent [string range $indent 0 end-4]
+    puts "${indent}</$name>"
+}
+
+set indent {}
+set parser [::xml::parser -characterdatacommand CData -elementstartcommand EStart  \
+  -elementendcommand EEnd]
+
+proc Format {} {
+    global  parser
+    
+    set fileName [tk_getOpenFile]
+    set fd [open $fileName]
+    $parser parse [read $fd]
+    close $fd
+}
+Format
+
diff --git a/lib/jabberlib/avatar.tcl b/lib/jabberlib/avatar.tcl
new file mode 100644
index 0000000..cfc88f7
--- /dev/null
+++ b/lib/jabberlib/avatar.tcl
@@ -0,0 +1,807 @@
+#  avatar.tcl --
+#  
+#      This file is part of the jabberlib. 
+#      It provides support for avatars (XEP-0008: IQ-Based Avatars)
+#      and vCard based avatars as XEP-0153.
+#      Note that this XEP is "historical" only but is easy to adapt to
+#      a future pub-sub method.
+#      
+#  Copyright (c) 2005-2006  Mats Bengtsson
+#  Copyright (c) 2006 Antonio Cano Damas
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: avatar.tcl,v 1.27 2007/11/10 15:44:59 matben Exp $
+# 
+############################# USAGE ############################################
+#
+#   NAME
+#      avatar - convenience command library for avatars.
+#      
+#   SYNOPSIS
+#      jlib::avatar::init jlibname
+#
+#   OPTIONS
+#      -announce   0|1
+#      -share      0|1
+#      -command    tclProc      invoked when hash changed
+#      -cache      0|1
+#	
+#   INSTANCE COMMANDS
+#      jlibName avatar configure ?-key value...?
+#      jlibName avatar set_data data mime
+#      jlibName avatar unset_data
+#      jlibName avatar store command
+#      jlibName avatar store_remove command
+#      jlibName avatar get_async jid command
+#      jlibName avatar send_get jid command
+#      jlibName avatar send_get_storage jid command
+#      jlibName avatar get_data jid2
+#      jlibName avatar get_hash jid2
+#      jlibName avatar get_mime jid2
+#      jlibName avatar have_data jid2
+#      jlibName avatar have_hash jid2
+#      
+#   Note that all internal storage refers to bare (2-tier) JIDs!
+#   @@@ It is unclear if this is correct. Perhaps the full JIDs shall be used.
+#   The problem is with XEP-0008 mixing JID2 with JID3.  
+#   Note that all vCards are defined per JID2, bare JID.
+#   
+#   @@@ And what happens for groupchat members?
+#   
+#   No automatic presence or server storage is made when reconfiguring or
+#   changing own avatar. This is up to the client layer to do.
+#   It is callback based which means that the -command is only invoked when
+#   getting hashes and not else.
+#      
+################################################################################
+# TODO:
+#       1) Update to XEP-0084: User Avatar 1.0, 2007-11-07, using PEP
+
+package require base64     ; # tcllib
+package require sha1       ; # tcllib                           
+package require jlib
+package require jlib::disco
+package require jlib::vcard
+
+package provide jlib::avatar 0.1
+
+namespace eval jlib::avatar {
+    variable inited 0
+    variable xmlns
+    set xmlns(x-avatar)   "jabber:x:avatar"
+    set xmlns(iq-avatar)  "jabber:iq:avatar"
+    set xmlns(storage)    "storage:client:avatar"
+    set xmlns(vcard-temp) "vcard-temp:x:update"
+
+    jlib::ensamble_register avatar \
+      [namespace current]::init    \
+      [namespace current]::cmdproc
+        
+    jlib::disco::registerfeature $xmlns(iq-avatar)
+    
+    # Note: jlib::ensamble_register is last in this file!
+}
+
+proc jlib::avatar::init {jlibname args} {
+
+    variable xmlns
+    
+    # Instance specific arrays:
+    #   avatar stores our own avatar
+    #   state stores other avatars
+    namespace eval ${jlibname}::avatar {
+	variable avatar
+	variable state
+	variable options
+    }
+    upvar ${jlibname}::avatar::avatar  avatar
+    upvar ${jlibname}::avatar::state   state
+    upvar ${jlibname}::avatar::options options
+
+    array set options {
+	-announce   0
+	-share      0
+	-cache      1
+	-command    ""
+    }
+    eval {configure $jlibname} $args
+    
+    # Register some standard iq handlers that are handled internally.
+    $jlibname iq_register get $xmlns(iq-avatar) [namespace current]::iq_handler
+    $jlibname presence_register_int available  \
+      [namespace current]::presence_handler
+    
+    $jlibname register_reset [namespace current]::reset
+
+    return
+}
+
+proc jlib::avatar::reset {jlibname} {
+    upvar ${jlibname}::avatar::state state
+    upvar ${jlibname}::avatar::options options
+
+    # Do not unset our own avatar.
+    if {!$options(-cache)} {
+	unset -nocomplain state
+    }
+}
+
+# jlib::avatar::cmdproc --
+#
+#       Just dispatches the command to the right procedure.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       cmd:        
+#       args:       all args to the cmd procedure.
+#       
+# Results:
+#       none.
+
+proc jlib::avatar::cmdproc {jlibname cmd args} {
+    
+    # Which command? Just dispatch the command to the right procedure.
+    return [eval {$cmd $jlibname} $args]
+}
+
+proc jlib::avatar::configure {jlibname args} {
+    
+    upvar ${jlibname}::avatar::options options
+    
+    set opts [lsort [array names options -*]]
+    set usage [join $opts ", "]
+    if {[llength $args] == 0} {
+	set result {}
+	foreach name $opts {
+	    lappend result $name $options($name)
+	}
+	return $result
+    }
+    regsub -all -- - $opts {} opts
+    set pat ^-([join $opts |])$
+    if {[llength $args] == 1} {
+	set flag [lindex $args 0]
+	if {[regexp -- $pat $flag]} {
+	    return $options($flag)
+	} else {
+	    return -code error "Unknown option $flag, must be: $usage"
+	}
+    } else {
+	array set oldopts [array get options]
+	foreach {flag value} $args {
+	    if {[regexp -- $pat $flag]} {
+		set options($flag) $value		
+	    } else {
+		return -code error "Unknown option $flag, must be: $usage"
+	    }
+	}
+	if {$options(-announce) != $oldopts(-announce)} {
+	    if {$options(-announce)} {
+		# @@@ ???
+	    } else {
+		$jlibname deregister_presence_stanza x $xmlns(x-avatar)
+                $jlibname deregister_presence_stanza x $xmlns(vcard-temp)
+	    }
+	}
+    }
+}
+
+#+++ Two sections: First part deals with our own avatar ------------------------
+
+# jlib::avatar::set_data --
+# 
+#       Sets our own avatar data and shares it by default.
+#       Registers new hashes but does not send updated presence.
+#       You have to send presence yourself.
+#       
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       data:       raw binary image data.
+#       mime:       the mime type: image/gif or image/png
+#       
+# Results:
+#       none.
+
+proc jlib::avatar::set_data {jlibname data mime} {
+    variable xmlns
+    upvar ${jlibname}::avatar::avatar  avatar
+    upvar ${jlibname}::avatar::options options
+
+    set options(-announce) 1
+    set options(-share)    1
+    
+    if {[info exists avatar(hash)]} {
+	set oldHash $avatar(hash)
+    } else {
+	set oldHash ""
+    }
+    set avatar(data)   $data
+    set avatar(mime)   $mime
+    set avatar(hash)   [::sha1::sha1 $data]
+    set avatar(base64) [::base64::encode $data]
+    
+    set hashElem [wrapper::createtag hash -chdata $avatar(hash)]
+    set xElem [wrapper::createtag x           \
+      -attrlist [list xmlns $xmlns(x-avatar)] \
+      -subtags [list $hashElem]]
+
+    $jlibname deregister_presence_stanza x $xmlns(x-avatar)
+    $jlibname register_presence_stanza $xElem -type available
+
+    #-- vCard-temp presence stanza --
+    set photoElem [wrapper::createtag photo -chdata $avatar(hash)]
+    set xVCardElem [wrapper::createtag x         \
+      -attrlist [list xmlns $xmlns(vcard-temp)]  \
+      -subtags [list $photoElem]]
+
+    $jlibname deregister_presence_stanza x $xmlns(vcard-temp)
+    $jlibname register_presence_stanza $xVCardElem -type available
+
+    return
+}
+
+proc jlib::avatar::get_my_data {jlibname what} {
+    upvar ${jlibname}::avatar::avatar avatar
+    
+    return $avatar($what)
+}
+
+# jlib::avatar::unset_data --
+# 
+#       Unsets our avatar and does not share it anymore.
+#       You have to send presence yourself with empty hashes.
+
+proc jlib::avatar::unset_data {jlibname} {
+    variable xmlns
+    upvar ${jlibname}::avatar::avatar  avatar
+    upvar ${jlibname}::avatar::options options
+    
+    unset -nocomplain avatar
+    set options(-announce) 0
+    set options(-share)    0
+    
+    $jlibname deregister_presence_stanza x $xmlns(x-avatar)
+    $jlibname deregister_presence_stanza x $xmlns(vcard-temp)
+
+    return
+}
+
+# jlib::avatar::store --
+# 
+#       Stores our avatar at the server.
+#       Must store as bare jid.
+
+proc jlib::avatar::store {jlibname cmd} {
+    variable xmlns
+    upvar ${jlibname}::avatar::avatar avatar
+    
+    if {![array exists avatar]} {
+	return -code error "no avatar set"
+    }
+    set dataElem [wrapper::createtag data        \
+      -attrlist [list mimetype $avatar(mime)] \
+      -chdata $avatar(base64)]
+
+    set jid2 [$jlibname getthis myjid2]
+    $jlibname iq_set $xmlns(storage)  \
+      -to $jid2 -command $cmd -sublists [list $dataElem]
+}
+
+proc jlib::avatar::store_remove {jlibname cmd} {
+    variable xmlns
+    
+    set jid2 [$jlibname getthis myjid2]
+    $jlibname iq_set $xmlns(storage) -to $jid2 -command $cmd   
+}
+
+# jlib::avatar::iq_handler --
+# 
+#       Handles incoming iq requests for our avatar.
+
+proc jlib::avatar::iq_handler {jlibname from queryElem args} {
+    variable xmlns
+    upvar ${jlibname}::avatar::options options
+    upvar ${jlibname}::avatar::avatar  avatar
+
+    array set argsArr $args
+    if {[info exists argsArr(-xmldata)]} {
+	set xmldata $argsArr(-xmldata)
+	set from [wrapper::getattribute $xmldata from]
+	set id   [wrapper::getattribute $xmldata id]
+    } else {
+	return 0
+    }
+    
+    if {$options(-share)} {
+	set dataElem [wrapper::createtag data    \
+	  -attrlist [list mimetype $avatar(mime)] \
+	  -chdata $avatar(base64)]
+	set qElem [wrapper::createtag query  \
+	  -attrlist [list xmlns $xmlns(iq-avatar)]  \
+	  -subtags [list $dataElem]]
+	$jlibname send_iq result [list $qElem] -to $from -id $id
+	return 1
+    } else {
+	$jlibname send_iq_error $from $id 404 cancel service-unavailable
+	return 1
+    }
+}
+
+#+++ Second part deals with getting other avatars ------------------------------
+
+proc jlib::avatar::get_data {jlibname jid2} {
+    upvar ${jlibname}::avatar::state state
+    
+    set mjid2 [jlib::jidmap $jid2]
+    if {[info exists state($mjid2,data)]} {
+	return $state($mjid2,data)
+    } else {
+	return ""
+    }
+}
+
+proc jlib::avatar::get_mime {jlibname jid2} {
+    upvar ${jlibname}::avatar::state state
+    
+    set mjid2 [jlib::jidmap $jid2]
+    if {[info exists state($mjid2,mime)]} {
+	return $state($mjid2,mime)
+    } else {
+	return ""
+    }
+}
+
+proc jlib::avatar::have_data {jlibname jid2} {
+    upvar ${jlibname}::avatar::state state
+    
+    set mjid2 [jlib::jidmap $jid2]
+    return [info exists state($mjid2,data)]
+}
+
+proc jlib::avatar::get_hash {jlibname jid2} {
+    upvar ${jlibname}::avatar::state state
+    
+    set mjid2 [jlib::jidmap $jid2]
+    if {[info exists state($mjid2,hash)]} {
+	return $state($mjid2,hash)
+    } else {
+	return ""
+    }
+}
+
+proc jlib::avatar::have_hash {jlibname jid2} {
+    upvar ${jlibname}::avatar::state state
+    
+    set mjid2 [jlib::jidmap $jid2]
+    return [info exists state($mjid2,hash)]
+}
+
+proc jlib::avatar::have_hash_protocol {jlibname jid2 protocol} {
+    upvar ${jlibname}::avatar::state state
+    
+    set mjid2 [jlib::jidmap $jid2]
+    return [info exists state($mjid2,protocol,$protocol)]
+}
+
+proc jlib::avatar::get_protocols {jlibname jid2} {
+    upvar ${jlibname}::avatar::state state
+    
+    set protocols {}
+    set mjid2 [jlib::jidmap $jid2]
+    foreach p {avatar vcard} {
+	if {[info exists state($mjid2,protocol,$p)]} {
+	    lappend protocols $p
+	}
+    }
+    return $protocols
+}
+
+# jlib::avatar::get_full_jid --
+# 
+#       This is the jid3 associated with 'avatar' or jid2 if 'vcard',
+#       else we just return the jid2.
+
+proc jlib::avatar::get_full_jid {jlibname jid2} {
+    upvar ${jlibname}::avatar::state state
+
+    set mjid2 [jlib::jidmap $jid2]
+    if {[info exists state($mjid2,jid3)]} {
+	return $state($mjid2,jid3)
+    } else {
+	return $jid2
+    }
+}
+
+# jlib::avatar::get_all_avatar_jids --
+# 
+#       Gets a list of all jids with avatar support.
+#       Actually, everyone that has sent us a presence jabber:x:avatar element.
+
+proc jlib::avatar::get_all_avatar_jids {jlibname} {
+    upvar ${jlibname}::avatar::state state
+    
+    debug "jlib::avatar::get_all_avatar_jids"
+    
+    set jids {}
+    set len [string length ",hash"]
+    foreach {key hash} [array get state *,hash] {
+	if {$hash ne ""} {
+	    set jid2 [string range $key 0 end-$len]
+	    lappend jids $jid2
+	}
+    }
+    return $jids
+}
+
+proc jlib::avatar::uptodate {jlibname jid2} {
+    upvar ${jlibname}::avatar::state state
+
+    set mjid2 [jlib::jidmap $jid2]
+    if {[info exists state($mjid2,uptodate)]} {
+	return $state($mjid2,uptodate)
+    } else {
+	return 0
+    }
+}
+
+# jlib::avatar::presence_handler --
+# 
+#       We must handle both 'avatar' and 'vcard' from one place
+#       since we don't want separate callbacks if both are supplied.
+#       It is assumed that hash from any are identical.
+#       Invokes any -command if hash changed.
+
+proc jlib::avatar::presence_handler {jlibname xmldata} {
+    upvar ${jlibname}::avatar::options options
+    upvar ${jlibname}::avatar::state   state
+
+    set from [wrapper::getattribute $xmldata from]
+    set mjid [jlib::jidmap $from]
+    set mjid2 [jlib::barejid $mjid]
+
+    if {[info exists state($mjid2,hash)]} {
+	set new 0
+	set oldhash $state($mjid2,hash)
+    } else {
+	set new 1
+    }
+    set gotAvaHash [PresenceAvatar $jlibname $xmldata]
+    set gotVcardHash [PresenceVCard $jlibname $xmldata]
+            
+    if {($gotAvaHash || $gotVcardHash)} {
+    
+	# 'uptodate' tells us if we need to request new avatar.
+	# If new, or not identical to previous, unless empty.
+	if {$new || ($state($mjid2,hash) ne $oldhash)} {
+	    set hash $state($mjid2,hash)
+	    
+	    # hash can be empty.
+	    if {$hash eq ""} {
+		set state($mjid2,uptodate) 1
+		unset -nocomplain state($mjid2,data)
+	    } else {
+		set state($mjid2,uptodate) 0
+	    }
+	    if {[string length $options(-command)]} {
+		uplevel #0 $options(-command) [list $from]
+	    }
+	}
+    } else {
+	
+	# Must be sure that nothing there.
+	if {[info exists state($mjid2,hash)]} {
+	    array unset state [jlib::ESC $mjid2],*
+	}
+    }
+}
+
+# jlib::avatar::PresenceAvatar --
+# 
+#       Caches incoming <x xmlns='jabber:x:avatar'> presence elements.
+#       "To disable the avatar, the avatar-generating user's client will send 
+#        a presence packet with the jabber:x:avatar namespace but with no hash 
+#        information"
+
+proc jlib::avatar::PresenceAvatar {jlibname xmldata} {
+    variable xmlns
+    upvar ${jlibname}::avatar::state   state
+    
+    set gotHash 0
+    set elems [wrapper::getchildswithtagandxmlns $xmldata x $xmlns(x-avatar)]
+    if {[llength $elems]} {
+	set hashElem [wrapper::getfirstchildwithtag [lindex $elems 0] hash]
+	set hash [wrapper::getcdata $hashElem]
+	set from [wrapper::getattribute $xmldata from]
+	set mjid2 [jlib::jidmap [jlib::barejid $from]]
+	
+	# hash can be empty.
+	set state($mjid2,hash) $hash
+	set state($mjid2,jid3) $from
+	set state($mjid2,protocol,avatar) 1
+	set gotHash 1
+    }
+    return $gotHash
+}
+
+proc jlib::avatar::PresenceVCard {jlibname xmldata} {
+    variable xmlns
+    upvar ${jlibname}::avatar::state   state
+
+    set gotHash 0
+    set elems [wrapper::getchildswithtagandxmlns $xmldata x $xmlns(vcard-temp)]
+    if {[llength $elems]} {
+	set hashElem [wrapper::getfirstchildwithtag [lindex $elems 0] photo]
+	set hash [wrapper::getcdata $hashElem]
+	set from [wrapper::getattribute $xmldata from]
+	set mjid2 [jlib::jidmap [jlib::barejid $from]]
+
+	# Note that all vCards are defined per jid2, bare JID.
+	set state($mjid2,hash) $hash
+	set state($mjid2,jid3) $from
+	set state($mjid2,protocol,vcard) 1
+	set gotHash 1
+    }
+    return $gotHash
+}
+
+# jlib::avatar::get_async --
+# 
+#       The economical way of obtaining a users avatar.
+#       If uptodate no query made, else it sends at most one query per user
+#       to get the avatar.
+
+proc jlib::avatar::get_async {jlibname jid cmd} {
+    upvar ${jlibname}::avatar::state state
+    
+    set mjid2 [jlib::jidmap [jlib::barejid $jid]]
+    if {[uptodate $jlibname $mjid2]} {
+	uplevel #0 $cmd [list result $mjid2]
+    } elseif {[info exists state($mjid2,pending)]} {
+	lappend state($mjid2,invoke) $cmd
+    } else {
+	send_get $jlibname $jid  \
+	  [list [namespace current]::get_async_cb $jlibname $mjid2 $cmd]
+    }
+}
+
+proc jlib::avatar::get_async_cb {jlibname jid2 cmd type subiq args} {
+    upvar ${jlibname}::avatar::state state
+        
+    uplevel #0 $cmd [list $type $jid2]
+}
+
+# jlib::avatar::send_get --
+# 
+#       Initiates a request for avatar to the full jid.
+#       If fails we try to get avatar from server storage of the bare jid.
+
+proc jlib::avatar::send_get {jlibname jid cmd} {
+    variable xmlns
+    upvar ${jlibname}::avatar::state state
+    
+    debug "jlib::avatar::send_get jid=$jid"
+    
+    set mjid2 [jlib::jidmap [jlib::barejid $jid]]
+    set state($mjid2,pending) 1
+    $jlibname iq_get $xmlns(iq-avatar) -to $jid  \
+      -command [list [namespace current]::send_get_cb $jid $cmd]    
+}
+
+proc jlib::avatar::send_get_cb {jid cmd jlibname type subiq args} {
+    variable xmlns
+    upvar ${jlibname}::avatar::state state
+        
+    debug "jlib::avatar::send_get_cb jid=$jid"
+    
+    set jid2  [jlib::barejid $jid]
+    set mjid2 [jlib::jidmap $jid2]
+    unset -nocomplain state($mjid2,pending)
+
+    if {$type eq "error"} {
+	
+	# XEP-0008: "If the first method fails, the second method that should
+	# be attempted by sending a request to the server..."
+	send_get_storage $jlibname $mjid2 $cmd
+    } elseif {$type eq "result"} {
+	set ok [SetDataFromQueryElem $jlibname $mjid2 $subiq $xmlns(iq-avatar)]
+	InvokeStacked $jlibname $type $jid2
+	uplevel #0 $cmd [list $type $subiq] $args
+    }
+}
+
+# jlib::avatar::SetDataFromQueryElem --
+# 
+#       Extracts and sets internal avtar storage for the BARE jid
+#       from a query element.
+#       
+# Results:
+#       1 if there was data to store, 0 else.
+
+proc jlib::avatar::SetDataFromQueryElem {jlibname mjid2 queryElem ns} {
+    upvar ${jlibname}::avatar::state state
+    
+    # Data may be empty from xmlns='storage:client:avatar' !
+
+    set ans 0
+    if {[wrapper::getattribute $queryElem xmlns] eq $ns} {
+	set dataElem [wrapper::getfirstchildwithtag $queryElem data]
+	if {$dataElem ne {}} {
+	    
+	    # Mime type can be empty.
+	    set state($mjid2,mime) [wrapper::getattribute $dataElem mimetype]
+
+	    # We keep data in base64 format. This seems to be ok for image 
+	    # handlers.
+	    set data [wrapper::getcdata $dataElem]
+	    if {[string length $data]} {
+		set state($mjid2,data) $data
+		set state($mjid2,uptodate) 1
+		set ans 1
+	    }
+	}
+    }
+    return $ans
+}
+
+proc jlib::avatar::send_get_storage {jlibname jid2 cmd} {
+    variable xmlns
+    upvar ${jlibname}::avatar::state state
+    
+    debug "jlib::avatar::send_get_storage jid2=$jid2"
+    
+    set mjid2 [jlib::jidmap $jid2]
+    set state($mjid2,pending) 1
+    $jlibname iq_get $xmlns(storage) -to $jid2  \
+      -command [list [namespace current]::send_get_storage_cb $jid2 $cmd]    
+}
+
+proc jlib::avatar::send_get_storage_cb {jid2 cmd jlibname type subiq args} {
+    variable xmlns
+    upvar ${jlibname}::avatar::state state
+
+    debug "jlib::avatar::send_get_storage_cb type=$type"
+
+    set mjid2 [jlib::jidmap $jid2]
+    unset -nocomplain state($mjid2,pending)
+    if {$type eq "result"} {
+	set ok [SetDataFromQueryElem $jlibname $mjid2 $subiq $xmlns(storage)]
+    }
+    InvokeStacked $jlibname $type $jid2
+    uplevel #0 $cmd [list $type $subiq] $args
+}
+
+proc jlib::avatar::InvokeStacked {jlibname type jid2} {
+    upvar ${jlibname}::avatar::state state
+    
+    set mjid2 [jlib::jidmap $jid2]
+    if {[info exists state($jid2,invoke)]} {
+	foreach cmd $state($jid2,invoke) {
+	    uplevel #0 $cmd [list $type $jid2]
+	}
+	unset -nocomplain state($jid2,invoke)
+    }
+}
+
+#--- vCard support -------------------------------------------------------------
+
+proc jlib::avatar::get_vcard_async {jlibname jid2 cmd} {
+    upvar ${jlibname}::avatar::state state
+    
+    debug "jlib::avatar::get_vcard_async jid=$jid2"
+    
+    set mjid2 [jlib::jidmap $jid2]
+    if {[uptodate $jlibname $mjid2]} {
+	uplevel #0 $cmd [list result $jid2]
+    } else {
+	
+	# Need to clear vcard cache to trigger sending a request.
+	# The photo is anyway not up-to-date.
+	$jlibname vcard clear $jid2
+	$jlibname vcard get_async $jid2  \
+	  [list [namespace current]::get_vcard_async_cb $jid2 $cmd]
+    }
+}
+
+proc jlib::avatar::get_vcard_async_cb {jid2 cmd jlibname type subiq args} {
+	
+    debug "jlib::avatar::get_vcard_async_cb jid=$jid2"
+    
+    if {$type eq "result"} {
+	set mjid2 [jlib::jidmap $jid2]
+	SetDataFromVCardElem $jlibname $mjid2 $subiq
+    }
+    uplevel #0 $cmd [list $type $jid2]
+}
+
+# jlib::avatar::send_get_vcard --
+# 
+#       Support for vCard based avatars as XEP-0153.
+#       We must get vcard avatars from here since the result shall be cached.
+#       Note that all vCards are defined per jid2, bare JID.
+#       This method is more sane compared to iq-based avatars since it is
+#       based on bare jids and thus not client instance specific.
+#       Therefore it also handles offline users.
+
+proc jlib::avatar::send_get_vcard {jlibname jid2 cmd} {
+    
+    debug "jlib::avatar::send_get_vcard jid2=$jid2"
+    
+    $jlibname vcard send_get $jid2  \
+      -command [list [namespace current]::send_get_vcard_cb $jid2 $cmd]
+}
+
+proc jlib::avatar::send_get_vcard_cb {jid2 cmd jlibname type subiq args} {
+    
+    debug "jlib::avatar::send_get_vcard_cb"
+
+    if { $type eq "result" } {
+	set mjid2 [jlib::jidmap $jid2]
+	SetDataFromVCardElem $jlibname $mjid2 $subiq
+	uplevel #0 $cmd [list $type $subiq] $args
+    }
+}
+
+# jlib::avatar::SetDataFromVCardElem --
+# 
+#       Extracts and sets internal avtar storage for the BARE jid
+#       from a vcard element.
+#       
+# Results:
+#       1 if there was data to store, 0 else.
+
+proc jlib::avatar::SetDataFromVCardElem {jlibname mjid2 subiq} {
+    upvar ${jlibname}::avatar::state state
+    
+    set ans 0
+    set photoElem [wrapper::getfirstchildwithtag $subiq PHOTO]
+    if {$photoElem ne {}} {
+	set dataElem [wrapper::getfirstchildwithtag $photoElem BINVAL]
+	set mimeElem [wrapper::getfirstchildwithtag $photoElem TYPE]
+	if {$dataElem ne {}} {
+	    
+	    # We keep data in base64 format. This seems to be ok for image 
+	    # handlers.
+	    set state($mjid2,data) [wrapper::getcdata $dataElem]
+	    set state($mjid2,mime) [wrapper::getcdata $mimeElem] 
+	    set state($mjid2,uptodate) 1
+	    set ans 1
+	}
+    }
+    return $ans
+}
+
+proc jlib::avatar::debug {msg} {
+    if {0} {
+	puts "\t $msg"
+    }
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::avatar {
+
+    jlib::ensamble_register avatar \
+      [namespace current]::init    \
+      [namespace current]::cmdproc
+}
+
+if {0} {
+    # Test.
+    set f "/Users/matben/Desktop/glaze/32x32/apps/clanbomber.png"
+    set fd [open $f]
+    fconfigure $fd -translation binary
+    set data [read $fd]
+    close $fd
+    
+    set data "0123456789"
+    
+    set jlib jlib::jlib1
+    proc cb {args} {puts "--- cb"}
+    $jlib avatar set_data $data image/png
+    $jlib avatar store cb
+    $jlib avatar send_get [$jlib getthis myjid] cb
+    $jlib avatar send_get_storage [$jlib getthis myjid2] cb
+}
+
+#-------------------------------------------------------------------------------
diff --git a/lib/jabberlib/bind.tcl b/lib/jabberlib/bind.tcl
new file mode 100644
index 0000000..ba9c51c
--- /dev/null
+++ b/lib/jabberlib/bind.tcl
@@ -0,0 +1,72 @@
+#  bind.tcl --
+#  
+#      This file is part of the jabberlib. 
+#      It implements the bind resource mechanism and establish a session.
+#      
+#  Copyright (c) 2007  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: bind.tcl,v 1.1 2007/07/23 15:11:43 matben Exp $
+
+package require jlib
+
+package provide jlib::bind 0.1
+
+namespace eval jlib::bind {}
+
+proc jlib::bind::resource {jlibname resource cmd} {
+    upvar ${jlibname}::state state
+    
+    set state(resource) $resource
+    set state(cmd)      $cmd
+    
+    if {[$jlibname have_feature bind]} {
+	$jlibname bind_resource $state(resource) [namespace code resource_bind_cb]
+    } else {
+	$jlibname trace_stream_features [namespace code features]
+    }
+}
+
+proc jlib::bind::features {jlibname} {
+    upvar ${jlibname}::state state
+    
+    if {[$jlibname have_feature bind]} {
+	$jlibname bind_resource $state(resource) [namespace code resource_bind_cb]
+    } else {
+	establish_session $jlibname
+    }
+}
+
+proc jlib::bind::resource_bind_cb {jlibname type subiq} {
+    
+    if {$type eq "error"} {
+	final $jlibname error $subiq
+    } else {
+	establish_session $jlibname
+    }
+}
+
+proc jlib::bind::establish_session {jlibname} {
+    upvar jlib::xmppxmlns xmppxmlns
+    
+    # Establish the session.
+    set xmllist [wrapper::createtag session \
+      -attrlist [list xmlns $xmppxmlns(session)]]
+    $jlibname send_iq set [list $xmllist] \
+      -command [namespace code [list send_session_cb $jlibname]]
+}
+
+proc jlib::bind::send_session_cb {jlibname type subiq args} {
+    final $jlibname $type $subiq
+}
+
+proc jlib::bind::final {jlibname type subiq} {
+    upvar ${jlibname}::state state
+    
+    uplevel #0 $state(cmd) [list $jlibname $type $subiq]
+    unset -nocomplain state
+}
+
+
+
diff --git a/lib/jabberlib/bytestreams.tcl b/lib/jabberlib/bytestreams.tcl
new file mode 100644
index 0000000..13e6eef
--- /dev/null
+++ b/lib/jabberlib/bytestreams.tcl
@@ -0,0 +1,1962 @@
+#  bytestreams.tcl --
+#  
+#      This file is part of the jabberlib. 
+#      It provides support for the bytestreams protocol (XEP-0065).
+#      
+#  Copyright (c) 2005-2007  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: bytestreams.tcl,v 1.33 2007/11/30 14:38:34 matben Exp $
+# 
+############################# USAGE ############################################
+#
+#   NAME
+#       bytestreams - implements the socks5 bytestream stream protocol.
+#      
+#   SYNOPSIS
+#
+#
+#   OPTIONS
+#
+#	
+#   INSTANCE COMMANDS
+#   
+#       jlibName bytestream configure ?-address -port -timeout ms -proxyhost?
+#       jlibName bytestream send_initiate to sid cmd ?-streamhosts -fastmode?
+#       
+#      
+############################# CHANGES ##########################################
+#
+#       0.1         first version
+#       0.2         timeouts + fast mode
+#       0.3         connector object
+#       0.4         proxy support
+#
+# FAST MODE:
+#   Some details:
+#       "This is done by sending an additional [CR] character across the 
+#       bytestream to indicate its selection."
+#       The character is sent after socks5 authorization, and even after 
+#       iq-streamhost-used, since the initiator must pick only a working stream.
+#       If the desired stream is offered by the initiator, it would send the 
+#       character only after receiving iq-streamhost-used from the target.  
+#       If the desired stream is offered by the target, then the initiator 
+#       would send the character after it sends iq-streamhost-used to the target.
+#
+#       When do we know to use the fast mode protocol?
+#       (initiator):  received streamhost with sid we have initiated
+#       (target):     receiving streamhost+fast and sent streamhost
+#       
+#       initiator                               target
+#       ---------                               ------
+#       
+#                      streamhosts + fast
+#                 --------------------------->
+#                 
+#                     streamhosts (fastmode)
+#                 <---------------------------
+#                 
+#                        connector (s5)
+#                 <---------------------------
+#                 
+#                     connector (s5) (fastmode)
+#                 --------------------------->
+#                 
+#                       streamhost-used
+#          sock   <---------------------------
+#                 
+#                  streamhost-used (fastmode)
+#       sock_fast --------------------------->
+#                 
+#       Initiator picks one of 0-2 sockets and fastmode sends a CR.
+#       
+# HASH:
+#       SHA1(SID + Initiator JID + Target JID)
+#       The JIDs provided MUST be the JIDs used for the IQ exchange; 
+#       furthermore, in order to ensure proper results, the appropriate 
+#       stringprep profiles.
+#       
+# INITIATOR FLOW:
+#       There are two different flows:
+#           (1) iq query/response
+#           (2) socks5 connections and negotiations, denoted s5 here
+#       They interact and depend on each other. (f) means fast mode only.
+#       As seen from the initiator:
+# 
+#           (a) iq-stream initiate (send)
+#       (f) (b) iq-stream target provides streamhosts to initiator (recv)
+#           (1) s5 socket to initiators server
+#       (f) (2) s5 fast socket to targets streamhost
+#           (3) s5 socket initiator to proxy
+#           
+#       iq-stream (a) controls (1) and (3)
+#       iq-stream (b) controls (2)
+#       
+#       There are three possible s5 streams:
+#           
+#           (A) s5 (server) initiator <---  s5 (client) target
+#       (f) (B) s5 (client) initiator  ---> s5 (server) target
+#           (C) s5 (client) initiator  ---> s5 (server) proxy
+#           
+#       The first succesful stream wins and kills the other.
+#       
+# TARGET:
+#       The target handles the (intiators) proxy like any other streamhost
+#       and proxies are therefore transparent to the target.
+#       
+#       
+# NOTES:
+#       o If yoy are trying to follow this code, focus on one side alone,
+#         initiator or target, else you are likely to get insane.
+
+package require sha1
+package require jlib
+package require jlib::disco
+package require jlib::si
+                          
+package provide jlib::bytestreams 0.4
+
+#--- generic bytestreams -------------------------------------------------------
+
+namespace eval jlib::bytestreams {
+
+    variable xmlns
+    set xmlns(bs)   "http://jabber.org/protocol/bytestreams"
+    set xmlns(fast) "http://affinix.com/jabber/stream"
+        
+    jlib::si::registertransport $xmlns(bs) $xmlns(bs) 40  \
+      [namespace current]::si_open   \
+      [namespace current]::si_close    
+    
+    jlib::disco::registerfeature $xmlns(bs)
+    
+    # Support for http://affinix.com/jabber/stream.
+    variable fastmode 1
+    
+    # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::bytestreams::init --
+# 
+#       Instance init procedure.
+  
+proc jlib::bytestreams::init {jlibname args} {
+    variable xmlns
+        
+    # Keep different state arrays for initiator (i) and receiver (t).
+    namespace eval ${jlibname}::bytestreams {
+	variable istate
+	variable tstate
+
+	# Mapper from SOCKS5 hash to sid.
+	variable hash2sid
+	
+	# Independent of sid variables.
+	variable static
+	
+	# Server port 0 says that arbitrary port can be chosen.
+	set static(-address)        ""
+	set static(-block-size)     4096
+	set static(-port)           0
+	set static(-s5timeoutms)    8000  ;# TODO
+	set static(-timeoutms)      30000
+	set static(-proxyhost)      [list]
+	set static(-targetproxy)    0     ;# Not implemented
+    }
+
+    # Register standard iq handler that is handled internally.
+    $jlibname iq_register set $xmlns(bs) [namespace current]::handle_set
+    eval {configure $jlibname} $args
+    
+    return
+}
+
+proc jlib::bytestreams::cmdproc {jlibname cmd args} {
+
+    # Which command? Just dispatch the command to the right procedure.
+    return [eval {$cmd $jlibname} $args]
+}
+
+proc jlib::bytestreams::configure {jlibname args} {
+    
+    upvar ${jlibname}::bytestreams::static static
+    
+    if {![llength $args]} {
+	return [array get static -*]
+    } else {
+	foreach {key value} $args {
+	    
+	    switch -- $key {
+		-address {
+		    set static($key) $value
+		}
+		-port - -timeoutms {
+		    if {![string is integer -strict $value]} {
+			return -code error "$key must be integer number"
+		    }
+		    set static($key) $value
+		}
+		-proxyhost {
+		    if {[llength $value]} {
+			if {[llength $value] != 3} {
+			    return -code error "$key must be a list {jid ip port}"
+			}
+			if {![string is integer -strict [lindex $value 2]]} {
+			    return -code error "port must be an integer number"
+			}
+		    }
+		    set static($key) $value
+		}
+		-targetproxy {
+		    if {![string is boolean -strict $value]} {
+			return -code error "$key must be integer number"
+		    }
+		    set static($key) $value
+		}
+		default {
+		    return -code error "unknown option \"$key\""
+		}
+	    }
+	}
+    }
+    return
+}
+
+# Common code for both initiator and target.
+
+# jlib::bytestreams::i_or_t --
+# 
+#       In some situations we must know if we are the initiator or target
+#       using just the sid.
+
+proc jlib::bytestreams::i_or_t {jlibname sid} {
+    
+    upvar ${jlibname}::bytestreams::istate istate
+    upvar ${jlibname}::bytestreams::tstate tstate
+    debug "jlib::bytestreams::i_or_t"
+    
+    if {[info exists istate($sid,state)]} {
+	return "i"
+    } elseif {[info exists tstate($sid,state)]} {
+	return "t"
+    } else {
+	return ""
+    }
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#
+# These are all functions to use by a initiator (sender).
+
+# si_open, si_close --
+# 
+#       Bindings for si.
+
+# jlib::bytestreams::si_open --
+# 
+#       Constructor for an initiator object.
+
+proc jlib::bytestreams::si_open {jlibname jid sid args} {
+    
+    variable fastmode
+    upvar ${jlibname}::bytestreams::istate istate
+    upvar ${jlibname}::bytestreams::static static
+    upvar ${jlibname}::bytestreams::hash2sid hash2sid
+    debug "jlib::bytestreams::si_open (i)"
+    
+    set jid [jlib::jidmap $jid]
+    set istate($sid,jid) $jid
+    
+    if {![info exists static(sock)]} {
+	
+	# Protect against server failure.
+	if {[catch {s5i_server $jlibname}]} {
+	    si_open_report $jlibname $sid error  \
+	      {error "Failed starting our streamhost"}
+	    return
+	}
+    }
+    
+    # Provide our streamhosts. 
+    # First, the local one.
+    if {$static(-address) ne ""} {
+	set ip $static(-address)
+    } else {
+	set ip [jlib::getip $jlibname]
+    }
+    set myjid [jlib::myjid $jlibname]
+    set hash  [::sha1::sha1 $sid$myjid$jid]
+    
+    set istate($sid,ip)           $ip
+    set istate($sid,state)        open
+    set istate($sid,fast)         0
+    set istate($sid,hash)         $hash
+    set istate($sid,used-proxy)   0      ;# Set if target picks our proxy host
+    set istate($sid,proxy,state)  ""
+    
+    set hash2sid($hash) $sid
+    set host [list $myjid -host $ip -port $static(port)]
+    set streamhosts [list $host]
+    set opts [list]
+    lappend opts -fastmode $fastmode
+    
+    # Second, the proxy host if any.
+    if {[llength $static(-proxyhost)]} {
+	lassign $static(-proxyhost) pjid pip pport
+	set proxyhost [list $pjid -host $pip -port $pport]
+	lappend streamhosts $proxyhost
+	lappend opts -proxyjid $pjid
+    }
+    lappend opts -streamhosts $streamhosts
+    
+    # Schedule a timeout until we get a streamhost-used returned.
+    set istate($sid,timeoutid) [after $static(-timeoutms)  \
+      [list [namespace current]::si_timeout_cb $jlibname $sid]]
+    
+    # Initiate the stream to the target.
+    set si_open_cb [list [namespace current]::si_open_cb $jlibname $sid]
+    eval {send_initiate $jlibname $jid $sid $si_open_cb} $opts
+
+    return
+}
+
+proc jlib::bytestreams::si_timeout_cb {jlibname sid} {
+    
+    upvar ${jlibname}::bytestreams::istate istate
+    debug "jlib::bytestreams::si_timeout_cb (i)"
+    
+    si_open_report $jlibname $sid "error" {timeout "Timeout"}
+    ifinish $jlibname $sid
+}
+
+# jlib::bytestreams::si_open_cb --
+# 
+#       This is the iq-response we get as an initiator when sent our streamhosts
+#       to the target. We expect that it either returns a 'streamhost-used'
+#       or an error. 
+#       We shall not return any iq as a response to this response.
+# 
+#       The target either returns an error if it failed to connect any
+#       streamhost, else it replies eith a 'streamhost-used' element.
+#       
+#       This is the main event handler for the initiator where it manages
+#       both open iq-streams as well as all sockets.
+#       
+#       See also 'i_connect_cb' for the fastmode side.
+
+proc jlib::bytestreams::si_open_cb {jlibname sid type subiq args} {
+    
+    variable xmlns
+    upvar ${jlibname}::bytestreams::istate istate
+    upvar ${jlibname}::bytestreams::static static
+    debug "jlib::bytestreams::si_open_cb (i) type=$type"
+    
+    # In fast mode we may get this callback after we have finished.
+    # Or after a timeout or something.
+    if {![info exists istate($sid,state)]} {
+	return
+    }
+
+    # 'result' is normally the iq type but we add more error checking.
+    # Try to catch possible error situations.
+    set result $type
+    set istate($sid,type)  $type
+    set istate($sid,subiq) $subiq
+    
+    # Collect streamhost used. If this fails we need to catch it below.
+    if {$type eq "result"} {
+	if {[wrapper::gettag $subiq] eq "query"  \
+	  && [wrapper::getattribute $subiq xmlns] eq $xmlns(bs)} {
+	    set usedE [wrapper::getfirstchildwithtag $subiq "streamhost-used"]
+	    if {[llength $usedE]} {
+		set jidused [wrapper::getattribute $usedE "jid"]
+		set istate($sid,streamhost-used) $jidused
+		
+		# Need to know if target picked our proxy streamhost.
+		set jidproxy [lindex $static(-proxyhost) 0]
+		if {[jlib::jidequal $jidused $jidproxy]} {
+		    set istate($sid,used-proxy) 1
+		}
+	    }
+	}
+    }
+    debug "\t used-proxy=$istate($sid,used-proxy)"
+    
+    # Must end the normal path if the target sent us weird response.
+    if {![info exists istate($sid,streamhost-used)]} {
+	set istate($sid,state) error    
+	set istate($sid,subiq) {error "missing streamhost-used"}
+    }
+    if {$result eq "error"} {
+	set istate($sid,state) error    
+    }
+    
+    # NB1: We may already have picked fast mode and istate($sid,state) = error
+    #      Even if the normal path succeded!
+    # NB2: We can never pick fast mode from this proc!
+    
+    # Fastmode only:
+    if {$istate($sid,fast)} {	
+	if {$istate($sid,state) eq "error"} {
+	    ifast_error_normal $jlibname $sid
+	} else {
+	    if {$istate($sid,used-proxy)} {
+		
+		# Now its time to start up and activate our proxy host.
+		iproxy_connect $jlibname $sid
+	    } else {
+		ifast_select_normal $jlibname $sid
+		ifast_end_fast $jlibname $sid
+	    }
+	}
+    } else {	
+	
+	# Normal non-fastmode execution path.
+	if {$result eq "error"} {
+	    if {[info exists istate($sid,sock)]} {
+		debug_sock "close $istate($sid,sock)"
+		catch {close $istate($sid,sock)}
+		unset istate($sid,sock)
+	    }
+	    si_open_report $jlibname $sid $type $istate($sid,subiq)
+	} else {
+	    
+	    if {$istate($sid,used-proxy)} {
+		
+		# Now its time to start up and activate our proxy host.
+		iproxy_connect $jlibname $sid
+	    } else {
+		
+		# One last check that we actually got a socket connection.
+		# Try to catch possible error situations.
+		if {![info exists istate($sid,sock)]} {
+		    set istate($sid,state) error
+		    si_open_report $jlibname $sid error {error "Network Error"}
+		} else {
+
+		    # Everything is fine.
+		    set istate($sid,state) streamhost-used    
+		    set istate($sid,active,sock) $istate($sid,sock)
+		    si_open_report $jlibname $sid $type $subiq
+		}
+	    }
+	}
+    }
+}
+
+# jlib::bytestreams::ifast_* --
+# 
+#       A number of methods to handle execution paths for the fast mode.
+#       They are normally called for iq-responses, but for the proxy they are
+#       called after activate response.
+#       Selects the first succesful stream and kills the others. 
+#       If all streams have failed we report the error to si.
+#       
+#       NB1: ifast_* means that we are in fast mode; the suffix normally 
+#            indicates which stream we are dealing with.
+#       NB2: we do not send any iq response here, which should only be done when
+#            calling 'ifast_select_fast'.
+
+proc jlib::bytestreams::ifast_error_normal {jlibname sid} {
+
+    upvar ${jlibname}::bytestreams::istate istate
+    debug "jlib::bytestreams::ifast_error_normal (i)"
+    
+    # The target failed the 'normal' s5 connection.
+    # Be sure to close normal and proxy sockets, (1) and (3) above.
+    set istate($sid,state) error
+    if {[info exists istate($sid,sock)]} {
+	debug_sock "close $istate($sid,sock)"
+	catch {close $istate($sid,sock)}
+	unset istate($sid,sock)
+    }
+    if {$istate($sid,used-proxy)} {
+	connector_reset $jlibname $sid p
+	if {[info exists istate($sid,proxy,sock)]} {
+	    debug_sock "close $istate($sid,proxy,sock)"
+	    catch {close $istate($sid,proxy,sock)}
+	    unset istate($sid,proxy,sock)
+	}
+    }
+    
+    # If also the 'fast' way failed we are done.
+    if {$istate($sid,fast,state) eq "error"} {
+	si_open_report $jlibname $sid error $istate($sid,subiq)
+    }
+    
+    # At this stage we may already have activated the fast stream.
+}
+
+proc jlib::bytestreams::ifast_select_normal {jlibname sid} {
+
+    upvar ${jlibname}::bytestreams::istate istate
+    debug "jlib::bytestreams::ifast_select_normal (i)"
+    
+    # Activate the 'normal' stream:
+    # Protect us from failed socks5 connections.
+    # This can be our own streamhost or the proxy host. Handle both here!
+    # Normally the target picks the one it wants.
+
+    debug "\t used-proxy=$istate($sid,used-proxy), proxy,state=$istate($sid,proxy,state)"
+    set have_s5 0
+    if {$istate($sid,used-proxy) && $istate($sid,proxy,state) eq "result"} {
+	set sock $istate($sid,proxy,sock)
+	set have_s5 1
+    } elseif {[info exists istate($sid,sock)]} {
+	set sock $istate($sid,sock)
+	set have_s5 1
+    }    
+    if {$have_s5} {
+	set istate($sid,state) activated
+	debug "\t select normal, send CR"
+	if {[catch {
+	    puts -nonewline $sock "\r"
+	    flush $sock
+	}]} {
+	    set have_s5 0
+	}
+    }
+    if {$have_s5} {
+	set istate($sid,active,sock) $sock
+	si_open_report $jlibname $sid result $istate($sid,subiq)	
+    } else {
+	debug "\t error missing s5 stream or failed send CR"
+	set istate($sid,state) error    
+	si_open_report $jlibname $sid error {error "Network Error"}
+    }
+}
+
+proc jlib::bytestreams::ifast_end_fast {jlibname sid} {
+
+    upvar ${jlibname}::bytestreams::istate istate
+    debug "jlib::bytestreams::ifast_end_fast (i)"
+		
+    # Put an end to any 'fast' stream. Both socket and iq-stream.
+    set istate($sid,fast,state) error    
+    connector_reset $jlibname $sid f
+    if {[info exists istate($sid,fast,sock)]} {
+	debug_sock "close $istate($sid,fast,sock)"
+	catch {close $istate($sid,fast,sock)}
+	unset istate($sid,fast,sock)
+    }
+    
+    # This just informs the target that our 'fast' stream is shut down.
+    if {[info exists istate($sid,fast,id)]} {
+	isend_error $jlibname $sid 404 cancel item-not-found
+    }      
+}
+
+proc jlib::bytestreams::ifast_select_fast {jlibname sid} {
+
+    upvar ${jlibname}::bytestreams::istate istate
+    debug "jlib::bytestreams::ifast_select_fast (i)"
+    
+
+    # Activate the fast stream. Set normal stream to error so we wont use it.
+    debug "\t select fast, send CR"
+    set sock $istate($sid,fast,sock)
+    set istate($sid,active,sock) $sock
+    set istate($sid,fast,state) activated
+    if {[catch {
+	puts -nonewline $sock "\r"
+	flush $sock
+    }]} {
+	debug "\t failed sending CR"
+	si_open_report $jlibname $sid error {error "Network Failure"}
+    } else {
+    
+	# Shut down the 'normal' stream:
+	# Must close down any connections to our own streamhost.
+	set istate($sid,state) error   
+	if {[info exists istate($sid,sock)]} {
+	    debug_sock "close $istate($sid,sock)"
+	    catch {close $istate($sid,sock)}
+	    unset istate($sid,sock)
+	}
+	si_open_report $jlibname $sid result {ok OK}
+    }
+}
+
+#...............................................................................
+
+# jlib::bytestreams::si_open_report --
+# 
+#       This prepares the callback to 'si' as a response to 'si_open.
+
+proc jlib::bytestreams::si_open_report {jlibname sid type subiq} {
+    
+    upvar ${jlibname}::bytestreams::istate istate
+    upvar ${jlibname}::bytestreams::static static
+    debug "jlib::bytestreams::si_open_report (i)"
+   
+    if {[info exists istate($sid,timeoutid)]} {
+	after cancel $istate($sid,timeoutid)
+	unset istate($sid,timeoutid)
+    }
+    jlib::si::transport_open_cb $jlibname $sid $type $subiq
+    
+    # If all went well this far we initiate the read/write data process.
+    if {$type eq "result"} {
+	
+	# Tell the profile to prepare to read data (open file).
+	jlib::si::open_data $jlibname $sid
+	
+	# Initiate the transport when socket is ready for writing.
+	set sock $istate($sid,active,sock)
+	setwritable $jlibname $sid $sock
+    }
+}
+
+# jlib::bytestreams::si_read --
+# 
+#       Read data from the profile via 'si' using its registered reader.
+
+proc jlib::bytestreams::si_read {jlibname sid} {
+    
+    upvar ${jlibname}::bytestreams::istate istate
+    debug "jlib::bytestreams::si_read (i)"
+
+    # NB: This should be safe to do since if we have been reset also
+    #     the fileevent handler is removed when socket is closed.
+    set s $istate($sid,active,sock)
+    
+    fileevent $s writable {}    
+    if {[catch {eof $s} iseof] || $iseof} {
+	jlib::si::close_data $jlibname $sid error
+	return
+    }
+    set data [jlib::si::read_data $jlibname $sid]
+    set len [string length $data]
+
+    if {$len > 0} {
+	if {[catch {puts -nonewline $s $data}]} {
+	    debug "\t failed"
+	    jlib::si::close_data $jlibname $sid error
+	    return
+	}
+	
+	# Trick to avoid UI blocking.
+	after idle [list after 0 [list \
+	  [namespace current]::setwritable $jlibname $sid $s]]
+    } else {
+	
+	# Empty data from the reader means that we are done.
+	jlib::si::close_data $jlibname $sid
+    }
+}
+
+proc jlib::bytestreams::setwritable {jlibname sid sock} {
+    
+    # We could have been closed since this event comes async.
+    if {[lsearch [file channels] $sock] >= 0} {
+	fileevent $sock writable  \
+	  [list [namespace current]::si_read $jlibname $sid]
+    }
+}
+
+# jlib::bytestreams::si_close --
+# 
+#       Destroys an initiator object.
+
+proc jlib::bytestreams::si_close {jlibname sid} {
+    
+    upvar ${jlibname}::bytestreams::istate istate
+    debug "jlib::bytestreams::si_close (i)"
+    
+    # We don't have any particular to do here as 'ibb' has.
+    jlib::si::transport_close_cb $jlibname $sid result {}
+    ifinish $jlibname $sid
+}
+
+proc jlib::bytestreams::is_initiator {jlibname sid} {
+    
+    upvar ${jlibname}::bytestreams::istate istate
+    debug "jlib::bytestreams::is_initiator [info exists istate($sid,state)]"
+    
+    return [info exists istate($sid,state)]
+}
+
+#--- Generic initiator code ----------------------------------------------------
+
+# jlib::bytestreams::send_initiate --
+# 
+#       -streamhosts {{jid (-host -port | -zeroconf)} {...} ...}
+#       -fastmode
+#       
+#       Stateless code that never access the istate array.
+
+proc jlib::bytestreams::send_initiate {jlibname to sid cmd args} {
+    variable xmlns    
+    debug "jlib::bytestreams::initiate"
+
+    set attrlist [list xmlns $xmlns(bs) sid $sid mode tcp]
+    set sublist [list]
+    set opts [list]
+    set proxyjid ""
+    foreach {key value} $args {
+	
+	switch -- $key {
+	    -streamhosts {
+		set streamhosts $value
+	    }
+	    -fastmode {
+		if {$value} {
+
+		    # <fast xmlns="http://affinix.com/jabber/stream"/> 
+		    lappend sublist [wrapper::createtag "fast"  \
+		      -attrlist [list xmlns $xmlns(fast)]]
+		}
+	    }
+	    -proxyjid {
+		# Mark proxy: <proxy xmlns="http://affinix.com/jabber/stream"/> 
+		set proxyjid $value
+	    }
+	    default {
+		return -code error "unknown option \"$key\""
+	    }
+	}
+    }
+    
+    # Need to do it here in order to handle any proxy element.
+    if {[info exists streamhosts]} {
+	foreach hostspec $streamhosts {
+	    set jid [lindex $hostspec 0]
+	    set hostattr [list jid $jid]
+	    foreach {hkey hvalue} [lrange $hostspec 1 end] {
+		lappend hostattr [string trimleft $hkey -] $hvalue
+	    }
+	    set ssub [list]
+	    if {[jlib::jidequal $proxyjid $jid]} {
+		set ssub [list [wrapper::createtag proxy \
+		  -attrlist [list xmlns $xmlns(fast)]]]
+	    }
+	    lappend sublist [wrapper::createtag "streamhost" \
+	      -attrlist $hostattr -subtags $ssub]
+	}
+    }
+    
+    set xmllist [wrapper::createtag "query" \
+      -attrlist $attrlist -subtags $sublist]
+    eval {$jlibname send_iq "set" [list $xmllist] -to $to -command $cmd} $opts
+    return
+}
+
+proc jlib::bytestreams::get_proxy {jlibname to cmd} {
+    variable xmlns
+    debug "jlib::bytestreams::get_proxy (i)"
+
+    $jlibname iq_get $xmlns(bs) -to $to -command $cmd
+}
+
+# jlib::bytestreams::activate --
+# 
+#       Initiator requests activation of bytestream.
+#       This is only necessary for proxy streamhosts.
+
+proc jlib::bytestreams::activate {jlibname sid to targetjid args} {
+    variable xmlns
+    debug "jlib::bytestreams::activate (i)"
+    
+    set opts [list]
+    foreach {key value} $args {
+	switch -- $key {
+	    -command {
+		set opts [list -command $value]
+	    }
+	    default {
+		return -code error "unknown option \"$key\""
+	    }
+	}
+    }
+    set activateE [wrapper::createtag "activate" -chdata $targetjid]
+    set xmllist [wrapper::createtag "query" \
+      -attrlist [list xmlns $xmlns(bs) sid $sid] \
+      -subtags [list $activateE]]
+
+    eval {$jlibname send_iq "set" [list $xmllist] -to $to} $opts
+}
+
+#--- Fastmode: handle targets streamhosts --------------------------------------
+
+# jlib::bytestreams::i_handle_set --
+# 
+#       This is the initiators handler when provided streamhosts by the
+#       target which only happens in fastmode.
+#       Fastmode only!
+
+proc jlib::bytestreams::i_handle_set {jlibname sid id jid hosts queryE} {
+
+    upvar ${jlibname}::bytestreams::istate istate
+    debug "jlib::bytestreams::i_handle_set (i)"
+    
+    # We have already initiated this sid and must have fastmode.
+    # At this stage we run in the fast mode!
+    set istate($sid,fast)        1
+    set istate($sid,fast,id)     $id
+    set istate($sid,fast,jid)    $jid
+    set istate($sid,fast,state)  inited
+    set istate($sid,fast,hosts)  $hosts
+    set istate($sid,fast,queryE) $queryE
+
+    set myjid [$jlibname myjid]
+    set hash [::sha1::sha1 $sid$jid$myjid]    
+
+    # Try connecting the host(s) in turn.
+    set cb [list [namespace current]::i_connect_cb $jlibname $sid]
+    connector $jlibname $sid f $hash $hosts $cb
+}
+
+# jlib::bytestreams::i_connect_cb --
+# 
+#       The 'connector' callback when tried to connect to the targets streamhosts. 
+#       We shall return an iq response to the targets iq streamhost offer.
+#       Fastmode only!
+
+proc jlib::bytestreams::i_connect_cb {jlibname sid result args} {
+    
+    upvar ${jlibname}::bytestreams::istate istate
+    debug "jlib::bytestreams::i_connect_cb $result (i)"
+    
+    array set argsA $args
+    
+    if {$result eq "error"} {
+	set istate($sid,fast,state) error
+	
+	# Deliver error to target.
+	isend_error $jlibname $sid 404 cancel item-not-found
+	
+	# In fastmode we are not done until the target also fails connecting.
+	if {!$istate($sid,fast) || ($istate($sid,state) eq "error")} {
+
+	    # Deliver error to target profile.
+	    si_open_report $jlibname $sid error {error "Network Failure"}
+	}
+    } elseif {$istate($sid,fast,state) ne "error"} {
+	
+	# Must be sure that the normal stream hasn't already put a stop at fast.
+	# Shouldn't be needed since it should do connector_reset.
+	set sock $argsA(-socket)
+	set host $argsA(-streamhost)
+	set hostjid [lindex $host 0]
+	
+	# Deliver 'streamhost-used' to the target.
+	set id  $istate($sid,fast,id)
+	set jid $istate($sid,fast,jid)
+	send_used $jlibname $jid $id $hostjid
+	
+	set istate($sid,fast,sock)    $sock
+	set istate($sid,fast,host)    $host
+	set istate($sid,fast,hostjid) $hostjid
+	
+	ifast_select_fast $jlibname $sid
+    }
+}
+
+# Proxy handling ---------------------------------------------------------------
+
+# This is done as a response that the target has selected the proxy streamhost.
+# There are two steps here:
+#   1) initiator make a complete socks5 connection to the proxy
+#   2) the stream is activated by the initiator
+
+proc jlib::bytestreams::iproxy_connect {jlibname sid} {
+    
+    upvar ${jlibname}::bytestreams::istate istate
+    upvar ${jlibname}::bytestreams::static static
+    debug "jlib::bytestreams::iproxy_connect (i)"
+    
+    set istate($sid,state) connecting    
+    set myjid [$jlibname myjid]
+    set jid $istate($sid,jid)
+    set hash [::sha1::sha1 $sid$myjid$jid] 
+    set hosts [list $static(-proxyhost)]
+
+    set cb [list [namespace current]::iproxy_s5_cb $jlibname $sid]
+    connector $jlibname $sid p $hash $hosts $cb    
+}
+
+proc jlib::bytestreams::iproxy_s5_cb {jlibname sid result args} {
+
+    upvar ${jlibname}::bytestreams::istate istate
+    upvar ${jlibname}::bytestreams::static static
+    debug "jlib::bytestreams::iproxy_s5_cb (i) $result $args"
+    
+    array set argsA $args
+    
+    if {$result eq "error"} {	
+	if {$istate($sid,fast)} {
+ 	    ifast_error_normal $jlibname $sid
+	} else {
+
+	    # If not fastmode we are finito.
+ 	    set istate($sid,state) error
+	    if {[info exists istate($sid,sock)]} {
+		debug_sock "close $istate($sid,sock)"
+		catch {close $istate($sid,sock)}
+		unset istate($sid,sock)
+	    }
+	    si_open_report $jlibname $sid error {error "Network Error"}
+	}
+    } else {
+	
+	# Allright so far, cache socket.
+	# Note that we need a specific variable for this since the target can
+	# connect our server: istate($sid,sock).
+	set istate($sid,proxy,sock) $argsA(-socket)
+	set proxyjid [lindex $static(-proxyhost) 0]
+	set jid $istate($sid,jid)
+	set cb [list [namespace current]::iproxy_activate_cb $jlibname $sid]
+	activate $jlibname $sid $proxyjid $jid -command $cb
+    }
+}
+
+proc jlib::bytestreams::iproxy_activate_cb {jlibname sid type subiq args} {
+
+    upvar ${jlibname}::bytestreams::istate istate
+    debug "jlib::bytestreams::iproxy_activate_cb (i) type=$type"
+    
+    set istate($sid,proxy,state) $type
+    set istate($sid,type) $type
+    set istate($sid,subiq) $subiq
+    
+    if {$istate($sid,fast)} {	
+	
+	# When we get this response the fast mode may already have succeded.
+	if {$istate($sid,state) eq "error"} {
+	    ifast_error_normal $jlibname $sid
+	} else {
+	    ifast_select_normal $jlibname $sid
+	    ifast_end_fast $jlibname $sid
+	}
+    } else {	
+	if {$type eq "error"} {
+
+	    # If not fastmode we are finito.
+	    set istate($sid,state) error
+	} else {
+	
+	    # Everything is fine.
+	    set istate($sid,state) streamhost-used    
+	    set istate($sid,active,sock) $istate($sid,proxy,sock)
+	}
+	si_open_report $jlibname $sid $type $subiq
+    }
+}    
+
+# Server side socks5 functions -------------------------------------------------
+# 
+# Normally used by the initiator except in fastmode where it is also used by
+# the target.
+# This is stateless code that never directly access the istate array.
+# Think of it like an object:
+#       [in]:  sock, addr, port
+#       [out]: sid, sock
+#       
+# NB: We don't return any errors on the server side; this is up to the client.
+
+# jlib::bytestreams::s5i_server --
+# 
+#       Start socks5 server. We use the server for the streams and keep it
+#       running for the lifetime of the application.
+
+proc jlib::bytestreams::s5i_server {jlibname} {
+    
+    upvar ${jlibname}::bytestreams::static static
+    debug "jlib::bytestreams::s5i_server (i)"
+    
+    # Note the difference between static(-port) and static(port) !
+    set connectProc [list [namespace current]::s5i_accept $jlibname]
+    set sock [socket -server $connectProc $static(-port)]
+    set static(sock) $sock
+    set static(port) [lindex [fconfigure $sock -sockname] 2]
+    
+    # Test fast mode or proxy host...
+    #close $sock
+    return $static(port)
+}
+
+# jlib::bytestreams::s5i_accept --
+# 
+#       The server socket callback when connected.
+#       We keep a single server socket for all transfers and distinguish
+#       them when they do the SOCKS5 authentication using the mapping
+#       hash (sha1 sid+jid+myjid)  -> sid
+
+proc jlib::bytestreams::s5i_accept {jlibname sock addr port} {
+
+    debug "jlib::bytestreams::s5i_accept (i)"
+    debug_sock "open $sock"
+    
+    fconfigure $sock -translation binary -blocking 0
+    fileevent $sock readable \
+      [list [namespace current]::s5i_read_methods $jlibname $sock]
+}
+
+proc jlib::bytestreams::s5i_read_methods {jlibname sock} {
+   
+    debug "jlib::bytestreams::s5i_read_methods (i)" 
+    # For testing...
+    #after 50
+    
+    fileevent $sock readable {}
+    if {[catch {read $sock} data] || [eof $sock]} {
+	debug_sock "close $sock"
+	catch {close $sock}
+	return
+    }
+    debug "\t read [string length $data]"
+    
+    # Pick method. Must be \x00
+    binary scan $data ccc* ver nmethods methods
+    if {($ver != 5) || ([lsearch -exact $methods 0] < 0)} {
+	catch {
+	    debug_sock "close $sock"
+	    puts -nonewline $sock "\x05\xff"
+	    close $sock
+	}
+	return
+    }
+    if {[catch {
+	puts -nonewline $sock "\x05\x00"
+	flush $sock
+	debug "\t wrote 2: 'x05x00'"
+    }]} {
+	return
+    }
+    fileevent $sock readable \
+      [list [namespace current]::s5i_read_auth $jlibname $sock]
+}
+
+proc jlib::bytestreams::s5i_read_auth {jlibname sock} {
+    
+    upvar ${jlibname}::bytestreams::hash2sid hash2sid
+    debug "jlib::bytestreams::s5i_read_auth (i)"
+
+    fileevent $sock readable {}
+    if {[catch {read $sock} data] || [eof $sock]} {
+	debug_sock "close $sock"
+	catch {close $sock}
+	return
+    }    
+    debug "\t read [string length $data]"
+    
+    binary scan $data ccccc ver cmd rsv atyp len
+    if {$ver != 5 || $cmd != 1 || $atyp != 3} {
+	set reply [string replace $data 1 1 \x07]
+	catch {
+	    debug_sock "close $sock"
+	    puts -nonewline $sock $reply
+	    close $sock
+	}	
+	return
+    }
+    
+    binary scan $data @5a${len} hash
+    
+    # At this stage we are in a position to find the sid.
+    if {[info exists hash2sid($hash)]} {
+	set sid $hash2sid($hash)
+	
+	# This is the way the initiator knows the socket.
+	s5i_register_socket $jlibname $sid $sock
+
+	set reply [string replace $data 1 1 \x00]
+	catch {
+	    puts -nonewline $sock $reply
+	    flush $sock
+	}
+	debug "\t wrote [string length $reply]"
+    } else {
+	debug "\t missing sid"
+	set reply [string replace $data 1 1 \x02]
+	catch {
+	    debug_sock "close $sock"
+	    puts -nonewline $sock $reply
+	    close $sock
+	}	
+	return
+    }
+}
+
+# jlib::bytestreams::s5i_register_socket --
+# 
+#       This is a callback when a client has connected and authentized
+#       with our server. Normally we are the initiator but in fastmode
+#       we may also be the target.
+#       Since the server handles connections async it needs this method to
+#       communicate.
+
+proc jlib::bytestreams::s5i_register_socket {jlibname sid sock} {
+    
+    variable fastmode
+    upvar ${jlibname}::bytestreams::istate istate
+    upvar ${jlibname}::bytestreams::tstate tstate
+    debug "jlib::bytestreams::s5i_register_socket"
+    
+    if {$fastmode && [info exists tstate($sid,fast,state)]} {
+	debug "\t (t)"
+	if {$tstate($sid,fast,state) ne "error"} {
+	    set tstate($sid,fast,sock)  $sock
+	    set tstate($sid,fast,state) connected
+	}
+    } elseif {[info exists istate($sid,state)]} {
+	debug "\t (i)"
+	if {$istate($sid,state) ne "error"} {
+	    set istate($sid,sock)  $sock
+	    set istate($sid,state) connected
+	}
+    } else {
+	debug "\t empty"
+	# We may have been reset (timeout) or something.
+    }
+}
+
+# End s5i ----------------------------------------------------------------------
+
+# jlib::bytestreams::isend_error --
+# 
+#       Deliver iq error to target as a response to the targets streamhosts.
+#       Fastmode only!
+
+proc jlib::bytestreams::isend_error {jlibname sid errcode errtype stanza} {
+
+    upvar ${jlibname}::bytestreams::istate istate
+    debug "jlib::bytestreams::isend_error (i)"
+    
+    set id  $istate($sid,fast,id)
+    set jid $istate($sid,fast,jid)
+    set qE  $istate($sid,fast,queryE)
+    jlib::send_iq_error $jlibname $jid $id $errcode $errtype $stanza $qE 
+}
+
+# jlib::bytestreams::ifinish --
+# 
+#       Close all sockets and make sure to free all memory.
+
+proc jlib::bytestreams::ifinish {jlibname sid} {
+
+    upvar ${jlibname}::bytestreams::istate istate
+    debug "jlib::bytestreams::ifinish (i)"
+
+    # Skip any ongoing socks5 connections.
+    if {$istate($sid,used-proxy)} {
+	connector_reset $jlibname $sid p
+    }
+    if {$istate($sid,fast)} {
+	connector_reset $jlibname $sid f
+    }
+    
+    # Close socket.
+    if {[info exists istate($sid,sock)]} {
+	debug_sock "close $istate($sid,sock)"
+	catch {close $istate($sid,sock)}
+    }
+    if {[info exists istate($sid,fast,sock)]} {
+	debug_sock "close $istate($sid,fast,sock)"
+	catch {close $istate($sid,fast,sock)}
+    }
+    if {[info exists istate($sid,proxy,sock)]} {
+	debug_sock "close $istate($sid,proxy,sock)"
+	catch {close $istate($sid,proxy,sock)}
+    }
+    ifree $jlibname $sid
+}
+
+# jlib::bytestreams::ifree --
+# 
+#       Releases all memory for an initiator object.
+
+proc jlib::bytestreams::ifree {jlibname sid} {
+    
+    upvar ${jlibname}::bytestreams::istate istate
+    upvar ${jlibname}::bytestreams::hash2sid hash2sid
+    debug "jlib::bytestreams::ifree (i)"
+
+    if {[info exists istate($sid,hash)]} {
+	set hash $istate($sid,hash)
+	unset -nocomplain hash2sid($hash)
+    }
+    array unset istate $sid,*
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#
+# These are all functions to use by a target (receiver) of a stream.
+
+# jlib::bytestreams::handle_set --
+# 
+#       Handler for incoming iq-set element with xmlns 
+#       "http://jabber.org/protocol/bytestreams".
+#       
+#       Initiator sends IQ-set to Target specifying the full JID and network 
+#       address of StreamHost/Initiator as well as the StreamID (SID) of the 
+#       proposed bytestream. 
+#    
+#       For fastmode this can be either initiator or target.
+#       It is stateless and only dispatches the iq to the target normally,
+#       but can also be the initiator in case of fastmode.
+#       
+# Result:
+#       MUST return 0 or 1!
+
+proc jlib::bytestreams::handle_set {jlibname from queryE args} {
+    variable xmlns    
+    variable fastmode
+    
+    debug "jlib::bytestreams::handle_set (t+i)"
+    
+    array set argsA $args
+    array set attr [wrapper::getattrlist $queryE]
+    if {![info exists argsA(-id)]} {
+	# We cannot handle this since missing id-attribute.
+	return 0
+    }
+    if {![info exists attr(sid)]} {
+	eval {return_error $jlibname $queryE 400 modify bad-request} $args
+	return 1
+    }
+    set id  $argsA(-id)
+    set sid $attr(sid)
+    set jid $from
+
+    # We make sure that we have already got a si with this sid.
+    if {![jlib::si::havesi $jlibname $sid]} {
+	eval {return_error $jlibname $queryE 406 cancel not-acceptable} $args
+	return 1
+    }
+
+    # Get streamhosts keeping their order.
+    set hosts [list]
+    foreach elem [wrapper::getchildswithtag $queryE "streamhost"] {
+	array unset sattr
+	array set sattr [wrapper::getattrlist $elem]
+	if {[info exists sattr(jid)]    \
+	  && [info exists sattr(host)]  \
+	  && [info exists sattr(port)]} {
+	    lappend hosts [list $sattr(jid) $sattr(host) $sattr(port)]
+	}
+    }
+    debug "\t hosts=$hosts"
+    if {![llength $hosts]} {
+	eval {return_error $jlibname $queryE 400 modify bad-request} $args
+	return 1
+    }
+    
+    # In fastmode we may get a streamhosts offer for reversed socks5 connections.
+    if {[is_initiator $jlibname $sid]} {
+	if {$fastmode} {
+	    i_handle_set $jlibname $sid $id $jid $hosts $queryE
+	} else {
+	    # @@@ inconsistency!
+	    return 0
+	}
+    } else {
+	
+	# This is the normal execution path.
+	t_handle_set $jlibname $sid $id $jid $hosts $queryE
+    }
+    return 1
+}
+
+# jlib::bytestreams::t_handle_set --
+# 
+#       This is like the constructor of a target sid object.
+
+proc jlib::bytestreams::t_handle_set {jlibname sid id jid hosts queryE} {
+    variable fastmode
+    variable xmlns
+    
+    upvar ${jlibname}::bytestreams::tstate tstate
+    upvar ${jlibname}::bytestreams::static static
+    upvar ${jlibname}::bytestreams::hash2sid hash2sid
+    debug "jlib::bytestreams::t_handle_set (t)"
+    
+    set tstate($sid,id)     $id
+    set tstate($sid,jid)    $jid
+    set tstate($sid,fast)   0
+    set tstate($sid,state)  open
+    set tstate($sid,hosts)  $hosts
+    set tstate($sid,queryE) $queryE
+    
+    if {$fastmode} {
+	set fastE [wrapper::getchildswithtagandxmlns $queryE "fast" $xmlns(fast)]
+	if {[llength $fastE]} {
+	    
+	    set haveserver 1
+	    if {![info exists static(sock)]} {
+
+		# Protect against server failure.
+		if {[catch {s5i_server $jlibname}]} {
+		    set haveserver 0
+		}
+	    }
+	    
+	    # At this stage we switch to use the fast mode protocol.
+	    if {$haveserver} {
+		set tstate($sid,fast) 1
+		set tstate($sid,fast,state) initiate
+		
+		# Provide our streamhosts. 
+		# First, the local one.
+		if {$static(-address) ne ""} {
+		    set ip $static(-address)
+		} else {
+		    set ip [jlib::getip $jlibname]
+		}
+		set myjid [jlib::myjid $jlibname]
+		set hash  [::sha1::sha1 $sid$myjid$jid]
+		set tstate($sid,hash) $hash
+		set hash2sid($hash) $sid
+		
+		# @@@ Is there a point that also the target provides a
+		#     proxy streamhost?
+		# If the clients are using different servers, one may have a 
+		# proxy while the other has not.
+		# Keep it optional (-targetproxy).
+		set host [list $myjid -host $ip -port $static(port)]
+		set streamhosts [list $host]
+		
+		# Second, the proxy host if any.
+		if {$static(-targetproxy) && [llength $static(-proxyhost)]} {
+		    lassign $static(-proxyhost) pjid pip pport
+		    set proxyhost [list $pjid -host $pip -port $pport]
+		    lappend streamhosts $proxyhost
+		}
+		
+		set t_initiate_cb  \
+		  [list [namespace current]::t_initiate_cb $jlibname $sid]
+		send_initiate $jlibname $jid $sid $t_initiate_cb \
+		  -streamhosts $streamhosts
+	    }
+	}
+    }
+
+    # Try connecting the host(s) in turn.
+    set tstate($sid,state) connecting    
+    set myjid [$jlibname myjid]
+    set hash [::sha1::sha1 $sid$jid$myjid]    
+
+    set cb [list [namespace current]::connect_cb $jlibname $sid]
+    connector $jlibname $sid t $hash $hosts $cb
+}
+
+# jlib::bytestreams::connect_cb --
+# 
+#       Callback command from 'connector' object when tried socks5 connections
+#       to initiators streamhosts.
+
+proc jlib::bytestreams::connect_cb {jlibname sid result args} {
+    
+    upvar ${jlibname}::bytestreams::tstate tstate
+    debug "jlib::bytestreams::connect_cb (t)"
+
+    array set argsA $args
+    
+    if {$result eq "error"} {
+	set tstate($sid,state) error
+	
+	# Deliver error to initiator.
+	tsend_error $jlibname $sid 404 cancel item-not-found
+	
+	# In fastmode we are not done until the fast mode also fails.
+	if {!$tstate($sid,fast) || ($tstate($sid,fast,state) eq "error")} {
+
+	    # Deliver error to target profile.
+	    jlib::si::stream_error $jlibname $sid item-not-found
+	    tfinish $jlibname $sid
+	}
+    } else {
+	set sock $argsA(-socket)
+	set host $argsA(-streamhost)
+	set hostjid [lindex $host 0]
+
+	set tstate($sid,sock)    $sock
+	set tstate($sid,host)    $host
+	set tstate($sid,hostjid) $hostjid
+
+	set jid $tstate($sid,jid)
+	set id  $tstate($sid,id)
+	send_used $jlibname $jid $id $hostjid
+	
+	# If fast mode we must wait for a CR before start reading.
+	if {$tstate($sid,fast)} {
+
+	    # Wait for initiator send a CR for selection or just close it.
+	    set tstate($sid,state) waiting-cr
+	    set cmd_cr [list [namespace current]::read_CR_cb $jlibname $sid]
+	    fileevent $sock readable  \
+	      [list [namespace current]::read_CR $sock $cmd_cr]
+
+	} else {
+	    start_read_data $jlibname $sid $sock
+	}
+    }
+}
+
+proc jlib::bytestreams::t_initiate_cb {jlibname sid type subiq args} {
+    
+    upvar ${jlibname}::bytestreams::tstate tstate
+    debug "jlib::bytestreams::t_initiate_cb (t) type=$type"
+
+    # In fast mode we may get this callback after we have finished.
+    # Or after a timeout or something.
+    if {![info exists tstate($sid,state)]} {
+	return
+    }
+
+    if {$type eq "error"} {
+	
+	# Cleanup and close any fast socks5 connection.
+	set tstate($sid,fast,state) error
+	if {[info exists tstate($sid,fast,sock)]} {
+	    debug_sock "close $tstate($sid,fast,sock)"
+	    catch {close $tstate($sid,fast,sock)}
+	    unset tstate($sid,fast,sock)
+	}
+	
+	# If also the standard way failed we are done.
+	if {$tstate($sid,state) eq "error"} {
+	    jlib::si::stream_error $jlibname $sid item-not-found
+	    tfinish $jlibname $sid
+	}
+    } else {
+    
+	# Wait for initiator send a CR for selction or just close it.
+	debug "\t waiting CR"
+	set tstate($sid,fast,state) waiting-cr
+	set sock $tstate($sid,fast,sock)
+	set cmd_cr [list [namespace current]::fast_read_CR_cb $jlibname $sid]
+	fileevent $sock readable  \
+	  [list [namespace current]::read_CR $sock $cmd_cr]
+    }
+}
+
+proc jlib::bytestreams::read_CR {sock cmd} {
+
+    debug "jlib::bytestreams::read_CR (t)"
+
+    fileevent $sock readable {}
+    if {[catch {read $sock 1} data] || [eof $sock]} {
+	debug "\t eof"
+	catch {close $sock}
+	eval $cmd error
+    } elseif {$data ne "\r"} {
+	debug "\t not CR"
+	catch {close $sock}
+	eval $cmd error
+    } else {
+	debug "\t got CR"
+	eval $cmd
+    }
+}
+
+proc jlib::bytestreams::fast_read_CR_cb {jlibname sid {error ""}} {
+    
+    upvar ${jlibname}::bytestreams::tstate tstate
+    debug "jlib::bytestreams::fast_read_CR_cb (t) error=$error"
+    
+    if {$error ne ""} {
+	set tstate($sid,fast,state) error
+	unset -nocomplain tstate($sid,fast,sock)		
+
+	# If also the standard way failed we are done.
+	if {$tstate($sid,state) eq "error"} {
+	    jlib::si::stream_error $jlibname $sid item-not-found
+	    tfinish $jlibname $sid
+	}
+    } else {
+    
+	# At this stage we are using reversed transport (fast mode).
+	# We are using the targets (our own) streamhost.
+	connector_reset $jlibname $sid t
+	if {[info exists tstate($sid,sock)]} {
+	    debug_sock "close $tstate($sid,sock)"
+	    catch {close $tstate($sid,sock)}
+	    unset tstate($sid,sock)
+	}
+	
+	# Deliver error to initiator unless not done so.
+	if {$tstate($sid,state) ne "error"} {
+	    tsend_error $jlibname $sid 404 cancel item-not-found
+	}
+	set tstate($sid,state)         error
+	set tstate($sid,fast,selected) fast
+	set tstate($sid,fast,state)    read
+
+	start_read_data $jlibname $sid $tstate($sid,fast,sock)
+    }
+}
+
+#...............................................................................
+
+proc jlib::bytestreams::read_CR_cb {jlibname sid {error ""}} {
+    
+    upvar ${jlibname}::bytestreams::tstate tstate
+    debug "jlib::bytestreams::read_CR_cb (t) error=$error"
+    
+    if {$error ne ""} {	
+	set tstate($sid,state) error
+	unset -nocomplain tstate($sid,sock)
+
+	# If also the fast mode failed this is The End.
+	if {$tstate($sid,fast) && ($tstate($sid,fast,state) eq "error")} {
+	    jlib::si::stream_error $jlibname $sid item-not-found
+	    tfinish $jlibname $sid
+	}
+    } else {
+	if {[info exists tstate($sid,fast,sock)]} {
+	    debug_sock "close $tstate($sid,fast,sock)"
+	    catch {close $tstate($sid,fast,sock)}
+	    unset tstate($sid,fast,sock)
+	}
+	set sock $tstate($sid,sock)
+
+	set tstate($sid,fast,selected) normal
+	set tstate($sid,state)  read
+	
+	start_read_data $jlibname $sid $sock
+    }
+}
+
+proc jlib::bytestreams::start_read_data {jlibname sid sock} {
+    
+    upvar ${jlibname}::bytestreams::static static
+
+    fconfigure $sock -buffersize $static(-block-size) -buffering full
+    fileevent $sock readable  \
+      [list [namespace current]::readable $jlibname $sid $sock]
+}
+
+# End connect_socks ------------------------------------------------------------
+
+# jlib::bytestreams::readable --
+# 
+#       Reads channel and delivers data up to si.
+
+proc  jlib::bytestreams::readable {jlibname sid sock} {
+    
+    upvar ${jlibname}::bytestreams::tstate tstate
+    upvar ${jlibname}::bytestreams::static static
+    debug "jlib::bytestreams::readable (t)"
+
+    fileevent $sock readable {}
+
+    # We may have been reset or something.
+    if {![jlib::si::havesi $jlibname $sid]} {
+	tfinish $jlibname $sid
+	return
+    }
+    
+    if {[catch {eof $sock} iseof] || $iseof} {
+	debug "\t eof"
+	# @@@ Perhaps we should check number of bytes reveived or something???
+	#     If the initiator closes socket before transfer is complete
+	#     we wont notice this otherwise.
+	jlib::si::stream_closed $jlibname $sid
+	tfinish $jlibname $sid
+    } else {
+	
+	# @@@ Keep tranck of number bytes read?
+	set data [read $sock $static(-block-size)]
+	set len [string length $data]
+	debug "\t len=$len"
+    
+	# Deliver to si for further processing.
+	jlib::si::stream_recv $jlibname $sid $data
+	
+	# This is a trick to put this event at the back of the queue to
+	# avoid using any 'update'.
+	after idle [list after 0 [list \
+	  [namespace current]::setreadable $jlibname $sid $sock]]
+    }
+}
+
+proc jlib::bytestreams::setreadable {jlibname sid sock} {
+    
+    # We could have been closed since this event comes async.
+    if {[lsearch [file channels] $sock] >= 0} {
+	fileevent $sock readable  \
+	  [list [namespace current]::readable $jlibname $sid $sock]
+    }
+}
+
+# jlib::bytestreams::send_used --
+# 
+#       Target (also initiator in fast mode) notifies initiator of connection.
+
+proc jlib::bytestreams::send_used {jlibname to id hostjid} {
+    variable xmlns
+    
+    set usedE [wrapper::createtag "streamhost-used" \
+      -attrlist [list jid $hostjid]]
+    set xmllist [wrapper::createtag "query" \
+      -attrlist [list xmlns $xmlns(bs)] \
+      -subtags [list $usedE]]
+
+    $jlibname send_iq "result" [list $xmllist] -to $to -id $id
+}
+
+# The client socks5 functions --------------------------------------------------
+# 
+# Normally used by the target but in fastmode also used by the initiator.
+#
+# This object handles everything to make a single socks5 connection + 
+# authentication.
+#       [in]:  addr, port, hash, cmd
+#       [out]: sock, result
+
+# jlib::bytestreams::socks5 --
+# 
+#       Open a client socket to the specified host and port and announce method.
+#       This must be kept stateless.
+
+proc jlib::bytestreams::socks5 {addr port hash cmd} {
+
+    debug "jlib::bytestreams::socks5 (t)"
+    
+    if {[catch {
+	set sock [socket -async $addr $port]
+    } err]} {
+	return -code error $err
+    }
+    debug_sock "open $sock"
+    fconfigure $sock -translation binary -blocking 0
+    fileevent $sock writable  \
+      [list [namespace current]::s5t_write_method $hash $sock $cmd]
+    return $sock
+}
+
+proc jlib::bytestreams::s5t_write_method {hash sock cmd} {
+    
+    debug "jlib::bytestreams::s5t_write_method (t)"
+    fileevent $sock writable {}
+    
+    # Announce method (\x00).
+    if {[catch {
+	puts -nonewline $sock "\x05\x01\x00"
+	flush $sock
+	debug "\t wrote 3: 'x05x01x00'"
+    } err]} {
+	catch {close $sock}
+	eval $cmd error-network-write
+	return
+    }
+    fileevent $sock readable  \
+      [list [namespace current]::s5t_method_result $hash $sock $cmd]
+}
+
+proc jlib::bytestreams::s5t_method_result {hash sock cmd} {
+    
+    debug "jlib::bytestreams::s5t_method_result (t)"
+    
+    fileevent $sock readable {}
+    if {[catch {read $sock} data] || [eof $sock]} {
+	catch {close $sock}
+	eval $cmd error-network-read
+	return
+    }    
+    debug "\t read [string length $data]"
+    binary scan $data cc ver method
+    if {($ver != 5) || ($method != 0)} {
+	catch {close $sock}
+	eval $cmd error-socks5
+	return
+    }
+    set len [binary format c [string length $hash]]
+    if {[catch {
+	puts -nonewline $sock "\x05\x01\x00\x03$len$hash\x00\x00"
+	flush $sock
+	debug "\t wrote [string length "\x05\x01\x00\x03$len$hash\x00\x00"]: 'x05x01x00x03${len}${hash}x00x00'"
+    } err]} {
+	catch {close $sock}
+	eval $cmd error-network-write
+	return
+    }
+    fileevent $sock readable \
+      [list [namespace current]::s5t_auth_result $sock $cmd]
+}
+
+proc jlib::bytestreams::s5t_auth_result {sock cmd} {
+    
+    debug "jlib::bytestreams::s5t_auth_result (t)"
+    
+    fileevent $sock readable {}
+    if {[catch {read $sock} data] || [eof $sock]} {
+	catch {close $sock}
+	eval $cmd error-network-read
+	return
+    }
+    debug "\t read [string length $data]"
+    binary scan $data cc ver method
+    if {($ver != 5) || ($method != 0)} {
+	catch {close $sock}
+	eval $cmd error-socks5
+	return
+    }
+
+    # Here we should be finished.
+    eval $cmd
+}
+
+# End s5t ----------------------------------------------------------------------
+
+# jlib::bytestreams::return_error, tsend_error --
+# 
+#       Various helper functions to return errors.
+
+proc jlib::bytestreams::return_error {jlibname qElem errcode errtype stanza args} {
+    
+    array set attr $args
+    set id  $attr(-id)
+    set jid $attr(-from)
+    jlib::send_iq_error $jlibname $jid $id $errcode $errtype $stanza $qElem
+}
+
+proc jlib::bytestreams::tsend_error {jlibname sid errcode errtype stanza} {
+
+    upvar ${jlibname}::bytestreams::tstate tstate
+    debug "jlib::bytestreams::tsend_error (t)"
+    
+    set id  $tstate($sid,id)
+    set jid $tstate($sid,jid)
+    set qE  $tstate($sid,queryE)
+    jlib::send_iq_error $jlibname $jid $id $errcode $errtype $stanza $qE 
+}
+
+proc jlib::bytestreams::tfinish {jlibname sid} {
+    
+    upvar ${jlibname}::bytestreams::tstate tstate
+    debug "jlib::bytestreams::tfinish (t)"
+    
+    # Close socket.
+    if {[info exists tstate($sid,sock)]} {
+	debug_sock "close $tstate($sid,sock)"
+	catch {close $tstate($sid,sock)}
+    }
+    if {[info exists tstate($sid,fast,sock)]} {
+	debug_sock "close $tstate($sid,fast,sock)"
+	catch {close $tstate($sid,fast,sock)}
+    }
+    if {[info exists tstate($sid,timeoutid)]} {
+	after cancel $tstate($sid,timeoutid)
+    }
+    tfree $jlibname $sid
+}
+
+proc jlib::bytestreams::tfree {jlibname sid} {
+    
+    upvar ${jlibname}::bytestreams::tstate tstate
+    upvar ${jlibname}::bytestreams::hash2sid hash2sid
+    debug "jlib::bytestreams::tfree (t)"
+
+    if {[info exists tstate($sid,hash)]} {
+	set hash $tstate($sid,hash)
+	unset -nocomplain hash2sid($hash)
+    }
+    array unset tstate $sid,*
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::bytestreams {
+	
+    jlib::ensamble_register bytestreams  \
+      [namespace current]::init          \
+      [namespace current]::cmdproc
+}
+
+# connector --------------------------------------------------------------------
+
+# jlib::bytestreams::connector --
+# 
+#       Standalone object which is target and initiator agnostic that tries
+#       to make socks5 connections to the hosts in turn. Invokes the callback
+#       for the first succesful connection or an error if none worked.
+#       The 'sid' is the characteristic identifier of an object.
+#       It sets its own timeouts. Needs also a unique 'key' if using multiple
+#       connectors for one sid.
+#       
+#       NB1: SHA1(SID + Initiator JID + Target JID)
+#       NB2: the initiator may have two connector objects if fast + proxy.
+#       
+#       [in]:  sid, key, hash, hosts, cmd
+#       [out]: result (-error | -host -socket)
+
+proc jlib::bytestreams::connector {jlibname sid key hash hosts cmd} {
+    
+    upvar ${jlibname}::bytestreams::conn conn
+    debug "jlib::bytestreams::connector $key"
+    
+    set x $sid,$key
+    set conn($x,hosts) $hosts
+    set conn($x,cmd)   $cmd
+    set conn($x,hash)  $hash
+    set conn($x,idx)   [expr {[llength $hosts]-1}]
+    
+    connector_sock $jlibname $sid $key
+    return
+}
+
+# jlib::bytestreams::connector_sock --
+# 
+#       Tries to make a socks5 connection to streamhost with 'idx' index.
+#       If 'idx' goes negative we report an error.
+
+proc jlib::bytestreams::connector_sock {jlibname sid key} {
+    
+    upvar ${jlibname}::bytestreams::conn conn
+    upvar ${jlibname}::bytestreams::static static
+    debug "jlib::bytestreams::connector_sock $key"
+    
+    set x $sid,$key
+    if {[info exists conn($x,timeoutid)]} {
+	after cancel $conn($x,timeoutid)
+	unset conn($x,timeoutid)
+    }
+    if {$conn($x,idx) < 0} {
+	connector_final $jlibname $sid $key "error"
+	return
+    }
+    set conn($x,timeoutid) [after $static(-s5timeoutms)  \
+      [list [namespace current]::connector_timeout_cb $jlibname $sid $key]]
+    
+    set host [lindex $conn($x,hosts) $conn($x,idx)]
+    lassign $host hostjid addr port
+    debug "\t host=$host"
+    set s5_cb [list [namespace current]::connector_s5_cb $jlibname $sid $key]
+    if {[catch {
+	set conn($x,sock) [socks5 $addr $port $conn($x,hash) $s5_cb]
+    }]} {
+	
+	# Retry with next streamhost if any.
+	incr conn($x,idx) -1
+	connector_sock $jlibname $sid $key
+    }
+}
+
+proc jlib::bytestreams::connector_s5_cb {jlibname sid key {err ""}} {
+        
+    upvar ${jlibname}::bytestreams::conn conn
+    debug "jlib::bytestreams::connector_s5_cb $key err=$err"
+    
+    set x $sid,$key
+    if {$err eq ""} {
+	connector_final $jlibname $sid $key
+    } else {
+	incr conn($x,idx) -1
+	connector_sock $jlibname $sid $key
+    }
+}
+
+proc jlib::bytestreams::connector_timeout_cb {jlibname sid key} {
+	
+    upvar ${jlibname}::bytestreams::conn conn
+    debug "jlib::bytestreams::connector_timeout_cb $key"
+
+    # On timeouts we are responsible for closing the socket.
+    set x $sid,$key
+    unset conn($x,timeoutid)
+    if {[info exists conn($x,sock)]} {
+	debug_sock "close $conn($x,sock)"
+	catch {close $conn($x,sock)}
+	unset conn($x,sock)
+    }
+    incr conn($x,idx) -1
+    connector_sock $jlibname $sid $key
+}
+
+proc jlib::bytestreams::connector_reset {jlibname sid key} {
+	
+    upvar ${jlibname}::bytestreams::conn conn
+    debug "jlib::bytestreams::connector_reset $key"
+    
+    # Protect for nonexisting connector object.
+    set x $sid,$key
+    if {![info exists conn($x,cmd)]} {
+	return
+    }
+    if {[info exists conn($x,timeoutid)]} {
+	after cancel $conn($x,timeoutid)
+	unset conn($x,timeoutid)
+    }
+    if {[info exists conn($x,sock)]} {
+	debug_sock "close $conn($x,sock)"
+	catch {close $conn($x,sock)}
+	unset conn($x,sock)
+    }
+    connector_final $jlibname $sid $key "reset"
+}
+
+proc jlib::bytestreams::connector_final {jlibname sid key {err ""}} {
+    
+    upvar ${jlibname}::bytestreams::conn conn
+    debug "jlib::bytestreams::connector_final err=$err"
+
+    set x $sid,$key
+    if {[info exists conn($x,timeoutid)]} {
+	after cancel $conn($x,timeoutid)
+	unset conn($x,timeoutid)
+    }
+    set cmd $conn($x,cmd)
+    if {$err eq ""} {
+	set host [lindex $conn($x,hosts) $conn($x,idx)]
+	eval $cmd ok -streamhost $host -socket $conn($x,sock)
+    } else {
+	
+	# Skip callback when we have reset. ?
+	if {$err ne "reset"} {
+	    eval $cmd error -error $err
+	}
+    }
+    array unset conn $x,*
+}
+
+proc jlib::bytestreams::debug {msg} {if {0} {puts $msg}}
+
+proc jlib::bytestreams::debug_sock {msg} {if {0} {puts $msg}}
+
+#-------------------------------------------------------------------------------
+
+if {0} {
+    # Testing the 'connector'
+    set jlib ::jlib::jlib1
+    set port [$jlib bytestreams s5i_server]
+    set hosts [list \
+      [list proxy.localhost junk.se 8237] \
+      [list matben@localhost 127.0.0.1 $port]]
+    proc cb {args} {puts "---> $args"}
+    set sid [jlib::generateuuid]
+    set myjid [$jlib myjid]
+    set jid killer@localhost/coccinella
+    set hash [::sha1::sha1 $sid$myjid$jid]    
+    $jlib bytestreams connector $sid $hash $hosts cb
+ 
+    # Testing proxy:
+    # 1) get proxy
+    set jlib ::jlib::jlib1
+    proc pcb {jlib type queryE} {
+	puts "---> $jlib $type $queryE"
+	set hostE [wrapper::getfirstchildwithtag $queryE "streamhost"]
+	array set attr [wrapper::getattrlist $hostE]
+	set ::proxyHost $attr(host)
+	set ::proxyPort $attr(port)
+    }
+    set proxy proxy.jabber.se
+    $jlib bytestreams get_proxy $proxy pcb
+    $jlib bytestreams configure -proxyhost [list $proxy $proxyHost $proxyPort]
+
+    # 2) socks5 connection
+    set sid [jlib::generateuuid]
+    set myjid [$jlib myjid]
+    set jid killer@jabber.se/coccinella
+    set hash [::sha1::sha1 $sid$myjid$jid]  
+    set hosts [list [list $proxy $proxyHost $proxyPort]]
+    $jlib bytestreams connector $sid $hash $hosts cb
+
+    # 3) activate
+    $jlib bytestreams activate $sid $proxy $jid
+    
+}
+
+
diff --git a/lib/jabberlib/caps.tcl b/lib/jabberlib/caps.tcl
new file mode 100644
index 0000000..ccb6860
--- /dev/null
+++ b/lib/jabberlib/caps.tcl
@@ -0,0 +1,530 @@
+#  caps.tcl --
+#  
+#   This file is part of the jabberlib. It handles the internal cache
+#   for caps (xmlns='http://jabber.org/protocol/caps') XEP-0115.
+#   It is updated to version 1.3 of XEP-0115.
+#      
+#   A typical caps element looks like:
+#   
+#   <presence>
+#      <c xmlns='http://jabber.org/protocol/caps'
+#          node='http://exodus.jabberstudio.org/caps'
+#          ver='0.9'
+#          ext='tins ftrans xhtml'/>
+#   </presence> 
+#      
+#  The core function of caps is a mapping:
+#     
+#     jid -> node+ver -> disco info
+#     jid -> node+ext -> disco info
+#     
+#  NB: The ext must be consistent over all versions (ver).
+#  
+#  UPDATE version 1.4: ---------------------------------------------------------
+#  
+#  <presence from='romeo@montague.lit/orchard'>
+#      <c xmlns='http://jabber.org/protocol/caps' 
+#         node='http://exodus.jabberstudio.org/#0.9.1'
+#         ver='8RovUdtOmiAjzj+xI7SK5BCw3A8='/>
+#  </presence> 
+#  
+#  The 'ver' map to a unique combination of disco identities+features.
+#  
+#  -----------------------------------------------------------------------------
+#  
+#  Copyright (c) 2005-2007  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: caps.tcl,v 1.25 2007/10/04 14:01:07 matben Exp $
+# 
+############################# USAGE ############################################
+#
+#   NAME
+#      caps - convenience command library for caps: Entity Capabilities 
+#      
+#   INSTANCE COMMANDS
+#      jlibname caps register name xmllist features
+#      jlibname caps configure ?-autodisco 0|1? -command tclProc
+#      jlibname caps getexts
+#      jlibname caps getxmllist name
+#      jlibname caps getallfeatures
+#      jlibname caps getfeatures name
+#           
+#      The 'name' is here the ext token.
+
+# TODO: make a static cache (variable cache) which maps the hashed ver attribute
+#       to a list of disco identities and features.
+
+package require base64     ; # tcllib
+package require sha1       ; # tcllib                           
+package require jlib::disco
+package require jlib::roster
+
+package provide jlib::caps 0.3
+
+namespace eval jlib::caps {
+    
+    variable xmlns
+    set xmlns(caps) "http://jabber.org/protocol/caps"    
+    
+    # Note: jlib::ensamble_register is last in this file!
+}
+
+proc jlib::caps::init {jlibname args} {
+           
+    # Instance specific arrays.
+    namespace eval ${jlibname}::caps {
+	variable ext
+	variable options
+    }
+    
+    upvar ${jlibname}::caps::options options
+    array set options {
+	-autodisco 0
+	-command   {}
+    }
+    eval {configure $jlibname} $args
+    
+    # Since the caps element from a JID is globally defined there is no need
+    # to keep its state instance specific (per jlibname).
+    
+    # The cache for disco results. Must not be instance specific.
+    variable caps
+    
+    # This collects various mappings and states:
+    #  o It keeps track of mapping jid -> node+ver+exts
+    #  o
+    variable state
+    
+    jlib::presence_register_int $jlibname available    \
+      [namespace current]::avail_cb
+    jlib::presence_register_int $jlibname unavailable  \
+      [namespace current]::unavail_cb
+    
+    jlib::register_reset $jlibname [namespace current]::reset
+}
+
+proc jlib::caps::configure {jlibname args} {
+    upvar ${jlibname}::caps::options options
+    
+    if {[llength $args]} {
+	foreach {key value} $args {
+	    switch -- $key {
+		-autodisco {
+		    if {[string is boolean -strict $value]} {
+			set options(-autodisco) $value
+		    } else {
+			return -code error "expected boolean for -autodisco"
+		    }
+		}
+		-command {
+		    set options(-command) $value
+		}
+		default {
+		    return -code error "unrecognized option \"$key\""
+		}
+	    }
+	}
+    } else {
+	return [array get options]
+    }
+}
+
+proc jlib::caps::cmdproc {jlibname cmd args} {
+    
+    # Just dispatch the command to the right procedure.
+    return [eval {$cmd $jlibname} $args]
+}
+
+#--- First, handle our own caps stuff ------------------------------------------
+
+# jlib::caps::register --
+# 
+#       Register an 'ext' token and associated disco#info element.
+#       The 'name' is the ext token.
+#       The 'features' must be the 'var' attributes in 'xmllist'.
+#       <feature var='http://jabber.org/protocol/disco#info'/> 
+
+proc jlib::caps::register {jlibname name xmllist features} {
+    upvar ${jlibname}::caps::ext ext
+    
+    set ext(name,$name)     $name
+    set ext(xmllist,$name)  $xmllist
+    set ext(features,$name) $features
+}
+
+proc jlib::caps::getallidentities {jlibname} {
+    upvar ${jlibname}::caps::ext ext
+    
+    return $ext(identities)
+}
+
+proc jlib::caps::getexts {jlibname} {
+    upvar ${jlibname}::caps::ext ext
+    
+    set exts [list]
+    foreach {key name} [array get ext name,*] {
+	lappend exts $name
+    }
+    return [lsort $exts]
+}
+
+proc jlib::caps::getxmllist {jlibname name} {
+    upvar ${jlibname}::caps::ext ext
+    
+    if {[info exists ext(xmllist,$name)]} {
+	return $ext(xmllist,$name)
+    } else {
+	return
+    }
+}
+
+proc jlib::caps::getfeatures {jlibname name} {
+    upvar ${jlibname}::caps::ext ext
+    
+    if {[info exists ext(features,$name)]} {
+	return $ext(features,$name)
+    } else {
+	return
+    }
+}
+
+proc jlib::caps::getallfeatures {jlibname} {
+    upvar ${jlibname}::caps::ext ext
+    
+    set featureL [list]
+    foreach {key features} [array get ext features,*] {
+	set featureL [concat $featureL $features]
+    }
+    return [lsort -unique $featureL]
+}
+
+# jlib::caps::generate_ver --
+# 
+#       This just takes the internal identities and features into account.
+#       NB: A client MUST synchronize the disco identity amd feature elements
+#           here else we respond with a false ver attribute!
+
+proc jlib::caps::generate_ver {jlibname} {
+    
+    set identities [jlib::disco::getidentities $jlibname]
+    set features [concat [getallfeatures $jlibname] \
+      [jlib::disco::getregisteredfeatures]]
+    return [create_ver $identities $features]
+}
+
+proc jlib::caps::create_ver {identityL featureL} {
+
+    set ver ""
+    append ver [join [lsort -unique $identityL] <]
+    append ver <
+    append ver [join [lsort -unique $featureL] <]
+    append ver <
+    set hex [::sha1::sha1 $ver]
+    
+    # Inverse to: [format %0.8x%0.8x%0.8x%0.8x%0.8x $H0 $H1 $H2 $H3 $H4]
+    set parts ""
+    for {set i 0} {$i < 5} {incr i} {
+	append parts "0x"
+	append parts [string range $hex [expr {8*$i}] [expr {8*$i + 7}]]
+	append parts " "
+    }
+    # Works independent on machine Endian order!
+    set bin [eval binary format IIIII $parts]
+    return [::base64::encode $bin]
+}
+
+# Test case:
+if {0} {
+    set S "client/pc<http://jabber.org/protocol/disco#info<http://jabber.org/protocol/disco#items<http://jabber.org/protocol/muc<"
+    # 8RovUdtOmiAjzj+xI7SK5BCw3A8=
+
+    set identityL {client/pc}
+    set featureL {
+	"http://jabber.org/protocol/disco#info"
+	"http://jabber.org/protocol/disco#items"
+	"http://jabber.org/protocol/muc"
+    }
+    jlib::caps::create_ver $identityL $featureL
+}
+
+#--- Second, handle all users caps stuff ---------------------------------------
+
+# jlib::caps::disco_ver --
+# 
+#       Disco#info request for client#version 
+#       
+#       <iq type='get' to='randomuser1@capulet.com/resource'>
+#           <query xmlns='http://jabber.org/protocol/disco#info'
+#               node='http://exodus.jabberstudio.org/caps#0.9'/>
+#       </iq> 
+# 
+#       We MUST have got a presence caps element for this user.
+#       
+#       The client that received the annotated presence sends a disco#info 
+#       request to exactly one of the users that sent a particular presenece
+#       element caps combination of node and ver.
+
+proc jlib::caps::disco_ver {jlibname jid} {
+
+    set ver [$jlibname roster getcapsattr $jid ver]
+    disco $jlibname $jid ver $ver
+}
+
+# jlib::caps::disco_ext --
+# 
+#       Disco the 'ext' via the caps node+ext cache.
+#       
+#       We MUST have got a presence caps element for this user with the
+#       corresponding 'ext' token.
+
+proc jlib::caps::disco_ext {jlibname jid ext} {
+
+    disco $jlibname $jid ext $ext
+}
+
+# jlib::caps::disco --
+# 
+#       Internal use only. See disco_ver and disco_ext.
+#       
+# Arguments:
+#       what:       "ver" or "ext"
+#       value:      value for 'ver' or the name of the 'ext'.
+
+proc jlib::caps::disco {jlibname jid what value} {
+    variable state
+    variable caps
+    
+    set node [$jlibname roster getcapsattr $jid node]
+    set key $what,$node,$value
+    	
+    # Mark that we have a pending node+ver or node+ext request.
+    set state(pending,$key) 1
+    
+    # It should be safe to use 'disco get_async' here.
+    # Need to provide node+ver for error recovery.
+    set cb [list [namespace current]::disco_cb $node $what $value]
+    $jlibname disco get_async info $jid $cb -node ${node}#${value}
+}
+
+# jlib::caps::disco_cb --
+# 
+#       Callback for 'disco get_async'.
+#       We must take care of a situation where the jid went unavailable,
+#       or otherwise returns an error, and try to use another jid.
+
+proc jlib::caps::disco_cb {node what value jlibname type from queryE args} {
+    upvar ${jlibname}::caps::options options
+    variable state
+    variable caps
+
+    set key $what,$node,$value
+    unset -nocomplain state(pending,$key)
+
+    if {$type eq "error"} {
+	
+	# If one client with a certain 'key' fails it is likely all will
+	# fail since they are assumed to be identical, unless it failed
+	# because it went offline.
+	# @@@ Risk for infinite loop?
+	if {$options(-autodisco) && ![$jlibname roster isavailable $from]} {
+	    set rjid [get_random_jid $what $node $value]
+	    if {$rjid ne ""} {
+		disco $jlibname $rjid $what $value
+	    }
+	}
+    } else {
+	set jid [jlib::jidmap $from]
+	
+	# Cache the returned element to be reused for all node+ver combinations.
+	set caps(queryE,$key) $queryE
+	if {[llength $options(-command)]} {
+	    uplevel #0 $options(-command) [list $jlibname $from $queryE]
+	}
+    }
+}
+
+# OBSOLETE IN 1.4
+
+# jlib::caps::avail_cb --
+# 
+#       Registered available presence callback.
+#       Keeps track of all jid <-> node+ver combinations.
+#       The exts may be different for identical node+ver and must be
+#       obtained for individual jids using 'roster getcapsattr'.
+
+proc jlib::caps::avail_cb {jlibname xmldata} {
+    upvar ${jlibname}::caps::options options
+    variable state
+    variable caps
+    
+    set jid [wrapper::getattribute $xmldata from]
+    set jid [jlib::jidmap $jid]
+
+    set node [$jlibname roster getcapsattr $jid node]
+	
+    # Skip if the client doesn't have a caps presence element.
+    if {$node eq ""} {
+	return
+    }
+    set ver [$jlibname roster getcapsattr $jid ver]
+    set ext [$jlibname roster getcapsattr $jid ext]
+        	    
+    # Map jid -> node+ver+ext. Note that 'ext' may be empty.
+    set state(jid,node,$jid) $node
+    set state(jid,ver,$jid)  $ver
+    set state(jid,ext,$jid)  $ext
+	    
+    # For each combinations node+ver and node+ext we must be able to collect
+    # a list of JIDs where we shall pick a random one to disco.    
+    # Avoid a linear search. Better to use the array hash mechanism.
+    
+    set state(jids,ver,$ver,$node,$jid) $jid
+    foreach e $ext {
+	set state(jids,ext,$e,$node,$jid) $jid
+    }
+        
+    # If auto disco then try to disco all node+ver and node+exts which we
+    # don't have and aren't waiting for.
+    if {$options(-autodisco)} {
+	set key ver,$node,$ver
+	if {![info exists caps(queryE,$key)]} {
+	    if {![info exists state(pending,$key)]} {
+		set rjid [get_random_jid ver $node $ver]
+		if {$rjid ne ""} {
+		    disco $jlibname $rjid ver $ver
+		}
+	    }
+	}
+	foreach e $ext {
+	    set key ext,$node,$e
+	    if {![info exists caps(queryE,$key)]} {
+		if {![info exists state(pending,$key)]} {
+		    set rjid [get_random_jid ext $node $e]
+		    if {$rjid ne ""} {
+			disco $jlibname $rjid ext $e
+		    }
+		}
+	    }
+	}
+    }
+    return 0
+}
+
+# OBSOLETE IN 1.4
+
+# jlib::caps::get_random_jid_ver, get_random_jid_ext --
+# 
+#       Methods to pick a random JID from node+ver or node+ext.
+
+proc jlib::caps::get_random_jid {what node value} {
+    get_random_jid_$what $node $value
+}
+
+proc jlib::caps::get_random_jid_ver {node ver} {
+    variable state
+    
+    set keys [array names state jids,ver,$ver,$node,*]
+    if {[llength $keys]} {
+	set idx [expr {int(rand()*[llength $keys])}]
+	return $state([lindex $keys $idx])
+    } else {
+	return 
+    }
+}
+
+proc jlib::caps::get_random_jid_ext {node ext} {
+    variable state
+    
+    set keys [array names state jids,ext,$ext,$node,*]
+    if {[llength $keys]} {
+	set idx [expr {int(rand()*[llength $keys])}]
+	return $state([lindex $keys $idx])
+    } else {
+	return 
+    }
+}
+
+# OBSOLETE IN 1.4
+
+# jlib::caps::unavail_cb --
+# 
+#       Registered unavailable presence callback.
+#       Frees internal cache related to this jid.
+
+proc jlib::caps::unavail_cb {jlibname xmldata} {
+    variable state
+
+    set jid [wrapper::getattribute $xmldata from]
+    set jid [jlib::jidmap $jid]
+    
+    # JID may not have caps.
+    if {![info exists state(jid,node,$jid)]} {
+	return
+    }
+    set node $state(jid,node,$jid)
+    set ver  $state(jid,ver,$jid)
+    set ext  $state(jid,ext,$jid)
+        
+    set jidESC [jlib::ESC $jid]
+    array unset state jid,node,$jidESC
+    array unset state jid,ver,$jidESC
+    array unset state jid,ext,$jidESC
+    array unset state jids,*,$jidESC
+
+    return 0
+}
+
+proc jlib::caps::reset {jlibname} {
+    variable state
+    
+    unset -nocomplain state
+}
+
+# OBSOLETE IN 1.4
+
+proc jlib::caps::writecache {fileName} {
+    variable caps
+
+    set fd [open $fileName w]
+    fconfigure $fd -encoding utf-8
+    foreach {key value} [array get caps] {
+	puts $fd [list set caps($key) $value]
+    }
+    close $fd
+}
+
+proc jlib::caps::readcache {fileName} {
+    variable caps
+
+    source $fileName
+}
+
+proc jlib::caps::freecache {} {
+    variable caps
+
+    unset -nocomplain caps
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::caps {
+
+    jlib::ensamble_register caps  \
+      [namespace current]::init   \
+      [namespace current]::cmdproc
+}
+
+# Tests
+if {0} {
+    
+    proc cb {args} {}
+    set jlib ::jlib::jlib1
+    set jid matben@localhost/coccinella
+    set caps "http://coccinella.sourceforge.net/protocol/caps"
+    set ver 0.95.17
+    $jlib disco send_get info $jid cb -node $caps#$ver
+    $jlib disco send_get info $jid cb -node $caps#whiteboard
+    $jlib disco send_get info $jid cb -node $caps#iax
+}
diff --git a/lib/jabberlib/compress.tcl b/lib/jabberlib/compress.tcl
new file mode 100644
index 0000000..fcdff04
--- /dev/null
+++ b/lib/jabberlib/compress.tcl
@@ -0,0 +1,231 @@
+#  compress.tcl --
+#  
+#      This file is part of jabberlib.
+#      It implements stream compression as defined in XEP-0138: 
+#      Stream Compression
+#      
+#  Copyright (c) 2006-2007  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+#  NB: There are several zlib packages floating around the net with the same
+#      name!. But we must have the one implemented for TIP 234, see
+#      http://www.tcl.tk/cgi-bin/tct/tip/234.html.
+#      This is currently of version 2.0.1 so we rely on this when doing
+#      package require. Beware!
+#      
+# $Id: compress.tcl,v 1.9 2008/01/04 13:41:32 matben Exp $
+
+package require jlib
+package require -exact zlib 2.0.1
+
+package provide jlib::compress 0.1
+
+namespace eval jlib::compress {
+
+    variable methods {zlib}
+    
+    # NB: There are two namespaces:
+    #     'http://jabber.org/features/compress' 
+    #     'http://jabber.org/protocol/compress' 
+    variable xmlns
+    array set xmlns {
+	features/compress    "http://jabber.org/features/compress"
+	protocol/compress    "http://jabber.org/protocol/compress"
+    }
+    jlib::register_instance [namespace code instance]
+}
+
+proc jlib::compress::instance {jlibname} {
+    $jlibname register_reset [namespace code reset]
+}
+
+proc jlib::compress::start {jlibname cmd} {
+    
+    variable xmlns
+    variable methods
+    
+    # puts "jlib::compress::start"
+    
+    # Instance specific namespace.
+    namespace eval ${jlibname}::compress {
+	variable state
+    }
+    upvar ${jlibname}::compress::state state
+    
+    set state(cmd) $cmd
+    set state(-method) [lindex $methods 0]
+    
+    # Set up the streams for zlib.
+    set state(compress)   [zlib stream compress]
+    set state(decompress) [zlib stream decompress]
+
+    # Set up callback for the xmlns that is of interest to us.
+    $jlibname element_register $xmlns(protocol/compress) [namespace code parse]
+
+    if {[$jlibname have_feature]} {
+	compress $jlibname
+    } else {
+	$jlibname trace_stream_features [namespace code features_write]
+    }
+}
+
+proc jlib::compress::features_write {jlibname} {
+    
+     # puts "jlib::compress::features_write"
+    
+     $jlibname trace_stream_features {}
+     compress $jlibname
+}
+
+# jlib::compress::compress --
+# 
+#       Initiating Entity Requests Stream Compression.
+
+proc jlib::compress::compress {jlibname} {
+    
+    variable methods
+    variable xmlns
+    upvar ${jlibname}::compress::state state
+    
+    # puts "jlib::compress::compress"
+       
+    # Note: If the initiating entity did not understand any of the advertised 
+    # compression methods, it SHOULD ignore the compression option and 
+    # proceed as if no compression methods were advertised. 
+
+    set have_method [$jlibname have_feature compression $state(-method)]
+    if {!$have_method} {
+	finish $jlibname
+	return
+    }
+    
+    # @@@ MUST match methods!!!
+    # A compliant implementation MUST implement the ZLIB compression method...
+    
+    set methodE [wrapper::createtag method -chdata $state(-method)]
+
+    set xmllist [wrapper::createtag compress  \
+      -attrlist [list xmlns $xmlns(protocol/compress)] -subtags [list $methodE]]
+    $jlibname send $xmllist
+
+    # Wait for 'compressed' or 'failure' element.
+}
+
+proc jlib::compress::parse {jlibname xmldata} {
+    
+    # puts "jlib::compress::parse"
+    
+    set tag [wrapper::gettag $xmldata]
+    
+    switch -- $tag {
+	compressed {
+	    compressed $jlibname $xmldata
+	}
+	failure {
+	    failure $jlibname $xmldata
+	}
+	default {
+	    finish $jlibname compress-protocol-error
+	}
+    }
+    return
+}
+
+proc jlib::compress::compressed {jlibname xmldata} {
+    
+    # puts "jlib::compress::compressed"
+    
+    # Example 5. Receiving Entity Acknowledges Stream Compression 
+    #     <compressed xmlns='http://jabber.org/protocol/compress'/> 
+    # Both entities MUST now consider the previous stream to be null and void, 
+    # just as with TLS negotiation and SASL negotiation 
+    # Therefore the initiating entity MUST initiate a new stream to the 
+    # receiving entity: 
+ 
+    $jlibname wrapper_reset
+    
+    # We must clear out any server info we've received so far.
+    $jlibname stream_reset
+    
+    $jlibname set_socket_filter [namespace code out] [namespace code in]
+    
+    if {[catch {
+	$jlibname sendstream -version 1.0
+    } err]} {
+	finish $jlibname network-failure $err
+	return
+    }
+    finish $jlibname
+}
+
+# jlib::compress::out, in --
+# 
+#       Actual compression takes place here.
+#       XEP says:
+#       When using ZLIB for compression, the sending application SHOULD 
+#       complete a partial flush of ZLIB when its current send is complete. 
+
+proc jlib::compress::out {jlibname data} {
+    upvar ${jlibname}::compress::state state
+
+    $state(compress) put -flush $data
+    return [$state(compress) get]
+}
+
+proc jlib::compress::in {jlibname cdata} {
+    upvar ${jlibname}::compress::state state
+    
+    $state(decompress) put $cdata
+    #$state(decompress) flush
+    return [$state(decompress) get]
+}
+
+proc jlib::compress::failure {jlibname xmldata} {
+    
+    # puts "jlib::compress::failure"
+    
+    set c [wrapper::getchildren $xmldata]
+    if {[llength $c]} {
+	set errcode [wrapper::gettag [lindex $c 0]]
+    } else {
+	set errcode unknown-failure
+    }
+    finish $jlibname $errcode
+}
+
+proc jlib::compress::finish {jlibname {errcode ""} {errmsg ""}} {
+    
+    upvar ${jlibname}::compress::state state
+    variable xmlns
+    
+    # puts "jlib::compress:finish errcode=$errcode, errmsg=$errmsg"
+
+    # NB: We must keep our state array for the lifetime of the stream.
+    $jlibname trace_stream_features {}
+    $jlibname element_deregister $xmlns(protocol/compress) [namespace code parse]
+    
+    if {$errcode ne ""} {
+	uplevel #0 $state(cmd) $jlibname [list $errcode $errmsg]
+    } else {
+	uplevel #0 $state(cmd) $jlibname
+    }
+}
+
+proc jlib::compress::reset {jlibname} {
+    
+    upvar ${jlibname}::compress::state state
+
+    # puts "jlib::compress::reset"
+    
+    if {[info exists state(compress)]} {
+	$state(compress) close
+	unset state(compress)
+    }
+    if {[info exists state(decompress)]} {
+	$state(decompress) close
+	unset state(decompress)
+    }
+    unset -nocomplain state
+}
+
diff --git a/lib/jabberlib/connect.tcl b/lib/jabberlib/connect.tcl
new file mode 100644
index 0000000..241a743
--- /dev/null
+++ b/lib/jabberlib/connect.tcl
@@ -0,0 +1,1109 @@
+#  connect.tcl --
+#  
+#      This file is part of the jabberlib. 
+#      It provides a high level method to handle all the things to establish
+#      a connection with a jabber server and do TLS, SASL, and authentication.
+#      
+#  Copyright (c) 2006-2007  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: connect.tcl,v 1.39 2008/03/27 15:15:26 matben Exp $
+# 
+############################# USAGE ############################################
+#
+#   jlib::connect::configure ?options?
+#   jlibname connect connect jid password ?options?     (constructor)
+#   jlibname connect reset
+#   jlibname connect register jid password
+#   jlibname connect auth
+#   jlibname connect free                               (destructor)
+#   jlibname connect feature name
+#
+#### EXECUTION PATHS ###########################################################
+# 
+#  sections:                                      callback status:
+# 
+#       o dns lookup (optional)                         dnsresolve
+#       o transport                                     initnetwork
+#       o initialize xmpp stream                        initstream
+#       o start tls (optional)                          starttls
+#       o stream compression (untested)                 startcompress
+#       o sasl authentication (or digest or plain)      authenticate
+#       o final                                         ok | error 
+# 
+#   error tokens:
+#   
+#       no-stream-id
+#       no-stream-version-1
+#       network-failure
+#       tls-failure
+#       starttls-nofeature
+#       starttls-failure
+#       starttls-protocol-error
+#       sasl-no-mechanisms
+#       sasl-protocol-error
+#       
+#       All SASL error elements according to RFC 3920 (XMPP Core)
+#       not-authorized    being the most common
+#       
+#       xmpp-streams-error
+#       
+#       And all stream error tags as defined in "4.7.3.  Defined Conditions"
+#       in RFC 3920 (XMPP Core) as:
+#       xmpp-streams-error-TheTagName
+#       
+### From: XEP-0170: Recommended Order of Stream Feature Negotiation ############
+#
+#   The XMPP RFCs define an ordering for the features defined therein, namely: 
+#       0.  TLS 
+#       1.  SASL 
+#       2.  Resource binding 
+#       3.  IM session establishment 
+#       
+#   Using Stream Compression:
+#       0.  TLS 
+#       1.  SASL 
+#       2.  Stream compression
+#       3.  Resource binding 
+#       4.  IM session establishment 
+#       
+################################################################################
+#
+#       @@@ Note to myself: maybe it would be a good idea to make this more OO
+#           like. jlib::connect returns a 'connector' object that is used as
+#           an instance for invoking the methods. We make sure that each jlib
+#           instance can make at most a single connector object at a time.
+#           Make sure that any connector object gets deleted from the jlib 
+#           instance destructor.
+
+package require jlib
+package require sha1
+package require autosocks       ;# wrapper for the 'socket' command.
+package require autoproxy       ;# another wrapper for 'socket'
+ 
+package provide jlib::connect 0.1
+
+namespace eval jlib::connect {
+    
+    variable inited 0
+    variable have
+    variable debug 0
+}
+
+proc jlib::connect::init {jlibname} {
+    variable inited
+
+    if {!$inited} {
+	init_static
+    }
+}
+
+proc jlib::connect::cmdproc {jlibname cmd args} {
+        
+    # Just dispatch the command to the right procedure.
+    return [eval {$cmd $jlibname} $args]
+}
+
+proc jlib::connect::init_static {} {
+    variable inited
+    variable have
+    
+    debug "jlib::connect::init_static"
+    
+    # Loop through all packages we may need.
+    foreach name {
+	tls        jlibsasl        jlibtls  
+	jlib::dns  jlib::compress  jlib::http
+	jlib::bind
+    } {
+	set have($name) 0
+	if {![catch {package require $name}]} {
+	    set have($name) 1
+	}	
+    }
+
+    autoproxy::init
+    
+    # -method: ssl | tlssasl | sasl
+    # -transport tcp | http | tunnel
+
+    # Default options.
+    variable options
+    array set options {
+	-command          ""
+	-compress         0
+	-defaulthttpurl   http://%h:5280/http-poll/
+	-defaultport      5222
+	-defaultresource  "default"
+	-defaultsslport   5223
+	-digest           1
+	-dnsprotocol      udp
+	-dnssrv           1
+	-dnstxthttp       1
+	-dnstimeout       3000
+	-http             0
+	-httpurl          ""
+	-ip               ""
+	-method           sasl
+	-minpollsecs      4
+	-noauth           0
+	-port             ""
+	-saslthencomp     1
+	-secure           0
+	-timeout          30000
+	-transport        tcp      
+    }
+    
+    # todo:
+    # -anonymous
+    set inited 1
+}
+
+# jlib::connect::filteroptions --
+# 
+#       Filter an arbitrary -key value list to receive options that can
+#       typically be used by a client.
+
+proc jlib::connect::filteroptions {args} {
+    variable options
+
+    set opts [list]
+    foreach {key value} $args {
+	if {$key eq "-command"} { continue }
+	if {[info exists options($key)]} {
+	    lappend opts $key $value
+	}
+    }
+    return $opts
+}
+
+# jlib::connect::configure --
+# 
+# 
+
+proc jlib::connect::configure {args} {    
+    variable have
+    variable options
+    
+    debug "jlib::connect::configure args=$args"
+    
+    if {[llength $args] == 0} {
+	return [array get options]
+    } else {
+	foreach {key value} $args {
+	    switch -- $key {
+		-compress {
+		    if {!$have(jlib::compress)} {
+			return -code error "missing jlib::compress package"
+		    }
+		}
+		-http {
+		    if {!$have(jlib::http)} {
+			return -code error "missing jlib::http package"
+		    }
+		}
+		-method {
+		    if {($value eq "ssl") && !$have(tls)} {
+			return -code error "missing tls package"
+		    } elseif {($value eq "tlssasl")  \
+		      && (!$have(jlibtls) || !$have(jlibsasl))} {
+			return -code error "missing jlibtls or jlibsasl package"
+		    } elseif {($value eq "sasl") && !$have(jlibsasl)} {
+			return -code error "missing jlibsasl package"
+		    }
+		}
+		-port {
+		    if {![string is integer $state(-port)]} {
+			return -code error "the -port must be an integer"
+		    }
+		}
+	    }
+	    set options($key) $value
+	}
+    }
+}
+
+proc jlib::connect::get_state {jlibname {name ""}} {    
+    upvar ${jlibname}::connect::state state
+
+    if {$name eq ""} {
+	return [array get state]
+    } else {
+	if {[info exists state($name)]} {
+	    return $state($name)
+	} else {
+	    return ""
+	}
+    }
+}
+
+# jlib::connect::connect --
+# 
+#       Initiate the login process.
+# 
+# Arguments:
+#       jid
+#       password
+#       cmd         callback command
+#       args:
+#           -command          tclProc
+#           -compress         0|1
+#           -defaulthttpurl   url
+#           -defaultport      5222
+#           -defaultresource  
+#           -defaultsslport   5223
+#           -digest           0|1
+#           -dnsprotocol      tcp[udp
+#           -dnssrv           0|1
+#           -dnstxthttp       0|1
+#           -dnstimeout       millisecs
+#           -http             0|1
+#           -httpurl          url
+#           -ip
+#           -secure           0|1        @@@ Change this to -xmpp ?
+#           -method           ssl|tlssasl|sasl
+#           -noauth           0|1
+#           -port
+#           -saslthencomp     0|1       This is the normal order for compression
+#           -timeout          millisecs
+#           -transport        tcp|http|tunnel
+#           
+#         o Note the naming convention for -method!
+#            ssl        using direct tls socket connection
+#                       it corresponds to the original jabber method
+#            tlssasl    in stream tls negotiation + sasl, xmpp compliant
+#                       XMPP requires sasl after starttls!
+#            sasl       only sasl authentication
+#            
+#         o @@@ Perhaps a better way is to use a -xmpp switch that sets
+#               the main mode of operation, and then use whatever as sub switches.
+#            
+#         o The http proxy is configured from the http package.
+#         o The SOCKS proxy is configured from the autosocks package.
+#            
+#       Port priorites:
+#           1) -port
+#           2) DNS SRV resource record
+#           3) -defaultport
+#       
+# Results:
+#       jlibname
+
+proc jlib::connect::connect {jlibname jid password args} {    
+    variable have
+    variable options
+    
+    debug "jlib::connect::connect jid=$jid, args=$args"
+            
+    # Instance specific namespace.
+    #   'state' only lives until connection finalized
+    #   'feature' lives until stream is closed
+
+    namespace eval ${jlibname}::connect {
+	variable state
+	variable feature
+    }
+    upvar ${jlibname}::connect::state state
+    upvar ${jlibname}::connect::feature feature
+      
+    $jlibname register_reset [namespace code stream_reset]
+    
+    jlib::splitjidex $jid username server resource
+    
+    # Notes:
+    #   o use "coccinella" as default resource
+    #   o state(host) is the DNS SRV record or server if DNS failed
+    #   o set one timeout on the complete sequence
+
+    set state(jid)         $jid
+    set state(username)    $username
+    set state(server)      $server
+    set state(host)        $server
+    set state(resource)    $resource
+    set state(password)    $password
+    set state(args)        $args
+    set state(error)       ""
+    set state(state)       ""
+    set state(httpurl)     ""
+    set state(dns_srv)     [list]   ; # list of {host port} DNS TXT records
+    set state(dns_srv_idx) 0        ; # index of dns_srv currently tried
+
+    foreach name {ssl tls sasl compress} {
+	set state(use$name) 0
+	set feature($name) 0
+    }
+    
+    # Default options.
+    array set state [array get options]
+    array set state $args
+
+    if {$resource eq ""} {
+	set state(resource) $state(-defaultresource)
+    }
+
+    # Verify that we have the necessary packages.
+    if {[catch {verify $jlibname} err]} {
+	return -code error $err
+    }
+
+    if {$state(-http)} {
+	set state(-transport) http
+    }
+    if {$state(-secure)} {
+	switch -- $state(-method) {
+	    sasl {
+		set state(usesasl) 1
+	    }
+	    tlssasl {
+		set state(usesasl) 1
+		set state(usetls) 1
+	    }
+	    ssl {
+		set state(usessl) 1
+	    }
+	}
+	if {$state(-compress)} {
+	    set state(usecompress) 1
+	}
+    }
+    if {$state(-compress) && ($state(usetls) || $state(usessl))} {
+	#return -code error "connot have -compress and tls at the same time"
+    }
+
+    # Any stream version. XMPP requires 1.0.
+    if {$state(usesasl) || $state(usetls) || $state(usecompress)} {
+	set state(version) 1.0
+    }
+    
+    if {$state(-ip) ne ""} {
+	set state(host) $state(-ip)
+    }
+    
+    # Actual port to connect to (tcp). 
+    # May be changed by DNS lookup unless -port set.
+    if {[string is integer -strict $state(-port)]} {
+	set state(port) $state(-port)
+    } else {
+	if {$state(usessl)} {
+	    set state(port) $state(-defaultsslport)
+	} else {
+	    set state(port) $state(-defaultport)
+	}
+    }
+    
+    # Schedule a timeout.
+    if {$state(-timeout) > 0} {
+	set state(after) [after $state(-timeout)  \
+	  [list jlib::connect::timeout $jlibname]]
+    }
+
+    # Start by doing a DNS lookup.
+    if {$state(-transport) eq "tcp" || $state(-transport) eq "tunnel"} {
+
+	# Do not do a DNS SRV lookup if we have an explicit ip address.
+	if {!$state(-dnssrv) || ($state(-ip) ne "")} {
+	    tcp_connect $jlibname
+	} else {
+	    set state(state) dnsresolve
+	    set cb [list jlib::connect::dns_srv_cb $jlibname]
+	    if {$state(-command) ne {}} {
+		uplevel #0 $state(-command) $jlibname dnsresolve
+	    }
+	    if {[catch {
+		set state(dnstoken) [jlib::dns::get_addr_port $server $cb  \
+		  -protocol $state(-dnsprotocol) -timeout $state(-dnstimeout)]
+	    } err]} {
+		# @@@ We should reset the jlib::dns here but it's buggy!
+		unset -nocomplain state(dnstoken)
+		tcp_connect $jlibname
+	    }
+	}
+    } elseif {$state(-transport) eq "http"} {
+
+	# Do not do a DNS TXT lookup if we have an explicit url address.
+	if {!$state(-dnstxthttp) || ($state(-httpurl) ne "")} {
+	    set state(httpurl) $state(-httpurl)
+	    http_init $jlibname
+	} else {
+	    set state(state) dnsresolve
+	    set cb [list jlib::connect::dns_http_cb $jlibname]
+	    if {$state(-command) ne {}} {
+		uplevel #0 $state(-command) $jlibname dnsresolve
+	    }
+	    if {[catch {
+		set state(dnstoken) [jlib::dns::get_http_poll_url $server $cb]
+	    } err]} {
+		# @@@ We should reset the jlib::dns here but it's buggy!
+		unset -nocomplain state(dnstoken)
+		http_init $jlibname
+	    }
+	}
+    }
+    jlib::set_async_error_handler $jlibname [namespace code async_error]
+    
+    return $jlibname
+}
+
+proc jlib::connect::verify {jlibname} {    
+    variable have
+    upvar ${jlibname}::connect::state state
+
+    if {$state(-secure)} {
+	if {($state(-method) eq "sasl") && !$have(jlibsasl)} {
+	    return -code error "missing jlibsasl package"
+	}
+	if {($state(-method) eq "ssl") && !$have(tls)} {
+	    return -code error "missing tls package"
+	}
+	if {($state(-method) eq "tlssasl")  \
+	  && (!$have(jlibtls) || !$have(jlibsasl))} {
+	    return -code error "missing jlibtls or jlibsasl package"
+	}
+    }
+    if {$state(-compress) && !$have(jlib::compress)} {
+	return -code error "missing jlib::compress package"
+    }
+}
+
+proc jlib::connect::async_error {jlibname err {msg ""}} {    
+    upvar ${jlibname}::connect::state state
+    
+    finish $jlibname $err $msg
+}
+
+# jlib::connect::dns_srv_cb --
+#
+#       This is our callback from the jlib::dns call.
+#
+#       addrPort: {{soumar.jabbim.cz 5222} {nezmar.jabbim.cz 5222} ...}
+
+proc jlib::connect::dns_srv_cb {jlibname addrPort {err ""}} {
+    upvar ${jlibname}::connect::state state
+    
+    debug "jlib::connect::dns_srv_cb addrPort=$addrPort, err=$err"
+
+    if {![info exists state(state)]} {
+	# We do not exist. dns::reset seems to be buggy!
+	return
+    }
+    
+    # dns doesn't seem to use the 'err' argument in this case.
+    set status [::dns::status $state(dnstoken)]
+    if {$status eq "reset"} {
+	return
+    }
+    
+    # We never let a failure stop us here. Use host as fallback.
+    if {$err eq ""} {
+	set state(host) [lindex $addrPort 0 0]
+	set state(port) [lindex $addrPort 0 1]
+	
+	# Collect multiple DNS TXT record responses so we may try them in order.
+	set state(dns_srv) $addrPort
+	set state(dns_srv_idx) 0
+	
+	# Try ad-hoc method for port number for ssl connections (5223).
+	if {$state(usessl)} {
+	    incr state(port)
+	}
+    }
+    
+    # If -port set this always takes precedence.
+    if {[string is integer -strict $state(-port)]} {
+	set state(port) $state(-port)
+    }
+    unset -nocomplain state(dnstoken)
+    tcp_connect $jlibname
+}
+
+proc jlib::connect::dns_http_cb {jlibname url {err ""}} {    
+    upvar ${jlibname}::connect::state state
+
+    debug "jlib::connect::dns_http_cb url=$url, err=$err"
+    
+    if {![info exists state(state)]} {
+	# We do not exist. dns::reset seems to be buggy!
+	return
+    }
+    
+    # dns doesn't seem to use the 'err' argument in this case.
+    set status [::dns::status $state(dnstoken)]
+    if {$status eq "reset"} {
+	return
+    }
+    unset -nocomplain state(dnstoken)
+    if {$err eq ""} {
+	set state(httpurl) $url
+    }
+    
+    # If -httpurl set this always takes precedence.
+    if {$state(-httpurl) ne ""} {
+	set state(httpurl) $state(-httpurl)
+    }
+    http_init $jlibname
+}
+
+proc jlib::connect::http_init {jlibname} {    
+    upvar ${jlibname}::connect::state state
+
+    debug "jlib::connect::http_init"
+    
+    if {$state(httpurl) eq ""} {
+	set state(httpurl)  \
+	  [string map [list "%h" $state(server)] $state(-defaulthttpurl)]
+    }
+    jlib::http::new $jlibname $state(httpurl)
+    init_stream $jlibname
+}
+
+proc jlib::connect::tunnel_connect {jlibname} {    
+    upvar ${jlibname}::connect::state state
+    
+    debug "jlib::connect::tunnel_connect $state(host) $state(port)"
+
+    set state(state) initnetwork
+    if {$state(-command) ne {}} {
+	uplevel #0 $state(-command) $jlibname initnetwork
+    }    
+    if {[catch {
+	set state(sock) [autoproxy::tunnel_connect $state(host) $state(port)]
+        tcp_writable $jlibname
+    } err]} {
+        puts stderr $::errorInfo
+	finish $jlibname network-failure $err
+    }
+}
+
+# jlib::connect::tcp_connect --
+#
+#       Try make a TCP connection to state(host/port).
+
+proc jlib::connect::tcp_connect {jlibname} {    
+    upvar ${jlibname}::connect::state state
+    
+    if {$state(-transport) eq "tunnel"} {
+        return [tunnel_connect $jlibname]
+    }
+
+    debug "jlib::connect::tcp_connect $state(host) $state(port)"
+
+    set state(state) initnetwork
+    if {$state(-command) ne {}} {
+	uplevel #0 $state(-command) $jlibname initnetwork
+    }    
+    if {[catch {
+	set state(sock) [autosocks::socket $state(host) $state(port) \
+	  -command [list jlib::connect::tcp_cb $jlibname]]
+    } err]} {
+	tcp_cb $jlibname network-failure
+    }
+}
+
+proc jlib::connect::tcp_cb {jlibname status} {
+    upvar ${jlibname}::connect::state state
+    
+    debug "jlib::connect::tcp_cb status=$status"
+    
+    # If we have multiple DNS TXT records try them in order.
+    if {$status eq "ok"} {
+	tcp_writable $jlibname
+    } else {
+	set len [llength $state(dns_srv)]
+	set idx $state(dns_srv_idx)
+	if {$len && ($idx < [expr {$len-1}])} {
+	    incr idx
+	    set state(dns_srv_idx) $idx
+	    set state(host) [lindex $state(dns_srv) $idx 0]
+	    set state(port) [lindex $state(dns_srv) $idx 1]
+	    
+	    # If -port set this always takes precedence.
+	    if {[string is integer -strict $state(-port)]} {
+		set state(port) $state(-port)
+	    }
+	    tcp_connect $jlibname
+	} else {
+	    finish $jlibname network-failure
+	}
+    }    
+}
+
+proc jlib::connect::socks_cb {jlibname status} {
+
+    debug "jlib::connect::socks_cb status=$status"
+
+    if {$status eq "ok"} {
+	tcp_writable $jlibname
+    } else {
+	finish $jlibname proxy-failure $status
+    }
+}
+
+proc jlib::connect::tcp_writable {jlibname} {    
+    upvar ${jlibname}::connect::state state
+    
+    debug "jlib::connect::tcp_writable"
+    
+    if {![info exists state(sock)]} {
+	return
+    }
+    set sock $state(sock)
+    fileevent $sock writable {}
+
+    if {[catch {eof $sock} iseof] || $iseof} {
+	finish $jlibname network-failure "connection eof"
+	return
+    }
+
+    # Check if something went wrong first.
+    if {[catch {fconfigure $sock -sockname} sockname]} {
+	finish $jlibname network-failure $sockname
+	return
+    }
+
+    # Configure socket.
+    fconfigure $sock -buffering line -blocking 0
+    catch {fconfigure $sock -encoding utf-8}
+
+    $jlibname setsockettransport $sock
+    
+    # Do SSL handshake. See jlib::tls_handshake for a better way!
+    if {$state(usessl)} {
+
+	# Make it a SSL connection.
+	if {[catch {
+	    tls::import $sock -cafile "" -certfile "" -keyfile "" \
+	      -request 1 -server 0 -require 0 -ssl2 no -ssl3 yes -tls1 yes
+	} err]} {
+	    close $sock
+	    finish $jlibname tls-failure $err
+	    return
+	}
+	set retry 0
+	
+	# Do SSL handshake.
+	while {1} {
+	    if {$retry > 100} { 
+		close $sock
+		set err "too long retry to setup SSL connection"
+		finish $jlibname tls-failure $err
+		return
+	    }
+	    if {[catch {tls::handshake $sock} err]} {
+		if {[string match "*resource temporarily unavailable*" $err]} {
+		    after 50  
+		    incr retry
+		} else {
+		    close $sock
+		    finish $jlibname tls-failure $err
+		    return
+		}
+	    } else {
+		break
+	    }
+	}
+	fconfigure $sock -blocking 0 -encoding utf-8
+    }
+    
+    # Send the init stream xml command.
+    init_stream $jlibname
+}
+
+proc jlib::connect::init_stream {jlibname} {    
+    upvar ${jlibname}::connect::state state
+    
+    debug "jlib::connect::init_stream"
+
+    set state(state) initstream
+    if {$state(-command) ne {}} {
+	uplevel #0 $state(-command) $jlibname initstream
+    }
+    
+    set opts [list]
+    if {[info exists state(version)]} {
+	lappend opts -version $state(version)
+    }
+    
+    # Initiate a new stream. We should wait for the server <stream>.
+    # openstream may throw error.
+    if {[catch {
+	eval {$jlibname openstream $state(server)  \
+	  -cmd [list jlib::connect::init_stream_cb]} $opts
+    } err]} {
+	finish $jlibname network-failure $err
+	return
+    }
+}
+
+proc jlib::connect::init_stream_cb {jlibname args} {
+    upvar ${jlibname}::connect::state state
+    
+    if {![info exists state]} return
+    
+    debug "jlib::connect::init_stream_cb args=$args"
+    
+    array set argsA $args
+        
+    # We require an 'id' attribute.
+    if {![info exists argsA(id)]} {
+	finish $jlibname no-stream-id
+	return
+    }
+    set state(streamid) $argsA(id)
+    
+    # If we are trying to use sasl or tls indicated by version='1.0' 
+    # we must also be sure to receive a version attribute larger or 
+    # equal to 1.0.
+    set version1 0
+    if {[info exists argsA(version)]} {
+	set state(streamversion) $argsA(version)
+	if {[package vcompare $argsA(version) 1.0] >= 0} {
+	    set version1 1
+	}
+    }
+    if {$state(usesasl) || $state(usetls)} {
+	if {!$version1} {
+	    finish $jlibname no-stream-version-1
+	    return
+	}
+    }
+
+    # This XEP is superseeded by XEP-0170
+    # XEP-0138: Stream Compression:
+    # If both TLS (whether including TLS compression or not) and stream 
+    # compression are used, then TLS MUST be negotiated first, followed by 
+    # negotiation of stream compression.
+
+    if {$state(usetls)} {
+	set state(state) starttls
+	if {$state(-command) ne {}} {
+	    uplevel #0 $state(-command) $jlibname starttls
+	}
+	$jlibname starttls jlib::connect::starttls_cb
+	
+	# This is the order ejabberd expects, compression before sasl.
+    } elseif {!$state(-saslthencomp) && $state(usecompress)} {
+	if {$state(-command) ne {}} {
+	    uplevel #0 $state(-command) $jlibname startcompress
+	}
+	jlib::compress::start $jlibname [namespace code compress_cb]
+    } elseif {$state(-noauth)} {
+	finish $jlibname
+    } else {
+	auth $jlibname
+    }
+}
+
+proc jlib::connect::starttls_cb {jlibname type args} {
+    upvar ${jlibname}::connect::state state
+    
+    if {![info exists state]} return
+    
+    debug "jlib::connect::starttls_cb type=$type, args=$args"
+
+    if {$type eq "error"} {
+	foreach {errcode errmsg} [lindex $args 0] break
+	finish $jlibname $errcode $errmsg
+    } else {
+    
+	# We have a new stream. XMPP Core:
+	#    12. If the TLS negotiation is successful, the initiating entity
+	#        MUST continue with SASL negotiation.
+	set state(streamid) [$jlibname getstreamattr id]
+	if {$state(-noauth)} {
+	    finish $jlibname
+	} else {
+	    auth $jlibname
+	}
+    }
+}
+
+# jlib::connect::register --
+# 
+#       Typically used after registered a new account since JID and password
+#       not known until registration succesful.
+
+proc jlib::connect::register {jlibname jid password} {    
+    upvar ${jlibname}::connect::state state
+    
+    jlib::splitjidex $jid username server resource
+
+    set state(jid)      $jid
+    set state(username) $username
+    set state(password) $password
+    if {$resource eq ""} {
+	set state(resource) $state(-defaultresource)
+    }
+}
+
+# jlib::connect::auth --
+# 
+#       Initiates the authentication process using an existing connect instance,
+#       typically when started using -noauth.
+#       The user can modify the options from the initial ones.
+
+proc jlib::connect::auth {jlibname args} {        
+    upvar ${jlibname}::connect::state state
+    
+    debug "jlib::connect::auth"
+
+    array set state $args
+    
+    if {[catch {verify $jlibname} err]} {
+	return -code error $err
+    }
+    set state(state) authenticate
+    if {$state(-command) ne {}} {
+	uplevel #0 $state(-command) $jlibname authenticate
+    }
+    
+    set username $state(username)
+    set password $state(password)
+    set resource $state(resource)
+    
+    if {$state(usesasl)} {
+	$jlibname auth_sasl $username $resource $password \
+	  [namespace code auth_cb]
+    } elseif {$state(-digest)} {
+	set digested [::sha1::sha1 $state(streamid)$password]
+	$jlibname send_auth $username $resource   \
+	  [namespace code auth_cb] -digest $digested
+    } else {
+
+	# Plain password authentication.
+	$jlibname send_auth $username $resource  \
+	  [namespace code auth_cb] -password $password
+    }
+}
+
+proc jlib::connect::auth_cb {jlibname type queryE} {    
+    upvar ${jlibname}::connect::state state
+    
+    if {![info exists state]} return
+    
+    debug "jlib::connect::auth_cb type=$type, queryE=$queryE"
+
+    if {$type eq "error"} {
+	lassign $queryE errcode errmsg
+	finish $jlibname $errcode $errmsg
+    } else {
+
+	# We have a new stream.
+	set state(streamid) [$jlibname getstreamattr id]
+	if {$state(-saslthencomp) && $state(usecompress)} {
+	    if {$state(-command) ne {}} {
+		uplevel #0 $state(-command) $jlibname startcompress
+	    }
+	    jlib::compress::start $jlibname [namespace code compress_cb]
+	} elseif {$state(usesasl)} {
+	    jlib::bind::resource $jlibname $state(resource) [namespace code bind_cb]
+	} else {
+	    finish $jlibname
+	}
+    }
+}
+
+proc jlib::connect::compress_cb {jlibname {errcode ""} {errmsg ""}} {    
+    upvar ${jlibname}::connect::state state
+    
+    if {![info exists state]} return
+    
+    debug "jlib::connect::compress_cb"
+  
+    # Note: Failure of compression setup SHOULD NOT be treated as an 
+    # unrecoverable error and therefore SHOULD NOT result in a stream error. 
+    if {$errcode ne ""} {
+	finish $jlibname $errcode $errmsg
+	return
+    }
+    
+    # We have a new stream.
+    set state(streamid) [$jlibname getstreamattr id]
+    if {$state(-saslthencomp)} {
+	jlib::bind::resource $jlibname $state(resource) [namespace code bind_cb]
+    } else {
+	
+	# If we have taken compression before SASL then go back.
+	if {$state(-noauth)} {
+	    finish $jlibname
+	} else {
+	    auth $jlibname
+	}
+    }
+}
+
+proc jlib::connect::bind_cb {jlibname type queryE} {
+
+    debug "jlib::connect::bind_cb"
+    
+    if {$type eq "error"} {
+	lassign $queryE errcode errmsg
+	finish $jlibname $errcode $errmsg
+    } else {
+	finish $jlibname
+    }
+}
+
+# jlib::connect::reset --
+# 
+#       This is kills any ongoing or nonexisting connect object.
+
+proc jlib::connect::reset {jlibname} {
+    
+    debug "jlib::connect::reset"
+    
+    if {[jlib::havesasl]} {
+	$jlibname sasl_reset
+    }
+    if {[jlib::havetls]} {
+	$jlibname tls_reset
+    }
+    if {[namespace exists ${jlibname}::connect]} {
+	finish $jlibname reset
+    }
+}
+
+proc jlib::connect::timeout {jlibname} {
+
+    if {[jlib::havesasl]} {
+	$jlibname sasl_reset
+    }
+    if {[jlib::havetls]} {
+	$jlibname tls_reset
+    }
+    finish $jlibname timeout
+}
+
+# jlib::connect::finish --
+# 
+#       Finalize the complete sequence, with or without any errors.
+#       
+# Arguments:
+#       errcode:    one word error code, empty if ok
+#       errmsg:     an additional arbitrary error message with details that
+#                   typically gets reported by some component
+#       
+# Results:
+#       Callback made.
+
+proc jlib::connect::finish {jlibname {errcode ""} {errmsg ""}} {    
+    upvar ${jlibname}::connect::state state
+    upvar ${jlibname}::connect::feature feature
+    
+    debug "jlib::connect::finish errcode=$errcode, errmsg=$errmsg"
+
+    jlib::set_async_error_handler $jlibname
+
+    if {![info exists state(state)]} {
+	# We do not exist.
+	return
+    }
+    if {[info exists state(after)]} {
+	after cancel $state(after)
+    }
+    if {[info exists state(dnstoken)]} {
+	jlib::dns::reset $state(dnstoken)
+    }
+    if {$state(error) ne ""} {
+	set errcode $state(error)
+    }
+    if {$errcode ne ""} {
+	set status error
+    
+	# We can be called before the socket has been registered with jlib.
+	if {[info exists state(sock)]} {
+	    catch {close $state(sock)}
+	}
+
+	# This 'kills' the connection. Needed for both tcp and http!
+	# after idle seems necessary when resetting xml parser from callback
+	#after idle [list $jlibname closestream]
+	$jlibname kill
+    } else {
+	set status ok
+	
+	# Copy the state(use*) to feature(*)
+	foreach name {ssl tls sasl compress} {
+	    set feature($name) $state(use$name)
+	}
+
+    }
+    
+    # Here status must be either 'ok' or 'error'.
+    if {$state(-command) ne {}} {
+	if {$errcode eq ""} {
+	    uplevel #0 $state(-command) [list $jlibname $status]
+	} else {
+	    uplevel #0 $state(-command) [list $jlibname $status $errcode $errmsg]
+	}
+    }
+}
+
+proc jlib::connect::feature {jlibname name} {
+    upvar ${jlibname}::connect::feature feature
+
+    if {[info exists feature($name)]} {
+	return $feature($name)
+    } else {
+	return 0
+    }
+}
+
+proc jlib::connect::free {jlibname} {
+    
+    debug  "jlib::connect::free"
+    if {[namespace exists ${jlibname}::connect]} {
+	upvar ${jlibname}::connect::state state
+	unset -nocomplain state
+    }
+}
+
+proc jlib::connect::stream_reset {jlibname} {
+    upvar ${jlibname}::connect::feature feature
+    debug "jlib::connect::stream_reset"
+    unset -nocomplain feature
+}
+
+proc jlib::connect::debug {str} {
+    variable debug
+    
+    if {$debug} {
+	puts $str
+    }
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::connect {
+
+    jlib::ensamble_register connect  \
+      [namespace current]::init      \
+      [namespace current]::cmdproc
+}
+
+# Tests
+if {0} {
+    package require jlib::connect
+    proc cb {args} {
+	puts "---> $args"
+	#puts [jlib::connect::get_state ::jlib::jlib1]
+    }
+    set pw xxx
+    ::jlib::jlib1 connect connect matben@localhost $pw -command cb    
+    ::jlib::jlib1 connect connect matben@devrieze.dyndns.org $pw \
+      -command cb -secure 1 -method tlssasl
+   
+    ::jlib::jlib1 connect connect matben@sgi.se xxx -command cb  \
+      -http 1 -httpurl http://sgi.se:5280/http-poll/
+
+    ::jlib::jlib1 connect connect openfire.matben@sgi.se $pw \
+      -command cb -compress 1 -secure 1 -method sasl
+    
+    ::jlib::jlib1 connect connect matben@jabber.ru $pw \
+      -command cb -compress 1 -secure 1 -method sasl
+
+    jlib::jlib1 closestream
+}
+
+#-------------------------------------------------------------------------------
+
diff --git a/lib/jabberlib/data.tcl b/lib/jabberlib/data.tcl
new file mode 100644
index 0000000..f1acb14
--- /dev/null
+++ b/lib/jabberlib/data.tcl
@@ -0,0 +1,105 @@
+#  data.tcl --
+#
+#      This file is part of the jabberlib. It contains support code
+#      for XEP-0231: Data Element 
+#
+#  Copyright (c) 2008 Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#
+# $Id: data.tcl,v 1.1 2008/05/30 14:21:02 matben Exp $
+#
+############################# USAGE ############################################
+#
+#   INSTANCE COMMANDS
+#      jlibName data create 
+#
+################################################################################
+
+package require jlib
+package require base64     ; # tcllib
+
+package provide jlib::data 0.1
+
+namespace eval jlib::data {
+
+    # Common xml namespaces.
+    variable xmlns
+    array set xmlns {
+        data "urn:xmpp:tmp:data-element"
+    }
+}
+
+# jlib::data::init --
+#
+#       Creates a new instance of the data object.
+
+proc jlib::data::init {jlibname} {
+    variable xmlns
+    
+    # Instance specifics arrays.
+    namespace eval ${jlibname}::data {
+	variable cache
+    }
+
+    # Register some standard iq handlers that are handled internally.
+    $jlibname iq_register get $xmlns(data) [namespace code iq_handler]
+}
+
+proc jlib::data::cmdproc {jlibname cmd args} {
+    return [eval {$cmd $jlibname} $args]
+}
+
+proc jlib::data::element {type data args} {
+    variable xmlns
+    upvar ${jlibname}::data::cache cache
+    
+    set attrL [list xmlns $xmlns(data)]
+    foreach {key value} $args {
+	-alt - -cid {
+	    set name [string trimleft $key -]
+	    set $name $value
+	    lappend attrL $name $value
+	}
+    }
+    set dataE [wrapper::createtag data \
+      -attrlist $attrL -chdata [::base64::encode $data]]
+    if {[info exists cid]} {
+	set cache($cid) $dataE
+    }
+    return $dataE
+}
+
+proc jlib::data::iq_handler {jlibname from dataE args} {
+    upvar ${jlibname}::data::cache cache
+
+    array set argsA $args
+    if {![info exists argsA(id)]} {
+	return 0
+    }
+    set cid [wrapper::getattribute $dataE cid]
+    if {![info exists cache($cid)]} {
+	# Should be <item-not-found/>
+	return 0
+    }
+    
+    $jlibname send_iq result $cache($cid) -to $from -id $id
+    return 1
+}
+
+# We have to do it here since need the initProc before doing this.
+namespace eval jlib::data {
+
+    jlib::ensamble_register data  \
+      [namespace current]::init    \
+      [namespace current]::cmdproc
+}
+
+# Test:
+if {0} {
+    package require jlib::data
+    set jlibname ::jlib::jlib1
+
+    
+}
+
diff --git a/lib/jabberlib/disco.tcl b/lib/jabberlib/disco.tcl
new file mode 100644
index 0000000..c7ed5b1
--- /dev/null
+++ b/lib/jabberlib/disco.tcl
@@ -0,0 +1,978 @@
+#  disco.tcl --
+#  
+#      This file is part of the jabberlib.
+#      
+#  Copyright (c) 2004-2007  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: disco.tcl,v 1.57 2008/06/11 08:12:05 matben Exp $
+# 
+############################# USAGE ############################################
+#
+#   NAME
+#      disco - convenience command library for the disco part of XMPP.
+#      
+#   SYNOPSIS
+#      jlib::disco::init jlibName ?-opt value ...?
+#
+#   OPTIONS
+#	-command tclProc
+#	
+#   INSTANCE COMMANDS
+#      jlibname disco children jid
+#      jlibname disco childs jid ?node?
+#      jlibname disco send_get discotype jid cmd ?-opt value ...?
+#      jlibname disco isdiscoed discotype jid ?node?
+#      jlibname disco get discotype key jid ?node?
+#      jlibname disco getallcategories pattern
+#      jlibname disco get_async discotype jid cmd ?-node node?
+#      jlibname disco getconferences
+#      jlibname disco getjidsforcategory pattern
+#      jlibname disco getjidsforfeature feature
+#      jlibname disco getxml jid ?node?
+#      jlibname disco features jid ?node?
+#      jlibname disco hasfeature feature jid ?node?
+#      jlibname disco isroom jid
+#      jlibname disco iscategorytype category/type jid ?node?
+#      jlibname disco name jid ?node?
+#      jlibname disco nodes jid ?node?
+#      jlibname disco types jid ?node?
+#      jlibname disco reset ?jid ?node??
+#      
+#      where discotype = (items|info)
+#      
+################################################################################
+#
+# Structures:
+#       items(jid,node,children)  list of any children JIDs
+#       items(jid,node,childs)    list of {JID node}
+#       
+#       jid must always be nonempty while node may be empty.
+#       
+#       rooms(jid,node)             exists if children of 'conference'
+
+# NEW: In order to manage the complex jid/node structure it is best to
+#      keep an internal structure always using a pair JID+node. 
+#      As array index: ($jid,$node,..) or list of childs:
+#      {{JID1 node1} {JID2 node2} ..} where any of JID or node can be
+#      empty but not both.
+#       
+#      This reflects the disco xml structure (node can be empty):
+#      
+#      JID node
+#            JID node
+#            JID node
+#            ...
+#            
+# @@@ While 'parent -> child' is uniquely defined 'parent <- child' is NOT!
+#     A certain JID+node can appear in more than one place in the disco tree!
+#     It is better to use another data structure to store this.
+
+package require jlib
+
+package provide jlib::disco 0.1
+
+namespace eval jlib::disco {
+    
+    # Globals same for all instances of this jlib.
+    variable debug 0
+    if {[info exists ::debugLevel] && ($::debugLevel > 1) && ($debug == 0)} {
+	set debug 2
+    }
+        
+    variable version 0.1
+        
+    # Common xml namespaces.
+    variable xmlns
+    array set xmlns {
+	disco   "http://jabber.org/protocol/disco"
+	items   "http://jabber.org/protocol/disco#items"
+	info    "http://jabber.org/protocol/disco#info"
+	muc     "http://jabber.org/protocol/muc"
+    }
+    
+    # Components register their feature elements for disco/info.
+    variable features [list]
+
+    # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::disco::init --
+# 
+#       Creates a new instance of the disco object.
+#       
+# Arguments:
+#       jlibname:     name of existing jabberlib instance
+#       args:
+# 
+# Results:
+#       namespaced instance command
+
+proc jlib::disco::init {jlibname args} {
+    
+    variable xmlns
+        
+    # Instance specific arrays.
+    namespace eval ${jlibname}::disco {
+	variable items
+	variable info
+	variable rooms
+	variable handler
+	variable state
+	variable identities [list]
+    }
+    upvar ${jlibname}::disco::items items
+    upvar ${jlibname}::disco::info  info
+    upvar ${jlibname}::disco::rooms rooms
+    
+    # Register service.
+    $jlibname service register disco disco
+    
+    # Register some standard iq handlers that is handled internally.
+    $jlibname iq_register get $xmlns(items)  \
+      [list [namespace current]::handle_get items]
+    $jlibname iq_register get $xmlns(info)   \
+      [list [namespace current]::handle_get info]
+
+    # Clear any cache info we may have collected since likely invalid offline.
+    $jlibname presence_register_int unavailable [namespace current]::unavail_cb
+
+    # Register our own features.
+    registerfeature $xmlns(disco)
+    registerfeature $xmlns(items)
+    registerfeature $xmlns(info)
+    
+    set info(conferences) [list]
+    
+    return
+}
+
+# jlib::disco::cmdproc --
+#
+#       Just dispatches the command to the right procedure.
+#
+# Arguments:
+#       jlibname:   name of existing jabberlib instance
+#       cmd:        
+#       args:       all args to the cmd procedure.
+#       
+# Results:
+#       none.
+
+proc jlib::disco::cmdproc {jlibname cmd args} {
+    
+    # Which command? Just dispatch the command to the right procedure.
+    return [eval {$cmd $jlibname} $args]
+}
+
+# jlib::disco::registerfeature --
+# 
+# @@@ Make instance specific instead!
+# 
+#       Components register their feature elements for disco#info.
+#       Clients must handle this using the disco handler.
+#       NB1: This is only for 'basic' features not associated with a caps ext
+#            token. Those are handled by jlib::caps::register.
+#       NB2: We consider everything inside jlib to be 'basic' but also client
+#            level features can be basic.
+#       NB3: Features registered here MUST NEVER change within a certain version.
+
+proc jlib::disco::registerfeature {feature} { 
+    variable features
+  
+    lappend features $feature
+    set features [lsort -unique $features]
+}
+
+proc jlib::disco::getregisteredfeatures {} {
+    variable features
+
+    return $features
+}
+
+# jlib::disco::registeridentity --
+#
+#       <identity category='client' type='pc' name='Coccinella'/> 
+#       as 'category type ?name?'
+
+proc jlib::disco::registeridentity {jlibname category type {name ""}} {
+    upvar ${jlibname}::identities identities
+
+    lappend identities [list $category $type $name]
+}
+
+proc jlib::disco::getidentities {jlibname} {
+    upvar ${jlibname}::identities identities
+ 
+    return $identities
+}
+
+# jlib::disco::registerhandler --
+# 
+#       Register handler to deliver incoming disco queries.
+
+proc jlib::disco::registerhandler {jlibname cmdProc} {
+    
+    upvar ${jlibname}::disco::handler handler
+    
+    set handler $cmdProc
+}
+
+# jlib::disco::send_get --
+#
+#       Sends a get request within the disco namespace.
+#
+# Arguments:
+#       jlibname:   name of existing jabberlib instance
+#       type:       items|info
+#       jid:        to jid
+#       cmd:        callback tcl proc        
+#       args:       -node chdata
+#       
+# Results:
+#       none.
+
+proc jlib::disco::send_get {jlibname type jid cmd args} {
+    
+    variable xmlns
+    upvar ${jlibname}::disco::state state
+    
+    set jid [jlib::jidmap $jid]
+    set node ""
+    set opts [list]
+    if {[set idx [lsearch -exact $args -node]] >= 0} {
+	set node [lindex $args [incr idx]]
+	set opts [list -node $node]
+    }
+    set state(pending,$type,$jid,$node) 1
+    
+    eval {$jlibname iq_get $xmlns($type) -to $jid  \
+      -command [list [namespace current]::send_get_cb $type $jid $cmd]} $opts
+}
+
+# jlib::disco::get_async --
+# 
+#       Do disco async using 'cmd' callback. 
+#       If cached it is returned directly using 'cmd', if pending the cmd
+#       is invoked when getting result, else we do a send_get.
+
+proc jlib::disco::get_async {jlibname type jid cmd args} {
+
+    upvar ${jlibname}::disco::items items
+    upvar ${jlibname}::disco::info  info
+    upvar ${jlibname}::disco::state state
+
+    set jid [jlib::jidmap $jid]
+    set node ""
+    set opts [list]
+    if {[set idx [lsearch -exact $args -node]] >= 0} {
+	set node [lindex $args [incr idx]]
+	set opts [list -node $node]
+    }
+    set var ${type}($jid,$node,xml)
+    if {[info exists $var]} {
+	set xml [set $var]
+	set etype [wrapper::getattribute $xml type]
+
+	# Errors are reported specially!
+	# @@@ BAD!!!
+	if {$etype eq "error"} {
+	    set xml [lindex [wrapper::getchildren $xml] 0]
+	}
+	uplevel #0 $cmd [list $jlibname $etype $jid $xml]
+    } elseif {[info exists state(pending,$type,$jid,$node)]} {
+	lappend state(invoke,$type,$jid,$node) $cmd
+    } else {
+	eval {send_get $jlibname $type $jid $cmd} $opts
+    }
+    return
+}
+
+# jlib::disco::send_get_cb --
+# 
+#       Fills in the internal state arrays, and invokes any callback.
+
+proc jlib::disco::send_get_cb {ditype from cmd jlibname type queryE args} {
+    
+    upvar ${jlibname}::disco::items items
+    upvar ${jlibname}::disco::info  info
+    upvar ${jlibname}::disco::state state
+    
+    # We need to use both jid and any node for addressing since
+    # each item may have identical jid's but different node's.
+
+    # Do STRINGPREP.
+    set from [jlib::jidmap $from]
+    set node [wrapper::getattribute $queryE "node"]
+
+    unset -nocomplain state(pending,$ditype,$from,$node)
+    
+    if {[string equal $type "error"]} {
+
+	# Cache xml for later retrieval.
+	set var ${ditype}($from,$node,xml)
+	set $var [eval {getfulliq $type $queryE} $args]
+    } else {
+	switch -- $ditype {
+	    items {
+		parse_get_items $jlibname $from $queryE
+	    }
+	    info {
+		parse_get_info $jlibname $from $queryE
+	    }
+	}
+    }
+    invoke_stacked $jlibname $ditype $type $from $queryE
+    
+    # Invoke callback for this get.
+    uplevel #0 $cmd [list $jlibname $type $from $queryE] $args
+}
+
+proc jlib::disco::invoke_stacked {jlibname ditype type jid queryE} {
+    
+    upvar ${jlibname}::disco::state state
+    
+    set node [wrapper::getattribute $queryE "node"]
+    if {[info exists state(invoke,$ditype,$jid,$node)]} {
+	foreach cmd $state(invoke,$ditype,$jid,$node) {
+	    uplevel #0 $cmd [list $jlibname $type $jid $queryE]
+	}
+	unset -nocomplain state(invoke,$ditype,$jid,$node)
+    }
+}
+
+proc jlib::disco::getfulliq {type queryE args} {
+    
+    # Errors are reported specially!
+    # @@@ BAD!!!
+    # If error queryE is just a two element list {errtag text}
+    set attr [list type $type]
+    foreach {key value} $args {
+	lappend attr [string trimleft $key "-"] $value
+    }
+    return [wrapper::createtag iq -attrlist $attr -subtags [list $queryE]]
+}
+
+# jlib::disco::parse_get_items --
+# 
+#       Fills the internal records with this disco items query result.
+#       There are four parent-childs combinations:
+#       
+#         (0)   JID1
+#                   JID         JID1 != JID
+#               
+#         (1)   JID1
+#                   JID1+node   JID equal
+#               
+#         (2)   JID1+node1
+#                   JID         JID1 != JID
+#               
+#         (3)   JID1+node1
+#                   JID+node    JID1 != JID
+#        
+#        Typical xml:
+#        <iq type='result' ...>
+#             <query xmlns='http://jabber.org/protocol/disco#items' 
+#                    node='music'>
+#                 <item jid='catalog.shakespeare.lit'
+#                       node='music/A'/> 
+#                 ...
+#
+#   Any of the following scenarios is perfectly acceptable: 
+#
+#   (0) Upon querying an entity (JID1) for items, one receives a list of items 
+#       that can be addressed as JIDs; each associated item has its own JID, 
+#       but no such JID equals JID1. 
+#
+#   (1) Upon querying an entity (JID1) for items, one receives a list of items 
+#       that cannot be addressed as JIDs; each associated item has its own 
+#       JID+node, where each JID equals JID1 and each NodeID is unique. 
+#
+#   (2) Upon querying an entity (JID1+NodeID1) for items, one receives a list 
+#       of items that can be addressed as JIDs; each associated item has its 
+#       own JID, but no such JID equals JID1. 
+#
+#   (3) Upon querying an entity (JID1+NodeID1) for items, one receives a list 
+#       of items that cannot be addressed as JIDs; each associated item has 
+#       its own JID+node, but no such JID equals JID1 and each NodeID is
+#       unique in the context of the associated JID. 
+#       
+#   In addition, the results MAY also be mixed, so that a query to a JID or a 
+#   JID+node could yield both (1) items that are addressed as JIDs and (2) 
+#   items that are addressed as JID+node combinations. 
+
+proc jlib::disco::parse_get_items {jlibname from queryE} {
+
+    upvar ${jlibname}::disco::items items
+    upvar ${jlibname}::disco::info  info
+    upvar ${jlibname}::disco::rooms rooms
+
+    # Parents node if any.
+    set pnode [wrapper::getattribute $queryE "node"]
+    set pitem [list $from $pnode]
+    
+    set items($from,$pnode,xml) [getfulliq result $queryE -from $from]
+    unset -nocomplain items($from,$pnode,children) items($from,$pnode,nodes)
+    unset -nocomplain items($from,$pnode,childs)
+    
+    # This is perhaps not a robust way.
+    if {0} {
+	if {![info exists items($from,parent)]} {
+	    set items($from,parent)  [list]
+	    set items($from,parents) [list]
+	}
+	if {![info exists items($from,$pnode,parent2)]} {
+	    set items($from,$pnode,parent2)  [list]
+	    set items($from,$pnode,parents2) [list]
+	}
+    }
+    if {![info exists items($from,$pnode,paL)]} {
+	set items($from,$pnode,paL)  [list]
+    }
+    
+    # Cache children of category='conference' as rooms.
+    if {[lsearch -exact $info(conferences) $from] >= 0} {
+	set isrooms 1
+    } else {
+	set isrooms 0
+    }
+    
+    foreach c [wrapper::getchildren $queryE] {
+	if {![string equal [wrapper::gettag $c] "item"]} {
+	    continue
+	}
+	unset -nocomplain attr
+	array set attr [wrapper::getattrlist $c]
+	
+	# jid is a required attribute!
+	set jid [jlib::jidmap $attr(jid)]
+	set node ""
+	
+	# Children--->
+	# Only 'childs' gives the full picture.
+	if {$jid ne $from} {
+	    lappend items($from,$pnode,children) $jid
+	}
+	if {[info exists attr(node)]} {
+	    
+	    # Not two nodes of a jid may be identical. Beware for infinite loops!
+	    # We only do some rudimentary check.
+	    set node $attr(node)
+	    if {[string equal $pnode $node]} {
+		continue
+	    }
+	    lappend items($from,$pnode,nodes) $node	    
+	}
+	lappend items($from,$pnode,childs) [list $jid $node]
+	
+	# Parents--->
+	
+	# Keep list of parents since not unique.
+	lappend items($jid,$node,paL) $pitem
+		
+	# Cache the optional attributes.
+	# Any {jid node} must have identical attributes and childrens.
+	foreach key {name action} {
+	    if {[info exists attr($key)]} {
+		set items($jid,$node,$key) $attr($key)
+	    }
+	}
+	if {$isrooms} {
+	    set rooms($jid,$node) 1
+	}
+    }	
+}
+
+# jlib::disco::parse_get_info --
+# 
+#       Fills the internal records with this disco info query result.
+
+proc jlib::disco::parse_get_info {jlibname from queryE} {
+    variable xmlns
+
+    upvar ${jlibname}::disco::items items
+    upvar ${jlibname}::disco::info  info
+    upvar ${jlibname}::disco::rooms rooms
+
+    set node [wrapper::getattribute $queryE "node"]
+
+    array unset info [jlib::ESC $from],[jlib::ESC $node],*
+    set info($from,$node,xml) [getfulliq result $queryE -from $from]
+    set isconference 0
+    
+    foreach c [wrapper::getchildren $queryE] {
+	unset -nocomplain attr
+	array set attr [wrapper::getattrlist $c]
+	
+	# There can be one or many of each 'identity' and 'feature'.
+	switch -- [wrapper::gettag $c] {
+	    identity {
+		
+		# Each <identity/> element MUST possess 'category' and 
+		# 'type' attributes. (category/type)
+		# Each identity element SHOULD have the same name value.
+		# 
+		# XEP 0030:
+		# If the hierarchy category is used, every node in the 
+		# hierarchy MUST be identified as either a branch or a leaf; 
+		# however, since a node MAY have multiple identities, any given 
+		# node MAY also possess an identity other than 
+		# "hierarchy/branch" or "hierarchy/leaf". 
+
+		# Protect for entities which don't follow the rules.
+		if {![info exists attr(category)] || ![info exists attr(type)]} {
+		    continue
+		}
+		set category [string tolower $attr(category)]
+		set ctype    [string tolower $attr(type)]
+		set name     ""
+		if {[info exists attr(name)]} {
+		    set name $attr(name)
+		}			
+		set info($from,$node,name) $name
+		set cattype $category/$ctype
+		lappend info($from,$node,cattypes) $cattype
+		lappend info($cattype,typelist) $from
+		set info($cattype,typelist) \
+		  [lsort -unique $info($cattype,typelist)]
+		
+		if {![string match *@* $from]} {
+		    
+		    switch -- $category {
+			conference {
+			    lappend info(conferences) $from
+			    set isconference 1
+			}
+		    }
+		}
+	    }
+	    feature {
+		set feature $attr(var)
+		lappend info($from,$node,features) $feature
+		lappend info($feature,featurelist) $from
+		
+		# Register any groupchat protocol with jlib.
+		# Note that each room also returns gc features; skip!
+		if {![string match *@* $from]} {
+		    
+		    switch -- $feature {
+			"http://jabber.org/protocol/muc" {
+			    $jlibname service registergcprotocol $from "muc"
+			}
+			"gc-1.0" {
+			    $jlibname service registergcprotocol $from "gc-1.0"
+			}
+		    }
+		}
+	    }
+	}
+    }
+    
+    # If this is a conference be sure to cache any children as rooms.
+    if {$isconference && [info exists items($from,,children)]} {
+	foreach c $items($from,,children) {
+	    set rooms($c,) 1
+	}
+    }
+}
+
+proc jlib::disco::isdiscoed {jlibname discotype jid {node ""}} {
+    
+    upvar ${jlibname}::disco::items items
+    upvar ${jlibname}::disco::info  info
+    
+    set jid [jlib::jidmap $jid]
+
+    switch -- $discotype {
+	items {
+	    return [info exists items($jid,$node,xml)]
+	}
+	info {
+	    return [info exists info($jid,$node,xml)]
+	}
+    }
+}
+
+proc jlib::disco::getxml {jlibname discotype jid {node ""}} {
+    return [get $jlibname $discotype xml $jid $node]
+}
+
+proc jlib::disco::get {jlibname discotype key jid {node ""}} {
+    
+    upvar ${jlibname}::disco::items items
+    upvar ${jlibname}::disco::info  info
+    
+    set jid [jlib::jidmap $jid]
+ 
+    switch -- $discotype {
+	items {
+	    if {[info exists items($jid,$node,$key)]} {
+		return $items($jid,$node,$key)
+	    }
+	}
+	info {
+	    if {[info exists info($jid,$node,$key)]} {
+		return $info($jid,$node,$key)
+	    }
+	}
+    }
+    return
+}
+
+# Both the items and the info elements may have name attributes! Related???
+
+#       The login servers jid name attribute is not returned via any items
+#       element; only via info/identity element. 
+#       
+
+proc jlib::disco::name {jlibname jid {node ""}} {
+    
+    upvar ${jlibname}::disco::items items
+    upvar ${jlibname}::disco::info  info
+    
+    set jid [jlib::jidmap $jid]
+    if {[info exists items($jid,$node,name)]} {
+	return $items($jid,$node,name)
+    } elseif {[info exists info($jid,$node,name)]} {
+	return $info($jid,$node,name)
+    } else {
+	return
+    }
+}
+
+# jlib::disco::features --
+# 
+#       Returns the var attributes of all feature elements for this jid/node.
+
+proc jlib::disco::features {jlibname jid {node ""}} {
+    
+    upvar ${jlibname}::disco::info info
+    
+    set jid [jlib::jidmap $jid]
+    if {[info exists info($jid,$node,features)]} {
+	return $info($jid,$node,features)
+    } else {
+	return
+    }
+}
+
+# jlib::disco::hasfeature --
+# 
+#       Returns 1 if the jid/node has the specified feature var.
+
+proc jlib::disco::hasfeature {jlibname feature jid {node ""}} {
+    
+    upvar ${jlibname}::disco::info info
+
+    set jid [jlib::jidmap $jid]
+    if {[info exists info($jid,$node,features)]} {
+	set features $info($jid,$node,features)
+	return [expr [lsearch -exact $features $feature] < 0 ? 0 : 1]
+    } else {
+	return 0
+    }
+}
+
+# jlib::disco::types --
+# 
+#       Returns a list of all category/types of this jid/node.
+
+proc jlib::disco::types {jlibname jid {node ""}} {
+    
+    upvar ${jlibname}::disco::info info
+    
+    set jid [jlib::jidmap $jid]
+    if {[info exists info($jid,$node,cattypes)]} {
+	return $info($jid,$node,cattypes)
+    } else {
+	return
+    }
+}
+
+# jlib::disco::iscategorytype --
+# 
+#       Search for any matching feature var glob pattern.
+
+proc jlib::disco::iscategorytype {jlibname cattype jid {node ""}} {
+    
+    upvar ${jlibname}::disco::info info
+    
+    set jid [jlib::jidmap $jid]
+    if {[info exists info($jid,$node,cattypes)]} {
+	set types $info($jid,$node,cattypes)
+	return [expr [lsearch -glob $types $cattype] < 0 ? 0 : 1]
+    } else {
+	return 0
+    }
+}
+
+# jlib::disco::getjidsforfeature --
+# 
+#       Returns a list of all jids that support the specified feature.
+
+proc jlib::disco::getjidsforfeature {jlibname feature} {
+    
+    upvar ${jlibname}::disco::info info
+    
+    if {[info exists info($feature,featurelist)]} {
+	set info($feature,featurelist) [lsort -unique $info($feature,featurelist)]
+	return $info($feature,featurelist)
+    } else {
+	return
+    }
+}
+
+# jlib::disco::getjidsforcategory --
+#
+#       Returns all jids that match the glob pattern category/type.
+#       
+# Arguments:
+#       jlibname:     name of existing jabberlib instance
+#       pattern:      a global pattern of jid type/subtype (gateway/*).
+#
+# Results:
+#       List of jid's matching the type pattern. nodes???
+
+proc jlib::disco::getjidsforcategory {jlibname pattern} {
+    
+    upvar ${jlibname}::disco::info info
+    
+    set jidL [list]   
+    foreach {key jids} [array get info "$pattern,typelist"] {
+	set jidL [concat $jidL $jids]
+    }
+    return $jidL
+}    
+
+# jlib::disco::getallcategories --
+#
+#       Returns all categories that match the glob pattern catpattern.
+#       
+# Arguments:
+#       jlibname:     name of existing jabberlib instance
+#       pattern:      a global pattern of jid type/subtype (gateway/*).
+#
+# Results:
+#       List of types matching the category/type pattern.
+
+proc jlib::disco::getallcategories {jlibname pattern} {    
+    
+    upvar ${jlibname}::disco::info info
+    
+    set cattypes [list]
+    foreach {key jids} [array get info "$pattern,typelist"] {
+	lappend cattypes [string map {,typelist ""} $key]
+    }
+    return [lsort -unique $cattypes]
+}    
+
+proc jlib::disco::getconferences {jlibname} {
+    
+    upvar ${jlibname}::disco::info info
+
+    return [lsort -unique $info(conferences)]
+}
+
+# jlib::disco::isroom --
+# 
+#       Room or not? The problem is that some components, notably some
+#       msn gateways, have multiple categories, gateway and conference. BAD!
+#       We therefore use a specific 'rooms' array.
+
+proc jlib::disco::isroom {jlibname jid} {
+
+    upvar ${jlibname}::disco::rooms rooms
+    
+    if {[info exists rooms($jid,)]} {
+	return 1
+    } else {
+	return 0
+    }
+}
+
+# jlib::disco::children --
+# 
+#       Returns a list of all child jids of this jid.
+
+proc jlib::disco::children {jlibname jid} {
+    
+    upvar ${jlibname}::disco::items items
+
+    set jid [jlib::jidmap $jid]
+    if {[info exists items($jid,,children)]} {
+	return $items($jid,,children)
+    } else {
+	return
+    }
+}
+
+proc jlib::disco::childs {jlibname jid {node ""}} {
+    
+    upvar ${jlibname}::disco::items items
+
+    set jid [jlib::jidmap $jid]
+    if {[info exists items($jid,$node,childs)]} {
+	return $items($jid,$node,childs)
+    } else {
+	return
+    }
+}
+
+# jlib::disco::nodes --
+# 
+#       Returns a list of child nodes of this jid|node.
+
+proc jlib::disco::nodes {jlibname jid {node ""}} {
+    
+    upvar ${jlibname}::disco::items items
+
+    set jid [jlib::jidmap $jid]
+    if {[info exists items($jid,$node,nodes)]} {
+	return $items($jid,$node,nodes)
+    } else {
+	return
+    }
+}
+
+proc jlib::disco::handle_get {discotype jlibname from queryE args} {
+    
+    upvar ${jlibname}::disco::handler handler
+
+    set ishandled 0
+    if {[info exists handler]} {
+	set ishandled [uplevel #0 $handler  \
+	  [list $jlibname $discotype $from $queryE] $args]
+    }
+    return $ishandled
+}
+
+# jlib::disco::unavail_cb --
+# 
+#       Registered unavailable presence callback.
+#       Frees internal cache related to this jid.
+
+proc jlib::disco::unavail_cb {jlibname xmldata} {
+
+    # This screws up gateway handling completely since a gateway is still
+    # a gateway even if unavailable!
+    # @@@ Perhaps we shall make a distinction here between ordinary users
+    # and services?
+    #set jid [wrapper::getattribute $xmldata from]
+    #reset $jlibname $jid
+}
+
+# jlib::disco::reset --
+# 
+#       Clear this particular jid and all its children.
+
+proc jlib::disco::reset {jlibname {jid ""} {node ""}} {
+
+    upvar ${jlibname}::disco::items items
+    upvar ${jlibname}::disco::info  info
+    upvar ${jlibname}::disco::rooms rooms
+
+    if {($jid eq "") && ($node eq "")} {
+	array unset items
+	array unset info
+	array unset rooms
+
+	set info(conferences) [list]
+    } else {
+	set jid [jlib::jidmap $jid]	
+	
+	# Can be problems with this (ICQ) ???
+	if {[info exists items($jid,,children)]} {
+	    foreach child $items($jid,,children) {
+		ResetJid $jlibname $child
+	    }
+	}
+	ResetJid $jlibname $jid
+    }
+}
+
+# jlib::disco::ResetJid --
+# 
+#       Clear only this particular jid.
+
+proc jlib::disco::ResetJid {jlibname jid} {
+    
+    upvar ${jlibname}::disco::items items
+    upvar ${jlibname}::disco::info  info
+    upvar ${jlibname}::disco::rooms rooms
+
+    if {$jid eq ""} {
+	unset -nocomplain items info rooms
+	set info(conferences) [list]
+    } else {
+	
+	if {0} {
+	    
+	# Keep parents!
+
+	if {[info exists items($jid,parent)]} {
+	    set parent $items($jid,parent)
+	}
+	if {[info exists items($jid,parents)]} {
+	    set parents $items($jid,parents)
+	}
+	
+	if {[info exists items($jid,,parent2)]} {
+	    set parent2 $items($jid,,parent2)
+	}
+	if {[info exists items($jid,,parents2)]} {
+	    set parents2 $items($jid,,parents2)
+	}
+	
+	}
+
+	array unset items [jlib::ESC $jid],*
+	array unset info  [jlib::ESC $jid],*
+	array unset rooms [jlib::ESC $jid],*
+	
+	if {0} {
+	    
+	# Add back parent(s).
+	if {[info exists parent]} {
+	    set items($jid,parent) $parent
+	}
+	if {[info exists parents]} {
+	    set items($jid,parents) $parents
+	}
+
+	if {[info exists parent2]} {
+	    set items($jid,,parent2) $parent2
+	}
+	if {[info exists parents2]} {
+	    set items($jid,,parents2) $parents2
+	}
+
+	}
+	
+	# Rest.
+	foreach {key value} [array get info "*,typelist"] {
+	    set info($key) [lsearch -all -not -inline -exact $value $jid]
+	}
+	foreach {key value} [array get info "*,featurelist"] {
+	    set info($key) [lsearch -all -not -inline -exact $value $jid]
+	}
+    }
+}
+
+proc jlib::disco::Debug {num str} {
+    variable debug
+    if {$num <= $debug} {
+	puts $str
+    }
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::disco {
+    
+    jlib::ensamble_register disco  \
+      [namespace current]::init    \
+      [namespace current]::cmdproc
+}
+
+#-------------------------------------------------------------------------------
diff --git a/lib/jabberlib/ftrans.tcl b/lib/jabberlib/ftrans.tcl
new file mode 100644
index 0000000..d1a4ee0
--- /dev/null
+++ b/lib/jabberlib/ftrans.tcl
@@ -0,0 +1,728 @@
+#  ftrans.tcl --
+#  
+#      This file is part of the jabberlib. 
+#      It provides support for the file-transfer profile (XEP-0096).
+#      
+#  Copyright (c) 2005-2007  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: ftrans.tcl,v 1.31 2008/02/10 09:43:22 matben Exp $
+# 
+############################# USAGE ############################################
+#
+#   NAME
+#      filetransfer - convenience library for the file-transfer profile of si.
+#      
+#   SYNOPSIS
+#
+#
+#   OPTIONS
+#
+#	
+#   INSTANCE COMMANDS
+#      jlibName filetransfer send jid tclProc  \
+#                 -progress, -description, -date, -hash, -block-size, -mime
+#      jlibName filetransfer reset sid
+#      jlibName filetransfer ifree sid
+#      
+############################# CHANGES ##########################################
+
+package require jlib		
+package require jlib::si
+package require jlib::disco
+			  
+package provide jlib::ftrans 0.1
+
+namespace eval jlib::ftrans {
+
+    variable xmlns
+    set xmlns(ftrans) "http://jabber.org/protocol/si/profile/file-transfer"
+            
+    # Our target handlers.
+    jlib::si::registerprofile $xmlns(ftrans)  \
+      [namespace current]::open_handler       \
+      [namespace current]::recv               \
+      [namespace current]::close_handler
+    	
+    # This is our reader commands when the transport sends off data
+    # on the network.
+    jlib::si::registerreader $xmlns(ftrans)  \
+      [namespace current]::open_data         \
+      [namespace current]::read_data         \
+      [namespace current]::close_data
+    
+    jlib::disco::registerfeature $xmlns(ftrans)
+
+    # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::ftrans::registerhandler --
+# 
+#       An application using file-transfer must register here to get a call
+#       when we receive a file-transfer query.
+
+proc jlib::ftrans::registerhandler {clientProc} {
+    variable handler
+    set handler $clientProc
+}
+
+proc jlib::ftrans::init {jlibname args} {
+    
+    # Keep different state arrays for initiator (i) and receiver (r).
+    namespace eval ${jlibname}::ftrans {
+	variable istate
+	variable tstate
+    }
+    
+    # Register this feature with disco.
+}
+
+# jlib::ftrans::cmdproc --
+#
+#       Just dispatches the command to the right procedure.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       cmd:        
+#       args:       all args to the cmd procedure.
+#       
+# Results:
+#       none.
+
+proc jlib::ftrans::cmdproc {jlibname cmd args} {
+    return [eval {$cmd $jlibname} $args]
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#
+# These are all functions used by the initiator (sender).
+
+# jlib::ftrans::send --
+# 
+#       High level interface to the file-transfer profile for si.
+#       
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:
+#       args:       
+#       
+# Results:
+#       sid to identify this transaction.
+
+proc jlib::ftrans::send {jlibname jid cmd args} {
+    variable xmlns
+    upvar ${jlibname}::ftrans::istate istate
+    #puts "jlib::ftrans::send $args"
+
+    set sid [jlib::util::from args -sid [jlib::generateuuid]]
+    set fileE [eval {i_constructor $jlibname $sid $jid $cmd} $args]
+
+    # The 'block-size' is crucial here; must tell the stream in question.
+    set cmd [namespace current]::open_cb
+    jlib::si::send_set $jlibname $jid $sid $istate($sid,-mime) $xmlns(ftrans) \
+      $fileE $cmd -block-size $istate($sid,-block-size)
+    
+    return $sid
+}
+
+# jlib::ftrans::i_constructor --
+# 
+#       This is the initiator constructor of a file transfer object.
+#       Makes a new ftrans instance but doesn't do any networking.
+#       
+# Results:
+#       The file element.
+
+proc jlib::ftrans::i_constructor {jlibname sid jid cmd args} {
+    variable xmlns
+    upvar ${jlibname}::ftrans::istate istate
+    
+    # 4096 is the recommended block-size
+    array set opts {
+	-progress     ""
+	-block-size   4096 
+	-mime         application/octet-stream
+    }
+    array set opts $args
+    if {![info exists opts(-data)]   \
+      && ![info exists opts(-file)]  \
+      && ![info exists opts(-base64)]} {
+	return -code error "must have any of -data, -file, or -base64"
+    }
+    #puts "jlib::ftrans::i_constructor (i) $args"
+    
+    # @@@ TODO
+    if {![info exists opts(-file)]} {return -code error "todo"}    
+    
+    switch -- [info exists opts(-base64)],[info exists opts(-data)],[info exists opts(-file)] {
+	1,0,0 {
+	    set dtype base64
+	    set size [string length $opts(-base64)]
+	}
+	0,1,0 {
+	    set dtype data
+	    set size [string length $opts(-data)]
+	}
+	0,0,1 {
+	    set dtype file
+	    set fileName $opts(-file)
+	    if {![file readable $fileName]} {
+		return -code error "file \"$fileName\" is not readable"
+	    }
+	    
+	    # File open is not done until we get the 'open_cb'.
+	    set size [file size $fileName]
+	    set name [file tail $fileName]
+	}
+	default {
+	    return -code error "must have exactly one of -data, -file, or -base64"
+	}
+    }
+    set istate($sid,sid)    $sid
+    set istate($sid,jid)    $jid
+    set istate($sid,cmd)    $cmd
+    set istate($sid,dtype)  $dtype
+    set istate($sid,size)   $size
+    set istate($sid,status) ""
+    set istate($sid,bytes)  0
+    foreach {key value} [array get opts] {
+	set istate($sid,$key) $value
+    }
+    switch -- $dtype {
+	file {
+	    set istate($sid,name)     $name
+	    set istate($sid,fileName) $fileName
+	}
+    }
+    
+    return [eval {element $name $size} $args]
+}
+
+# jlib::ftrans::uri --
+# 
+#       Create a sipub uri that references a local file.
+#       XEP-0096 File Transfer, sect. 6.2.2 recvfile:
+#       xmpp:romeo@montague.net/orchard?recvfile;sid=pub234;mime-type=text%2Fplain&name=reply.txt&size=2048 
+
+proc jlib::ftrans::uri {jid fileName mime} {
+   
+    # NB: The JID must be uri encoded as a path to preserver the "/"
+    #     while the query part must be encoded as is.
+    set spid [jlib::sipub::newcache $fileName $mime]
+    set tail [file tail $fileName]
+    set size [file size $fileName]
+    set jid [uriencode::quotepath $jid]
+    set uri "xmpp:$jid?recvfile"
+    set uri2 ""
+    append uri2 ";" "sid=$spid"
+    append uri2 ";" "mime-type=$mime"
+    append uri2 ";" "name=$tail"
+    append uri2 ";" "size=$size"
+    set uri2 [::uri::urn::quote $uri2]
+    
+    return $uri$uri2
+}
+
+# jlib::ftrans::element --
+# 
+#       Just create the file element. Nothing cached. Stateless.
+#       
+#       <file xmlns='http://jabber.org/protocol/si/profile/file-transfer'
+#           name='NDA.pdf'
+#           size='138819'
+#           date='2004-01-28T10:07Z'>
+#         <desc>All Shakespearean characters must sign and return this NDA ASAP</desc>
+#       </file> 
+#       
+# Arguments:
+#       name
+#       size
+#       args: -description -date -hash
+#       
+# Result:
+#       The file element.
+
+proc jlib::ftrans::element {name size args} {
+    variable xmlns
+    
+    array set argsA $args
+    
+    set subEL [list]
+    if {[info exists argsA(-description)]} {
+	set descE [wrapper::createtag "desc" -chdata $argsA(-description)]
+	set subEL [list $descE]
+    }
+    set attrs [list xmlns $xmlns(ftrans) name $name size $size]
+    if {[info exists argsA(-date)]} {
+	lappend attrs date $argsA(-date)
+    }
+    if {[info exists argsA(-hash)]} {
+	lappend attrs hash $argsA(-hash)
+    }    
+    set fileE [wrapper::createtag "file" -attrlist $attrs -subtags $subEL]
+    
+    return $fileE
+}
+
+# jlib::ftrans::sipub_element --
+# 
+#       This creates a new sipub instance. Typically only used for normal
+#       messages. For groupchats, pubsub etc. you must not use this one.
+
+proc jlib::ftrans::sipub_element {jlibname name size fileName mime args} {
+    variable xmlns
+    
+    set fileE [element $name $size]
+    set sipubE [jlib::sipub::element [$jlibname myjid] $xmlns(ftrans) \
+      $fileE $fileName $mime]
+
+    return $sipubE
+}
+
+# jlib::ftrans::open_cb --
+# 
+#       This is a transports way of reporting result from it's 'open' method.
+
+proc jlib::ftrans::open_cb {jlibname type sid subiq} {
+    variable xmlns
+    upvar ${jlibname}::ftrans::istate istate
+    
+    #puts "jlib::ftrans::open_cb (i)"
+        
+    if {[string equal $type "error"]} {
+	set istate($sid,status) "error"
+	uplevel #0 $istate($sid,cmd) [list $jlibname error $sid $subiq]
+	ifree $jlibname $sid
+    }
+}
+
+# jlib::ftrans::open_data, read_data, close_data --
+# 
+#       These are all used by the streams (transports) to handle the data
+#       stream it needs when transmitting.
+
+proc jlib::ftrans::open_data {jlibname sid} {
+    upvar ${jlibname}::ftrans::istate istate
+    #puts "jlib::ftrans::open_data (i) sid=$sid"
+    
+    # @@@ assuming -file type
+    # This must never fail since tested if 'readable' before.
+    set fd [open $istate($sid,fileName) r]
+    fconfigure $fd -translation binary
+    set istate($sid,fd) $fd
+    return
+}
+
+proc jlib::ftrans::read_data {jlibname sid} {    
+    upvar ${jlibname}::ftrans::istate istate
+    #puts "jlib::ftrans::read_data (i) sid=$sid"
+
+    # If we have reached eof we receive empty.
+    set data [read $istate($sid,fd) $istate($sid,-block-size)]
+    set len [string length $data]
+    #puts "\t len=$len"
+    incr istate($sid,bytes) $len
+
+    if {[string length $istate($sid,-progress)]} {
+	uplevel #0 $istate($sid,-progress)  \
+	  [list $jlibname $sid $istate($sid,size) $istate($sid,bytes)]
+    }
+    return $data
+}
+
+# This is called by the stream when either all data have been sent or if
+# there is any network error.
+
+proc jlib::ftrans::close_data {jlibname sid {err ""}} {    
+    upvar ${jlibname}::ftrans::istate istate
+    #puts "jlib::ftrans::close_data (i) sid=$sid, err=$err"
+
+    # Empty -> eof.
+    catch {close $istate($sid,fd)}
+    
+    if {$err eq ""} {
+	set istate($sid,status) "ok"
+    } else {
+	set istate($sid,status) "error"
+	set istate($sid,error) "networkerror"
+    }
+    
+    # Close stream. 
+    # Shall we wait for a result from this query before reporting?
+    set cmd [namespace current]::close_cb
+    jlib::si::send_close $jlibname $sid $cmd
+}
+
+# jlib::ftrans::close_cb --
+# 
+#       This is the callback to 'jlib::si::send_close'.
+#       It is our destructor.
+
+proc jlib::ftrans::close_cb {jlibname type sid subiq} {        
+    upvar ${jlibname}::ftrans::istate istate
+    #puts "jlib::ftrans::close_cb (i)"
+
+    # We may have an error status.
+    set status $istate($sid,status)
+    if {$status eq "error"} {
+	set err $istate($sid,error)
+	uplevel #0 $istate($sid,cmd) [list $jlibname error $sid [list $err ""]]
+    } elseif {$status eq "reset"} {
+	uplevel #0 $istate($sid,cmd) [list $jlibname reset $sid {}]
+    } else {
+	uplevel #0 $istate($sid,cmd) [list $jlibname $type $sid $subiq]
+    }
+    
+    # There could be situations, a transfer manager, where we want to keep
+    # this information.
+    ifree $jlibname $sid
+}
+
+# jlib::ftrans::ireset --
+# 
+#       Reset an initiated transaction.
+
+proc jlib::ftrans::ireset {jlibname sid} {
+    upvar ${jlibname}::ftrans::istate istate
+    
+    if {[info exists istate($sid,aid)]} {
+	after cancel $istate($sid,aid)
+    }
+    set istate($sid,status) "reset"
+    set cmd [namespace current]::close_cb
+    jlib::si::send_close $jlibname $sid $cmd
+}
+
+proc jlib::ftrans::iresetall {jlibname} {
+    
+    foreach spec [initiatorinfo $jlibname] {
+	set sid [lindex $spec 0]
+	ireset $jlibname $sid
+    }
+}
+
+# jlib::ftrans::initiatorinfo --
+# 
+#       Returns current open transfers we have initiated.
+
+proc jlib::ftrans::initiatorinfo {jlibname} {   
+    upvar ${jlibname}::ftrans::istate istate
+
+    set iList [list]
+    foreach skey [array names istate *,sid] {
+	set sid $istate($skey)
+	set opts $sid
+	foreach {key value} [array get istate $sid,*] {
+	    set name [string map [list $sid, ""] $key]
+	    lappend opts $name $value
+	}
+	lappend iList $opts
+    }
+    return $iList
+}
+
+proc jlib::ftrans::getinitiatorstate {jlibname sid} {    
+    upvar ${jlibname}::ftrans::istate istate
+    
+    set opts [list]
+    foreach {key value} [array get istate $sid,*] {
+	set name [string map [list $sid, ""] $key]
+	lappend opts $name $value
+    }
+    return $opts
+}
+
+proc jlib::ftrans::ifree {jlibname sid} {
+    upvar ${jlibname}::ftrans::istate istate
+    #puts "jlib::ftrans::ifree (i) sid=$sid"
+
+    array unset istate $sid,*    
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#
+# These are all functions to use by a target (receiver) of a stream.
+
+# jlib::ftrans::open_handler --
+# 
+#       Callback when si receives this specific profile (file-transfer).
+#       It is called as an iq-set/si handler.
+#       
+#       There are two ways this can work:
+#       1) Using the global handler registered by 'registerhandler'
+#       2) Or the for a specific sid, 'register_sid_handler', which is typically
+#          used for sipub.
+
+proc jlib::ftrans::open_handler {jlibname sid jid siE respCmd args} {    
+    variable handler
+    variable xmlns
+    upvar ${jlibname}::ftrans::tstate tstate
+    upvar ${jlibname}::ftrans::sid_handler sid_handler
+    #puts "jlib::ftrans::open_handler (t)"
+    
+    if {![info exists handler]} {
+	return -code break
+    }
+    eval {t_constructor $jlibname $sid $jid $siE} $args
+    
+    set tstate($sid,cmd) $respCmd
+    
+    set opts [list]
+    foreach key {mime desc hash date} {
+	if {[string length $tstate($sid,$key)]} {
+	    lappend opts -$key $tstate($sid,$key)
+	}
+    }
+    lappend opts -queryE $siE
+    
+    # Make a call up to application level to pick destination file.
+    # This is an idle call in order not to block.
+    set cb [list [namespace current]::accept $jlibname $sid]
+    
+    # For sipub we have a registered handler for this sid.
+    if {[info exists sid_handler($sid)]} {
+	set cmd $sid_handler($sid)
+	unset sid_handler($sid)
+    } else {
+	set cmd $handler
+    }
+    after idle [list eval $cmd \
+      [list $jlibname $jid $tstate($sid,name) $tstate($sid,size) $cb] $opts]
+
+    return
+}
+
+proc jlib::ftrans::t_constructor {jlibname sid jid siE args} {    
+    variable handler
+    variable xmlns
+    upvar ${jlibname}::ftrans::tstate tstate
+    #puts "jlib::ftrans::t_constructor (t)"
+
+    array set opts {
+	-channel    ""
+	-command    ""
+	-progress   ""
+    }
+    array set opts $args
+    set fileE [wrapper::getfirstchild $siE "file" $xmlns(ftrans)]
+    if {![llength $fileE]} {
+	# Exception
+	return
+    }
+    set tstate($sid,sid)  $sid
+    set tstate($sid,jid)  $jid
+    set tstate($sid,mime) [wrapper::getattribute $siE "mime-type"]
+    foreach {key value} [array get opts] {
+	set tstate($sid,$key) $value
+    }
+    if {[string length $opts(-channel)]} {
+	fconfigure $opts(-channel) -translation binary
+    }
+    
+    # File element attributes 'name' and 'size' are required!
+    array set attr {
+	name        ""
+	size        0
+	date        ""
+	hash        ""
+    }
+    array set attr [wrapper::getattrlist $fileE]
+    foreach {name value} [array get attr] {
+	set tstate($sid,$name) $value
+    }
+    set tstate($sid,desc) ""
+    set descE [wrapper::getfirstchildwithtag $fileE "desc"]
+    if {[llength $descE]} {
+	set tstate($sid,desc) [wrapper::getcdata $descE]
+    }
+    set tstate($sid,bytes) 0
+    set tstate($sid,data)  ""
+
+    return
+}
+
+# jlib::ftrans::register_sid_handler --
+# 
+#       Used by sipub to take over from the client handler for this sid.
+
+proc jlib::ftrans::register_sid_handler {jlibname sid cmd} {
+    upvar ${jlibname}::ftrans::sid_handler sid_handler
+    #puts "jlib::ftrans::register_sid_handler (t)"
+    set sid_handler($sid) $cmd
+}
+
+# jlib::ftrans::accept --
+# 
+#       Used by profile handler to accept/reject file transfer.
+#       
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       args:       -channel
+#                   -command
+#                   -progress
+
+proc jlib::ftrans::accept {jlibname sid accepted args} {    
+    upvar ${jlibname}::ftrans::tstate tstate
+    
+    array set opts {
+	-channel    ""
+	-command    ""
+	-progress   ""
+    }
+    array set opts $args
+    foreach {key value} [array get opts] {
+	set tstate($sid,$key) $value
+    }
+    if {$accepted} {
+	set type ok
+	if {[string length $opts(-channel)]} {
+	    fconfigure $opts(-channel) -translation binary
+	    # -buffersize 4096
+	}
+    } else {
+	set type error
+    }
+    set respCmd $tstate($sid,cmd)
+    eval $respCmd [list $type {}]
+    if {!$accepted} {
+	tfree $jlibname $sid
+    }
+}
+
+# jlib::ftrans::recv --
+# 
+#       Registered handler when receiving data. Called indirectly from stream.
+
+proc jlib::ftrans::recv {jlibname sid data} {    
+    upvar ${jlibname}::ftrans::tstate tstate
+    #puts "jlib::ftrans::recv (t)"
+    
+    set len [string length $data]
+    #puts "\t len=$len"
+    incr tstate($sid,bytes) $len
+    if {[string length $tstate($sid,-channel)]} {
+	if {[catch {puts -nonewline $tstate($sid,-channel) $data} err]} {
+	    terror $jlibname $sid $err
+	    return
+	}
+    } else {
+	#puts "\t append"
+	append tstate($sid,data) $data
+    }
+    if {$len && [string length $tstate($sid,-progress)]} {
+	uplevel #0 $tstate($sid,-progress) [list $jlibname $sid  \
+	  $tstate($sid,size) $tstate($sid,bytes)]
+    }   
+}
+
+# jlib::ftrans::close_handler --
+# 
+#       Registered handler when closing the stream.
+#       This is called both for normal close and when an error occured
+#       in the stream to close prematurely.
+
+proc jlib::ftrans::close_handler {jlibname sid {errmsg ""}} {    
+    upvar ${jlibname}::ftrans::tstate tstate
+    #puts "jlib::ftrans::close_handler (t)"
+    
+    # Be sure to close the file before doing the callback, else md5 bail out!
+    if {[string length $tstate($sid,-channel)]} {
+	close $tstate($sid,-channel)
+    }
+    if {[string length $tstate($sid,-command)]} {
+	if {[string length $errmsg]} {
+	    uplevel #0 $tstate($sid,-command) [list $jlibname $sid error $errmsg]	    
+	} else {
+	    uplevel #0 $tstate($sid,-command) [list $jlibname $sid ok]
+	}
+    }
+    tfree $jlibname $sid
+}
+
+proc jlib::ftrans::data {jlibname sid} {    
+    return $tstate($sid,data)
+}
+
+# jlib::ftrans::treset --
+# 
+#       Resets are closes down target side file-transfer during transport.
+
+proc jlib::ftrans::treset {jlibname sid} {
+    upvar ${jlibname}::ftrans::tstate tstate
+    #puts "jlib::ftrans::treset (t)"
+    
+    # Tell transport we are resetting.
+    jlib::si::reset $jlibname $sid
+    
+    set tstate($sid,status) "reset"
+    if {[string length $tstate($sid,-channel)]} {
+	close $tstate($sid,-channel)
+    }
+    if {[string length $tstate($sid,-command)]} {
+	uplevel #0 $tstate($sid,-command) [list $jlibname $sid reset]
+    }
+    tfree $jlibname $sid
+}
+
+# jlib::ftrans::targetinfo --
+# 
+#       Returns current target transfers.
+
+proc jlib::ftrans::targetinfo {jlibname} {    
+    upvar ${jlibname}::ftrans::tstate tstate
+
+    set tList [list]
+    foreach skey [array names tstate *,sid] {
+	set sid $tstate($skey)
+	set opts [list]
+	foreach {key value} [array get tstate $sid,*] {
+	    set name [string map [list $sid, ""] $key]
+	    lappend opts $name $value
+	}
+	lappend tList $opts
+    }
+    return $tList
+}
+
+proc jlib::ftrans::gettargetstate {jlibname sid} {
+    upvar ${jlibname}::ftrans::tstate tstate
+    
+    set opts [list]
+    foreach {key value} [array get tstate $sid,*] {
+	set name [string map [list $sid, ""] $key]
+	lappend opts $name $value
+    }
+    return $opts
+}
+
+proc jlib::ftrans::terror {jlibname sid {errormsg ""}} {
+    upvar ${jlibname}::ftrans::tstate tstate
+    #puts "jlib::ftrans::terror (t) errormsg=$errormsg"
+    
+    if {[string length $tstate($sid,-channel)]} {
+	close $tstate($sid,-channel)
+    }
+    if {[string length $tstate($sid,-command)]} {
+	uplevel #0 $tstate($sid,-command) [list $jlibname $sid error $errormsg]
+    }
+    tfree $jlibname $sid
+}
+
+proc jlib::ftrans::tfree {jlibname sid} {
+    upvar ${jlibname}::ftrans::tstate tstate
+    #puts "jlib::ftrans::tfree (t) sid=$sid"
+
+    array unset tstate $sid,*    
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::ftrans {
+	
+    jlib::ensamble_register filetransfer  \
+      [namespace current]::init           \
+      [namespace current]::cmdproc
+}
+
+#-------------------------------------------------------------------------------
diff --git a/lib/jabberlib/groupchat.tcl b/lib/jabberlib/groupchat.tcl
new file mode 100644
index 0000000..dceff5e
--- /dev/null
+++ b/lib/jabberlib/groupchat.tcl
@@ -0,0 +1,161 @@
+# groupchat.tcl--
+# 
+#       Support for the old gc-1.0 groupchat protocol.
+#       
+#  Copyright (c) 2002-2005  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: groupchat.tcl,v 1.10 2008/02/06 13:57:25 matben Exp $
+# 
+############################# USAGE ############################################
+#
+#   INSTANCE COMMANDS
+#      jlibName groupchat enter room nick
+#      jlibName groupchat exit room
+#      jlibName groupchat mynick room
+#      jlibName groupchat setnick room nick ?-command tclProc?
+#      jlibName groupchat status room
+#      jlibName groupchat participants room
+#      jlibName groupchat allroomsin
+#
+################################################################################
+
+package provide groupchat 1.0
+package provide jlib::groupchat 1.0
+
+namespace eval jlib {}
+
+namespace eval jlib::groupchat {}
+
+# jlib::groupchat --
+#
+#       Provides API's for the old-style groupchat protocol, 'groupchat 1.0'.
+
+proc jlib::groupchat {jlibname cmd args} {
+    return [eval {[namespace current]::groupchat::${cmd} $jlibname} $args]
+}
+
+proc jlib::groupchat::init {jlibname} {
+    upvar ${jlibname}::gchat gchat
+    
+    namespace eval ${jlibname}::groupchat {
+	variable rooms
+    }
+    set gchat(allroomsin) [list]
+}
+
+# jlib::groupchat::enter --
+#
+#       Enter room using the 'gc-1.0' protocol by sending <presence>.
+#
+#       args:  -command callback
+
+proc jlib::groupchat::enter {jlibname room nick args} {
+    upvar ${jlibname}::gchat gchat
+    upvar ${jlibname}::groupchat::rooms rooms
+    
+    set room [jlib::jidmap $room]
+    set jid $room/$nick
+    eval {$jlibname send_presence -to $jid} $args
+    set gchat($room,mynick) $nick
+    
+    # This is not foolproof since it may not always success.
+    lappend gchat(allroomsin) $room
+    set rooms($room) 1
+    $jlibname service setroomprotocol $room "gc-1.0"
+    set gchat(allroomsin) [lsort -unique $gchat(allroomsin)]
+    return
+}
+
+proc jlib::groupchat::exit {jlibname room} {
+    upvar ${jlibname}::gchat gchat
+    
+    set room [jlib::jidmap $room]
+    if {[info exists gchat($room,mynick)]} {
+	set nick $gchat($room,mynick)
+	set jid $room/$nick
+	$jlibname send_presence -to $jid -type "unavailable"
+	unset -nocomplain gchat($room,mynick)
+    }
+    set ind [lsearch -exact $gchat(allroomsin) $room]
+    if {$ind >= 0} {
+	set gchat(allroomsin) [lreplace $gchat(allroomsin) $ind $ind]
+    }
+    $jlibname roster clearpresence "${room}*"
+    return
+}
+
+proc jlib::groupchat::mynick {jlibname room} {
+    upvar ${jlibname}::gchat gchat
+
+    set room [jlib::jidmap $room]
+    return $gchat($room,mynick)
+}
+
+proc jlib::groupchat::setnick {jlibname room nick args} {
+    upvar ${jlibname}::gchat gchat
+    
+    set room [jlib::jidmap $room]
+    set jid $room/$nick
+    eval {$jlibname send_presence -to $jid} $args
+    set gchat($room,mynick) $nick    
+}
+
+proc jlib::groupchat::status {jlibname room args} {
+    upvar ${jlibname}::gchat gchat
+
+    set room [jlib::jidmap $room]
+    if {[info exists gchat($room,mynick)]} {
+	set nick $gchat($room,mynick)
+    } else {
+	return -code error "Unknown nick name for room \"$room\""
+    }
+    set jid ${room}/${nick}
+    eval {$jlibname send_presence -to $jid} $args
+}
+
+proc jlib::groupchat::participants {jlibname room} {
+
+    upvar ${jlibname}::agent agent
+    upvar ${jlibname}::gchat gchat
+
+    set room [jlib::jidmap $room]
+    set isroom 0
+    if {[regexp {^[^@]+@([^@ ]+)$} $room match domain]} {
+	if {[info exists agent($domain,groupchat)]} {
+	    set isroom 1
+	}
+    }    
+    if {!$isroom} {
+	return -code error "Not recognized \"$room\" as a groupchat room"
+    }
+    
+    # The rosters presence elements should give us all info we need.
+    set everyone {}
+    foreach userAttr [$jlibname roster getpresence $room -type available] {
+	unset -nocomplain attrArr
+	array set attrArr $userAttr
+	lappend everyone ${room}/$attrArr(-resource)
+    }
+    return $everyone
+}
+
+proc jlib::groupchat::isroom {jlibname jid} {
+    upvar ${jlibname}::groupchat::rooms rooms
+    
+    if {[info exists rooms($jid)]} {
+	return 1
+    } else {
+	return 0
+    }
+}
+
+proc jlib::groupchat::allroomsin {jlibname} {
+    upvar ${jlibname}::gchat gchat
+
+    set gchat(allroomsin) [lsort -unique $gchat(allroomsin)]
+    return $gchat(allroomsin)
+}
+
+#-------------------------------------------------------------------------------
diff --git a/lib/jabberlib/ibb.tcl b/lib/jabberlib/ibb.tcl
new file mode 100644
index 0000000..0131699
--- /dev/null
+++ b/lib/jabberlib/ibb.tcl
@@ -0,0 +1,491 @@
+#  ibb.tcl --
+#  
+#      This file is part of the jabberlib. 
+#      It provides support for the ibb stuff (In Band Bytestreams).
+#      
+#  Copyright (c) 2005  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: ibb.tcl,v 1.22 2007/11/30 14:38:34 matben Exp $
+# 
+############################# USAGE ############################################
+#
+#   NAME
+#      ibb - convenience command library for the ibb part of XMPP.
+#      
+#   SYNOPSIS
+#      jlib::ibb::init jlibname
+#
+#   OPTIONS
+#   
+#	
+#   INSTANCE COMMANDS
+#      jlibName ib send_set jid command ?-key value?
+#      
+############################# CHANGES ##########################################
+#
+#       0.1         first version
+
+package require jlib
+package require base64     ; # tcllib
+package require jlib::disco
+package require jlib::si
+
+package provide jlib::ibb 0.1
+
+namespace eval jlib::ibb {
+
+    variable inited 0
+    variable xmlns
+    set xmlns(ibb) "http://jabber.org/protocol/ibb"
+    set xmlns(amp) "http://jabber.org/protocol/amp"
+
+    jlib::si::registertransport $xmlns(ibb) $xmlns(ibb) 80  \
+      [namespace current]::si_open   \
+      [namespace current]::si_close
+    
+    jlib::disco::registerfeature $xmlns(ibb)
+
+    # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::ibb::init --
+# 
+#       Sets up jabberlib handlers and makes a new instance if an ibb object.
+  
+proc jlib::ibb::init {jlibname args} {
+
+    #puts "jlib::ibb::init"
+    
+    variable inited
+    variable xmlns
+    
+    if {!$inited} {
+	InitOnce
+    }    
+
+    # Keep different state arrays for initiator (i) and target (t).
+    namespace eval ${jlibname}::ibb {
+	variable priv
+	variable opts
+	variable istate
+	variable tstate
+    }
+    upvar ${jlibname}::ibb::priv  priv
+    upvar ${jlibname}::ibb::opts  opts
+    
+    array set opts {
+	-block-size     4096
+    }
+    array set opts $args
+    
+    # Each base64 byte takes 6 bits; need to translate to binary bytes.
+    set binblock [expr {(6 * $opts(-block-size))/8}]
+    set priv(binblock) [expr {6 * ($binblock/6)}]
+    
+    # Register some standard iq handlers that is handled internally.
+    $jlibname iq_register    set $xmlns(ibb) [namespace current]::handle_set
+    $jlibname message_register * $xmlns(ibb) [namespace current]::message_handler
+
+    return
+}
+
+proc jlib::ibb::InitOnce { } {
+    
+    variable ampElem
+    variable inited
+    variable xmlns
+    
+    set rule1 [wrapper::createtag "rule"   \
+      -attrlist {condition deliver-at value stored action error}]
+    set rule2 [wrapper::createtag "rule"   \
+      -attrlist {condition match-resource value exact action error}]
+    set ampElem [wrapper::createtag "amp"  \
+      -attrlist [list xmlns $xmlns(amp)]   \
+      -subtags [list $rule1 $rule2]]
+
+    set inited 1
+}
+
+# jlib::ibb::cmdproc --
+#
+#       Just dispatches the command to the right procedure.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       cmd:        
+#       args:       all args to the cmd procedure.
+#       
+# Results:
+#       none.
+
+proc jlib::ibb::cmdproc {jlibname cmd args} {
+    
+    # Which command? Just dispatch the command to the right procedure.
+    return [eval {$cmd $jlibname} $args]
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#
+# These are all functions to use by a initiator (sender).
+
+# jlib::ibb::si_open, si_close --
+# 
+#       Bindings for si.
+
+proc jlib::ibb::si_open {jlibname jid sid args} {
+    
+    upvar ${jlibname}::ibb::istate istate
+    #puts "jlib::ibb::si_open (i)"
+    
+    set istate($sid,sid) $sid
+    set istate($sid,jid) $jid
+    set istate($sid,seq) 0
+    set istate($sid,status) ""
+    set si_open_cb [namespace current]::si_open_cb
+    eval {send_open $jlibname $jid $sid $si_open_cb} $args
+    return
+}
+
+proc jlib::ibb::si_open_cb {jlibname sid type subiq args} {
+    
+    upvar ${jlibname}::ibb::istate istate
+    #puts "jlib::ibb::si_open_cb (i)"    
+    
+    # Since this is an async call we may have been reset.
+    if {![info exists istate($sid,sid)]} {
+	return
+    }    
+    jlib::si::transport_open_cb $jlibname $sid $type $subiq
+    
+    # If all went well this far we initiate the read/write data process.
+    if {$type eq "result"} {
+	
+	# Tell the profile to prepare to read data (open file).
+	jlib::si::open_data $jlibname $sid
+	si_read $jlibname $sid
+    }    
+}
+
+proc jlib::ibb::si_read {jlibname sid} {
+    
+    upvar ${jlibname}::ibb::istate istate
+    #puts "jlib::ibb::si_read (i)"
+    
+    # Since this is an async call we may have been reset.
+    if {![info exists istate($sid,sid)]} {
+	return
+    }    
+    
+    # We have been reset or something.
+    if {$istate($sid,status) eq "close"} {
+	return
+    }
+    set data [jlib::si::read_data $jlibname $sid]
+    set len [string length $data]
+
+    if {$len > 0} {
+	si_send $jlibname $sid $data
+    } else {
+	
+	# Empty data from the reader means that we are done.
+	jlib::si::close_data $jlibname $sid
+    }
+}
+
+proc jlib::ibb::si_send {jlibname sid data} {
+    
+    upvar ${jlibname}::ibb::istate istate
+    #puts "jlib::ibb::si_send (i)"
+    
+    set jid $istate($sid,jid)
+    send_data $jlibname $jid $sid $data [namespace current]::si_send_cb
+
+    # Trick to avoid UI blocking.
+    # @@@ We should have a method to detect if xmpp socket writable.
+    after idle [list after 0 [list \
+      [namespace current]::si_read $jlibname $sid]]
+}
+
+# jlib::ibb::si_send_cb --
+# 
+#       XEP says that we SHOULD track each mesage, in case of error.
+
+proc jlib::ibb::si_send_cb {jlibname sid type subiq args} {
+
+    upvar ${jlibname}::ibb::istate istate
+    #puts "jlib::ibb::si_send_cb (i)"
+    
+    # We get this async so we may have been reset or something.
+    if {![info exists istate($sid,sid)]} {
+	return
+    }
+    if {[string equal $type "error"]} {
+	jlib::si::close_data $jlibname $sid error
+	ifree $jlibname $sid
+    }
+}
+
+# jlib::ibb::si_close --
+# 
+#       The profile closes us down. It could be a reset.
+
+proc jlib::ibb::si_close {jlibname sid} {
+    
+    upvar ${jlibname}::ibb::istate istate
+    #puts "jlib::ibb::si_close (i)"
+
+    # Keep a status so we can stop sending messages right away.
+    set istate($sid,status) "close"
+    set jid $istate($sid,jid)
+    set cmd [namespace current]::si_close_cb
+
+    send_close $jlibname $jid $sid $cmd
+}
+
+# jlib::ibb::si_close_cb --
+# 
+#       This is our destructor that ends it all.
+
+proc jlib::ibb::si_close_cb {jlibname sid type subiq args} {
+    
+    upvar ${jlibname}::ibb::istate istate
+    #puts "jlib::ibb::si_close_cb (i)"
+
+    set jid $istate($sid,jid)
+    
+    jlib::si::transport_close_cb $jlibname $sid $type $subiq
+    ifree $jlibname $sid
+}
+
+proc jlib::ibb::ifree {jlibname sid} {
+    
+    upvar ${jlibname}::ibb::istate istate
+    #puts "jlib::ibb::ifree (i)"   
+
+    array unset istate $sid,*
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+proc jlib::ibb::configure {jlibname args} {
+    
+    upvar ${jlibname}::ibb::opts opts
+
+    # @@@ TODO
+    
+}
+
+# jlib::ibb::send_open --
+# 
+#       Initiates a file transport. We must be able to configure 'block-size'
+#       from the file-transfer profile.
+#
+# Arguments:
+# 
+
+proc jlib::ibb::send_open {jlibname jid sid cmd args} {    
+    variable xmlns
+    upvar ${jlibname}::ibb::opts opts
+    
+    #puts "jlib::ibb::send_open (i)"
+    
+    array set arr [list -block-size $opts(-block-size)]
+    array set arr $args
+        
+    set openElem [wrapper::createtag "open"  \
+      -attrlist [list sid $sid block-size $arr(-block-size) xmlns $xmlns(ibb)]]
+    jlib::send_iq $jlibname set [list $openElem] -to $jid  \
+      -command [concat $cmd [list $jlibname $sid]]
+    return
+}
+
+# jlib::ibb::send_data --
+# 
+# 
+
+proc jlib::ibb::send_data {jlibname jid sid data cmd} {    
+    variable xmlns
+    variable ampElem
+    upvar ${jlibname}::ibb::istate istate
+    #puts "jlib::ibb::send_data (i) sid=$sid, cmd=$cmd"
+
+    set jid $istate($sid,jid)
+    set seq $istate($sid,seq)
+    set edata [base64::encode $data]
+    set dataElem [wrapper::createtag "data"  \
+      -attrlist [list xmlns $xmlns(ibb) sid $sid seq $seq]  \
+      -chdata $edata]
+    set istate($sid,seq) [expr {($seq + 1) % 65536}]
+
+    jlib::send_message $jlibname $jid -xlist [list $dataElem $ampElem]  \
+      -command [concat $cmd [list $jlibname $sid]]
+}
+
+# jlib::ibb::send_close --
+# 
+#       Sends the close tag.
+#
+# Arguments:
+# 
+
+proc jlib::ibb::send_close {jlibname jid sid cmd} {    
+    variable xmlns
+    #puts "jlib::ibb::send_close (i)"
+
+    set closeElem [wrapper::createtag "close"  \
+      -attrlist [list sid $sid xmlns $xmlns(ibb)]]
+    jlib::send_iq $jlibname set [list $closeElem] -to $jid  \
+      -command [concat $cmd [list $jlibname $sid]]
+    return
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#
+# These are all functions to use by a target (receiver) of a stream.
+
+# jlib::ibb::handle_set --
+# 
+#       Parse incoming ibb iq-set open/close element.
+#       It is being assumed that we already have accepted a stream initiation.
+
+proc jlib::ibb::handle_set {jlibname from subiq args} {
+
+    variable xmlns
+    upvar ${jlibname}::ibb::tstate tstate
+    
+    #puts "jlib::ibb::handle_set (t)"
+    
+    set tag [wrapper::gettag $subiq]
+    array set attr [wrapper::getattrlist $subiq]
+    array set argsArr $args
+    if {![info exists argsArr(-id)] || ![info exists attr(sid)]} {
+	# We can't do more here.
+	return 0
+    }
+    set sid $attr(sid)
+    
+    # We make sure that we have already got a si with this sid.
+    if {![jlib::si::havesi $jlibname $sid]} {
+	send_error $jlibname $from $argsArr(-id) $sid 404 cancel item-not-found
+	return 1
+    }
+
+    switch -- $tag {
+	open {
+	    if {![info exists attr(block-size)]} {
+		# @@@ better stanza!
+		send_error $jlibname $from $argsArr(-id) $sid 501 cancel  \
+		  feature_not_implemented
+		return
+	    }
+	    set tstate($sid,sid)        $sid
+	    set tstate($sid,jid)        $from
+	    set tstate($sid,block-size) $attr(block-size)
+	    set tstate($sid,seq)        0
+	    
+	    # Make a success response on open.
+	    jlib::send_iq $jlibname "result" {} -to $from -id $argsArr(-id)
+	}
+	close {
+	    
+	    # Make a success response on close.
+	    jlib::send_iq $jlibname "result" {} -to $from -id $argsArr(-id)
+	    jlib::si::stream_closed $jlibname $sid
+	    tfree $jlibname $sid
+	}
+	default {
+	    return 0
+	}
+    }
+    return 1
+}
+
+# jlib::ibb::message_handler --
+# 
+#       Message handler for incoming http://jabber.org/protocol/ibb elements.
+
+proc jlib::ibb::message_handler {jlibname ns msgElem args} {
+
+    variable xmlns
+    upvar ${jlibname}::ibb::tstate tstate
+    
+    array set argsArr $args
+    #puts "jlib::ibb::message_handler (t) ns=$ns"
+    
+    set jid [wrapper::getattribute $msgElem "from"]
+    
+    # Pack up the data and deliver to si.
+    set dataElems [wrapper::getchildswithtagandxmlns $msgElem data $xmlns(ibb)]
+    foreach dataElem $dataElems {
+	array set attr [wrapper::getattrlist $dataElem]
+	set sid $attr(sid)
+	set seq $attr(seq)
+		
+	# We make sure that we have already got a si with this sid.
+	# Since there can be many of these, reply with error only to first.
+	if {![jlib::si::havesi $jlibname $sid]  \
+	  || ![info exists tstate($sid,sid)]} {
+	    if {[info exists argsArr(-id)]} {
+		set id $argsArr(-id)
+		jlib::send_message_error $jlibname $jid $id 404 cancel  \
+		  item-not-found
+	    }
+	    return 1
+	}
+	
+	# Check that no packets have been lost.
+	if {$seq != $tstate($sid,seq)} {
+	    if {[info exists argsArr(-id)]} {
+		#puts "\t seq=$seq, expectseq=$expectseq"
+		set id $argsArr(-id)
+		jlib::send_message_error $jlibname $jid $id 400 cancel  \
+		  bad-request
+	    }
+	    return 1
+	}
+	
+	set encdata [wrapper::getcdata $dataElem]
+	if {[catch {
+	    set data [base64::decode $encdata]
+	}]} {
+	    if {[info exists argsArr(-id)]} {
+		jlib::send_message_error $jlibname $jid $id 400 cancel bad-request
+	    }
+	    return 1
+	}
+	
+	# Next expected 'seq'.
+	set tstate($sid,seq) [expr {($seq + 1) % 65536}]
+
+	# Deliver to si for further processing.
+	jlib::si::stream_recv $jlibname $sid $data
+    }
+    return 1
+}
+
+proc jlib::ibb::send_error {jlibname jid id sid errcode errtype stanza} {
+
+    jlib::send_iq_error $jlibname $jid $id $errcode $errtype $stanza    
+    tfree $jlibname $sid
+}
+
+proc jlib::ibb::tfree {jlibname sid} {
+    
+    upvar ${jlibname}::ibb::tstate tstate
+    #puts "jlib::ibb::tfree (t)"   
+
+    array unset tstate $sid,*
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::ibb {
+
+    jlib::ensamble_register ibb   \
+      [namespace current]::init   \
+      [namespace current]::cmdproc
+}
+
+#-------------------------------------------------------------------------------
diff --git a/lib/jabberlib/jabberlib.tcl b/lib/jabberlib/jabberlib.tcl
new file mode 100644
index 0000000..3285c71
--- /dev/null
+++ b/lib/jabberlib/jabberlib.tcl
@@ -0,0 +1,4319 @@
+# jabberlib.tcl --
+#
+#       This is the main part of the jabber lib, a Tcl library for interacting
+#       with jabber servers. The core parts are known under the name XMPP.
+#
+# Copyright (c) 2001-2007  Mats Bengtsson
+# 
+# This file is distributed under BSD style license.
+#  
+# $Id: jabberlib.tcl,v 1.199 2008/06/09 14:24:46 matben Exp $
+# 
+# Error checking is minimal, and we assume that all clients are to be trusted.
+# 
+# News: the transport mechanism shall be completely configurable, but where
+#       the standard mechanism (put directly to socket) is included here.
+#
+# Variables used in JabberLib:
+# 
+# lib:
+#	lib(wrap)                  : Wrap ID
+#       lib(clientcmd)             : Callback proc up to the client
+#	lib(sock)                  : socket name
+#	lib(streamcmd)             : Callback command to run when the <stream>
+#	                             tag is received from the server.
+#
+# iqcmd:	                             
+#	iqcmd(uid)                 : Next iq id-number. Sent in 
+#                                    "id" attributes of <iq> packets.
+#	iqcmd($id)                 : Callback command to run when iq result 
+#	                             packet of $id is received.
+#
+# locals:
+#       locals(server)             : The servers logical name (streams 'from')
+#       locals(username)
+#       locals(myjid)
+#       locals(myjid2)
+#	                               
+############################# SCHEMA ###########################################
+#
+#   TclXML <---> wrapper <---> jabberlib <---> client
+#                                 | 
+#                             jlib::roster
+#                             jlib::disco
+#                             jlib::muc
+#                               ...
+#                               
+#   Most jlib-packages are self-registered and are invoked using ensamble (sub)
+#   commands.
+#
+############################# USAGE ############################################
+#
+#   NAME
+#      jabberlib - an interface between Jabber clients and the wrapper
+#      
+#   SYNOPSIS
+#      jlib::new clientCmd ?-opt value ...?
+#      jlib::havesasl
+#      jlib::havetls
+#      
+#   OPTIONS
+#	-iqcommand            callback for <iq> elements not handled explicitly
+#	-messagecommand       callback for <message> elements
+#	-presencecommand      callback for <presence> elements
+#	-streamnamespace      initialization namespace (D = "jabber:client")
+#	-keepalivesecs        send a newline character with this interval
+#	-autoawaymins         if > 0 send away message after this many minutes
+#	-xautoawaymins        if > 0 send xaway message after this many minutes
+#	-awaymsg              the away message 
+#	-xawaymsg             the xaway message
+#	-autodiscocaps        0|1 should presence caps elements be auto discoed
+#	
+#   INSTANCE COMMANDS
+#      jlibName config ?args?
+#      jlibName openstream server ?args?
+#      jlibName closestream
+#      jlibName element_deregister xmlns func
+#      jlibName element_register xmlns func ?seq?
+#      jlibName getstreamattr name
+#      jlibName get_feature name
+#      jlibName get_last to cmd
+#      jlibName get_time to cmd
+#      jlibName getserver
+#      jlibName get_version to cmd
+#      jlibName getrecipientjid jid
+#      jlibName get_registered_presence_stanzas ?tag? ?xmlns?
+#      jlibName iq_get xmlns ?-to, -command, -sublists?
+#      jlibName iq_set xmlns ?-to, -command, -sublists?
+#      jlibName iq_register type xmlns cmd
+#      jlibName message_register xmlns cmd
+#      jlibName myjid
+#      jlibName myjid2
+#      jlibName myjidmap
+#      jlibName myjid2map
+#      jlibName mypresence
+#      jlibName oob_set to cmd url ?args?
+#      jlibName presence_register type cmd
+#      jlibName registertransport name initProc sendProc resetProc ipProc
+#      jlibName register_set username password cmd ?args?
+#      jlibName register_get cmd ?args?
+#      jlibName register_presence_stanza elem
+#      jlibName register_remove to cmd ?args?
+#      jlibName resetstream
+#      jlibName schedule_auto_away
+#      jlibName search_get to cmd
+#      jlibName search_set to cmd ?args?
+#      jlibName send_iq type xmldata ?args?
+#      jlibName send_message to ?args?
+#      jlibName send_presence ?args?
+#      jlibName send_auth username resource ?args?
+#      jlibName send xmllist
+#      jlibName setsockettransport socket
+#      jlibName state
+#      jlibName transport
+#      jlibName deregister_presence_stanza tag xmlns
+#      
+#      
+#   The callbacks given for any of the '-iqcommand', '-messagecommand', 
+#   or '-presencecommand' must have the following form:
+#   
+#      tclProc {jlibname xmldata}
+#      
+#   where 'type' is the type attribute valid for each specific element, and
+#   'args' is a list of '-key value' pairs. The '-iqcommand' returns a boolean
+#   telling if any 'get' is handled or not. If not, then a "Not Implemented" is
+#   returned automatically.
+#                 
+#   The clientCmd procedure must have the following form:
+#   
+#      clientCmd {jlibName what args}
+#      
+#   where 'what' can be any of: connect, disconnect, xmlerror,
+#   version, networkerror, ....
+#   'args' is a list of '-key value' pairs.
+#      
+#   @@@ TODO:
+#   
+#      1) Rewrite from scratch and deliver complete iq, message, and presence
+#      elements to callbacks. Callbacks then get attributes like 'from' etc
+#      using accessor functions.
+#      
+#      2) Cleanup all the presence code.
+#      
+#-------------------------------------------------------------------------------
+
+# @@@ TODO: change package names to jlib::*
+
+package require wrapper
+package require service
+package require stanzaerror
+package require streamerror
+package require groupchat
+package require jlib::util
+
+package provide jlib 2.0
+
+
+namespace eval jlib {
+    
+    # Globals same for all instances of this jlib.
+    #    > 1 prints raw xml I/O
+    #    > 2 prints a lot more
+    variable debug 0
+    if {[info exists ::debugLevel] && ($::debugLevel > 1) && ($debug == 0)} {
+	set debug 2
+    }
+    
+    variable statics
+    set statics(inited) 0
+    set statics(presenceTypeExp)  \
+      {(available|unavailable|subscribe|unsubscribe|subscribed|unsubscribed|invisible|probe)}
+    set statics(instanceCmds) [list]
+    
+    variable version 1.0
+    
+    # Running number.
+    variable uid 0
+    
+    # Let jlib components register themselves for subcommands, ensamble,
+    # so that they can be invoked by: jlibname subcommand ...
+    variable ensamble
+    
+    # Some common xmpp xml namespaces.
+    variable xmppxmlns
+    array set xmppxmlns {
+	stream      "http://etherx.jabber.org/streams"
+	streams     "urn:ietf:params:xml:ns:xmpp-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"
+	stanzas     "urn:ietf:params:xml:ns:xmpp-stanzas"
+	session     "urn:ietf:params:xml:ns:xmpp-session"
+    }
+    
+    variable jxmlns
+    array set jxmlns {
+	amp             "http://jabber.org/protocol/amp"
+	caps            "http://jabber.org/protocol/caps"
+	compress        "http://jabber.org/features/compress"
+	disco           "http://jabber.org/protocol/disco"
+	disco,items     "http://jabber.org/protocol/disco#items"
+	disco,info      "http://jabber.org/protocol/disco#info"
+	ibb             "http://jabber.org/protocol/ibb"
+	muc             "http://jabber.org/protocol/muc"
+	muc,user        "http://jabber.org/protocol/muc#user"
+	muc,admin       "http://jabber.org/protocol/muc#admin"
+	muc,owner       "http://jabber.org/protocol/muc#owner"
+	pubsub          "http://jabber.org/protocol/pubsub"
+    }
+    
+    # This is likely to change when XEP accepted.
+    set jxmlns(entitytime) "http://www.xmpp.org/extensions/xep-0202.html#ns"
+    
+    # Auto away and extended away are only set when the
+    # current status has a lower priority than away or xa respectively.
+    # After an idea by Zbigniew Baniewski.
+    variable statusPriority
+    array set statusPriority {
+	chat            1
+	available       2
+	away            3
+	xa              4
+	dnd             5
+	invisible       6
+	unavailable     7
+    }
+}
+
+proc jlib::getxmlns {name} {
+    variable xmppxmlns
+    variable jxmlns
+    
+    if {[info exists xmppxmlns($name)]} {
+	return $xmppxmlns($name)
+    } elseif {[info exists xmppxmlns($name)]} {
+	return $jxmlns($name)
+    } else {
+	return -code error "unknown xmlns for $name"
+    }
+}
+
+# jlib::register_instance --
+#     
+#       Packages can register here to get notified when a new jlib instance is
+#       created.
+
+proc jlib::register_instance {cmd} {
+    variable statics
+    
+    lappend statics(instanceCmds) $cmd
+}
+
+# jlib::new --
+#
+#       This creates a new instance jlib interpreter.
+#       
+# Arguments:
+#       clientcmd:  callback procedure for the client
+#       args:       
+#	-iqcommand            
+#	-messagecommand       
+#	-presencecommand      
+#	-streamnamespace      
+#	-keepalivesecs        
+#	-autoawaymins              
+#	-xautoawaymins             
+#	-awaymsg              
+#	-xawaymsg         
+#	-autodiscocaps    
+#       
+# Results:
+#       jlibname which is the namespaced instance command
+  
+proc jlib::new {clientcmd args} {    
+
+    variable jxmlns
+    variable statics
+    variable objectmap
+    variable uid
+    variable ensamble
+    
+    # Generate unique command token for this jlib instance.
+    # Fully qualified!
+    set jlibname [namespace current]::jlib[incr uid]
+      
+    # Instance specific namespace.
+    namespace eval $jlibname {
+	variable lib
+	variable locals
+	variable iqcmd
+	variable iqhook
+	variable msghook
+	variable preshook
+	variable genhook
+	variable opts
+	variable pres
+	variable features
+    }
+            
+    # Set simpler variable names.
+    upvar ${jlibname}::lib      lib
+    upvar ${jlibname}::iqcmd    iqcmd
+    upvar ${jlibname}::prescmd  prescmd
+    upvar ${jlibname}::msgcmd   msgcmd
+    upvar ${jlibname}::opts     opts
+    upvar ${jlibname}::locals   locals
+    upvar ${jlibname}::features features
+    
+    array set opts {
+	-iqcommand            ""
+	-messagecommand       ""
+	-presencecommand      ""
+	-streamnamespace      "jabber:client"
+	-keepalivesecs        60
+	-autoawaymins         0
+	-xautoawaymins        0
+	-awaymsg              ""
+	-xawaymsg             ""
+	-autodiscocaps        0
+    }
+    
+    # Verify options.
+    eval verify_options $jlibname $args
+    
+    if {!$statics(inited)} {
+	init
+    }
+
+    set wrapper [wrapper::new [list [namespace current]::got_stream $jlibname] \
+      [list [namespace current]::end_of_parse $jlibname]  \
+      [list [namespace current]::dispatcher $jlibname]    \
+      [list [namespace current]::xmlerror $jlibname]]
+    
+    set iqcmd(uid)   1001
+    set prescmd(uid) 1001
+    set msgcmd(uid)  1001
+    set lib(clientcmd)      $clientcmd
+    set lib(async_handler)  ""
+    set lib(wrap)           $wrapper
+    set lib(resetCmds)      [list]
+    
+    set lib(isinstream) 0
+    set lib(state)      ""
+    set lib(transport,name) ""
+
+    set lib(socketfilter,out) [list]
+    set lib(socketfilter,in)  [list]
+
+    set lib(tee,send) [list]
+    set lib(tee,recv) [list]
+
+    init_inst $jlibname
+            
+    # Init groupchat state.
+    groupchat::init $jlibname
+        
+    # Register some standard iq handlers that are handled internally.
+    iq_register $jlibname get jabber:iq:last    \
+      [namespace current]::handle_get_last
+    iq_register $jlibname get jabber:iq:time    \
+      [namespace current]::handle_get_time
+    # This overrides any client handler which is bad.
+    #iq_register $jlibname get jabber:iq:version \
+    #  [namespace current]::handle_get_version
+
+    iq_register $jlibname get $jxmlns(entitytime) \
+      [namespace current]::handle_entity_time
+
+    # Create the actual jlib instance procedure.
+    proc $jlibname {cmd args}   \
+      "eval jlib::cmdproc {$jlibname} \$cmd \$args"
+    
+    # Init the service layer for this jlib instance.
+    service::init $jlibname
+    
+    # Init ensamble commands.
+    foreach {- name} [array get ensamble *,name] {
+	uplevel #0 $ensamble($name,init) $jlibname
+    }
+    
+    return $jlibname
+}
+
+# jlib::init --
+# 
+#       Static initializations.
+
+proc jlib::init {} {
+    variable statics
+    
+    if {[catch {package require jlibsasl}]} {
+	set statics(sasl) 0
+    } else {
+	set statics(sasl) 1
+	sasl_init
+    }
+    if {[catch {package require jlibtls}]} {
+	set statics(tls) 0
+    } else {
+	set statics(tls) 1
+    }
+    
+    set statics(inited) 1
+}
+
+# jlib::init_inst --
+# 
+#       Instance specific initializations.
+
+proc jlib::init_inst {jlibname} {
+
+    upvar ${jlibname}::locals   locals
+    upvar ${jlibname}::features features
+    
+    # Any of {available chat away xa dnd invisible unavailable}
+    set locals(status)        "unavailable"
+    set locals(pres,type)     "unavailable"
+    set locals(myjid)         ""
+    set locals(myjid2)        ""
+    set locals(myjidmap)      ""
+    set locals(myjid2map)     ""
+    set locals(trigAutoAway)  1
+    set locals(server)        ""
+    set locals(servermap)     ""
+
+    set features(trace) [list]
+}
+
+# jlib::havesasl --
+# 
+#       Cache this info for effectiveness. It is needed at application level.
+
+proc jlib::havesasl {} {
+    variable statics
+    
+    if {![info exists statics(sasl)]} {
+	if {[catch {package require jlibsasl}]} {
+	    set statics(sasl) 0
+	} else {
+	    set statics(sasl) 1
+	}
+    }
+    return $statics(sasl)
+}
+
+# jlib::havetls --
+# 
+#       Cache this info for effectiveness. It is needed at application level.
+
+proc jlib::havetls {} {
+    variable statics
+    
+    if {![info exists statics(tls)]} {
+	if {[catch {package require jlibtls}]} {
+	    set statics(tls) 0
+	} else {
+	    set statics(tls) 1
+	}
+    }
+    return $statics(tls)
+}
+
+proc jlib::havecompress {} {
+    variable statics
+    
+    if {![info exists statics(compress)]} {
+	if {[catch {package require jlib::compress}]} {
+	    set statics(compress) 0
+	} else {
+	    set statics(compress) 1
+	}
+    }
+    return $statics(compress)
+}
+
+# jlib::register_package --
+# 
+#       This is supposed to be a method for jlib::* packages to register
+#       themself just so we know they are there. So far only for the 'roster'.
+
+proc jlib::register_package {name} {
+    variable statics
+    
+    set statics($name) 1
+}
+
+# jlib::ensamble_register --
+# 
+#       Register a sub command.
+#       This is then used as: 'jlibName subCmd ...'
+
+proc jlib::ensamble_register {name initProc cmdProc} {
+    variable statics
+    variable ensamble
+    
+    set ensamble($name,name) $name
+    set ensamble($name,init) $initProc
+    set ensamble($name,cmd)  $cmdProc
+    
+    # Must call the initProc for already existing jlib instances.
+    if {$statics(inited)} {
+	foreach jlibname [namespace children ::jlib jlib*] {
+	    uplevel #0 $initProc $jlibname
+	}
+    }
+}
+
+proc jlib::ensamble_deregister {name} {
+    variable ensamble
+    
+    array unset ensamble ${name},*
+}
+
+# jlib::cmdproc --
+#
+#       Just dispatches the command to the right procedure.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       cmd:        openstream - closestream - send_iq - send_message ... etc.
+#       args:       all args to the cmd procedure.
+#       
+# Results:
+#       none.
+
+proc jlib::cmdproc {jlibname cmd args} {
+    variable ensamble
+    
+    # Which command? Just dispatch the command to the right procedure.
+    if {[info exists ensamble($cmd,cmd)]} {
+	return [uplevel #0 $ensamble($cmd,cmd) $jlibname $args]
+    } else {
+	return [eval {$cmd $jlibname} $args]
+    }
+}
+
+# jlib::config --
+#
+#	See documentaion for details.
+#
+# Arguments:
+#	args		Options parsed by the procedure.
+#	
+# Results:
+#       depending on args.
+
+proc jlib::config {jlibname args} {    
+    variable ensamble
+    upvar ${jlibname}::opts opts
+    
+    set options [lsort [array names opts -*]]
+    set usage [join $options ", "]
+    if {[llength $args] == 0} {
+	set result [list]
+	foreach name $options {
+	    lappend result $name $opts($name)
+	}
+	return $result
+    }
+    regsub -all -- - $options {} options
+    set pat ^-([join $options |])$
+    if {[llength $args] == 1} {
+	set flag [lindex $args 0]
+	if {[regexp -- $pat $flag]} {
+	    return $opts($flag)
+	} else {
+	    return -code error "Unknown option $flag, must be: $usage"
+	}
+    } else {
+	array set argsA $args
+	
+	# Reschedule auto away only if changed. Before setting new opts!
+	# Better to use 'tk inactive' or 'tkinactive' and handle this on
+	# application level.
+	if {[info exists argsA(-autoawaymins)] &&  \
+	  ($argsA(-autoawaymins) != $opts(-autoawaymins))} {
+	    schedule_auto_away $jlibname
+	}
+	if {[info exists argsA(-xautoawaymins)] &&  \
+	  ($argsA(-xautoawaymins) != $opts(-xautoawaymins))} {
+	    schedule_auto_away $jlibname
+	}
+	foreach {flag value} $args {
+	    if {[regexp -- $pat $flag]} {
+		set opts($flag) $value		
+	    } else {
+		return -code error "Unknown option $flag, must be: $usage"
+	    }
+	}
+    }
+    
+    # Let components configure themselves.
+    # @@@ It is better to let components handle this???
+    foreach ename [array names ensamble] {
+	set ecmd ${ename}::configure
+	if {[llength [info commands $ecmd]]} {
+	    #uplevel #0 $ecmd $jlibname $args
+	}
+    }
+
+    return
+}
+
+# jlib::verify_options
+#
+#	Check if valid options and set them.
+#
+# Arguments
+# 
+#	args    The argument list given on the call.
+#
+# Side Effects
+#	Sets error
+
+proc jlib::verify_options {jlibname args} {    
+
+    upvar ${jlibname}::opts opts
+    
+    set validopts [array names opts]
+    set usage [join $validopts ", "]
+    regsub -all -- - $validopts {} theopts
+    set pat ^-([join $theopts |])$
+    foreach {flag value} $args {
+	if {[regexp $pat $flag]} {
+	    
+	    # Validate numbers
+	    if {[info exists opts($flag)] && \
+	      [string is integer -strict $opts($flag)] && \
+	      ![string is integer -strict $value]} {
+		return -code error "Bad value for $flag ($value), must be integer"
+	    }
+	    set opts($flag) $value
+	} else {
+	    return -code error "Unknown option $flag, can be: $usage"
+	}
+    }
+}
+
+# jlib::state --
+# 
+#       Accesor for the internal 'state'.
+
+proc jlib::state {jlibname} {
+    
+    upvar ${jlibname}::lib lib
+    
+    return $lib(state)
+}
+
+# jlib::register_reset --
+# 
+#       Packages can register here to get notified when the jlib stream is reset.
+
+proc jlib::register_reset {jlibname cmd} {
+    
+    upvar ${jlibname}::lib lib
+    
+    lappend lib(resetCmds) $cmd
+}
+
+# jlib::registertransport --
+# 
+#       We must have a transport mechanism for our xml. Socket is standard but
+#       http is also possible.
+
+proc jlib::registertransport {jlibname name initProc sendProc resetProc ipProc} {
+    
+    upvar ${jlibname}::lib lib
+
+    set lib(transport,name)  $name
+    set lib(transport,init)  $initProc
+    set lib(transport,send)  $sendProc
+    set lib(transport,reset) $resetProc
+    set lib(transport,ip)    $ipProc
+}
+
+proc jlib::transport {jlibname} {
+    
+    upvar ${jlibname}::lib lib
+
+    return $lib(transport,name)
+}
+
+# jlib::setsockettransport --
+# 
+#       Sets the standard socket transport and the actual socket to use.
+
+proc jlib::setsockettransport {jlibname sock} {
+    
+    upvar ${jlibname}::lib lib
+    
+    # Settings for the raw socket transport layer.
+    set lib(sock) $sock
+    set lib(transport,name)  "socket"
+    set lib(transport,init)  [namespace current]::initsocket
+    set lib(transport,send)  [namespace current]::putssocket
+    set lib(transport,reset) [namespace current]::resetsocket
+    set lib(transport,ip)    [namespace current]::ipsocket
+}
+
+# The procedures for the standard socket transport layer -----------------------
+
+# jlib::initsocket
+#
+#	Default transport mechanism; init already opened socket.
+#
+# Arguments:
+# 
+# Side Effects:
+#	none
+
+proc jlib::initsocket {jlibname} {
+
+    upvar ${jlibname}::lib lib
+    upvar ${jlibname}::opts opts
+
+    set sock $lib(sock)
+    if {[catch {
+	fconfigure $sock -blocking 0 -buffering none -encoding utf-8
+    } err]} {
+	return -code error "The connection failed or dropped later"
+    }
+     
+    # Set up callback on incoming socket.
+    fileevent $sock readable [list [namespace current]::recvsocket $jlibname]
+
+    # Schedule keep-alives to keep socket open in case anyone want's to close it.
+    # Be sure to not send any keep-alives before the stream is inited.
+    if {$opts(-keepalivesecs)} {
+	after [expr 1000 * $opts(-keepalivesecs)] \
+	  [list [namespace current]::schedule_keepalive $jlibname]
+    }
+}
+
+# jlib::putssocket
+#
+#	Default transport mechanism; put directly to socket.
+#
+# Arguments:
+# 
+#	xml    The xml that is to be written.
+#
+# Side Effects:
+#	none
+
+proc jlib::putssocket {jlibname xml} {
+
+    upvar ${jlibname}::lib lib
+
+    Debug 2 "SEND: $xml"
+
+    if {$lib(socketfilter,out) ne {}} {
+	set xml [$lib(socketfilter,out) $jlibname $xml]
+    }
+    if {[catch {puts -nonewline $lib(sock) $xml} err]} {
+	# Error propagated to the caller that calls clientcmd.
+	return -code error $err
+    }
+}
+
+# jlib::resetsocket
+#
+#	Default transport mechanism; reset socket.
+#
+# Arguments:
+# 
+# Side Effects:
+#	none
+
+proc jlib::resetsocket {jlibname} {
+
+    upvar ${jlibname}::lib lib
+    upvar ${jlibname}::locals locals
+
+    catch {close $lib(sock)}
+    catch {after cancel $locals(aliveid)}
+
+    set lib(socketfilter,out) [list]
+    set lib(socketfilter,in)  [list]
+}
+
+# jlib::recvsocket --
+#
+#	Default transport mechanism; fileevent on socket socket.
+#       Callback on incoming socket xml data. Feeds our wrapper and XML parser.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       
+# Results:
+#       none.
+
+proc jlib::recvsocket {jlibname} {
+
+    upvar ${jlibname}::lib lib
+        
+    if {[catch {eof $lib(sock)} iseof] || $iseof} {
+	kill $jlibname
+	invoke_async_error $jlibname networkerror
+	return
+    }
+    
+    # Read what we've got.
+    if {[catch {read $lib(sock)} data]} {
+	kill $jlibname
+	invoke_async_error $jlibname networkerror
+	return
+    }
+    if {$lib(socketfilter,in) ne {}} {
+	set data [$lib(socketfilter,in) $jlibname $data]
+    }
+    Debug 2 "RECV: $data"
+    
+    # Feed the XML parser. When the end of a command element tag is reached,
+    # we get a callback to 'jlib::dispatcher'.
+    wrapper::parse $lib(wrap) $data
+}
+
+proc jlib::set_socket_filter {jlibname outcmd incmd} {
+    
+    upvar ${jlibname}::lib lib
+
+    set lib(socketfilter,out) $outcmd
+    set lib(socketfilter,in)  $incmd
+
+    fconfigure $lib(sock) -translation binary
+}
+
+# jlib::ipsocket --
+# 
+#       Get our own ip address.
+
+proc jlib::ipsocket {jlibname} {
+    
+    upvar ${jlibname}::lib lib
+    
+    if {[string length $lib(sock)]} {
+	return [lindex [fconfigure $lib(sock) -sockname] 0]
+    } else {
+	return ""
+    }
+}
+
+# standard socket transport layer end ------------------------------------------
+
+proc jlib::tee_recv {jlibname cmd procName} {
+    
+    upvar ${jlibname}::lib lib
+
+    if {$cmd eq "add"} {
+	lappend lib(tee,recv) $procName
+    } elseif {$cmd eq "remove"} {
+	set lib(tee,recv) [lsearch -all -inline -not $lib(tee,recv) $procName]
+    } else {
+	return -code error "unknown sub command \"$cmd\""
+    }
+}
+
+proc jlib::tee_send {jlibname cmd procName} {
+    
+    upvar ${jlibname}::lib lib
+
+    if {$cmd eq "add"} {
+	lappend lib(tee,send) $procName
+    } elseif {$cmd eq "remove"} {
+	set lib(tee,send) [lsearch -all -inline -not $lib(tee,send) $procName]
+    } else {
+	return -code error "unknown sub command \"$cmd\""
+    }
+}
+
+# jlib::recv --
+#
+# 	Feed the XML parser. When the end of a command element tag is reached,
+# 	we get a callback to 'jlib::dispatcher'.
+
+proc jlib::recv {jlibname xml} {
+
+    upvar ${jlibname}::lib lib
+
+    wrapper::parse $lib(wrap) $xml
+}
+
+# jlib::openstream --
+#
+#       Initializes a stream to a jabber server. The socket must already 
+#       be opened. Sets up fileevent on incoming xml stream.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       server:     the domain name or ip number of the server.
+#       args:
+#           -cmd    callback when we receive the <stream> tag from the server.
+#           -to     the receipients jabber id.
+#           -id
+#           -version
+#       
+# Results:
+#       none.
+
+proc jlib::openstream {jlibname server args} {    
+
+    upvar ${jlibname}::lib lib
+    upvar ${jlibname}::locals locals
+    upvar ${jlibname}::opts opts
+    variable xmppxmlns
+
+    array set argsA $args
+    
+    # The server 'to' attribute is only temporary until we have either a 
+    # confirmation or a redirection (alias) in received streams 'from' attribute.
+    set locals(server)    $server
+    set locals(servermap) [jidmap $server]
+    set locals(last) [clock seconds]
+    
+    # Make sure we start with a clean state.
+    wrapper::reset $lib(wrap)
+
+    set optattr ""
+    foreach {key value} $args {
+	
+	switch -- $key {
+	    -cmd {
+		if {$value ne ""} {
+		    # Register a <stream> callback proc.
+		    set lib(streamcmd) $value
+		}
+	    }
+	    -socket {
+		# empty
+	    }
+	    default {
+		set attr [string trimleft $key "-"]
+		append optattr " $attr='$value'"
+	    }
+	}
+    }
+    set lib(isinstream) 1
+    set lib(state) "instream"
+
+    if {[catch {
+
+	# This call to the transport layer shall set up fileevent callbacks etc.
+   	# to handle all incoming xml.
+	uplevel #0 $lib(transport,init) $jlibname
+        
+    	# Network errors if failed to open connection properly are likely to show here.
+	set xml "<?xml version='1.0' encoding='UTF-8'?><stream:stream\
+	  xmlns='$opts(-streamnamespace)' xmlns:stream='$xmppxmlns(stream)'\
+	  xml:lang='[getlang]' to='$server'$optattr>"
+
+	sendraw $jlibname $xml
+    } err]} {
+	
+	# The socket probably was never connected,
+	# or the connection dropped later.
+	#closestream $jlibname
+	kill $jlibname
+	return -code error "The connection failed or dropped later: $err"
+    }
+    return
+}
+
+# jlib::sendstream --
+# 
+#       Utility for SASL, TLS etc. Sends only the actual stream:stream tag.
+#       May throw error!
+
+proc jlib::sendstream {jlibname args} {
+    
+    upvar ${jlibname}::locals locals
+    upvar ${jlibname}::opts opts
+    variable xmppxmlns
+    
+    set attr ""
+    foreach {key value} $args {
+	set name [string trimleft $key "-"]
+	append attr " $name='$value'"
+    }
+    set xml "<stream:stream\
+      xmlns='$opts(-streamnamespace)' xmlns:stream='$xmppxmlns(stream)'\
+      to='$locals(server)' xml:lang='[getlang]' $attr>"
+   
+    sendraw $jlibname $xml
+}
+
+# jlib::closestream --
+#
+#       Closes the stream down, closes socket, and resets internal variables.
+#       It should handle the complete shutdown of our connection and state.
+#       
+#       There is a potential problem if called from within a xml parser 
+#       callback which makes the subsequent parsing to fail. (after idle?)
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       
+# Results:
+#       none.
+
+proc jlib::closestream {jlibname} {    
+
+    upvar ${jlibname}::lib lib
+
+    Debug 4 "jlib::closestream"
+    
+    if {$lib(isinstream)} {
+	set xml "</stream:stream>"
+	catch {sendraw $jlibname $xml}
+	set lib(isinstream) 0
+    }
+    kill $jlibname
+}
+
+# jlib::invoke_async_error --
+# 
+#       Used for reporting async errors, typically network errors.
+
+proc jlib::invoke_async_error {jlibname err {msg ""}} {
+    
+    upvar ${jlibname}::lib lib
+    Debug 4 "jlib::invoke_async_error err=$err, msg=$msg"
+    
+    if {$lib(async_handler) eq ""} {
+	uplevel #0 $lib(clientcmd) [list $jlibname $err -errormsg $msg]
+    } else {
+	uplevel #0 $lib(async_handler) [list $jlibname $err $msg]
+    }
+}
+
+# jlib::set_async_error_handler --
+# 
+#       This is a way to get all async events directly to a registered handler
+#       without delivering them to clientcmd. Used in jlib::connect.
+proc jlib::set_async_error_handler {jlibname {cmd ""}} {
+    
+    upvar ${jlibname}::lib lib
+
+    set lib(async_handler) $cmd
+}
+
+# jlib::reporterror --
+# 
+#       Used for transports to report async, fatal and nonrecoverable errors.
+
+proc jlib::reporterror {jlibname err {msg ""}} {
+    
+    Debug 4 "jlib::reporterror"
+
+    kill $jlibname
+    invoke_async_error $jlibname $err $msg
+}
+
+# jlib::kill --
+# 
+#       Like closestream but without any network transactions.
+
+proc jlib::kill {jlibname} {
+    
+    upvar ${jlibname}::lib lib
+    
+    Debug 4 "jlib::kill"
+
+    # Close socket typically.
+    catch {uplevel #0 $lib(transport,reset) $jlibname}
+    reset $jlibname
+    
+    # Be sure to reset the wrapper, which implicitly resets the XML parser.
+    wrapper::reset $lib(wrap)
+    return
+}
+
+proc jlib::wrapper_reset {jlibname} {    
+    upvar ${jlibname}::lib lib
+    wrapper::reset $lib(wrap)
+}
+
+# jlib::getip --
+# 
+#       Transport independent way of getting own ip address.
+
+proc jlib::getip {jlibname} {
+    upvar ${jlibname}::lib lib
+    return [$lib(transport,ip) $jlibname]
+}
+
+# jlib::getserver --
+# 
+#       Is the received streams 'from' attribute which is the logical host.
+#       This is normally identical to the 'to' attribute but not always.
+
+proc jlib::getserver {jlibname} {
+    upvar ${jlibname}::locals locals 
+    return $locals(server)
+}
+
+proc jlib::getservermap {jlibname} {
+    upvar ${jlibname}::locals locals 
+    return $locals(servermap)
+}
+
+# jlib::isinstream --
+# 
+#       Utility to help us closing down a stream.
+
+proc jlib::isinstream {jlibname} {
+    upvar ${jlibname}::lib lib
+    return $lib(isinstream)
+}
+
+# jlib::dispatcher --
+#
+#       Just dispatches the xml to any of the iq, message, or presence handlers,
+#       which in turn dispatches further and/or handles internally.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       xmldata:    the complete xml as a hierarchical list.
+#       
+# Results:
+#       none.
+
+proc jlib::dispatcher {jlibname xmldata} {
+    upvar ${jlibname}::lib    lib
+
+    # Which method?
+    set tag [wrapper::gettag $xmldata]
+    
+    switch -- $tag {
+	iq {
+	    iq_handler $jlibname $xmldata
+	}
+	message {
+	    message_handler $jlibname $xmldata	    
+	}
+	presence {
+	    presence_handler $jlibname $xmldata	
+	}
+	features {
+	    features_handler $jlibname $xmldata
+	}
+	error {
+	    error_handler $jlibname $xmldata
+	}
+	default {
+	    element_run_hook $jlibname $xmldata
+	}
+    }
+    
+    foreach cmd $lib(tee,recv) {
+	uplevel #0 $cmd [list $jlibname $xmldata]
+    }
+    
+    # Will have to wait...
+    #general_run_hook $jlibname $xmldata
+}
+
+# jlib::iq_handler --
+#
+#       Callback for incoming <iq> elements.
+#       The handling sequence is the following:
+#       1) handle all preregistered callbacks via id attributes
+#       2) handle callbacks specific for 'type' and 'xmlns' that have been
+#          registered with 'iq_register'
+#       3) if unhandled by 2, use any -iqcommand callback
+#       4) if type='get' and still unhandled, return an error element
+#       
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#	xmldata     the xml element as a list structure.
+#	
+# Results:
+#       roster object set, callbacks invoked.
+
+proc jlib::iq_handler {jlibname xmldata} {    
+
+    upvar ${jlibname}::lib    lib
+    upvar ${jlibname}::iqcmd  iqcmd
+    upvar ${jlibname}::opts   opts    
+    upvar ${jlibname}::locals locals 
+    variable xmppxmlns
+
+    Debug 4 "jlib::iq_handler: ------------"
+
+    # Extract the command level XML data items.    
+    set tag [wrapper::gettag $xmldata]
+    array set attrArr [wrapper::getattrlist $xmldata]
+    
+    # Make an argument list ('-key value' pairs) suitable for callbacks.
+    # Make variables of the attributes.
+    set arglist [list]
+    foreach {key value} [array get attrArr] {
+	set $key $value
+	lappend arglist -$key $value
+    }
+    
+    # This helps callbacks to adapt to using full element as argument.
+    lappend arglist -xmldata $xmldata
+    
+    # The 'type' attribute must exist! Else we return silently.
+    if {![info exists type]} {	
+	return
+    }
+    if {[info exists from]} {
+	set afrom $from
+    } else {
+	set afrom $locals(servermap)
+    }
+    
+    # @@@ Section 9.2.3 of RFC 3920 states in part:
+    # 6. An IQ stanza of type "result" MUST include zero or one child elements.
+    # 7. An IQ stanza of type "error" SHOULD include the child element 
+    # contained in the associated "get" or "set" and MUST include an <error/> 
+    # child....
+    
+    set childlist [wrapper::getchildren $xmldata]
+    set subiq [lindex $childlist 0]
+    set xmlns [wrapper::getattribute $subiq xmlns]
+    
+    set ishandled 0
+    
+    # (1) Handle all preregistered callbacks via id attributes.
+    #     Must be type 'result' or 'error'.
+    #     Some components use type='set' instead of 'result'.
+    #     BUT this creates logical errors since we may also receive iq with
+    #     identical id!
+
+    # @@@ It would be better NOT to have separate calls for errors.
+    
+    switch -- $type {
+	result {
+	    
+	    # Protect us from our own 'set' calls when we are awaiting 
+	    # 'result' or 'error'.
+	    set setus 0
+	    if {($type eq "set") && ($afrom eq $locals(myjidmap))} {
+		set setus 1
+	    }
+
+	    if {!$setus && [info exists id] && [info exists iqcmd($id)]} {
+		uplevel #0 $iqcmd($id) [list result $subiq]
+		      
+		# @@@ TODO:
+		#uplevel #0 $iqcmd($id) [list $jlibname xmldata]
+		
+		# The callback my in turn call 'closestream' which unsets 
+		# all iq before returning.
+		unset -nocomplain iqcmd($id)
+		set ishandled 1
+	    }
+	}
+	error {
+	    set errspec [getstanzaerrorspec $xmldata]
+	    if {[info exists id] && [info exists iqcmd($id)]} {
+		
+		# @@@ Having a separate form of error callbacks is really BAD!!!
+		uplevel #0 $iqcmd($id) [list error $errspec]
+		
+		#uplevel #0 $iqcmd($id) [list $jlibname $xmldata]
+		
+		unset -nocomplain iqcmd($id)
+		set ishandled 1
+	    }	    
+	}
+    }
+	        
+    # (2) Handle callbacks specific for 'type' and 'xmlns' that have been
+    #     registered with 'iq_register'
+
+    if {[string equal $ishandled "0"]} {
+	set ishandled [eval {
+	    iq_run_hook $jlibname $type $xmlns $afrom $subiq} $arglist]
+    }
+    
+    # (3) If unhandled by 2, use any -iqcommand callback.
+
+    if {[string equal $ishandled "0"]} {	
+	if {[string length $opts(-iqcommand)]} {
+	    set ishandled [uplevel #0 $opts(-iqcommand) [list $jlibname $xmldata]]
+	} 
+	    
+	# (4) If type='get' or 'set', and still unhandled, return an error element.
+
+	if {[string equal $ishandled "0"] && \
+	  ([string equal $type "get"] || [string equal $type "set"])} {
+	    
+	    # Return a "Not Implemented" to the sender. Just switch to/from,
+	    # type='result', and add an <error> element.
+	    if {[info exists attrArr(from)]} {
+		return_error $jlibname $xmldata 501 cancel "feature-not-implemented"
+	    }
+	}
+    }
+}
+
+# jlib::return_error --
+# 
+#       Returns an iq-error response using complete iq-element.
+
+proc jlib::return_error {jlibname iqElem errcode errtype errtag} {
+    variable xmppxmlns
+    
+    array set attr [wrapper::getattrlist $iqElem]
+    set childlist  [wrapper::getchildren $iqElem]
+    
+    # Switch from -> to, type='error', retain any id.
+    set attr(to)   $attr(from)
+    set attr(type) "error"
+    unset attr(from)
+
+    set iqElem [wrapper::setattrlist $iqElem [array get attr]]    
+    set stanzaElem [wrapper::createtag $errtag \
+      -attrlist [list xmlns $xmppxmlns(stanzas)]]
+    set errElem [wrapper::createtag "error" -subtags [list $stanzaElem] \
+      -attrlist [list code $errcode type $errtype]]
+    
+    lappend childlist $errElem
+    set iqElem [wrapper::setchildlist $iqElem $childlist]
+
+    send $jlibname $iqElem
+}
+
+# jlib::send_iq_error --
+# 
+#       Sends an iq error element as a response to a iq element.
+
+proc jlib::send_iq_error {jlibname jid id errcode errtype stanza {extraElem {}}} {
+    variable xmppxmlns
+ 
+    set stanzaElem [wrapper::createtag $stanza  \
+      -attrlist [list xmlns $xmppxmlns(stanzas)]]
+    set errChilds [list $stanzaElem]
+    if {[llength $extraElem]} {
+	lappend errChilds $extraElem
+    }
+    set errElem [wrapper::createtag "error"         \
+      -attrlist [list code $errcode type $errtype]  \
+      -subtags $errChilds]
+    set iqElem [wrapper::createtag "iq"  \
+      -attrlist [list type error to $jid id $id] -subtags [list $errElem]]
+
+    send $jlibname $iqElem
+}
+
+# jlib::message_handler --
+#
+#       Callback for incoming <message> elements. See 'jlib::dispatcher'.
+#       
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#	xmldata     the xml element as a list structure.
+#	
+# Results:
+#       callbacks invoked.
+
+proc jlib::message_handler {jlibname xmldata} {    
+
+    upvar ${jlibname}::opts opts    
+    upvar ${jlibname}::lib lib
+    upvar ${jlibname}::msgcmd msgcmd
+    
+    # Extract the command level XML data items.
+    set attrlist  [wrapper::getattrlist $xmldata]
+    set childlist [wrapper::getchildren $xmldata]
+    set attrArr(type) "normal"
+    array set attrArr $attrlist
+    set type $attrArr(type)
+    
+    # Make an argument list ('-key value' pairs) suitable for callbacks.
+    # Make variables of the attributes.
+    foreach {key value} [array get attrArr] {
+	set vopts(-$key) $value
+    }
+    
+    # This helps callbacks to adapt to using full element as argument.
+    set vopts(-xmldata) $xmldata
+    set ishandled 0
+    
+    switch -- $type {
+	error {
+	    set errspec [getstanzaerrorspec $xmldata]
+	    set vopts(-error) $errspec
+	}
+    }
+   
+    # Extract the message sub-elements.
+    # @@@ really bad solution... Deliver full element instead
+    set xmlnsList  [list]
+    foreach child $childlist {
+	
+	# Extract the message sub-elements XML data items.
+	set ctag    [wrapper::gettag $child]
+	set cchdata [wrapper::getcdata $child]
+	
+	switch -- $ctag {
+	    body - subject - thread {
+		set vopts(-$ctag) $cchdata
+	    }
+	    error {
+		# handled above
+	    }
+	    default {
+		lappend elem(-$ctag) $child
+		lappend xmlnsList [wrapper::getattribute $child xmlns]
+	    }
+	}
+    }
+    set xmlnsList [lsort -unique $xmlnsList]	
+    set arglist [array get vopts]
+    
+    # Invoke any registered handler for this particular message.
+    set iscallback 0
+    if {[info exists attrArr(id)]} {
+	set id $attrArr(id)
+	
+	# Avoid the weird situation when we send to ourself.
+	if {[info exists msgcmd($id)] && ![info exists msgcmd($id,self)]} {
+	    uplevel #0 $msgcmd($id) [list $jlibname $type] $arglist
+	    unset -nocomplain msgcmd($id)
+	    set iscallback 1
+	}
+	unset -nocomplain msgcmd($id,self)
+    }	
+
+    # Invoke any registered message handlers for this type and xmlns.
+    if {[array exists elem]} {
+	set arglist [concat [array get vopts] [array get elem]]
+	foreach xmlns $xmlnsList {
+	    set ishandled [eval {
+		message_run_hook $jlibname $type $xmlns $xmldata} $arglist]
+	    if {$ishandled} {
+		break
+	    }
+	}
+    }
+    if {!$iscallback && [string equal $ishandled "0"]} {
+    
+	# Invoke callback to client.
+	if {[string length $opts(-messagecommand)]} {
+	    uplevel #0 $opts(-messagecommand) [list $jlibname $xmldata]
+	}
+    }
+}
+
+# jlib::send_message_error --
+# 
+#       Sends a message error element as a response to another message.
+
+proc jlib::send_message_error {jlibname jid id errcode errtype stanza {extraElem {}}} {
+    variable xmppxmlns
+ 
+    set stanzaElem [wrapper::createtag $stanza  \
+      -attrlist [list xmlns $xmppxmlns(stanzas)]]
+    set errChilds [list $stanzaElem]
+    if {[llength $extraElem]} {
+	lappend errChilds $extraElem
+    }
+    set errElem [wrapper::createtag "error"         \
+      -attrlist [list code $errcode type $errtype]  \
+      -subtags $errChilds]
+    set msgElem [wrapper::createtag "iq"  \
+      -attrlist [list type error to $jid id $id]  \
+      -subtags [list $errElem]]
+
+    send $jlibname $msgElem
+}
+
+# jlib::presence_handler --
+#
+#       Callback for incoming <presence> elements. See 'jlib::dispatcher'.
+#       
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#	xmldata     the xml element as a list structure.
+#	
+# Results:
+#       roster object set, callbacks invoked.
+
+proc jlib::presence_handler {jlibname xmldata} { 
+    variable statics
+    upvar ${jlibname}::lib lib
+    upvar ${jlibname}::prescmd prescmd
+    upvar ${jlibname}::opts opts
+    upvar ${jlibname}::locals locals
+    
+    set id [wrapper::getattribute $xmldata id]
+    
+    # Handle callbacks specific for 'type' that have been registered with 
+    # 'presence_register(_ex)'.
+    
+    # We keep two sets of registered handlers, jlib internal which are
+    # called first, and then externals which are used by the client.
+
+    # Internals:
+    presence_run_hook $jlibname 1 $xmldata
+    presence_ex_run_hook $jlibname 1 $xmldata
+    
+    # Externals:
+    presence_run_hook $jlibname 0 $xmldata
+    presence_ex_run_hook $jlibname 0 $xmldata
+
+    # Invoke any callback before the rosters callback.
+    # @@@ Right place ???
+    if {[info exists prescmd($id)]} {
+	uplevel #0 $prescmd($id) [list $jlibname $xmldata]
+	unset -nocomplain prescmd($id)
+    }	
+    
+    # This is the last station.
+    if {[string length $opts(-presencecommand)]} {
+	uplevel #0 $opts(-presencecommand) [list $jlibname $xmldata]
+    }
+}
+
+# jlib::features_handler --
+# 
+#       Callback for the <stream:features> element.
+
+proc jlib::features_handler {jlibname xmllist} {
+
+    upvar ${jlibname}::features features
+    variable xmppxmlns
+    variable jxmlns
+    
+    Debug 4 "jlib::features_handler"
+
+    set features(xmllist) $xmllist
+
+    foreach child [wrapper::getchildren $xmllist] {
+	wrapper::splitxml $child tag attr chdata children
+	set xmlns [wrapper::getattribute $child xmlns]
+	
+	# All feature elements must be namespaced.
+	if {$xmlns eq ""} {
+	    continue
+	}
+	set features(elem,$xmlns) $child
+		
+	switch -- $tag {
+	    starttls {
+		
+		# TLS
+		if {$xmlns eq $xmppxmlns(tls)} {
+		    set features(starttls) 1
+		    set childs [wrapper::getchildswithtag $child required]
+		    if {$childs ne ""} {
+			set features(starttls,required) 1
+		    }
+		}
+	    }
+	    compression {
+		
+		# Compress
+		if {$xmlns eq $jxmlns(compress)} {
+		    set features(compression) 1
+		    foreach c [wrapper::getchildswithtag $child method] {
+			set method [wrapper::getcdata $c]
+			set features(compression,$method) 1
+		    }
+		}
+	    }
+	    mechanisms {
+		
+		# SASL
+		set mechanisms [list]
+		if {$xmlns eq $xmppxmlns(sasl)} {
+		    set features(sasl) 1
+		    foreach mechelem $children {
+			wrapper::splitxml $mechelem mtag mattr mchdata mchild
+			if {$mtag eq "mechanism"} {
+			    lappend mechanisms $mchdata
+			}
+			set features(mechanism,$mchdata) 1
+		    }
+		}
+
+		# Variable that may trigger a trace event.
+		set features(mechanisms) $mechanisms
+	    }
+	    bind {
+		if {$xmlns eq $xmppxmlns(bind)} {
+		    set features(bind) 1
+		}
+	    }
+	    session {
+		if {$xmlns eq $xmppxmlns(session)} {
+		    set features(session) 1
+		}
+	    }
+	    default {
+		
+		# Have no idea of what this could be.
+		set features($xmlns) 1
+	    }
+	}
+    }
+        
+    if {$features(trace) ne {}} {
+	uplevel #0 $features(trace) [list $jlibname]
+    }
+}
+
+# jlib::trace_stream_features --
+# 
+#       Register a callback when getting stream features.
+#       Only one component at a time.
+#       
+#       args:     tclProc  set callback
+#                 {}       unset callback
+#                 empty    return callback
+
+proc jlib::trace_stream_features {jlibname args} {
+    
+    upvar ${jlibname}::features features
+    
+    switch -- [llength $args] {
+	0 {
+	    return $features(trace)
+	}
+	1 {
+	    set features(trace) [lindex $args 0]
+	}
+	default {
+	    return -code error "Usage: trace_stream_features ?tclProc?"
+	}
+    }
+}
+
+# jlib::get_feature, have_feature --
+# 
+#       Just to get access of the stream features.
+
+proc jlib::get_feature {jlibname name {name2 ""}} {
+    
+    upvar ${jlibname}::features features
+
+    set ans ""
+    if {$name2 ne ""} {
+	if {[info exists features($name,$name2)]} {
+	    set ans $features($name,$name2)
+	}
+    } else {
+	if {[info exists features($name)]} {
+	    set ans $features($name)
+	}
+    }
+    return $ans
+}
+
+proc jlib::have_feature {jlibname {name ""} {name2 ""}} {
+    
+    upvar ${jlibname}::features features
+    
+    set ans 0
+    if {$name2 ne ""} {
+	if {[info exists features($name,$name2)]} {
+	    set ans 1
+	}
+    } elseif {$name ne ""} {
+	if {[info exists features($name)]} {
+	    set ans 1
+	}
+    } else {
+	if {[info exists features(xmllist)]} {
+	    set ans 1
+	}
+    }
+    return $ans
+}
+
+# jlib::got_stream --
+#
+#       Callback when we have parsed the initial root element.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       args:       attributes
+#       
+# Results:
+#       none.
+
+proc jlib::got_stream {jlibname args} {
+
+    upvar ${jlibname}::lib lib
+    upvar ${jlibname}::locals locals
+
+    Debug 4 "jlib::got_stream jlibname=$jlibname, args='$args'"
+    
+    # Cache stream attributes.
+    foreach {name value} $args {
+	set locals(streamattr,$name) $value
+    }
+    
+    # The streams 'from' attribute has the "last word" on the servers name.
+    if {[info exists locals(streamattr,from)]} {
+	set locals(server)    $locals(streamattr,from)
+	set locals(servermap) [jidmap $locals(server)]
+    }
+    schedule_auto_away $jlibname
+    
+    # If we use    we should have a callback command here.
+    if {[info exists lib(streamcmd)] && [llength $lib(streamcmd)]} {
+	uplevel #0 $lib(streamcmd) $jlibname $args
+	unset lib(streamcmd)
+    }
+}
+
+# jlib::getthis --
+# 
+#       Access function for: server, username, myjid, myjid2...
+
+proc jlib::getthis {jlibname name} {
+    
+    upvar ${jlibname}::locals locals
+    
+    if {[info exists locals($name)]} {
+	return $locals($name)
+    } else {
+	return
+    }
+}
+
+# jlib::getstreamattr --
+# 
+#       Returns the value of any stream attribute, typically 'id'.
+
+proc jlib::getstreamattr {jlibname name} {
+    
+    upvar ${jlibname}::locals locals
+    
+    if {[info exists locals(streamattr,$name)]} {
+	return $locals(streamattr,$name)
+    } else {
+	return
+    }
+}
+
+# jlib::end_of_parse --
+#
+#       Callback when the ending root element is parsed.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       
+# Results:
+#       none.
+
+proc jlib::end_of_parse {jlibname} {
+
+    upvar ${jlibname}::lib lib
+
+    Debug 4 "jlib::end_of_parse jlibname=$jlibname"
+    
+    catch {eval $lib(transport,reset) $jlibname}
+    invoke_async_error $jlibname disconnect
+    reset $jlibname
+}
+
+# jlib::error_handler --
+# 
+#       Callback when receiving an stream:error element. According to xmpp-core
+#       this is an unrecoverable error (4.7.1) and the stream MUST be closed
+#       and the TCP connection also be closed.
+#       
+#       jabberd 1.4.3: <stream:error>Disconnected</stream:error>
+#       jabberd 1.4.4: 
+#       <stream:error>
+#           <xml-not-well-formed xmlns='urn:ietf:params:xml:ns:xmpp-streams'/>
+#       </stream:error>
+#   </stream:stream>
+
+proc jlib::error_handler {jlibname xmllist} {
+
+    variable xmppxmlns
+    
+    Debug 4 "jlib::error_handler"
+    
+    # This should handle all internal stuff.
+    closestream $jlibname
+    
+    if {[llength [wrapper::getchildren $xmllist]]} {
+	set errspec [getstreamerrorspec $xmllist]
+	set errcode "xmpp-streams-error-[lindex $errspec 0]"
+	set errmsg [lindex $errspec 1]
+    } else {
+	set errcode xmpp-streams-error
+	set errmsg [wrapper::getcdata $xmllist]
+    }
+    invoke_async_error $jlibname $errcode $errmsg
+}
+
+# jlib::xmlerror --
+#
+#       Callback when we receive an XML error from the wrapper (parser).
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       
+# Results:
+#       none.
+
+proc jlib::xmlerror {jlibname args} {
+
+    Debug 4 "jlib::xmlerror jlibname=$jlibname, args='$args'"
+    
+    # This should handle all internal stuff.
+    closestream $jlibname
+    invoke_async_error $jlibname xmlerror $args
+}
+
+# jlib::reset --
+#
+#       Unsets all iqcmd($id) callback procedures.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       
+# Results:
+#       none.
+
+proc jlib::reset {jlibname} {
+
+    upvar ${jlibname}::lib lib
+    upvar ${jlibname}::iqcmd iqcmd
+    upvar ${jlibname}::prescmd prescmd
+    upvar ${jlibname}::locals locals
+    upvar ${jlibname}::features features
+    
+    Debug 4 "jlib::reset"
+    
+    cancel_auto_away $jlibname
+    
+    set num $iqcmd(uid)
+    unset -nocomplain iqcmd
+    set iqcmd(uid) $num
+    
+    set num $prescmd(uid)
+    unset -nocomplain prescmd
+    set prescmd(uid) $num
+    
+    unset -nocomplain locals
+    unset -nocomplain features
+    
+    init_inst $jlibname
+
+    set lib(isinstream) 0
+    set lib(state) "reset"
+
+    stream_reset $jlibname
+    if {[havesasl]} {
+	sasl_reset $jlibname
+    }
+    if {[havetls]} {
+	tls_reset $jlibname
+    }
+        
+    # Execute any register reset commands.
+    foreach cmd $lib(resetCmds) {
+	uplevel #0 $cmd $jlibname
+    }
+}
+
+# jlib::stream_reset --
+# 
+#       Clears out all variables that are cached for this stream.
+#       The xmpp specifies that any information obtained during tls,sasl
+#       must be discarded before opening a new stream.
+#       Call this before opening a new stream
+
+proc jlib::stream_reset {jlibname} {
+    
+    upvar ${jlibname}::locals locals
+    upvar ${jlibname}::features features
+    
+    array unset locals streamattr,*
+    
+    set cmd $features(trace)
+    unset -nocomplain features
+    set features(trace) $cmd
+}
+
+# jlib::getstanzaerrorspec --
+# 
+#       Extracts the error code and an error message from an type='error'
+#       element. We must handle both the original Jabber protocol and the
+#       XMPP protocol:
+#
+#   The syntax for stanza-related errors is as follows (XMPP):
+#
+#   <stanza-kind to='sender' type='error'>
+#     [RECOMMENDED to include sender XML here]
+#     <error type='error-type'>
+#       <defined-condition xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>
+#       <text xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'>
+#         OPTIONAL descriptive text
+#       </text>
+#       [OPTIONAL application-specific condition element]
+#     </error>
+#   </stanza-kind>
+#   
+#   Jabber:
+#   
+#   <iq type='error'>
+#     <query ...>
+#       <error code='..'> ... </error>
+#     </query>
+#   </iq>
+#   
+#   or:
+#   <iq type='error'>
+#     <error code='401'/>
+#     <query ...>...</query>
+#   </iq>
+#   
+#   or:
+#   <message type='error' ...>
+#       ...
+#       <error code='403'>Forbidden</error>
+#   </message>
+
+proc jlib::getstanzaerrorspec {stanza} {
+    
+    variable xmppxmlns
+
+    set errcode ""
+    set errmsg  ""
+        
+    # First search children of stanza (<iq> element) for error element.
+    foreach child [wrapper::getchildren $stanza] {
+	set tag [wrapper::gettag $child]
+	if {[string equal $tag "error"]} {
+	    set errelem $child
+	}
+	if {[string equal $tag "query"]} {
+	    set queryelem $child
+	}
+    }
+    if {![info exists errelem] && [info exists queryelem]} {
+	
+	# Search children if <query> element (Jabber).
+	set errlist [wrapper::getchildswithtag $queryelem "error"]
+	if {[llength $errlist]} {
+	    set errelem [lindex $errlist 0]
+	}
+    }
+	
+    # Found it! XMPP contains an error stanza and not pure text.
+    if {[info exists errelem]} {
+	foreach {errcode errmsg} [geterrspecfromerror $errelem stanzas] {break}
+    }
+    return [list $errcode $errmsg]
+}
+
+# jlib::getstreamerrorspec --
+# 
+#       Extracts the error code and an error message from a stream:error
+#       element. We must handle both the original Jabber protocol and the
+#       XMPP protocol:
+#
+#   The syntax for stream errors is as follows:
+#
+#   <stream:error>
+#      <defined-condition xmlns='urn:ietf:params:xml:ns:xmpp-streams'/>
+#      <text xmlns='urn:ietf:params:xml:ns:xmpp-streams'>
+#        OPTIONAL descriptive text
+#      </text>
+#      [OPTIONAL application-specific condition element]
+#   </stream:error>
+#
+#   Jabber:
+#   
+
+proc jlib::getstreamerrorspec {errelem} {
+    
+    return [geterrspecfromerror $errelem streams]
+}
+
+# jlib::geterrspecfromerror --
+# 
+#       Get an error specification from an stanza error element.
+#       
+# Arguments:
+#       errelem:    the <error/> element
+#       kind.       'stanzas' or 'streams'
+#       
+# Results:
+#       {errcode errmsg}
+
+proc jlib::geterrspecfromerror {errelem kind} {
+       
+    variable xmppxmlns
+    variable errCodeToText
+
+    array set msgproc {
+	stanzas  stanzaerror::getmsg
+	streams  streamerror::getmsg
+    }
+    set cchdata [wrapper::getcdata $errelem]
+    set errcode [wrapper::getattribute $errelem code]
+    set errmsg  "Unknown"
+
+    if {[string is integer -strict $errcode]} {
+	if {$cchdata ne ""} {
+	    set errmsg $cchdata
+	} elseif {[info exists errCodeToText($errcode)]} {
+	    set errmsg $errCodeToText($errcode)
+	}
+    } elseif {$cchdata ne ""} {
+	
+	# Old jabber way.
+	set errmsg $cchdata
+    }
+	
+    # xmpp way.
+    foreach c [wrapper::getchildren $errelem] {
+	set tag [wrapper::gettag $c]
+	
+	switch -- $tag {
+	    text {
+		# Use only as a complement iff our language. ???
+		set xmlns [wrapper::getattribute $c xmlns]
+		set lang  [wrapper::getattribute $c xml:lang]
+		# [string equal $lang [getlang]]
+		if {[string equal $xmlns $xmppxmlns($kind)]} {
+		    set errstr [wrapper::getcdata $c]
+		}
+	    } 
+	    default {
+		set xmlns [wrapper::getattribute $c xmlns]
+		if {[string equal $xmlns $xmppxmlns($kind)]} {
+		    set errcode $tag
+		    set errstr [$msgproc($kind) $tag]
+		}
+	    }
+	}
+    }
+    if {[info exists errstr]} {
+	set errmsg $errstr
+    }
+    if {$errmsg eq ""} {
+	set errmsg "Unknown"
+    }
+    return [list $errcode $errmsg]
+}
+
+# jlib::bind_resource --
+# 
+#       xmpp requires us to bind a resource to the stream.
+
+proc jlib::bind_resource {jlibname resource cmd} {
+    
+    variable xmppxmlns
+
+    # If resource is an empty string request the server to create it.
+    set subtags [list]
+    if {$resource ne ""} {
+	set subtags [list [wrapper::createtag resource -chdata $resource]]
+    }
+    set xmllist [wrapper::createtag bind       \
+      -attrlist [list xmlns $xmppxmlns(bind)] -subtags $subtags]
+    send_iq $jlibname set [list $xmllist]  \
+      -command [list [namespace current]::parse_bind_resource $jlibname $cmd]
+}
+
+proc jlib::parse_bind_resource {jlibname cmd type subiq args} {
+    
+    upvar ${jlibname}::locals locals
+    variable xmppxmlns
+    
+    # The server MAY change the 'resource' why we need to check this here.
+    if {[string equal [wrapper::gettag $subiq] bind] &&  \
+      [string equal [wrapper::getattribute $subiq xmlns] $xmppxmlns(bind)]} {
+	set jidElem [wrapper::getfirstchildwithtag $subiq jid]
+	if {[llength $jidElem]} {
+	    
+	    # Server replies with full JID.
+	    set sjid [wrapper::getcdata $jidElem]
+	    splitjid $sjid sjid2 sresource
+	    if {![string equal [resourcemap $locals(resource)] $sresource]} {
+		set locals(myjid)     $sjid
+		set locals(myjid2)    $sjid2
+		set locals(resource)  $sresource
+		set locals(myjidmap)  [jidmap $sjid]
+		set locals(myjid2map) [jidmap $sjid2]
+	    }
+	}
+    }    
+    uplevel #0 $cmd [list $jlibname $type $subiq]
+}
+   
+# jlib::invoke_iq_callback --
+#
+#       Callback when we get server response on iq set/get.
+#       This is a generic callback procedure.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       cmd:        the 'cmd' argument in the calling procedure.
+#       type:       "error" or "ok".
+#       subiq:      if type="error", this is a list {errcode errmsg},
+#                   else it is the query element as a xml list structure.
+#       
+# Results:
+#       none.
+
+proc jlib::invoke_iq_callback {jlibname cmd type subiq} {
+
+    Debug 3 "jlib::invoke_iq_callback cmd=$cmd, type=$type, subiq=$subiq"
+    
+    uplevel #0 $cmd [list $jlibname $type $subiq]
+}
+
+# jlib::parse_search_set --
+#
+#       Callback for 'jabber:iq:search' 'result' and 'set' elements.
+#       
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       cmd:        the callback to notify.
+#       type:       "ok", "error", or "set"
+#       subiq:
+
+proc jlib::parse_search_set {jlibname cmd type subiq} {    
+
+    upvar ${jlibname}::lib lib
+
+    uplevel #0 $cmd [list $type $subiq]
+}
+
+# jlib::iq_register --
+# 
+#       Handler for registered iq callbacks.
+#       
+#       @@@ We could think of a more general mechanism here!!!!
+#       1) Using -type, -xmlns, -from etc.
+
+proc jlib::iq_register {jlibname type xmlns func {seq 50}} {
+    
+    upvar ${jlibname}::iqhook iqhook
+    
+    lappend iqhook($type,$xmlns) [list $func $seq]
+    set iqhook($type,$xmlns) \
+      [lsort -integer -index 1 [lsort -unique $iqhook($type,$xmlns)]]
+}
+
+proc jlib::iq_run_hook {jlibname type xmlns from subiq args} {
+    
+    upvar ${jlibname}::iqhook iqhook
+
+    set ishandled 0    
+
+    foreach key [list $type,$xmlns *,$xmlns $type,*] {
+	if {[info exists iqhook($key)]} {
+	    foreach spec $iqhook($key) {
+		set func [lindex $spec 0]
+		set code [catch {
+		    uplevel #0 $func [list $jlibname $from $subiq] $args
+		} ans]
+		if {$code} {
+		    bgerror "iqhook $func failed: $code\n$::errorInfo"
+		}
+		if {[string equal $ans "1"]} {
+		    set ishandled 1
+		    break
+		}
+	    }
+	}	
+	if {$ishandled} {
+	    break
+	}
+    }
+    return $ishandled
+}
+
+# jlib::message_register --
+# 
+#       Handler for registered message callbacks.
+#       
+#       We could think of a more general mechanism here!!!!
+
+proc jlib::message_register {jlibname type xmlns func {seq 50}} {
+    
+    upvar ${jlibname}::msghook msghook
+    
+    lappend msghook($type,$xmlns) [list $func $seq]
+    set msghook($type,$xmlns)  \
+      [lsort -integer -index 1 [lsort -unique $msghook($type,$xmlns)]]
+}
+
+proc jlib::message_run_hook {jlibname type xmlns xmldata args} {
+    
+    upvar ${jlibname}::msghook msghook
+
+    set ishandled 0
+    
+    foreach key [list $type,$xmlns *,$xmlns $type,*] {
+	if {[info exists msghook($key)]} {
+	    foreach spec $msghook($key) {
+		set func [lindex $spec 0]
+		set code [catch {
+		    uplevel #0 $func [list $jlibname $xmlns $xmldata] $args
+		} ans]
+		if {$code} {
+		    bgerror "msghook $func failed: $code\n$::errorInfo"
+		}
+		if {[string equal $ans "1"]} {
+		    set ishandled 1
+		    break
+		}
+	    }
+	}	
+	if {$ishandled} {
+	    break
+	}
+    }
+    return $ishandled
+}
+
+# @@@ We keep two versions, internal for jlib usage and external for apps.
+#     Do this for all registered callbacks!
+
+# jlib::presence_register --
+# 
+#       Handler for registered presence callbacks. Simple version.
+
+proc jlib::presence_register_int {jlibname type func {seq 50}} {
+    pres_reg $jlibname 1 $type $func $seq
+}
+
+proc jlib::presence_register {jlibname type func {seq 50}} {
+    pres_reg $jlibname 0 $type $func $seq
+}
+
+proc jlib::pres_reg {jlibname int type func {seq 50}} {
+    
+    upvar ${jlibname}::preshook preshook
+    
+    lappend preshook($int,$type) [list $func $seq]
+    set preshook($int,$type)  \
+      [lsort -integer -index 1 [lsort -unique $preshook($int,$type)]]
+}
+
+proc jlib::presence_run_hook {jlibname int xmldata} {
+    
+    upvar ${jlibname}::preshook preshook
+    upvar ${jlibname}::locals locals
+    
+    set type [wrapper::getattribute $xmldata type]
+    set from [wrapper::getattribute $xmldata from]
+    if {$type eq ""} {
+	set type "available"
+    }
+    if {$from eq ""} {
+	set from $locals(server)
+    }
+    set ishandled 0
+    
+    if {[info exists preshook($int,$type)]} {
+	foreach spec $preshook($int,$type) {
+	    set func [lindex $spec 0]
+	    set code [catch {
+		uplevel #0 $func [list $jlibname $xmldata]
+	    } ans]
+	    if {$code} {
+		bgerror "preshook $func failed: $code\n$::errorInfo"
+	    }
+	    if {[string equal $ans "1"]} {
+		set ishandled 1
+		break
+	    }
+	}
+    }
+    return $ishandled
+}
+
+proc jlib::presence_deregister_int {jlibname type func} {
+    pres_dereg $jlibname 1 $type $func
+}
+
+proc jlib::presence_deregister {jlibname type func} {
+    pres_dereg $jlibname 0 $type $func
+}
+
+proc jlib::pres_dereg {jlibname int type func} {
+    
+    upvar ${jlibname}::preshook preshook
+    
+    if {[info exists preshook($int,$type)]} {
+	set idx [lsearch -glob $preshook($int,$type) "$func *"]
+	if {$idx >= 0} {
+	    set preshook($int,$type) [lreplace $preshook($int,$type) $idx $idx]
+	}
+    }
+}
+
+# jlib::presence_register_ex --
+# 
+#       Set extended presence callbacks which can be triggered for
+#       various attributes and elements.
+#       
+#       The internal storage consists of two parts:
+#       1) attributes; stored as array keys using wildcards (*)
+#       2) elements  : stored as a -tag .. -xmlns .. list
+#       
+#       expreshook($type,$from,$from2) {{{-key value ...} tclProc seq} {...} ...}
+#       
+#       These are matched separately but not independently.
+#       
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       func:       tclProc        
+#       args:       -type     type and from must match the presence element
+#                   -from     attributes
+#                   -from2    match the bare from jid
+#                   -tag      tag and xmlns must coexist in the same element
+#                   -xmlns    for a valid match
+#                   -seq      priority 0-100 (D=50)
+#       
+# Results:
+#       none.
+
+proc jlib::presence_register_ex_int {jlibname func args} {
+    eval {pres_reg_ex $jlibname 1 $func} $args
+}
+
+proc jlib::presence_register_ex {jlibname func args} {
+    eval {pres_reg_ex $jlibname 0 $func} $args
+}
+
+proc jlib::pres_reg_ex {jlibname int func args} {
+    
+    upvar ${jlibname}::expreshook expreshook
+
+    set type  "*"
+    set from  "*"
+    set from2 "*"
+    set seq   50
+
+    foreach {key value} $args {
+	switch -- $key {
+	    -from - -from2 {
+		set name [string trimleft $key "-"]
+		set $name [ESC $value]
+	    }
+	    -type {
+		set type $value
+	    }
+	    -tag - -xmlns {
+		set aopts($key) $value
+	    }
+	    -seq {
+		set seq $value
+	    }
+	}
+    }
+    set pat "$type,$from,$from2"
+    
+    # The 'opts' must be ordered.
+    set opts [list]
+    foreach key [array names aopts] {
+	lappend opts $key $aopts($key)
+    }
+    lappend expreshook($int,$pat) [list $opts $func $seq]
+    set expreshook($int,$pat)  \
+      [lsort -integer -index 2 [lsort -unique $expreshook($int,$pat)]]  
+}
+
+proc jlib::presence_ex_run_hook {jlibname int xmldata} {
+
+    upvar ${jlibname}::expreshook expreshook
+    upvar ${jlibname}::locals locals
+    
+    set type [wrapper::getattribute $xmldata type]
+    set from [wrapper::getattribute $xmldata from]
+    if {$type eq ""} {
+	set type "available"
+    }
+    if {$from eq ""} {
+	set from $locals(server)
+    }
+    set from2 [barejid $from]
+    set pkey "$int,$type,$from,$from2"
+            
+    # Make matching in two steps, attributes and elements.
+    # First the attributes.
+    set matched [list]
+    foreach {pat value} [array get expreshook $int,*] {
+
+	if {[string match $pat $pkey]} {
+	    
+	    foreach spec $value {
+    
+		# Match attributes only if opts empty.
+		if {[lindex $spec 0] eq {}} {
+		    set func [lindex $spec 1]
+		    set code [catch {
+			uplevel #0 $func [list $jlibname $xmldata]
+		    } ans]
+		    if {$code} {
+			bgerror "preshook $func failed: $code\n$::errorInfo"
+		    }
+		} else {
+		    
+		    # Collect all callbacks that match the attributes and have
+		    # a nonempty element spec.
+		    lappend matched $spec
+		}
+	    }
+	}
+    }
+    
+    # Now try match the elements with the ones that matched the attributes.
+    if {[llength $matched]} {
+	
+	# Start by collecting all tags and xmlns we have in 'xmldata'.
+	set tagxmlns [list]
+	foreach c [wrapper::getchildren $xmldata] {
+	    set xmlns [wrapper::getattribute $c xmlns]
+	    lappend tagxmlns [list [wrapper::gettag $c] $xmlns]	    
+	}
+
+	foreach spec $matched {
+	    array set opts {-tag * -xmlns *}
+	    array set opts [lindex $spec 0]
+
+	    # The 'olist' must be ordered.
+	    set olist [list $opts(-tag) $opts(-xmlns)]
+	    set idx [lsearch -glob $tagxmlns $olist]
+	    if {$idx >= 0} {
+		set func [lindex $spec 1]
+		set code [catch {
+		    uplevel #0 $func [list $jlibname $xmldata]
+		} ans]
+		if {$code} {
+		    bgerror "preshook $func failed: $code\n$::errorInfo"
+		}
+	    }
+	}
+    }
+}
+
+proc jlib::presence_deregister_ex_int {jlibname func args} {
+    eval {pres_dereg_ex $jlibname 1 $func} $args
+}
+
+proc jlib::presence_deregister_ex {jlibname func args} {
+    eval {pres_dereg_ex $jlibname 0 $func} $args
+}
+
+proc jlib::pres_dereg_ex {jlibname int func args} {
+    
+    upvar ${jlibname}::expreshook expreshook
+    
+    set type  "*"
+    set from  "*"
+    set from2 "*"
+    set seq   "*"
+
+    foreach {key value} $args {
+	switch -- $key {
+	    -from - -from2 {
+		set name [string trimleft $key "-"]
+		set $name [jlib::ESC $value]
+	    }
+	    -type {
+		set type $value
+	    }
+	    -tag - -xmlns {
+		set aopts($key) $value
+	    }
+	    -seq {
+		set seq $value
+	    }
+	}
+    }
+    set pat "$type,$from,$from2"
+    if {[info exists expreshook($int,$pat)]} {
+
+	# The 'opts' must be ordered.
+	set opts [list]
+	foreach key [array names aopts] {
+	    lappend opts $key $aopts($key)
+	}
+	set idx [lsearch -glob $expreshook($int,$pat) [list $opts $func $seq]]
+	if {$idx >= 0} {
+	    set expreshook($int,$pat) [lreplace $expreshook($int,$pat) $idx $idx]
+	    if {$expreshook($int,$pat) eq {}} {
+		unset expreshook($int,$pat)
+	    }
+	}
+    }
+}
+
+# jlib::element_register --
+# 
+#       Used to get callbacks from non stanza elements, like sasl etc.
+
+proc jlib::element_register {jlibname xmlns func {seq 50}} {
+    
+    upvar ${jlibname}::elementhook elementhook
+    
+    lappend elementhook($xmlns) [list $func $seq]
+    set elementhook($xmlns)  \
+      [lsort -integer -index 1 [lsort -unique $elementhook($xmlns)]]
+}
+
+proc jlib::element_deregister {jlibname xmlns func} {
+    
+    upvar ${jlibname}::elementhook elementhook
+    
+    if {![info exists elementhook($xmlns)]} {
+	return
+    }
+    set ind -1
+    set found 0
+    foreach spec $elementhook($xmlns) {
+	incr ind
+	if {[string equal $func [lindex $spec 0]]} {
+	    set found 1
+	    break
+	}
+    }
+    if {$found} {
+	set elementhook($xmlns) [lreplace $elementhook($xmlns) $ind $ind]
+    }
+}
+
+proc jlib::element_run_hook {jlibname xmldata} {
+    
+    upvar ${jlibname}::elementhook elementhook
+
+    set ishandled 0
+    set xmlns [wrapper::getattribute $xmldata xmlns]
+    
+    if {[info exists elementhook($xmlns)]} {
+	foreach spec $elementhook($xmlns) {
+	    set func [lindex $spec 0]
+	    set code [catch {
+		uplevel #0 $func [list $jlibname $xmldata]
+	    } ans]
+	    if {$code} {
+		bgerror "preshook $func failed: $code\n$::errorInfo"
+	    }
+	    if {[string equal $ans "1"]} {
+		set ishandled 1
+		break
+	    }
+	}
+    }
+    return $ishandled
+}
+
+# This part is supposed to be a maximal flexible event register mechanism.
+# 
+# Bind:  stanza  (presence, iq, message,...)
+#        its attributes  (optional)
+#        any child tag name  (optional)
+#        its attributes  (optional)
+#        
+# genhook(stanza) = {{attrspec childspec func seq} ...}
+# 
+# with:  attrspec = {name1 value1 name2 value2 ...}
+#        childspec = {tag attrspec}
+
+# jlib::general_register --
+# 
+#       A mechanism to register for almost any kind of elements.
+
+proc jlib::general_register {jlibname tag attrspec childspec func {seq 50}} {
+    
+    upvar ${jlibname}::genhook genhook
+    
+    lappend genhook($tag) [list $attrspec $childspec $func $seq]
+    set genhook($tag)  \
+      [lsort -integer -index 3 [lsort -unique $genhook($tag)]]
+}
+
+proc jlib::general_run_hook {jlibname xmldata} {
+
+    upvar ${jlibname}::genhook genhook
+
+    set ishandled 0
+    set tag [wrapper::gettag $xmldata]
+    if {[info exists genhook($tag)]} {
+	foreach spec $genhook($tag) {
+	    lassign $spec attrspec childspec func seq
+	    lassign $childspec ctag cattrspec
+	    if {![match_attr $attrspec [wrapper::getattrlist $xmldata]]} {
+		continue
+	    }
+	    
+	    # Search child elements for matches.
+	    set match 0
+	    foreach c [wrapper::getchildren $xmldata] {
+		if {$ctag ne "" && $ctag ne [wrapper::gettag $c]} {
+		    continue
+		}
+		if {![match_attr $cattrspec [wrapper::getattrlist $c]]} {
+		    continue
+		}
+		set match 1
+		break
+	    }
+	    if {!$match} {
+		continue
+	    }
+	    
+	    # If the spec survived here it matched.
+	    set code [catch {
+		uplevel #0 $func [list $jlibname $xmldata]
+	    } ans]
+	    if {$code} {
+		bgerror "genhook $func failed: $code\n$::errorInfo"
+	    }
+	    if {[string equal $ans "1"]} {
+		set ishandled 1
+		break
+	    }
+	}
+    }
+    return $ishandled
+}
+
+proc jlib::match_attr {attrspec attr} {
+    
+    array set attrA $attr
+    foreach {name value} $attrspec {
+	if {![info exists attrA($name)]} {
+	    return 0
+	} elseif {$value ne $attrA($name)} {
+	    return 0
+	}
+    }
+    return 1
+}
+
+proc jlib::general_deregister {jlibname tag attrspec childspec func} {
+    
+    upvar ${jlibname}::genhook genhook
+
+    if {[info exists genhook($tag)]} {
+	set idx [lsearch -glob $genhook($tag) [list $attrspec $childspec $func *]]
+	if {$idx >= 0} {
+	    set genhook($tag) [lreplace $genhook($tag) $idx $idx]
+	
+	}
+    }
+}
+
+# Test code...
+if {0} {
+    proc cb {args} {puts "************** $args"}
+    set childspec [list query [list xmlns "http://jabber.org/protocol/disco#items"]]
+    ::jlib::jlib1 general_register iq {} $childspec cb
+    ::jlib::jlib1 general_deregister iq {} $childspec cb
+    
+    
+}
+
+# jlib::send_iq --
+#
+#       To send an iq (info/query) packet.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       type:       can be "get", "set", "result", or "error".
+#                   "result" and "error" are used when replying an incoming iq.
+#       xmldata:    list of elements as xmllists
+#       args:
+#                   -to $to       : Specify jid to send this packet to. If it 
+#		    isn't specified, this part is set to sender's user-id by 
+#		    the server.
+#		    
+#                   -id $id       : Specify an id to send with the <iq>. 
+#                   If $type is "get", or "set", then the id will be generated 
+#                   by jlib internally, and this switch will not work. 
+#                   If $type is "result" or "error", then you may use this 
+#                   switch.
+#                   
+#                   -command $cmd : Specify a callback to call when the 
+#                   reply-packet is got. This switch will not work if $type 
+#                   is "result" or "error".
+#       
+# Results:
+#       none.
+
+proc jlib::send_iq {jlibname type xmldata args} {
+
+    upvar ${jlibname}::lib lib
+    upvar ${jlibname}::iqcmd iqcmd
+        
+    Debug 3 "jlib::send_iq type='$type', xmldata='$xmldata', args='$args'"
+    
+    array set argsA $args
+    set attrlist [list "type" $type]
+    
+    # Need to generate a unique identifier (id) for this packet.
+    if {[string equal $type "get"] || [string equal $type "set"]} {
+	lappend attrlist "id" $iqcmd(uid)
+	
+	# Record any callback procedure.
+	if {[info exists argsA(-command)] && ($argsA(-command) ne "")} {
+	    set iqcmd($iqcmd(uid)) $argsA(-command)
+	}
+	incr iqcmd(uid)
+    } elseif {[info exists argsA(-id)]} {
+	lappend attrlist "id" $argsA(-id)
+    }
+    unset -nocomplain argsA(-id) argsA(-command)
+    foreach {key value} [array get argsA] {
+	set name [string trimleft $key -]
+	lappend attrlist $name $value
+    }
+    set xmllist [wrapper::createtag "iq" -attrlist $attrlist -subtags $xmldata]
+
+    send $jlibname $xmllist
+    return
+}
+
+# jlib::iq_get, iq_set --
+#
+#       Wrapper for 'send_iq' for set/getting namespaced elements.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       xmlns:
+#       args:     -to recepient jid
+#                 -command procName
+#                 -sublists
+#                 else as attributes
+#       
+# Results:
+#       none.
+
+proc jlib::iq_get {jlibname xmlns args} {
+
+    set opts [list]
+    set sublists [list]
+    set attrlist [list xmlns $xmlns]
+    foreach {key value} $args {
+	
+	switch -- $key {
+	    -command {
+		lappend opts -command  \
+		  [list [namespace current]::invoke_iq_callback $jlibname $value]
+	    }
+	    -to {
+		lappend opts -to $value
+	    }
+	    -sublists {
+		set sublists $value
+	    }
+	    default {
+		lappend attrlist [string trimleft $key "-"] $value
+	    }
+	}
+    }
+    set xmllist [wrapper::createtag "query" -attrlist $attrlist \
+      -subtags $sublists]
+    eval {send_iq $jlibname "get" [list $xmllist]} $opts
+    return
+}
+
+proc jlib::iq_set {jlibname xmlns args} {
+
+    set opts [list]
+    set sublists [list]
+    foreach {key value} $args {
+	
+	switch -- $key {
+	    -command {
+		lappend opts -command  \
+		  [list [namespace current]::invoke_iq_callback $jlibname $value]
+	    }
+	    -to {
+		lappend opts -to $value
+	    }
+	    -sublists {
+		set sublists $value
+	    }
+	    default {
+		#lappend subelements [wrapper::createtag  \
+		#  [string trimleft $key -] -chdata $value]		
+	    }
+	}
+    }
+    set xmllist [wrapper::createtag "query" -attrlist [list xmlns $xmlns] \
+      -subtags $sublists]
+    eval {send_iq $jlibname "set" [list $xmllist]} $opts
+    return
+}
+
+# jlib::send_auth --
+#
+#       Send simple client authentication.
+#       It implements the 'jabber:iq:auth' set method.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       username:
+#       resource:
+#       cmd:        client command to be executed at the iq "result" element.
+#       args:       Any of "-password" or "-digest" must be given.
+#           -password
+#           -digest
+#           -to
+#       
+# Results:
+#       none.
+
+proc jlib::send_auth {jlibname username resource cmd args} {
+
+    upvar ${jlibname}::locals locals
+
+    set subelements [list  \
+      [wrapper::createtag "username" -chdata $username]  \
+      [wrapper::createtag "resource" -chdata $resource]]
+    set toopt [list]
+
+    foreach {key value} $args {
+	switch -- $key {
+	    -password - -digest {
+		lappend subelements [wrapper::createtag  \
+		  [string trimleft $key -] -chdata $value]
+	    }
+	    -to {
+		set toopt [list -to $value]
+	    }
+	}
+    }
+    
+    # Cache our login jid.
+    set myjid  ${username}@$locals(server)/${resource}
+    set myjid2 ${username}@$locals(server)
+
+    set locals(username)  $username
+    set locals(resource)  $resource
+    set locals(myjid)     $myjid
+    set locals(myjid2)    $myjid2
+    set locals(myjidmap)  [jidmap $myjid]
+    set locals(myjid2map) [jidmap $myjid2]
+
+    set xmllist [wrapper::createtag "query" -attrlist {xmlns jabber:iq:auth} \
+      -subtags $subelements]
+    eval {send_iq $jlibname "set" [list $xmllist] -command  \
+      [list [namespace current]::invoke_iq_callback $jlibname $cmd]} $toopt
+
+    return
+}
+
+# jlib::register_get --
+#
+#       Sent with a blank query to retrieve registration information.
+#       Retrieves a key for use on future registration pushes.
+#       It implements the 'jabber:iq:register' get method.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       cmd:        client command to be executed at the iq "result" element.
+#       args:       -to     : the jid for the service
+#       
+# Results:
+#       none.
+
+proc jlib::register_get {jlibname cmd args} {
+
+    array set argsA $args
+    set xmllist [wrapper::createtag "query" -attrlist {xmlns jabber:iq:register}]
+    if {[info exists argsA(-to)]} {
+	set toopt [list -to $argsA(-to)]
+    } else {
+	set toopt ""
+    }
+    eval {send_iq $jlibname "get" [list $xmllist] -command  \
+      [list [namespace current]::invoke_iq_callback $jlibname $cmd]} $toopt
+    return
+}
+
+# jlib::register_set --
+#
+#       Create a new account with the server, or to update user information.
+#       It implements the 'jabber:iq:register' set method.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       username:
+#       password:
+#       cmd:        client command to be executed at the iq "result" element.
+#       args:       -to       : the jid for the service
+#                   -nick     :
+#                   -name     :
+#                   -first    :
+#                   -last     :
+#                   -email    :
+#                   -address  :
+#                   -city     :
+#                   -state    :
+#                   -zip      :
+#                   -phone    :
+#                   -url      :
+#                   -date     :
+#                   -misc     :
+#                   -text     :
+#                   -key      :
+#       
+# Results:
+#       none.
+
+proc jlib::register_set {jlibname username password cmd args} {
+    
+    set subelements [list  \
+      [wrapper::createtag "username" -chdata $username]  \
+      [wrapper::createtag "password" -chdata $password]]
+    array set argsA $args
+    foreach argsswitch [array names argsA] {
+	if {[string equal $argsswitch "-to"]} {
+	    continue
+	}
+	set par [string trimleft $argsswitch {-}]
+	lappend subelements [wrapper::createtag $par  \
+	  -chdata $argsA($argsswitch)]
+    }
+    set xmllist [wrapper::createtag "query"  \
+      -attrlist {xmlns jabber:iq:register}   \
+      -subtags $subelements]
+    
+    if {[info exists argsA(-to)]} {
+	set toopt [list -to $argsA(-to)]
+    } else {
+	set toopt ""
+    }
+    eval {send_iq $jlibname "set" [list $xmllist] -command  \
+      [list [namespace current]::invoke_iq_callback $jlibname $cmd]} $toopt
+    return
+}
+
+# jlib::register_remove --
+#
+#       It implements the 'jabber:iq:register' set method with a <remove/> tag.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       to:
+#       cmd:        client command to be executed at the iq "result" element.
+#       args    -key
+#       
+# Results:
+#       none.
+
+proc jlib::register_remove {jlibname to cmd args} {
+
+    set subelements [list [wrapper::createtag "remove"]]
+    array set argsA $args
+    if {[info exists argsA(-key)]} {
+	lappend subelements [wrapper::createtag "key" -chdata $argsA(-key)]
+    }
+    set xmllist [wrapper::createtag "query"  \
+      -attrlist {xmlns jabber:iq:register} -subtags $subelements]
+
+    eval {send_iq $jlibname "set" [list $xmllist] -command   \
+      [list [namespace current]::invoke_iq_callback $jlibname $cmd]} -to $to
+    return
+}
+
+# jlib::search_get --
+#
+#       Sent with a blank query to retrieve search information.
+#       Retrieves a key for use on future search pushes.
+#       It implements the 'jabber:iq:search' get method.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       to:         this must be a searchable jud service, typically 
+#                   'jud.jabber.org'.
+#       cmd:        client command to be executed at the iq "result" element.
+#       
+# Results:
+#       none.
+
+proc jlib::search_get {jlibname to cmd} {
+    
+    set xmllist [wrapper::createtag "query" -attrlist {xmlns jabber:iq:search}]
+    send_iq $jlibname "get" [list $xmllist] -to $to -command        \
+      [list [namespace current]::invoke_iq_callback $jlibname $cmd]
+    return
+}
+
+# jlib::search_set --
+#
+#       Makes an actual search in our roster at the server.
+#       It implements the 'jabber:iq:search' set method.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       cmd:        client command to be executed at the iq "result" element.
+#       to:         this must be a searchable jud service, typically 
+#                   'jud.jabber.org'.
+#       args:    -subtags list
+#       
+# Results:
+#       none.
+
+proc jlib::search_set {jlibname to cmd args} {
+
+    set argsA(-subtags) [list]
+    array set argsA $args
+
+    set xmllist [wrapper::createtag "query"  \
+      -attrlist {xmlns jabber:iq:search}   \
+      -subtags $argsA(-subtags)]
+    send_iq $jlibname "set" [list $xmllist] -to $to -command  \
+      [list [namespace current]::parse_search_set $jlibname $cmd]
+
+    return
+}
+
+# jlib::send_message --
+#
+#       Sends a message element.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       to:         the jabber id of the receiver.
+#       args:
+#                   -subject $subject     : Set subject of the message to 
+#                   $subject.
+#
+#                   -thread $thread       : Set thread of the message to 
+#                   $thread.
+#                   
+#                   -priority $priority   : Set priority of the message to 
+#                   $priority.
+#
+#                   -body text            : 
+#                   
+#                   -type $type           : normal, chat or groupchat
+#                   
+#                   -id token
+#                   
+#                   -from                 : only for internal use, never send
+#
+#                   -xlist $xlist         : A list containing *X* xml_data. 
+#                   Anything can be put inside an *X*. Please make sure you 
+#                   created it with "wrapper::createtag" procedure, 
+#                   and also, it has a "xmlns" attribute in its root tag. 
+#
+#                   -command
+#                   
+# Results:
+#       none.
+
+proc jlib::send_message {jlibname to args} {
+
+    upvar ${jlibname}::msgcmd msgcmd
+    upvar ${jlibname}::locals locals 
+
+    Debug 3 "jlib::send_message to=$to, args=$args"
+    
+    array set argsA $args
+    if {[info exists argsA(-command)]} {
+	set uid $msgcmd(uid)
+	set msgcmd($uid) $argsA(-command)
+	incr msgcmd(uid)
+	lappend args -id $uid
+	unset argsA(-command)
+	
+	# There exist a weird situation if we send to ourself.
+	# Skip this registered command the 1st time we get this,
+	# and let any handlers take over. Trigger this 2nd time.
+	if {[string equal $to $locals(myjidmap)]} {
+	    set msgcmd($uid,self) 1
+	}
+	
+    }
+    set xmllist [eval {send_message_xmllist $to} [array get argsA]]
+    send $jlibname $xmllist
+    return
+}
+
+# jlib::send_message_xmllist --
+# 
+#       Create the xml list for send_message.
+
+proc jlib::send_message_xmllist {to args} {
+    
+    array set argsA $args
+    set attr [list to $to]
+    set children [list]
+    
+    foreach {name value} $args {
+	set par [string trimleft $name "-"]
+	
+	switch -- $name {
+	    -xlist {
+		foreach xchild $value {
+		    lappend children $xchild
+		}
+	    }
+	    -type {
+		if {![string equal $value "normal"]} {
+		    lappend attr "type" $value
+		}
+	    }
+	    -id - -from {
+		lappend attr $par $value
+	    }
+	    default {
+		lappend children [wrapper::createtag $par -chdata $value]
+	    }
+	}
+    }
+    return [wrapper::createtag "message" -attrlist $attr -subtags $children]
+}
+
+# jlib::send_presence --
+#
+#       To send your presence.
+#
+# Arguments:
+# 
+#       jlibname:   the instance of this jlib.
+#       args:
+#           -keep   0|1 (D=0) we may keep the present 'status' and 'show'
+#                   elements for undirected presence
+#           -to     the JID of the recepient.
+#           -from   should never be set by client!
+#           -type   one of 'available', 'unavailable', 'subscribe', 
+#                   'unsubscribe', 'subscribed', 'unsubscribed', 'invisible'.
+#           -status
+#           -priority  persistant option if undirected presence
+#           -show
+#           -xlist
+#           -extras
+#           -command   Specify a callback to call if we may expect any reply
+#                   package, as entering a room with 'gc-1.0'.
+#     
+# Results:
+#       none.
+
+proc jlib::send_presence {jlibname args} {
+
+    variable statics
+    upvar ${jlibname}::locals locals
+    upvar ${jlibname}::opts opts
+    upvar ${jlibname}::prescmd prescmd
+    upvar ${jlibname}::pres pres
+    
+    Debug 3 "jlib::send_presence args='$args'"
+    
+    set attrlist [list]
+    set children [list]
+    set directed 0
+    set keep     0
+    set type "available"
+    array set argsA $args
+    
+    foreach {key value} $args {
+	set par [string trimleft $key -]
+	
+	switch -- $key {
+	    -command {
+		lappend attrlist "id" $prescmd(uid)
+		set prescmd($prescmd(uid)) $value
+		incr prescmd(uid)
+	    }
+	    -extras - -xlist {
+		foreach xchild $value {
+		    lappend children $xchild
+		}
+	    }
+	    -from {
+		# Should never happen!
+		lappend attrlist $par $value
+	    }
+	    -keep {
+		set keep $value
+	    }
+	    -priority - -show {
+		lappend children [wrapper::createtag $par -chdata $value]
+	    }
+	    -status {
+		if {$value ne ""} {
+		    lappend children [wrapper::createtag $par -chdata $value]
+		}
+	    }
+	    -to {
+		# Presence to server (undirected) shall not contain a to.
+		if {$value ne $locals(servermap)} {
+		    lappend attrlist $par $value
+		    set directed 1
+		}
+	    }
+	    -type {
+		set type $value
+		if {[regexp $statics(presenceTypeExp) $type]} {
+		    lappend attrlist $par $type
+		} else {
+		    return -code error "Is not valid presence type: \"$type\""
+		}
+	    }
+	    default {
+		return -code error "unrecognized option \"$value\""
+	    }
+	}
+    }
+    
+    # Must be destined to login server (by default).
+    if {!$directed} {
+	
+	# Each and every presence stanza MUST contain the complete presence
+	# state of the client. As a convinience we cache previous states and
+	# may use them if not set explicitly:
+	#    1.  <show/>
+	#    2.  <status/>
+	#    3.  <priority/>  Always reused if cached
+	
+	foreach name {show status} {
+	    if {[info exists argsA(-$name)]} {
+		set locals(pres,$name) $argsA(-$name)
+	    } elseif {[info exists locals(pres,$name)]} {
+		if {$keep} {
+		    lappend children [wrapper::createtag $name  \
+		      -chdata $locals(pres,$name)]
+		} else {
+		    unset -nocomplain locals(pres,$name)
+		}
+	    }
+	}
+	if {[info exists argsA(-priority)]} {
+	    set locals(pres,priority) $argsA(-priority)
+	} elseif {[info exists locals(pres,priority)]} {
+	    lappend children [wrapper::createtag "priority"  \
+	      -chdata $locals(pres,priority)]
+	}
+
+	set locals(pres,type) $type
+
+	set locals(status) $type
+	if {[info exists argsA(-show)]} {
+	    set locals(status) $argsA(-show)
+	    set locals(pres,show) $argsA(-show)
+	}
+    }
+    
+    # Assemble our registered presence stanzas. Only for undirected?
+    foreach {key elem} [array get pres "stanza,*,"] {
+	lappend children $elem
+    }
+    foreach {key elem} [array get pres "stanza,*,$type"] {
+	lappend children $elem
+    }
+    
+    set xmllist [wrapper::createtag "presence" -attrlist $attrlist \
+      -subtags $children]
+    send $jlibname $xmllist
+    
+    return
+}
+
+# jlib::register_presence_stanza, ... --
+# 
+#       Each presence element we send to the server (undirected) must contain
+#       the complete state. This is a way to add custom presence stanzas
+#       to our internal presence state to send each time we set our presence 
+#       with the server (undirected presence).
+#       They are stored by tag, xmlns, and an optional type attribute.
+#       Any existing presence stanza with identical tag/xmlns/type will 
+#       be replaced.
+#       
+# Arguments:
+#       jlibname:   the instance of this jlib
+#       elem:       xml element
+#       args        -type  available | unavailable | ...
+
+proc jlib::register_presence_stanza {jlibname elem args} {
+
+    upvar ${jlibname}::pres pres
+
+    set argsA(-type) ""
+    array set argsA $args
+    set type $argsA(-type)
+    
+    set tag   [wrapper::gettag $elem]
+    set xmlns [wrapper::getattribute $elem xmlns]
+    set pres(stanza,$tag,$xmlns,$type) $elem
+}
+
+proc jlib::deregister_presence_stanza {jlibname tag xmlns} {
+    
+    upvar ${jlibname}::pres pres
+    
+    array unset pres "stanza,$tag,$xmlns,*"
+}
+
+proc jlib::get_registered_presence_stanzas {jlibname {tag *} {xmlns *}} {
+    
+    upvar ${jlibname}::pres pres
+    
+    set stanzas [list]
+    foreach key [array names pres -glob stanza,$tag,$xmlns,*] {
+	lassign [split $key ,] - t x type
+	set spec [list $t $x $pres($key)]
+	if {$type ne ""} {
+	    lappend spec -type $type
+	}
+	lappend stanzas $spec
+    }
+    return $stanzas
+}
+
+# jlib::send --
+# 
+#       Sends general xml using a xmllist.
+#       Never throws error. Network errors reported via callback.
+
+proc jlib::send {jlibname xmllist} {
+    
+    upvar ${jlibname}::lib lib
+    upvar ${jlibname}::locals locals
+    
+    # For the auto away function.
+    if {$locals(trigAutoAway)} {
+	schedule_auto_away $jlibname
+    }
+    set locals(last) [clock seconds]
+    set xml [wrapper::createxml $xmllist]
+    foreach cmd $lib(tee,send) {
+	uplevel #0 $cmd [list $jlibname $xmllist]
+    }
+    
+    # We fail only if already in stream.
+    # The first failure reports the network error, closes the stream,
+    # which stops multiple errors to be reported to the client.
+    if {$lib(isinstream)} {
+	if {[catch {
+	    uplevel #0 $lib(transport,send) [list $jlibname $xml]
+	} err]} {
+	    kill $jlibname
+	    invoke_async_error $jlibname networkerror
+	}
+    }
+    return
+}
+
+# jlib::sendraw --
+# 
+#       Send raw xml. The caller is responsible for catching errors.
+
+proc jlib::sendraw {jlibname xml} {
+    
+    upvar ${jlibname}::lib lib
+
+    uplevel #0 $lib(transport,send) [list $jlibname $xml]
+}
+
+# jlib::mypresence --
+# 
+#       Returns any of {available away xa chat dnd invisible unavailable}
+#       for our status with the login server.
+
+proc jlib::mypresence {jlibname} {
+
+    upvar ${jlibname}::locals locals
+    
+    if {[info exists locals(pres,show)]} {
+	return $locals(pres,show)
+    } else {
+	return $locals(pres,type)
+    }
+}
+
+proc jlib::mypresencestatus {jlibname} {
+
+    upvar ${jlibname}::locals locals
+    
+    if {[info exists locals(pres,status)]} {
+	return $locals(pres,status)
+    } else {
+	return ""
+    }
+}
+
+# jlib::myjid --
+# 
+#       Returns our 3-tier jid as authorized with the login server.
+
+proc jlib::myjid {jlibname} {
+    upvar ${jlibname}::locals locals
+    return $locals(myjid)
+}
+
+proc jlib::myjid2 {jlibname} {
+    upvar ${jlibname}::locals locals
+    return $locals(myjid2)
+}
+
+proc jlib::myjidmap {jlibname} {
+    upvar ${jlibname}::locals locals
+    return $locals(myjidmap)
+}
+
+proc jlib::myjid2map {jlibname} {
+    upvar ${jlibname}::locals locals
+    return $locals(myjid2map)
+}
+
+# jlib::oob_set --
+#
+#       It implements the 'jabber:iq:oob' set method.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       to:
+#       cmd:        client command to be executed at the iq "result" element.
+#       url:
+#       args:
+#                   -desc
+#       
+# Results:
+#       none.
+
+proc jlib::oob_set {jlibname to cmd url args} {
+
+    set attrlist {xmlns jabber:iq:oob}
+    set children [list [wrapper::createtag "url" -chdata $url]]
+    array set argsA $args
+    if {[info exists argsA(-desc)] && [string length $argsA(-desc)]} {
+	lappend children [wrapper::createtag "desc" -chdata $argsA(-desc)]
+    }
+    set xmllist [wrapper::createtag query -attrlist $attrlist  \
+      -subtags $children]
+    send_iq $jlibname set [list $xmllist] -to $to -command  \
+      [list [namespace current]::invoke_iq_callback $jlibname $cmd]
+    return
+}
+
+# jlib::get_last --
+#
+#       Query the 'last' of 'to' using 'jabber:iq:last' get.
+
+proc jlib::get_last {jlibname to cmd} {
+    
+    set xmllist [wrapper::createtag "query"  \
+      -attrlist {xmlns jabber:iq:last}]
+    send_iq $jlibname "get" [list $xmllist] -to $to -command   \
+      [list [namespace current]::invoke_iq_callback $jlibname $cmd]
+    return
+}
+
+# jlib::handle_get_last --
+#
+#       Seconds since last activity. Response to 'jabber:iq:last' get.
+
+proc jlib::handle_get_last {jlibname from subiq args} {    
+
+    upvar ${jlibname}::locals locals
+    
+    array set argsA $args
+
+    set secs [expr [clock seconds] - $locals(last)]
+    set xmllist [wrapper::createtag "query"  \
+      -attrlist [list xmlns jabber:iq:last seconds $secs]]
+    
+    set opts [list]
+    if {[info exists argsA(-from)]} {
+	lappend opts -to $argsA(-from)
+    }
+    if {[info exists argsA(-id)]} {
+	lappend opts -id $argsA(-id)
+    }
+    eval {send_iq $jlibname "result" [list $xmllist]} $opts
+
+    # Tell jlib's iq-handler that we handled the event.
+    return 1
+}
+
+# jlib::get_time --
+#
+#       Query the 'time' of 'to' using 'jabber:iq:time' get.
+
+proc jlib::get_time {jlibname to cmd} {
+    
+    set xmllist [wrapper::createtag "query"  \
+      -attrlist {xmlns jabber:iq:time}]
+    send_iq $jlibname "get" [list $xmllist] -to $to -command        \
+      [list [namespace current]::invoke_iq_callback $jlibname $cmd]
+    return
+}
+
+# jlib::handle_get_time --
+#
+#       Send our time. Response to 'jabber:iq:time' get.
+
+proc jlib::handle_get_time {jlibname from subiq args} {
+    
+    array set argsA $args
+    
+    # Applications using 'jabber:iq:time' SHOULD use the old format, 
+    # not the format defined in XEP-0082.
+    set secs [clock seconds]
+    set utc [clock format $secs -format "%Y%m%dT%H:%M:%S" -gmt 1]
+    set tz "GMT"
+    set display [clock format $secs]
+    set subtags [list  \
+      [wrapper::createtag "utc" -chdata $utc]  \
+      [wrapper::createtag "tz" -chdata $tz]  \
+      [wrapper::createtag "display" -chdata $display] ]
+    set xmllist [wrapper::createtag "query" -subtags $subtags  \
+      -attrlist {xmlns jabber:iq:time}]
+
+    set opts [list]
+    if {[info exists argsA(-from)]} {
+	lappend opts -to $argsA(-from)
+    }
+    if {[info exists argsA(-id)]} {
+	lappend opts -id $argsA(-id)
+    }
+    eval {send_iq $jlibname "result" [list $xmllist]} $opts
+
+    # Tell jlib's iq-handler that we handled the event.
+    return 1
+}
+
+# Support for XEP-0202 Entity Time.
+
+proc jlib::get_entity_time {jlibname to cmd} {
+    variable jxmlns
+
+    set xmllist [wrapper::createtag "time"  \
+      -attrlist [list xmlns $jxmlns(entitytime)]]
+    send_iq $jlibname "get" [list $xmllist] -to $to -command        \
+      [list [namespace current]::invoke_iq_callback $jlibname $cmd]
+    return
+}
+
+proc jlib::handle_entity_time {jlibname from subiq args} {    
+    variable jxmlns
+
+    array set argsA $args
+
+    # Figure out our time zone in terms of HH:MM.
+    # Compare with the GMT time and take the diff. Avoid year wrap around.
+    set secs [clock seconds]
+    set day [clock format $secs -format "%j"]
+    if {$day eq "001"} {
+	incr secs [expr {24*60*60}]
+    } elseif {($day eq "365") || ($day eq "366")} {
+	incr secs [expr {-2*24*60*60}]    
+    }
+    set format "%S + 60*(%M + 60*(%H + 24*%j))"
+    set local [clock format $secs -format $format]
+    set gmt   [clock format $secs -format $format -gmt 1]
+
+    # Remove leading zeros since they will be interpreted as octals.
+    regsub -all {0+([1-9]+)} $local {\1} local
+    regsub -all {0+([1-9]+)} $gmt   {\1} gmt
+    set local [expr $local]
+    set gmt [expr $gmt]
+    set mindiff [expr {($local - $gmt)/60}]
+    set sign [expr {$mindiff >= 0 ? "" : "-"}]
+    set zhour [expr {abs($mindiff)/60}]
+    set zmin [expr {$mindiff % 60}]
+    set tzo [format "$sign%.2d:%.2d" $zhour $zmin]
+    
+    # Time format according to XEP-0082 (XMPP Date and Time Profiles).
+    # <utc>2006-12-19T17:58:35Z</utc> 
+    set utc [clock format $secs -format "%Y-%m-%dT%H:%M:%SZ" -gmt 1]
+
+    set subtags [list  \
+      [wrapper::createtag "tzo" -chdata $tzo] \
+      [wrapper::createtag "utc" -chdata $utc] ]
+    set xmllist [wrapper::createtag "time" -subtags $subtags  \
+      -attrlist [list xmlns $jxmlns(entitytime)]]
+
+    set opts [list]
+    if {[info exists argsA(-from)]} {
+	lappend opts -to $argsA(-from)
+    }
+    if {[info exists argsA(-id)]} {
+	lappend opts -id $argsA(-id)
+    }
+    eval {send_iq $jlibname "result" [list $xmllist]} $opts
+    return 1
+}
+    
+# jlib::get_version --
+#
+#       Query the 'version' of 'to' using 'jabber:iq:version' get.
+
+proc jlib::get_version {jlibname to cmd} {
+        
+    set xmllist [wrapper::createtag "query"  \
+      -attrlist {xmlns jabber:iq:version}]
+    send_iq $jlibname "get" [list $xmllist] -to $to -command   \
+      [list [namespace current]::invoke_iq_callback $jlibname $cmd]
+    return
+}
+
+# jlib::handle_get_version --
+#
+#       Send our version. Response to 'jabber:iq:version' get.
+
+proc jlib::handle_get_version {jlibname from subiq args} {
+    global  prefs tcl_platform
+    variable version
+    
+    array set argsA $args
+    
+    # Return any id!
+    set opts [list]
+    if {[info exists argsA(-id)]} {
+	set opts [list -id $argsA(-id)]
+    }
+    set os $tcl_platform(os)
+    if {[info exists tcl_platform(osVersion)]} {
+	append os " " $tcl_platform(osVersion)
+    }
+    lappend opts -to $from
+    set subtags [list  \
+      [wrapper::createtag name    -chdata "JabberLib"]  \
+      [wrapper::createtag version -chdata $version]  \
+      [wrapper::createtag os      -chdata $os] ]
+    set xmllist [wrapper::createtag query -subtags $subtags  \
+      -attrlist {xmlns jabber:iq:version}]
+    eval {send_iq $jlibname "result" [list $xmllist]} $opts
+
+    # Tell jlib's iq-handler that we handled the event.
+    return 1
+}
+
+# jlib::schedule_keepalive --
+# 
+#       Supposed to detect network failures but seems not to work like that.
+
+proc jlib::schedule_keepalive {jlibname} {   
+
+    upvar ${jlibname}::locals locals
+    upvar ${jlibname}::opts opts
+    upvar ${jlibname}::lib lib
+    
+    if {$opts(-keepalivesecs) && $lib(isinstream)} {
+	if {[catch {
+	    uplevel #0 $lib(transport,send) [list $jlibname "\n"]
+	    flush $lib(sock)
+	} err]} {
+	    kill $jlibname
+	    invoke_async_error $jlibname networkerror
+	} else {
+	    set locals(aliveid) [after [expr 1000 * $opts(-keepalivesecs)] \
+	      [list [namespace current]::schedule_keepalive $jlibname]]
+	}
+    }
+}
+
+# OUTDATED !!!!!!!!!!!!!!!!!!!!
+
+# jlib::schedule_auto_away, cancel_auto_away, auto_away_cmd
+#
+#       Procedures for auto away things.
+#       Better to use 'tk inactive' or 'tkinactive' and handle this on
+#       application level.
+
+proc jlib::schedule_auto_away {jlibname} {       
+
+    upvar ${jlibname}::locals locals
+    upvar ${jlibname}::opts opts
+    
+    cancel_auto_away $jlibname
+    if {$opts(-autoawaymins) > 0} {
+	set locals(afterawayid) [after [expr 60000 * $opts(-autoawaymins)] \
+	  [list [namespace current]::auto_away_cmd $jlibname away]]
+    }
+    if {$opts(-xautoawaymins) > 0} {
+	set locals(afterxawayid) [after [expr 60000 * $opts(-xautoawaymins)] \
+	  [list [namespace current]::auto_away_cmd $jlibname xaway]]
+    }    
+}
+
+proc jlib::cancel_auto_away {jlibname} {
+
+    upvar ${jlibname}::locals locals
+
+    if {[info exists locals(afterawayid)]} {
+	after cancel $locals(afterawayid)
+	unset locals(afterawayid)
+    }
+    if {[info exists locals(afterxawayid)]} {
+	after cancel $locals(afterxawayid)
+	unset locals(afterxawayid)
+    }
+}
+
+# jlib::auto_away_cmd --
+# 
+#       what:       "away", or "xaway"
+#       
+#       @@@ Replaced by idletime and AutoAway
+
+proc jlib::auto_away_cmd {jlibname what} {      
+
+    variable statusPriority
+    upvar ${jlibname}::locals locals
+    upvar ${jlibname}::lib lib
+    upvar ${jlibname}::opts opts
+
+    Debug 3 "jlib::auto_away_cmd what=$what"
+    
+    if {$what eq "xaway"} {
+	set status xa
+    } else {
+	set status $what
+    }
+
+    # Auto away and extended away are only set when the
+    # current status has a lower priority than away or xa respectively.
+    if {$statusPriority($locals(status)) >= $statusPriority($status)} {
+	return
+    }
+    
+    # Be sure not to trig ourselves.
+    set locals(trigAutoAway) 0
+
+    switch -- $what {
+	away {
+	    send_presence $jlibname -show "away" -status $opts(-awaymsg)
+	}
+	xaway {
+	    send_presence $jlibname -show "xa" -status $opts(-xawaymsg)
+	}
+    }
+    set locals(trigAutoAway) 1
+    uplevel #0 $lib(clientcmd) [list $jlibname $status]
+}
+
+# jlib::getrecipientjid --
+# 
+#       Tries to obtain the correct form of jid to send message to.
+#       Follows the XMPP spec, section 4.1.
+#       
+#       @@@ Perhaps this should go in app code?
+
+proc jlib::getrecipientjid {jlibname jid} {
+    variable statics
+    
+    set jid2 [barejid $jid]
+    set isroom [[namespace current]::service::isroom $jlibname $jid2]
+    if {$isroom} {
+	return $jid
+    } elseif {[info exists statics(roster)] &&  \
+      [$jlibname roster isavailable $jid]} {
+	return $jid
+    } else {
+	return $jid2
+    }
+}
+
+proc jlib::getlang {} {
+    
+    if {[catch {package require msgcat}]} {
+	return en
+    } else {
+	set lang [lindex [::msgcat::mcpreferences] end]
+    
+	switch -- $lang {
+	    "" - c - posix {
+		return en
+	    }
+	    default {
+		return $lang
+	    }
+	}
+    }
+}
+
+namespace eval jlib {
+    
+    # We just the http error codes here since may be useful if we only
+    # get the 'code' attribute in an error element.
+    # @@@ Add to message catalogs.
+    variable errCodeToText
+    array set errCodeToText {
+	100 "Continue"
+	101 "Switching Protocols"
+	200 "OK"
+	201 "Created"
+	202 "Accepted"
+	203 "Non-Authoritative Information"
+	204 "No Content"
+	205 "Reset Content"
+	206 "Partial Content"
+	300 "Multiple Choices"
+	301 "Moved Permanently"
+	302 "Found"
+	303 "See Other"
+	304 "Not Modified"
+	305 "Use Proxy"
+	307 "Temporary Redirect"
+	400 "Bad Request"
+	401 "Unauthorized"
+	402 "Payment Required"
+	403 "Forbidden"
+	404 "Not Found"
+	405 "Method Not Allowed"
+	406 "Not Acceptable"
+	407 "Proxy Authentication Required"
+	408 "Request Time-out"
+	409 "Conflict"
+	410 "Gone"
+	411 "Length Required"
+	412 "Precondition Failed"
+	413 "Request Entity Too Large"
+	414 "Request-URI Too Large"
+	415 "Unsupported Media Type"
+	416 "Requested Range Not Satisfiable"
+	417 "Expectation Failed"
+	500 "Internal Server Error"	
+	501 "Not Implemented"
+	502 "Bad Gateway"
+	503 "Service Unavailable"
+	504 "Gateway Time-out"
+	505 "HTTP Version not supported"
+    }
+}
+
+# Various utility procedures to handle jid's....................................
+
+# jlib::ESC --
+#
+#	array get and array unset accepts glob characters. These need to be
+#	escaped if they occur as part of a JID.
+#	NB1: 'string match pattern str' MUST have pattern escaped!
+#	NB2: This also applies to 'lsearch'!
+
+proc jlib::ESC {s} {
+    return [string map {* \\* ? \\? [ \\[ ] \\] \\ \\\\} $s]
+}
+
+# STRINGPREPs for the differnt parts of jids.
+
+proc jlib::UnicodeListToRE {ulist} {
+    
+    set str [string map {- -\\u} $ulist]
+    set str "\\u[join $str \\u]"
+    return [subst $str]
+}
+
+# jlib::MakeHexHexEscList --
+# 
+#       Takes a list of characters and transforms them to their hexhex form.
+#       Used by: XEP-0106: JID Escaping
+
+proc jlib::MakeHexHexEscList {clist} {
+    
+    set hexlist [list]
+    foreach c $clist {
+	scan $c %c n
+	lappend hexlist [format %x $n]
+    }
+    return $hexlist
+}
+
+proc jlib::MakeHexHexCharMap {clist} {
+    
+    set map [list]
+    foreach c $clist h [MakeHexHexEscList $clist] {
+	lappend map $c \\$h
+    }
+    return $map
+}
+
+proc jlib::MakeHexHexInvCharMap {clist} {
+    
+    set map [list]
+    foreach c $clist h [MakeHexHexEscList $clist] {
+	lappend map \\$h $c
+    }
+    return $map
+}
+
+namespace eval jlib {
+    
+    # Characters that need to be escaped since non valid.
+    #       XEP-0106: JID Escaping
+    variable jidEsc { "\&'/:<>@\\}
+    variable jidEscMap [MakeHexHexCharMap [split $jidEsc ""]]
+    variable jidEscInvMap [MakeHexHexInvCharMap [split $jidEsc ""]]
+    
+    # Prohibited ASCII characters.
+    set asciiC12C22 {\x00-\x1f\x80-\x9f\x7f\xa0}
+    set asciiC11 {\x20}
+    
+    # C.1.1 is actually allowed (RFC3491), weird!
+    set    asciiProhibit(domain) $asciiC11
+    append asciiProhibit(domain) $asciiC12C22
+    append asciiProhibit(domain) /@   
+
+    # The nodeprep prohibits these characters in addition:
+    # All whitespace characters (which reduce to U+0020, also called SP) 
+    # U+0022 (") 
+    # U+0026 (&) 
+    # U+0027 (') 
+    # U+002F (/) 
+    # U+003A (:) 
+    # U+003C (<) 
+    # U+003E (>) 
+    # U+0040 (@) 
+    set    asciiProhibit(node) {"&'/:<>@} 
+    append asciiProhibit(node) $asciiC11 
+    append asciiProhibit(node) $asciiC12C22
+    
+    set asciiProhibit(resource) $asciiC12C22
+    
+    # RFC 3454 (STRINGPREP); all unicode characters:
+    # 
+    # Maps to nothing (empty).
+    set mapB1 {
+	00ad	034f	1806	180b	180c	180d	200b	200c
+	200d	2060	fe00	fe01	fe02	fe03	fe04	fe05
+	fe06	fe07	fe08	fe09	fe0a	fe0b	fe0c	fe0d
+	fe0e	fe0f	feff    
+    }
+    
+    # ASCII space characters. Just a space.
+    set prohibitC11 {0020}
+    
+    # Non-ASCII space characters
+    set prohibitC12 {
+	00a0	1680	2000	2001	2002	2003	2004	2005
+	2006	2007	2008	2009	200a	200b	202f	205f
+	3000
+    }
+    
+    # C.2.1 ASCII control characters
+    set prohibitC21 {
+	0000-001F   007F
+    }
+    
+    # C.2.2 Non-ASCII control characters
+    set prohibitC22 {
+	0080-009f	06dd	070f	180e	200c	200d	2028
+	2029	2060	2061	2062	2063	206a-206f	feff
+	fff9-fffc       1d173-1d17a
+    }
+    
+    # C.3 Private use
+    set prohibitC3 {
+	e000-f8ff	f0000-ffffd	100000-10fffd
+    }
+    
+    # C.4 Non-character code points
+    set prohibitC4 {
+	fdd0-fdef	fffe-ffff	1fffe-1ffff	2fffe-2ffff
+	3fffe-3ffff	4fffe-4ffff	5fffe-5ffff	6fffe-6ffff
+	7fffe-7ffff	8fffe-8ffff	9fffe-9ffff	afffe-affff
+	bfffe-bffff	cfffe-cffff	dfffe-dffff	efffe-effff
+	ffffe-fffff	10fffe-10ffff
+    }
+    
+    # C.5 Surrogate codes
+    set prohibitC5 {d800-dfff}
+    
+    # C.6 Inappropriate for plain text
+    set prohibitC6 {
+	fff9	fffa	fffb	fffc	fffd
+    }
+    
+    # C.7 Inappropriate for canonical representation
+    set prohibitC7 {2ff0-2ffb}
+    
+    # C.8 Change display properties or are deprecated
+    set prohibitC8 {
+	0340	0341	200e	200f	202a	202b	202c	202d
+	202e	206a	206b	206c	206d	206e	206f
+    }
+    
+    # Test: 0, 1, 2, A-Z
+    set test {
+	0030    0031   0032    0041-005a
+    }
+    
+    # And many more...
+
+    variable mapB1RE       [UnicodeListToRE $mapB1]
+    variable prohibitC11RE [UnicodeListToRE $prohibitC11]
+    variable prohibitC12RE [UnicodeListToRE $prohibitC12]
+
+}
+
+# jlib::splitjid --
+# 
+#       Splits a general jid into a jid-2-tier and resource
+
+proc jlib::splitjid {jid jid2Var resourceVar} {
+    
+    set idx [string first / $jid]
+    if {$idx == -1} {
+	uplevel 1 [list set $jid2Var $jid]
+	uplevel 1 [list set $resourceVar {}]
+    } else {
+	set jid2 [string range $jid 0 [expr {$idx - 1}]]
+	set res [string range $jid [expr {$idx + 1}] end]
+	uplevel 1 [list set $jid2Var $jid2]
+	uplevel 1 [list set $resourceVar $res]
+    }
+}
+
+# jlib::splitjidex --
+# 
+#       Split a jid into the parts: jid = [ node "@" ] domain [ "/" resource ]
+#       Possibly empty. Doesn't check for valid content, only the form.
+#       
+#       RFC3920 3.1:
+#            jid             = [ node "@" ] domain [ "/" resource ]
+
+proc jlib::splitjidex {jid nodeVar domainVar resourceVar} {
+    
+    set node   ""
+    set domain ""
+    set res    ""
+    
+    # Node part:
+    set idx [string first @ $jid]
+    if {$idx > 0} {
+	set node [string range $jid 0 [expr {$idx-1}]]
+	set jid [string range $jid [expr {$idx+1}] end]
+    }
+
+    # Resource part:
+    set idx [string first / $jid]
+    if {$idx > 0} {
+	set res [string range $jid [expr {$idx+1}] end]
+	set jid [string range $jid 0 [expr {$idx-1}]]
+    }
+    
+    # Domain part is what remains:
+    set domain $jid
+    
+    uplevel 1 [list set $nodeVar $node]
+    uplevel 1 [list set $domainVar $domain]
+    uplevel 1 [list set $resourceVar $res]
+}
+
+proc jlib::barejid {jid} {
+    
+    set idx [string first / $jid]
+    if {$idx == -1} {
+	return $jid
+    } else {
+	return [string range $jid 0 [expr {$idx-1}]]
+    }
+}
+
+proc jlib::resourcejid {jid} {
+    set idx [string first / $jid]
+    if {$idx > 0} {
+	return [string range $jid [expr {$idx+1}] end]
+    } else {
+	return ""
+    }
+}
+
+proc jlib::isbarejid {jid} {
+    return [expr {([string first / $jid] == -1) ? 1 : 0}]
+}
+
+proc jlib::isfulljid {jid} {
+    return [expr {([string first / $jid] == -1) ? 0 : 1}]
+}
+
+# jlib::joinjid --
+# 
+#       Joins the, optionally empty, parts into a jid.
+#       domain must be nonempty though.
+
+proc jlib::joinjid {node domain resource} {
+    
+    set jid $domain
+    if {$node ne ""} {
+	set jid ${node}@${jid}
+    }
+    if {$resource ne ""} {
+	append jid "/$resource"
+    }
+    return $jid
+}
+
+# jlib::jidequal --
+# 
+#       Checks if two jids are actually equal after mapped. Does not check
+#       for prohibited characters.
+
+proc jlib::jidequal {jid1 jid2} {
+    return [string equal [jidmap $jid1] [jidmap $jid2]]
+}
+
+# jlib::jidvalidate --
+# 
+#       Checks if this is a valid jid interms of form and characters.
+
+proc jlib::jidvalidate {jid} {
+    
+    if {$jid eq ""} {
+	return 0
+    } elseif {[catch {splitjidex $jid node name resource} ans]} {
+	return 0
+    }
+    foreach what {node name resource} {
+	if {$what ne ""} {
+	    if {[catch {${what}prep [set $what]} ans]} {
+		return 0
+	    }
+	}
+    }
+    return 1
+}
+
+# String preparation (STRINGPREP) RFC3454:
+# 
+#    The steps for preparing strings are:
+#
+#  1) Map -- For each character in the input, check if it has a mapping
+#     and, if so, replace it with its mapping.  This is described in
+#     section 3.
+#
+#  2) Normalize -- Possibly normalize the result of step 1 using Unicode
+#     normalization.  This is described in section 4.
+#
+#  3) Prohibit -- Check for any characters that are not allowed in the
+#     output.  If any are found, return an error.  This is described in
+#     section 5.
+#
+#  4) Check bidi -- Possibly check for right-to-left characters, and if
+#     any are found, make sure that the whole string satisfies the
+#     requirements for bidirectional strings.  If the string does not
+#     satisfy the requirements for bidirectional strings, return an
+#     error.  This is described in section 6.
+
+# jlib::*map --
+# 
+#       Does the mapping part.
+
+proc jlib::nodemap {node} {
+
+    return [string tolower $node]
+}
+
+proc jlib::namemap {domain} { 
+ 
+    return [string tolower $domain]
+}
+
+proc jlib::resourcemap {resource} {
+    
+    # Note that resources are case sensitive!
+    return $resource
+}
+
+# jlib::*prep --
+# 
+#       Does the complete stringprep.
+
+proc jlib::nodeprep {node} {
+    variable asciiProhibit
+    
+    set node [nodemap $node]
+    if {[regexp ".*\[${asciiProhibit(node)}\].*" $node]} {
+	return -code error "node part contains illegal character(s)"
+    }
+    return $node
+}
+
+proc jlib::nameprep {domain} {   
+    variable asciiProhibit
+    
+    set domain [namemap $domain]
+    if {[regexp ".*\[${asciiProhibit(domain)}\].*" $domain]} {
+	return -code error "domain contains illegal character(s)"
+    }
+    return $domain
+}
+
+proc jlib::resourceprep {resource} {
+    variable asciiProhibit
+    
+    set resource [resourcemap $resource]
+    
+    # Orinary spaces are allowed!
+    if {[regexp ".*\[${asciiProhibit(resource)}\].*" $resource]} {
+	return -code error "resource contains illegal character(s)"
+    }
+    return $resource
+}
+
+# jlib::jidmap --
+# 
+#       Does the mapping part of STRINGPREP. Does not check for prohibited
+#       characters.
+#       
+# Results:
+#       throws an error if form unrecognized, else the mapped jid.
+
+proc jlib::jidmap {jid} {
+    
+    if {$jid eq ""} {
+	return
+    }
+    # Guard against spurious spaces.
+    set jid [string trim $jid]
+    splitjidex $jid node domain resource
+    return [joinjid [nodemap $node] [namemap $domain] [resourcemap $resource]]
+}
+
+# jlib::jidprep --
+# 
+#       Applies STRINGPREP to the individiual and specific parts of the jid.
+#       
+# Results:
+#       throws an error if prohibited, else the prepared jid.
+
+proc jlib::jidprep {jid} {
+    
+    if {$jid eq ""} {
+	return
+    }
+    splitjidex $jid node domain resource
+    set node     [nodeprep $node]
+    set domain   [nameprep $domain]
+    set resource [resourceprep $resource]
+    return [joinjid $node $domain $resource]
+}
+
+proc jlib::MapStr {str } {
+    
+    # TODO
+}
+
+# jlib::escapestr, unescapestr, escapejid, unescapejid --
+# 
+#       XEP-0106: JID Escaping 
+#       NB1: 'escapstr' and 'unescapstr' must only be applied to the node 
+#            part of a JID.
+#       NB2: 'escapstr' must never be applied twice!
+#       NB3: it is currently unclear if escaping should be allowed on "ordinary"
+#            user JIDs
+
+proc jlib::escapestr {str} {    
+    variable jidEscMap
+    return [string map $jidEscMap $str]
+}
+
+proc jlib::unescapestr {str} {
+    variable jidEscInvMap    
+    return [string map $jidEscInvMap $str]
+}
+
+proc jlib::escapejid {jid} {
+  
+    # Node part:
+    # @@@ I think there is a protocol flaw here!!!
+    set idx [string first @ $jid]
+    if {$idx > 0} {
+	set node [string range $jid 0 [expr {$idx-1}]]
+	set rest [string range $jid [expr {$idx+1}] end]
+	return [escapestr $node]@$rest
+    } else {
+	return $jid
+    }
+}
+
+proc jlib::unescapejid {jid} {
+  
+    # Node part:
+    # @@@ I think there is a protocol flaw here!!!
+    set idx [string first @ $jid]
+    if {$idx > 0} {
+	set node [string range $jid 0 [expr {$idx-1}]]
+	set rest [string range $jid [expr {$idx+1}] end]
+	return [unescapestr $node]@$rest
+    } else {
+	return $jid
+    }
+}
+
+proc jlib::setdebug {args} {
+    variable debug
+    
+    if {[llength $args] == 0} {
+	return $debug
+    } elseif {[llength $args] == 1} {
+	set debug $args
+    } else {
+	return -code error "Usage: jlib::setdebug ?integer?"
+    }
+}
+
+# jlib::generateuuid --
+# 
+#       Simplified uuid generator. See the uuid package for a better one.
+
+proc jlib::generateuuid {} {
+    set MAX_INT 0x7FFFFFFF
+    # Bugfix Eric Hassold from Evolane
+    set hex1 [format {%x} [expr {[clock clicks] & $MAX_INT}]]
+    set hex2 [format {%x} [expr {int($MAX_INT*rand())}]]
+    return $hex1-$hex2
+}
+
+proc jlib::Debug {num str} {
+    global  fdDebug
+    variable debug
+    if {$num <= $debug} {
+	if {[info exists fdDebug]} {
+	    puts $fdDebug $str
+	    flush $fdDebug
+	}
+	puts $str
+    }
+}
+
+#-------------------------------------------------------------------------------
diff --git a/lib/jabberlib/jingle.tcl b/lib/jabberlib/jingle.tcl
new file mode 100644
index 0000000..725819c
--- /dev/null
+++ b/lib/jabberlib/jingle.tcl
@@ -0,0 +1,719 @@
+#  jingle.tcl --
+#  
+#      This file is part of the jabberlib. 
+#      It provides support for the jingle stuff XEP-0166,
+#      and provides pluggable "slots" for media description formats and 
+#      transport methods, which are implemented separately. 
+#      
+#  Copyright (c) 2006  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: jingle.tcl,v 1.10 2007/07/19 06:28:17 matben Exp $
+# 
+############################# USAGE ############################################
+#
+#   NAME
+#      jingle - library for Jingle
+#      
+#   SYNOPSIS
+#      jlib::jingle::init jlibname
+#      jlib::jingle::register name priority mediaElems transportElems tclProc
+#      
+#   The 'tclProc' is invoked for all jingle 'set' we get as:
+#   
+#      tclProc {jlibname jingleElem args}
+#      
+#   where the args are as usual the iq attributes, and the jingleElem is
+#   guranteed to be a valid jingle element with the required attributes.
+#      
+#   OPTIONS
+#   
+#	
+#   INSTANCE COMMANDS
+#      jlibName jingle initiate name jid mediaElems trptElems cmd
+#      jlibName jingle getstate session|media|transport sid
+#      jlibName jingle getvalue session|media|transport sid key
+#      jlibName jingle send_set sid action cmd ?elems?
+#      jlibName jingle free sid
+#      
+#   The 'cmd' here are invoked just as ordinary send_iq callbacks:
+#   
+#      cmd {type subiq args}
+#     
+#   o You MUST use either 'initiate' or 'send_set' for anything not a *-info
+#     call in order to keep the internal state machines inn sync.
+#     
+#   o In your registered tclProc you must handle all calls and start by 
+#     acknowledging the receipt by sending a result for session-* actions (?). 
+#     
+#   o When a session is ended you are required to 'free' it yourself.
+#   
+#   o While debugging you may switch off 'verifyState' below.
+#   
+#   Each component registers a callback proc which gets called when there is
+#   a 'set' (async) call aimed for it. 
+#   
+#                jlib::jingle
+#                ------------
+#               /  |       | \
+#              /   |       |  \
+#             /    |       |   \
+#            /     |       |    \
+#         iax  libjingle  sip  file-transfer
+#        
+#   TODO
+#      Use responder attribute        
+#      
+#   UNCLEAR
+#   o When are the state changed, after sending an action or when the response
+#     is received?
+#   o Does the media and transport require a result set for every state change?
+#   
+################################################################################
+
+package require jlib
+package require jlib::disco
+
+package provide jlib::jingle 0.1
+
+namespace eval jlib::jingle {
+
+    variable inited 0
+    variable inited_reg 0
+    variable jxmlns
+    set jxmlns(jingle)    "http://jabber.org/protocol/jingle"
+    set jxmlns(media)     "http://jabber.org/protocol/jingle/media"
+    set jxmlns(transport) "http://jabber.org/protocol/jingle/transport"
+    set jxmlns(errors)    "http://jabber.org/protocol/jingle#errors"
+    
+    # Storage for registered media and transport.
+    variable jingle
+    
+    # Cache some of our capabilities.
+    variable have
+    set have(jingle) 0
+    
+    # By default we verify all state changes.
+    variable verifyState 1
+    
+    # For each session/media/transport state, make a map of allowed 
+    # state changes:  state + action -> new state
+    # State changes not listed here are not allowed.
+    # @@@ It is presently unclear if these are independent.
+    #     At least session-initiate and session-terminate control
+    #     the media and transport states.
+    
+    # Session state maps:
+    variable sessionMap
+    array set sessionMap {
+	pending,session-accept      active
+	pending,session-redirect    ended
+	pending,session-info        pending
+	pending,session-terminate   ended
+	active,session-redirect     ended
+	active,session-info         active
+	active,session-terminate    ended
+    }    
+        
+    # Media state maps:
+    variable mediaMap
+    array set mediaMap {
+	pending,media-info          pending
+	pending,media-accept        active
+	active,media-info           active
+	active,media-modify         modifying
+	modifying,media-info        modifying
+	modifying,media-accept      active
+	modifying,media-decline     active
+    }
+    
+    # Transport state maps:
+    variable transportMap
+    array set transportMap {
+	pending,transport-info      pending
+	pending,transport-accept    active
+	active,transport-info       active
+	active,transport-modify     modifying
+	modifying,transport-info    modifying
+	modifying,transport-accept  active
+	modifying,transport-decline active
+    }
+    
+    # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::jingle::first_register --
+# 
+#       This is called for the first component that registers.
+
+proc jlib::jingle::first_register {} {
+    variable jxmlns
+    variable inited_reg
+    variable have
+    
+    # Now we know we have at least one component supporting this.
+    jlib::disco::registerfeature $jxmlns(jingle)
+    set have(jingle) 1
+    set inited_reg 1
+}
+
+# jlib::jingle::register --
+# 
+#       A jingle component registers for a number of media and transport
+#       elements. These are used together with its registered command to
+#       dispatch incoming requests.
+#       The 'name' is for internal use only and is not related to the
+#       Jabber Registrar.
+#       Disco features are automatically registered but caps are not.
+#       
+#       NB: Currently this must be called before any jlib instance created,
+#           that is, before jlib::jingle::init!
+#       
+# Arguments:
+#       name:       unique name 
+#       priority:   number between 0-100
+#       mediaElems:   list of the media elements. Only the xmlns is necessary.
+#                     The complete elements is supplied when doing an initiate.
+#       transportElems:  same for transport
+#       cmd:        tclProc for callbacks
+# 
+# Result:
+#       name
+
+proc jlib::jingle::register {name priority mediaElems transportElems cmd} {
+    variable jingle
+    variable inited_reg
+        
+    set jingle($name,name)       $name
+    set jingle($name,prio)       $priority
+    set jingle($name,cmd)        $cmd
+    set jingle($name,lmedia)     $mediaElems
+    set jingle($name,ltransport) $transportElems
+    
+    # Extract the xmlns for media and transport.
+    set jingle($name,media,lxmlns) {}
+    foreach elem $mediaElems {
+	set xmlns [wrapper::getattribute $elem xmlns]
+	lappend jingle($name,media,lxmlns) $xmlns
+    }
+    set jingle($name,transport,lxmlns) {}
+    foreach elem $transportElems {
+	set xmlns [wrapper::getattribute $elem xmlns]
+	lappend jingle($name,transport,lxmlns) $xmlns
+    }
+    
+    # Register disco xmlns.
+    if {!$inited_reg} {
+	first_register
+    }
+    foreach xmlns $jingle($name,media,lxmlns) {
+	jlib::disco::registerfeature $xmlns
+    }
+    foreach xmlns $jingle($name,transport,lxmlns) {
+	jlib::disco::registerfeature $xmlns
+    }
+    return $name
+}
+
+# jlib::jingle::init --
+# 
+#       Sets up jabberlib handlers and makes a new instance if a jingle object.
+  
+proc jlib::jingle::init {jlibname args} {
+    variable inited
+    variable jxmlns
+    
+    if {!$inited} {
+	InitOnce
+    }    
+
+    # Keep state array for each session as session(sid,...).
+    namespace eval ${jlibname}::jingle {
+	variable session
+    }
+    upvar ${jlibname}::jingle::session  session
+                
+    # Register some standard iq handlers that is handled internally.
+    $jlibname iq_register  set  $jxmlns(jingle) [namespace current]::set_handler
+    $jlibname register_reset [namespace current]::reset
+
+    return
+}
+
+proc jlib::jingle::InitOnce { } {
+    
+    variable inited
+
+    
+    set inited 1
+}
+
+proc jlib::jingle::have {what} {
+    variable have
+    
+    # ???
+}
+
+# jlib::jingle::cmdproc --
+#
+#       Just dispatches the command to the right procedure.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       cmd:        
+#       args:       all args to the cmd procedure.
+#       
+# Results:
+#       none.
+
+proc jlib::jingle::cmdproc {jlibname cmd args} {
+    
+    # Which command? Just dispatch the command to the right procedure.
+    return [eval {$cmd $jlibname} $args]
+}
+
+# jlib::jingle::send_set --
+# 
+#       Utility function for sending jingle set stanzas.
+#       This MUST be used instead of send_iq since the internal state
+#       machines must be updated as well. The exception is *-info actions
+#       which don't affect the state.
+#       
+# Arguments:
+# 
+# Results:
+#       None.
+
+proc jlib::jingle::send_set {jlibname sid action cmd {elems {}}} {
+    variable verifyState
+    
+    # Be sure to set the internal state as well.
+    set state [set_state $jlibname $sid $action]
+    if {$verifyState && $state eq ""} {
+	return -code error "the proposed action $action is not allowed"
+    }
+    do_send_set $jlibname $sid $action $cmd $elems
+    return
+}
+
+# jlib::jingle::do_send_set --
+# 
+#       Makes the actual sending. State must be fixed prior to call.
+#       Internal use only.
+
+proc jlib::jingle::do_send_set {jlibname sid action cmd {elems {}}} {
+    variable jxmlns
+    upvar ${jlibname}::jingle::session  session
+    
+    set jid       $session($sid,jid)
+    set initiator $session($sid,initiator)
+    set attr [list xmlns $jxmlns(jingle) action $action  \
+      initiator $initiator sid $sid]
+    set jelem [wrapper::createtag jingle -attrlist $attr -subtags $elems]
+    
+    jlib::send_iq $jlibname set [list $jelem] -to $jid -command $cmd
+}
+
+# @@@ If the state changes shall only take place *after* received a response,
+#     we need to intersect all calls here.
+proc jlib::jingle::send_set_cb {} {
+    
+}
+
+# @@@ Same thing here!
+proc jlib::jingle::send_result {} {
+    
+}
+
+# jlib::jingle::set_state --
+# 
+#       Checks to see if the requested action is a valid one.
+#       Sets the new state if ok.
+#       
+# Arguments:
+# 
+# Results:
+#       empty if inconsistent, else the new state.
+
+proc jlib::jingle::set_state {jlibname sid action} {    
+    variable sessionMap
+    variable mediaMap
+    variable transportMap
+    upvar ${jlibname}::jingle::session  session
+
+    #puts "jlib::jingle::set_state"
+    
+    # Since we are a state machine we must check that the requested state
+    # change is consistent.
+    if {$action eq "session-initiate"} {
+
+	# No error checking here!
+	set session($sid,state,session)   "pending"
+	set session($sid,state,media)     "pending"
+	set session($sid,state,transport) "pending"
+	#puts "\t action=$action, state=pending"
+	return "pending"
+    } elseif {$action eq "session-terminate"} {
+
+	# No error checking here!
+	set session($sid,state,session)   "ended"
+	set session($sid,state,media)     "ended"
+	set session($sid,state,transport) "ended"
+	#puts "\t action=$action, state=ended"
+	return "ended"
+
+    } else {
+	set actionType [lindex [split $action -] 0]
+	set state $session($sid,state,$actionType)
+    
+	#puts "\t action=$action, state=$state,   actionType=$actionType"
+	if {[info exists ${actionType}Map\($state,$action)]} {
+	    set state [set ${actionType}Map\($state,$action)]
+	    #puts "\t new state=$state"
+	    set session($sid,state,$actionType) $state
+	    return $state
+	} else {
+	    #puts "\t out-of-sync"
+	    return ""
+	}
+    }    
+}
+
+# jlib::jingle::initiate --
+# 
+#       A jingle component makes a session-initiate request.
+#       This must be used instead of send_set for the initiate call.
+#       
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       name:
+#       jid:
+#       mediaElems:
+#       trptElems:
+#       cmd:
+#       
+# Results:
+#       sid.
+
+proc jlib::jingle::initiate {jlibname name jid mediaElems trptElems cmd args} {
+    variable jingle
+    upvar ${jlibname}::jingle::session  session
+    
+    #puts "jlib::jingle::initiate"
+      
+    # SIP may want to generate its own sid.
+    set opts(-sid) [jlib::generateuuid]
+    set opts(-initiator) [jlib::myjid $jlibname]
+    array set opts $args
+    set sid $opts(-sid)
+
+    # We keep the internal jingle states for this sid.
+    set session($sid,sid)       $sid
+    set session($sid,jid)       $jid
+    set session($sid,name)      $name
+    set session($sid,initiator) $opts(-initiator)
+    set session($sid,cmd)       $jingle($name,cmd)
+
+    set subElems [concat $mediaElems $trptElems]
+    set_state $jlibname $sid "session-initiate"
+    
+    do_send_set $jlibname $sid "session-initiate" $cmd $subElems
+    
+    return $sid
+}
+
+# jlib::jingle::set_handler --
+# 
+#       Parse incoming jingle set element.
+
+proc jlib::jingle::set_handler {jlibname from subiq args} {
+    variable have
+    variable verifyState
+    upvar ${jlibname}::jingle::session  session
+    
+    #puts "jlib::jingle::set_handler"
+    
+    array set argsArr $args
+    if {![info exists argsArr(-id)]} {
+	return
+    }
+    set id $argsArr(-id)
+    
+    # There are several reasons why the target entity might return an error 
+    # instead of acknowledging receipt of the initiation request: 
+    # o The initiating entity is unknown to the target entity (e.g., via 
+    #   presence subscription). 
+    # o The target entity does not support Jingle. 
+    # o The target entity does not support any of the specified media 
+    #   description formats. 
+    # o The target entity does not support any of the specified transport 
+    #   methods.
+    # o The initiation request was malformed. 
+
+    set jelem [wrapper::getfirstchildwithtag $argsArr(-xmldata) "jingle"]
+    if {$jelem eq {}} {
+	jlib::send_iq_error $jlibname $from $id 404 cancel service-unavailable
+	return 1
+    }
+    if {!$have(jingle)} {
+	jlib::send_iq_error $jlibname $from $id 404 cancel service-unavailable
+	return 1
+    }
+    
+    # Check required attributes: sid, action, initiator.
+    foreach aname {sid action initiator} {
+	set $aname [wrapper::getattribute $jelem $aname]
+	if {$aname eq ""} {
+	    #puts "\t missing $aname"
+	    jlib::send_iq_error $jlibname $from $id 404 cancel bad-request
+	    return 1
+	}
+    }
+    #puts "\t $sid $action $initiator"
+    
+    # We already have a session for this sid.
+    if {[info exists session($sid,sid)]} {
+	if {$verifyState && $session($sid,state,session) eq "ended"} {
+	    send_error $jlibname $from $id unknown-session
+	    return 1
+	}
+
+	# The action must not be an initiate.
+	if {$verifyState && $action eq "session-initiate"} {
+	    send_error $jlibname $from $id out-of-order
+	    return 1
+	}	
+	
+	# Since we are a state machine we must check that the requested state
+	# change is consistent.
+	set state [set_state $jlibname $sid $action]
+	if {$verifyState && $state eq ""} {
+	    #puts "\t $action out-of-order"
+	    send_error $jlibname $from $id out-of-order
+	    return 1
+	}
+    } else {
+	
+	# The first action must be an initiate.
+	if {$verifyState && $action ne "session-initiate"} {
+	    send_error $jlibname $from $id out-of-order
+	    return 1
+	}	
+    }
+    
+    switch -- $action {
+	"session-initiate" {
+	    set session($sid,sid)       $sid
+	    set session($sid,jid)       $from
+	    set session($sid,initiator) $initiator
+	    set session($sid,jelem)     $jelem
+	    eval {initiate_handler $jlibname $sid $id $jelem} $args
+	}
+	default {
+	    uplevel #0 $session($sid,cmd) $jlibname [list $jelem] $args
+	}
+    }
+    
+    # Is handled here.
+    return 1
+}
+
+# jlib::jingle::initiate_handler --
+# 
+#       We must find the jingle component that matches this initiate.
+
+proc jlib::jingle::initiate_handler {jlibname sid id jelem args} {
+    variable jingle
+    upvar ${jlibname}::jingle::session  session
+    
+    #puts "jlib::jingle::initiate_handler"
+    
+    # Use the 'sid' as the identifier for the state array.
+    set session($sid,state,session)   "pending"
+    set session($sid,state,media)     "pending"
+    set session($sid,state,transport) "pending"
+    
+    set jid $session($sid,jid)
+    
+    # Match the media and transport with the ones we have registered,
+    # and use the best matched registered component.
+    set nsmedia {}
+    foreach elem [wrapper::getchildswithtag $jelem "description"] {
+	lappend nsmedia [wrapper::getattribute $elem xmlns]
+    }
+    set nstrpt {}
+    foreach elem [wrapper::getchildswithtag $jelem "transport"] {
+	lappend nstrpt [wrapper::getattribute $elem xmlns]
+    }
+    
+    # @@@ This matches only the xmlns which is not enough.
+    #     The details is up to each component to negotiate?
+    #     
+    # Make a list of candidates that support both media and transport xmlns:
+    #    {{name prio} ...} and order them in decreasing priorities.
+    set lbest {}
+    set anymedia 0
+    set anytransport 0
+    foreach {- name} [array get jingle *,name] {
+	set mns [jlib::util::lintersect $jingle($name,media,lxmlns) $nsmedia]
+	set tns [jlib::util::lintersect $jingle($name,transport,lxmlns) $nstrpt]
+	
+	# A component must support both media and transport.
+	if {[llength $mns] && [llength $tns]} {
+	    lappend lbest [list $name $jingle($name,prio)]
+	}
+	if {[llength $mns]} {
+	    set anymedia 1
+	}
+	if {[llength $tns]} {
+	    set anytransport 1
+	}
+    }
+    if {$lbest eq {}} {
+	if {!$anymedia} {
+	    send_error $jlibname $jid $id unsupported-media
+	} elseif {!$anytransport} {
+	    send_error $jlibname $jid $id unsupported-transports
+	} else {
+	    # It is the actual combination media/transport that is unsupported.
+	    send_error $jlibname $jid $id unsupported-media
+	}
+    } else {
+	set lbest [lsort -integer -index 1 -decreasing $lbest]
+	#puts "\t lbest=$lbest"
+    
+	# Delegate to the component.
+	# It is then up to the component to take the initiatives:
+	#     transport-accept etc.
+	# @@@ We make a crude shortcut here and pick only the best.
+	set name [lindex $lbest 0 0]
+	set cmd $jingle($name,cmd)
+	set session($sid,name) $name
+	set session($sid,cmd)  $cmd
+	uplevel #0 $cmd $jlibname [list $jelem] $args
+    }
+}
+
+proc jlib::jingle::send_error {jlibname jid id stanza} {
+    variable jxmlns
+    
+    #puts "jlib::jingle::send_error"
+    # @@@ Not sure about the details here.
+    # We must add an extra error element:
+    #   <unsupported-transports 
+    #       xmlns='http://jabber.org/protocol/jingle#errors'/>
+    set elem [wrapper::createtag $stanza  \
+      -attrlist [list xmlns $jxmlns(errors)]]
+    jlib::send_iq_error $jlibname $jid $id 404 cancel bad-request $elem
+}
+
+# A few accessor functions.
+
+# jlib::jingle::getstate --
+# 
+#       Return the current state for session, media, or transport.
+
+proc jlib::jingle::getstate {jlibname type sid} {
+    upvar ${jlibname}::jingle::session  session
+
+    return $session($sid,state,$type)
+}
+
+proc jlib::jingle::getvalue {jlibname sid key} {
+    upvar ${jlibname}::jingle::session  session
+
+    return $session($sid,$key)
+}
+
+proc jlib::jingle::havesession {jlibname sid} {
+    upvar ${jlibname}::jingle::session  session
+    
+    return [info exists session($sid,sid)]
+}
+
+proc jlib::jingle::reset {jlibname} {
+    
+    # Shall we clear out all sessions here?
+}
+
+proc jlib::jingle::free {jlibname sid} {
+    upvar ${jlibname}::jingle::session  session
+
+    array unset session   $sid,*
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::jingle {
+
+    jlib::ensamble_register jingle  \
+      [namespace current]::init     \
+      [namespace current]::cmdproc
+}
+
+# Primitive test code.
+if {0} {
+    package require jlib::jingle
+    
+    set jlibname jlib::jlib1
+    set myjid [jlib::myjid $jlibname]
+    set jid $myjid
+    set xmlnsTransportIAX     "http://jabber.org/protocol/jingle/transport/iax"
+    set xmlnsMediaAudio       "http://jabber.org/protocol/jingle/media/audio"
+
+    # Register:
+    set transportElem [wrapper::createtag "transport" \
+      -attrlist [list xmlns $xmlnsTransportIAX version 2] ]
+    set mediaElemAudio [wrapper::createtag "description" \
+      -attrlist [list xmlns $xmlnsMediaAudio] ]
+    
+    proc cmdIAX {jlibname _jelem args} {
+	#puts "IAX: $args"
+	array set argsArr $args
+	set sid    [wrapper::getattribute $_jelem sid]
+	set action [wrapper::getattribute $_jelem action]
+	#puts "\t action=$action, sid=$sid"
+	
+	# Only session actions are acknowledged?
+	if {[string match "session-*" $action]} {
+	    $jlibname send_iq result {} -to $argsArr(-from) -id $argsArr(-id)
+	}
+	
+	switch -- $action {
+	    "session-initiate" {
+		set ::jelem $_jelem
+		
+		
+	    }
+	}
+    }
+    jlib::jingle::register iax 50  \
+      [list $mediaElemAudio] [list $transportElem] cmdIAX
+    
+    # Disco:
+    proc cb {args} {puts "cb: $args"}
+    $jlibname disco send_get info $jid cb
+    
+    # Initiate:
+    set sid [$jlibname jingle initiate iax $jid  \
+      [list $mediaElemAudio] [list $transportElem] cb]
+    
+    # IAX callbacks:
+    set media [wrapper::getfirstchildwithtag $jelem "description"]
+    $jlibname jingle send_set $sid "media-accept" cb [list $media]
+
+    set trpt  [wrapper::getfirstchildwithtag $jelem "transport"]
+    $jlibname jingle send_set $sid "transport-accept" cb [list $trpt]
+
+    $jlibname jingle send_set $sid "session-accept" cb
+
+    # Talk here!
+    
+    parray ${jlibname}::jingle::session
+    
+    # Shut up!
+    $jlibname jingle send_set $sid "session-terminate" cb
+}
+
+#-------------------------------------------------------------------------------
diff --git a/lib/jabberlib/jlibdns.tcl b/lib/jabberlib/jlibdns.tcl
new file mode 100644
index 0000000..da2aca5
--- /dev/null
+++ b/lib/jabberlib/jlibdns.tcl
@@ -0,0 +1,187 @@
+#  jlibdns.tcl --
+#  
+#      This file is part of the jabberlib. 
+#      It provides support for XEP-0156: 
+#          A DNS TXT Resource Record Format for XMPP Connection Methods 
+#      and client DNS SRV records (XMPP Core sect. 14.3)
+#      
+#  Copyright (c) 2006-2008  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: jlibdns.tcl,v 1.9 2008/03/27 15:15:26 matben Exp $
+# 
+############################# USAGE ############################################
+#
+#   NAME
+#      jlib::dns - library for DNS lookups
+#      
+#   SYNOPSIS
+#      jlib::dns::get_addr_port domain cmd
+#      jlib::dns::get_http_bind_url domain cmd   OUTDATED
+#      jlib::dns::get_http_poll_url domain cmd
+#      jlib::dns::get_http_bosh_url domain cmd
+#
+############################# 7.1.2 Initial Registration #######################
+#
+# <method>
+#   <name>_xmpp-client-httppoll</name>
+#   <desc>HTTP Polling connection method</desc>
+#   <syntax>
+#     The http: or https: URL at which to contact the HTTP Polling connection manager or proxy
+#   </syntax>
+#   <doc>XEP-0025</doc>
+# </method>
+# 
+# <method>
+#   <name>_xmpp-client-xbosh</name>
+#   <desc>XMPP Over Bosh connection method</desc>
+#   <syntax>
+#     The http: or https: URL at which to contact the HTTP Binding connection manager or proxy
+#   </syntax>
+#   <doc>XEP-0206</doc>
+# </method>
+
+package require dns 9.9    ;# Fake version to avoid loding buggy version.
+package require jlib
+
+package provide jlib::dns 0.1
+
+namespace eval jlib::dns {
+    
+    variable owner
+    array set owner {
+	client      _xmpp-client._tcp
+	poll        _xmppconnect
+    }
+
+    variable nameA
+    array set nameA {
+	bind        _xmpp-client-httpbind
+	bosh        _xmpp-client-xbosh
+	poll        _xmpp-client-httppoll
+    }
+}
+
+proc jlib::dns::get_addr_port {domain cmd args} {
+    
+    # dns::resolve may throw error!
+    set name _xmpp-client._tcp.$domain
+    return [eval {dns::resolve $name -type SRV  \
+      -command [list [namespace current]::addr_cb $cmd]} $args]
+}
+
+proc jlib::dns::addr_cb {cmd token} {
+        
+    set addrList {}
+    if {[dns::status $token] eq "ok"} {
+	set result [dns::result $token]
+	foreach reply $result {
+	    array unset rr
+	    array set rr $reply
+	    if {[info exists rr(rdata)]} {
+		array unset rd
+		array set rd $rr(rdata)
+		if {[info exists rd(priority)] &&  \
+		  [info exists rd(weight)] &&      \
+		  [info exists rd(port)] &&        \
+		  [info exists rd(target)] &&      \
+		  [isUInt16 $rd(priority)] &&      \
+		  [isUInt16 $rd(weight)] &&        \
+		  [isUInt16 $rd(port)] &&          \
+		  ($rd(target) ne ".")} {
+		    if {$rd(weight) == 0} {
+			set n 0
+		    } else {
+			set n [expr {($rd(weight)+1)*rand()}]
+		    }
+		    set priority [expr {$rd(priority)*65536 - $n}]
+		    lappend addrList [list $priority $rd(target) $rd(port)]
+		}
+	    }	    
+	}
+	if {[llength $addrList]} {
+	    set addrPort {}
+	    foreach p [lsort -real -index 0 $addrList] {
+		lappend addrPort [lrange $p 1 2]
+	    }
+	    uplevel #0 $cmd [list $addrPort]
+	} else {
+	    uplevel #0 $cmd [list {} dns-empty]
+	}
+    } else {
+	uplevel #0 $cmd [list {} [dns::error $token]]
+    }
+    
+    # Weird bug!
+    #after 2000 [list dns::cleanup $token]
+}
+
+proc jlib::dns::isUInt16 {n} {
+    return [expr {[string is integer -strict $n] && $n >= 0 && $n < 65536}  \
+      ? 1 : 0]
+}
+
+proc jlib::dns::get_http_bind_url {domain cmd args} {    
+    set name _xmppconnect.$domain
+    return [eval {dns::resolve $name -type TXT  \
+      -command [list [namespace current]::http_cb bind $cmd]} $args]
+}
+
+proc jlib::dns::get_http_bosh_url {domain cmd args} {
+    set name _xmppconnect.$domain
+    return [eval {dns::resolve $name -type TXT  \
+      -command [list [namespace current]::http_cb bosh $cmd]} $args]
+}
+
+proc jlib::dns::get_http_poll_url {domain cmd args} {
+    set name _xmppconnect.$domain
+    return [eval {dns::resolve $name -type TXT  \
+      -command [list [namespace current]::http_cb poll $cmd]} $args]
+}
+
+proc jlib::dns::http_cb {attr cmd token} {
+    variable nameA
+        
+    set found 0
+    if {[dns::status $token] eq "ok"} {
+	set result [dns::result $token]
+	foreach reply $result {
+	    array unset rr
+	    array set rr $reply
+	    if {[info exists rr(rdata)]} {
+		if {[regexp "$nameA($attr)=(.*)" $rr(rdata) - url]} {
+		    set found 1
+		    uplevel #0 $cmd [list $url]
+		}
+	    }
+	}
+	if {!$found} {
+	    uplevel #0 $cmd [list {} dns-no-resource-record]
+	}
+    } else {
+	uplevel #0 $cmd [list {} [dns::error $token]]
+    }
+
+    # Weird bug!
+    #after 2000 [list dns::cleanup $token]
+}
+
+proc jlib::dns::reset {token} {    
+    ::dns::reset $token
+    ::dns::cleanup $token
+}
+
+# Test
+if {0} {
+    proc cb {args} {puts "---> $args"}
+    jlib::dns::get_addr_port gmail.com cb
+    jlib::dns::get_addr_port jabber.ru cb
+    jlib::dns::get_addr_port jabber.com cb
+    jlib::dns::get_addr_port jabber.cz cb
+    jlib::dns::get_addr_port tigase.org cb
+    # Missing 
+    jlib::dns::get_http_poll_url gmail.com cb    
+    jlib::dns::get_http_poll_url jabber.ru cb    
+    jlib::dns::get_http_poll_url ham9.net cb    
+}
diff --git a/lib/jabberlib/jlibhttp.tcl b/lib/jabberlib/jlibhttp.tcl
new file mode 100644
index 0000000..a6ba26b
--- /dev/null
+++ b/lib/jabberlib/jlibhttp.tcl
@@ -0,0 +1,688 @@
+# jlibhttp.tcl ---
+#  
+#      Provides a http transport mechanism for jabberlib. 
+#      Implements the deprecated XEP-0025: Jabber HTTP Polling protocol.
+#      
+# Copyright (c) 2002-2008  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#
+# $Id: jlibhttp.tcl,v 1.21 2008/02/29 12:55:36 matben Exp $
+# 
+# USAGE ########################################################################
+#
+# jlib::http::new jlibname url ?-key value ...?
+#	url 	A valid url for the POST method of HTTP.
+#	
+#       -keylength              sets the length of the key sequence
+#	-maxpollms ms	        max interval in ms for post requests
+#	-minpollms ms	        min interval in ms for post requests
+#       -proxyhost domain	name of proxu host if any
+#       -proxyport integer	and its port number
+#	-proxyusername name	your username for the proxy
+#	-proxypasswd secret	and your password
+#	(-resendinterval ms	if sending fails, try again after this interval)
+#	-timeout ms		timeout for connecting the server
+#	-usekeys 0|1            if keys should be used
+#
+# Although you can use the -proxy* switches here, it is much simpler to let
+# the autoproxy package configure them.
+#
+# Callbacks for the JabberLib:
+#	jlib::http::transportinit, jlib::http::transportreset, 
+#	jlib::http::send,          jlib::http::transportip
+#
+# STATES #######################################################################
+# 
+# priv(state):    ""          inactive and not reset
+#                 "instream"  active connection
+#                 "reset"     reset by callback
+# 
+# priv(status):   ""          inactive
+#                 "scheduled" http post is scheduled as timer event
+#                 "pending"   http post made, waiting for response
+#                 "error"     error status
+
+package require jlib
+package require http 2.4
+package require base64
+package require sha1
+
+package provide jlib::http 0.1
+
+namespace eval jlib::http {
+    
+    # Check for the TLS package so we can use https.
+    if {![catch {package require tls}]} {
+	http::register https 443 ::tls::socket
+    }
+
+    # Inherit jlib's debug level.
+    variable debug 0
+    if {!$debug} {
+	set debug [namespace parent]::debug
+    }
+    variable errcode
+    array set errcode {
+	0       "unknown error"
+       -1       "server error"
+       -2       "bad request"
+       -3       "key sequence error"
+    }
+}
+
+# jlib::http::new --
+#
+#	Configures the state of this thing.
+
+proc jlib::http::new {jlibname url args} {
+
+    namespace eval ${jlibname}::http {
+	variable priv
+	variable opts
+    }
+    upvar ${jlibname}::http::priv priv
+    upvar ${jlibname}::http::opts opts
+    
+    Debug 2 "jlib::http::new url=$url, args=$args"
+
+    array set opts {
+	-keylength              64
+	-maxpollms           16000
+	-minpollms            4000
+	-proxyhost              ""
+	-proxyport              80
+	-proxyusername          ""
+	-proxypasswd            ""
+	-resendinterval      20000
+	-timeout             30000
+	-usekeys                 1
+	header                  ""
+	port                    80
+	proxyheader             ""
+	url                     ""
+	pollupfactor           0.8
+	polldownfactor         1.2
+    }
+    set RE {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$}
+    if {![regexp -nocase $RE $url - prefix proto host - port filepath]} {
+	return -code error "the url \"$url\" is not valid"
+    }
+    set opts(url)  $url
+    set opts(host) $host
+    if {$port ne ""} {
+	set opts(port) $port
+    }
+    array set opts $args
+
+    set priv(id)      0
+    set priv(afterid) ""
+
+    # Perhaps the autoproxy package can be used here?
+    if {[string length $opts(-proxyhost)] && [string length $opts(-proxyport)]} {
+   	::http::config -proxyhost $opts(-proxyhost) -proxyport $opts(-proxyport)
+    }
+    if {[string length $opts(-proxyusername)] || \
+	[string length $opts(-proxypasswd)]} {
+	set opts(proxyheader) [BuildProxyHeader  \
+	  $opts(-proxyusername) $opts(-proxypasswd)]
+    }
+    set opts(header) $opts(proxyheader)
+    
+    # Initialize.
+    InitState $jlibname
+
+    $jlibname registertransport "http"    \
+      [namespace current]::transportinit  \
+      [namespace current]::send           \
+      [namespace current]::transportreset \
+      [namespace current]::transportip
+    
+    return
+}
+
+# jlib::http::InitState --
+# 
+#       Sets initial state of 'priv' array.
+
+proc jlib::http::InitState {jlibname} {
+    
+    upvar ${jlibname}::http::priv priv
+    upvar ${jlibname}::http::opts opts
+
+    set ms [clock clicks -milliseconds]
+    
+    set priv(state)       ""
+    set priv(status)      ""
+    
+    set priv(afterid)     ""
+    set priv(xml)         ""
+    set priv(lastxml)     ""     ; # Last posted xml.
+    set priv(id)          0
+    set priv(first)       1
+    set priv(first)       0
+    set priv(postms)     -1
+    set priv(ip)          ""
+    set priv(lastpostms)  $ms
+    set priv(2lastpostms) $ms
+    set priv(keys)        {}
+    if {$opts(-usekeys)} {
+	set priv(keys) [NewKeySequence [NewSeed] $opts(-keylength)]
+    }
+}
+
+# jlib::http::BuildProxyHeader --
+#
+#	Builds list for the "Proxy-Authorization" header line.
+
+proc jlib::http::BuildProxyHeader {proxyusername proxypasswd} {
+    
+    set str $proxyusername:$proxypasswd
+    set auth [list "Proxy-Authorization" "Basic [base64::encode $str]"]
+    return $auth
+}
+
+proc jlib::http::NewSeed { } {
+    set MAX_INT 0x7FFFFFFF    
+    set num [expr {int($MAX_INT*rand())}]
+    return [format %0x $num]
+}
+
+proc jlib::http::NewKeySequence {seed len} {
+
+    set keys    $seed
+    set prevkey $seed
+    
+    for {set i 1} {$i < $len} {incr i} {
+	
+	# It seems that it is expected to have sha1 in binary format;
+	# get from hex
+	set hex [::sha1::sha1 $prevkey]
+	set key [::base64::encode [binary format H* $hex]]
+	lappend keys $key
+	set prevkey $key
+    }
+    return $keys
+}
+
+# jlib::http::transportinit --
+#
+#	For the -transportinit command.
+
+proc jlib::http::transportinit {jlibname} {
+
+    upvar ${jlibname}::http::priv priv
+    upvar ${jlibname}::http::opts opts
+    
+    InitState $jlibname
+}
+
+# jlib::http::transportreset --
+#
+#	For the -transportreset command.
+
+proc jlib::http::transportreset {jlibname} {
+
+    upvar ${jlibname}::http::priv priv
+  
+    Debug 2 "jlib::http::transportreset"
+
+    # Stop polling and resends.
+    if {$priv(afterid) ne ""} {
+	catch {after cancel $priv(afterid)}
+    }
+    set priv(afterid) ""
+    set priv(state)   "reset"
+    set priv(ip)      ""
+    
+    # If we have got cached xml to send must post it now and ignore response.
+    if {[string length $priv(xml)] > 2} {
+	Post $jlibname
+    }
+    if {[info exists priv(token)]} {
+	::http::reset $priv(token)
+	::http::cleanup $priv(token)
+	unset priv(token)
+    }
+}
+
+# jlib::http::transportip --
+# 
+#       Get our own ip address.
+#       @@@ If proxy we have the usual firewall problem!
+
+proc jlib::http::transportip {jlibname} {
+    
+    upvar ${jlibname}::http::priv priv
+
+    return $priv(ip)
+}
+
+# jlib::http::send --
+#
+#	For the -transportsend command.
+
+proc jlib::http::send {jlibname xml} {
+    
+    upvar ${jlibname}::http::priv priv
+    upvar ${jlibname}::http::opts opts
+    
+    Debug 2 "jlib::http::send state='$priv(state)' $xml"
+
+    # Cancel if already 'reset'.
+    if {[string equal $priv(state) "reset"]} {
+	return
+    }
+    set priv(state) "instream"
+    
+    append priv(xml) $xml
+    
+    # If this is our first post we shall post right away.
+    if {$priv(status) eq ""} {
+	Post $jlibname
+
+	# Unless we already have a pending event, post as soon as possible.
+    } elseif {$priv(status) ne "pending"} {
+	PostASAP $jlibname
+    }
+}
+
+# jlib::http::PostASAP --
+# 
+#       Make a post as soon as possible without taking 'minpollms' as the
+#       constraint. If we have waited longer than 'minpollms' post right away,
+#       else reschedule if necessary to post at 'minpollms'.
+
+proc jlib::http::PostASAP {jlibname} {
+    
+    upvar ${jlibname}::http::priv priv
+    upvar ${jlibname}::http::opts opts
+    
+    Debug 2 "jlib::http::PostASAP"
+    
+    if {$priv(afterid) eq ""} {
+	SchedulePost $jlibname minpollms
+    } else {
+	
+	#        now (case A)         now (case B)
+	#           |                    |
+	#  ---------------------------------------------------> time
+	#   |                 ->|                       ->|
+	# last post            min                       max
+	
+	# We shall always use '-minpollms' when there is something to send.
+	set nowms [clock clicks -milliseconds]
+	set minms [expr {$priv(lastpostms) + $opts(-minpollms)}]
+	if {$nowms < $minms} {
+	    
+	    # Case A:
+	    # If next post is scheduled after min, then repost at min instead.
+	    if {$priv(nextpostms) > $minms} {
+		SchedulePost $jlibname minpollms
+	    }
+	} else {
+	    
+	    # Case B:
+	    # We have already waited longer than '-minpollms'.
+	    after cancel $priv(afterid)
+	    set priv(afterid) ""
+	    Post $jlibname
+	}
+    }
+}
+
+# jlib::http::Schedule --
+#
+#       Computes the time for the next post and calls SchedulePost.
+
+proc jlib::http::Schedule {jlibname} {
+    
+    upvar ${jlibname}::http::priv priv
+    upvar ${jlibname}::http::opts opts
+    
+    Debug 2 "jlib::http::Schedule len priv(lastxml)=[string length $priv(lastxml)]"
+    
+    # Compute time for next post.
+    set ms [clock clicks -milliseconds]
+    if {$priv(lastxml) eq ""} {
+	set when [expr {$opts(polldownfactor) * ($ms - $priv(2lastpostms))}]
+	set when [Min $when $opts(-maxpollms)]
+	set when [Max $when $opts(-minpollms)]
+    } else {
+	set when minpollms
+    }
+    
+    # Reschedule next post unless 'reset'.
+    # Always keep a scheduled post at 'maxpollms' (or something else),
+    # and let any subsequent events reschedule if at an earlier time.
+    if {[string equal $priv(state) "instream"]} {
+	SchedulePost $jlibname $when
+    }
+}
+
+# jlib::http::SchedulePost --
+# 
+#       Schedule a post as a timer event.
+
+proc jlib::http::SchedulePost {jlibname when} {
+    
+    upvar ${jlibname}::http::priv priv
+    upvar ${jlibname}::http::opts opts
+
+    Debug 2 "jlib::http::SchedulePost when=$when"
+
+    set nowms [clock clicks -milliseconds]
+
+    switch -- $when {
+	minpollms {
+	    set minms [expr {$priv(lastpostms) + $opts(-minpollms)}]
+	    set afterms [expr {$minms - $nowms}]
+	}
+	maxpollms {
+	    set maxms [expr {$priv(lastpostms) + $opts(-maxpollms)}]
+	    set afterms [expr {$maxms - $nowms}]
+	}
+	default {
+	    set afterms $when
+	}
+    }
+    if {$afterms < 0} {
+	set afterms 0
+    }
+    set priv(afterms)    [expr int($afterms)]
+    set priv(nextpostms) [expr {$nowms + $afterms}]
+    set priv(postms)     [expr {$priv(nextpostms) - $priv(lastpostms)}]
+
+    if {$priv(afterid) ne ""} {
+	after cancel $priv(afterid)
+    }
+    set priv(status) "scheduled"
+    set priv(afterid) [after $priv(afterms)  \
+      [list [namespace current]::Post $jlibname]]
+}
+
+# jlib::http::Post --
+# 
+#       Just a wrapper for PostXML when sending xml.
+       
+proc jlib::http::Post {jlibname} {
+    
+    upvar ${jlibname}::http::priv priv
+
+    Debug 2 "jlib::http::Post"
+    
+    # If called directly any timers must have been cancelled before this.
+    set priv(afterid) ""
+    set xml $priv(xml)
+    set priv(xml) ""
+    PostXML $jlibname $xml
+}
+
+# jlib::http::PostXML --
+# 
+#       Do actual posting with (any) xml to send.
+#       Always called from 'Post'.
+       
+proc jlib::http::PostXML {jlibname xml} {
+    
+    upvar ${jlibname}::http::priv priv
+    upvar ${jlibname}::http::opts opts
+    
+    Debug 2 "jlib::http::PostXML"
+    
+    set xml [encoding convertto utf-8 $xml]
+
+    if {$opts(-usekeys)} {
+	
+	# Administrate the keys. Pick from end until no left.
+	set key [lindex $priv(keys) end]
+	set priv(keys) [lrange $priv(keys) 0 end-1]
+
+	# Need new key sequence?
+	if {[llength $priv(keys)] == 0} {
+	    set priv(keys) [NewKeySequence [NewSeed] $opts(-keylength)]
+	    set newkey     [lindex $priv(keys) end]
+	    set priv(keys) [lrange $priv(keys) 0 end-1]
+	    set query "$priv(id);$key;$newkey,$xml"
+	    Debug 4 "\t key change"
+	} else {
+	    set query "$priv(id);$key,$xml"
+	}
+    } else {
+	set query "$priv(id),$xml"
+    }
+    set priv(status) "pending"
+    if {[string equal $priv(state) "reset"]} {
+	set cmdProc [namespace current]::NoopResponse
+    } else {
+	set cmdProc [list [namespace current]::Response $jlibname]
+    }
+    set progProc [list [namespace current]::Progress $jlibname]
+    
+    Debug 2 "POST: $query"
+    
+    # -query forces a POST request.
+    # Make sure we send it as text dispite the application/* type.???
+    if {[catch {
+	set token [::http::geturl $opts(url)   \
+	  -timeout  $opts(-timeout)            \
+	  -headers  $opts(header)              \
+	  -query    $query                     \
+	  -queryprogress $progProc             \
+	  -command  $cmdProc]
+    } msg]} {
+	# @@@ We could have a method here to retry a number of times before
+	#     giving up.
+	Debug 2 "\t post failed: $msg"
+	Error $jlibname networkerror $msg
+    } else {
+	set priv(token) $token
+	set priv(lastxml) $xml
+	set priv(2lastpostms) $priv(lastpostms)
+	set priv(lastpostms) [clock clicks -milliseconds]
+    }
+}
+
+# jlib::http::Progress --
+# 
+#       Only useful the first post to get socket and our own IP.
+
+proc jlib::http::Progress {jlibname token args} {
+    
+    upvar ${jlibname}::http::priv priv
+
+    if {$priv(ip) eq ""} {
+	# @@@ When we switch to httpex we will add a method for this.
+	set s [set $token\(sock)]
+	set priv(ip) [lindex [fconfigure $s -sockname] 0]
+    }
+}
+
+# jlib::http::Response --
+#
+#	The response to our POST request. Parse any indata that should
+#	be of mime type text/xml
+
+proc jlib::http::Response {jlibname token} {
+    
+    upvar #0 $token state
+    upvar ${jlibname}::http::priv priv
+    upvar ${jlibname}::http::opts opts
+    variable errcode
+    
+    Debug 2 "jlib::http::Response priv(state)=$priv(state)"
+    
+    # We may have been 'reset' after this post was sent!
+    if {[string equal $priv(state) "reset"]} {
+	return
+    }
+    set status [::http::status $token]
+    
+    Debug 2 "\t status=$status, ::http::ncode=[::http::ncode $token]"
+    
+    if {$status eq "ok"} {
+	if {[::http::ncode $token] != 200} {
+	    Error $jlibname error [::http::ncode $token]
+	    return
+	}	    
+	set haveCookie 0
+	set haveContentType 0
+	
+	foreach {key value} $state(meta) {
+	    
+	    if {[string equal -nocase $key "set-cookie"]} {
+		
+		# Extract the 'ID' from the Set-Cookie key.
+		foreach pair [split $value ";"] {
+		    set pair [string trim $pair]
+		    if {[string equal -nocase -length 3 "ID=" $pair]} {
+			set id [string range $pair 3 end]
+			break
+		    }
+		}
+		
+		if {![info exists id]} {
+		    Error $jlibname error \
+		      "Set-Cookie in HTTP header \"$value\" invalid"
+		    return
+		}
+		
+		# Invesitigate the ID:
+		set ids [split $id :]
+		if {[llength $ids] == 2} {
+		    
+		    # Any identifier that ends in ':0' indicates an error.
+		    if {[string equal [lindex $ids 1] "0"]} {
+			
+			#   ID=0:0  Unknown Error. The response body can 
+			#           contain a textual error message. 
+			#   ID=-1:0 Server Error.
+			#   ID=-2:0 Bad Request.
+			#   ID=-3:0 Key Sequence Error .
+			set code [lindex $ids 0]
+			if {[info exists errcode($code)]} {
+			    set errmsg $errcode($code)
+			} else {
+			    set errmsg "Server error $id"
+			}
+			Error $jlibname error $errmsg
+			return
+		    }
+		}
+		set haveCookie 1
+	    } elseif {[string equal -nocase $key "content-type"]} {
+		
+		# Responses from the server have Content-Type: text/xml. 
+		# Both the request and response bodies are UTF-8       
+		# encoded text, even if an HTTP header to the contrary 
+		# exists. 
+		# ejabberd: Content-Type {text/plain; charset=utf-8}
+		
+		set typeOK 0
+		if {[string match -nocase "*text/xml*" $value]} {
+		    set typeOK 1
+		} elseif {[regexp -nocase { *text/plain; *charset=utf-8} $value]} {
+		    set typeOK 1
+		}
+		
+		if {!$typeOK} {
+		    # This is an invalid response.
+		    set errmsg "Content-Type in HTTP header is "
+		    append errmsg $value
+		    append errmsg " expected \"text/xml\" or \"text/plain\""
+		    Error $jlibname error $errmsg
+		    return
+		}
+		set haveContentType 1
+	    }
+	}
+	if {!$haveCookie} {
+	    Error $jlibname error "missing Set-Cookie in HTTP header"
+	    return
+	}
+	if {!$haveContentType} {
+	    Error $jlibname error "missing Content-Type in HTTP header"
+	    return
+	}
+	set priv(id) $id
+	set priv(lastxml) ""	
+	set body [::http::data $token]
+	Debug 2 "POLL: $body"
+	
+	# Send away to jabberlib for parsing and processing.
+	if {[string length $body] > 2} {
+	    [namespace parent]::recv $jlibname $body
+	}
+	
+	# Reschedule new POST.
+	# NB: We always rescedule from the POST callback to avoid queuing
+	#     up requests which can distort the order and make a 
+	#     'key sequence error'
+	if {[string length $body] > 2} {
+	    SchedulePost $jlibname minpollms
+	} else {
+	    Schedule $jlibname
+	}
+    } else {
+	
+	# @@@ We could have a method here to retry a number of times before
+	#     giving up.
+	Error $jlibname $status [::http::error $token]
+	return
+    }
+    
+    # And cleanup after each post.
+    ::http::cleanup $token
+    unset priv(token)
+}
+
+# jlib::http::NoopResponse --
+# 
+#       This shall be used when we flush out any xml after a 'reset' and
+#       don't expect any further actions to be taken.
+
+proc jlib::http::NoopResponse {token} {
+
+    Debug 2 "jlib::http::NoopResponse"
+
+    # Only thing we shall do here.
+    ::http::cleanup $token
+}
+
+# jlib::http::Error --
+# 
+#       Only network errors and server errors are reported here.
+
+proc jlib::http::Error {jlibname status {errmsg ""}} {
+    
+    upvar ${jlibname}::http::priv priv
+
+    Debug 2 "jlib::http::Error status=$status, errmsg=$errmsg"
+    
+    set priv(status) "error"
+    if {[info exists priv(token)]} {
+	::http::cleanup $priv(token)
+	unset priv(token)
+    }
+    
+    # @@@ We should perhaps be more specific here.
+    jlib::reporterror $jlibname networkerror $errmsg
+}
+
+proc jlib::http::Min {x y} {
+    return [expr {$x <= $y ? $x : $y}]
+}
+
+proc jlib::http::Max {x y} {
+    return [expr {$x >= $y ? $x : $y}]
+}
+
+proc jlib::http::Debug {num str} {
+    variable debug
+    if {$num <= $debug} {
+	puts $str
+    }
+}
+
+#-------------------------------------------------------------------------------
+
diff --git a/lib/jabberlib/jlibsasl.tcl b/lib/jabberlib/jlibsasl.tcl
new file mode 100644
index 0000000..6118ae1
--- /dev/null
+++ b/lib/jabberlib/jlibsasl.tcl
@@ -0,0 +1,506 @@
+#  jlibsasl.tcl --
+#  
+#      This file is part of the jabberlib. It provides support for the
+#      sasl authentication layer via the tclsasl package or the saslmd5
+#      pure tcl package.
+#      It also makes the resource binding and session initiation.
+#      
+#        o sasl authentication
+#         skipped:
+#        X bind resource
+#        X establish session
+#      
+#  Copyright (c) 2004-2006  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: jlibsasl.tcl,v 1.29 2007/09/12 07:20:46 matben Exp $
+
+package require jlib
+package require saslmd5
+set ::_saslpack saslmd5
+
+package provide jlibsasl 1.0
+
+
+namespace eval jlib {
+    variable cyrussasl 
+    
+    if {$::_saslpack eq "cyrussasl"} {
+	set cyrussasl 1
+    } else {
+	set cyrussasl 0
+    }
+    unset ::_saslpack
+}
+
+proc jlib::sasl_init {} {
+    variable cyrussasl 
+    
+    if {$cyrussasl} {
+	sasl::client_init -callbacks \
+	  [list [list log [namespace current]::sasl_log]]
+    } else {
+	# empty
+    }
+}
+
+proc jlib::decode64 {str} {
+    variable cyrussasl 
+
+    if {$cyrussasl} {
+	return [sasl::decode64 $str]
+    } else {
+	return [saslmd5::decode64 $str]
+    }
+}
+
+proc jlib::encode64 {str} {
+    variable cyrussasl 
+
+    if {$cyrussasl} {
+	return [sasl::encode64 $str]
+    } else {
+	return [saslmd5::encode64 $str]
+    }
+}
+
+# jlib::auth_sasl --
+# 
+#       Create a new SASL object.
+
+proc jlib::auth_sasl {jlibname username resource password cmd} {
+    
+    upvar ${jlibname}::locals locals
+    variable xmppxmlns
+    
+    Debug 4 "jlib::auth_sasl"
+        
+    # Cache our login jid.
+    set locals(username) $username
+    set locals(resource) $resource
+    set locals(password) $password
+    set locals(myjid2)   ${username}@$locals(server)
+    set locals(myjid)    ${username}@$locals(server)/${resource}
+    set locals(sasl,cmd) $cmd
+    
+    # Set up callbacks for elements that are of interest to us.
+    element_register $jlibname $xmppxmlns(sasl) [namespace current]::sasl_parse
+
+    if {[have_feature $jlibname mechanisms]} {
+	auth_sasl_continue $jlibname
+    } else {
+	trace_stream_features $jlibname [namespace current]::sasl_features
+    }
+}
+
+proc jlib::sasl_features {jlibname} {
+
+    upvar ${jlibname}::locals locals
+
+    Debug 4 "jlib::sasl_features"
+    
+    # Verify that sasl is supported before going on.
+    set features [get_feature $jlibname "mechanisms"]
+    if {$features eq ""} {
+	set msg "no sasl mechanisms announced by the server"
+	sasl_final $jlibname error [list sasl-no-mechanisms $msg]
+    } else {
+	auth_sasl_continue $jlibname
+    }
+}
+
+proc jlib::sasl_parse {jlibname xmldata} {
+    
+    set tag [wrapper::gettag $xmldata]
+    
+    switch -- $tag {
+	challenge {
+	    sasl_challenge $jlibname $tag $xmldata
+	}
+	failure {
+	    sasl_failure $jlibname $tag $xmldata
+	}
+	success {
+	    sasl_success $jlibname $tag $xmldata	    
+	}
+	default {
+	    sasl_final $jlibname error [list sasl-protocol-error {}]
+	}
+    }
+    return
+}
+
+# jlib::auth_sasl_continue --
+# 
+#       We respond to the 
+#       <stream:features>
+#           <mechanisms ...>
+#               <mechanism>DIGEST-MD5</mechanism>
+#               <mechanism>PLAIN</mechanism>
+#            ...
+
+proc jlib::auth_sasl_continue {jlibname} {
+    
+    upvar ${jlibname}::lib lib
+    upvar ${jlibname}::locals locals
+    variable xmppxmlns
+    variable cyrussasl 
+
+    Debug 4 "jlib::auth_sasl_continue"
+    
+    if {$cyrussasl} {
+
+	# TclSASL's callback id's seem to be a bit mixed up.
+	foreach id {authname user pass getrealm} {
+	    lappend callbacks [list $id [list [namespace current]::sasl_callback \
+	      $jlibname]]
+	}
+	set sasltoken [sasl::client_new \
+	  -service xmpp -serverFQDN $locals(server) -callbacks $callbacks \
+	  -flags success_data]
+    } else {
+	
+	# The saslmd5 package follow the naming convention in RFC 2831
+	foreach id {username authzid pass realm} {
+	    lappend callbacks [list $id [list [namespace current]::saslmd5_callback \
+	      $jlibname]]
+	}
+	set sasltoken [saslmd5::client_new \
+	  -service xmpp -serverFQDN $locals(server) -callbacks $callbacks \
+	  -flags success_data]
+    }
+    set lib(sasl,token) $sasltoken
+    
+    if {$cyrussasl} {
+	$sasltoken -operation setprop -property sec_props \
+	  -value {min_ssf 0 max_ssf 0 flags {noplaintext}}
+    } else {
+	$sasltoken setprop sec_props {min_ssf 0 max_ssf 0 flags {noplaintext}}
+    }
+    
+    # Returns a serialized array if succesful.
+    set mechanisms [get_feature $jlibname mechanisms]
+    if {$cyrussasl} {
+	set code [catch {
+	    $sasltoken -operation start -mechanisms $mechanisms \
+	      -interact [list [namespace current]::sasl_interact $jlibname]
+	} out]
+    } else {
+	set ans [$sasltoken start -mechanisms $mechanisms]
+	set code [lindex $ans 0]
+	set out  [lindex $ans 1]
+    }
+    Debug 4 "\t -operation start: code=$code, out=$out"
+    
+    switch -- $code {
+	0 {	    
+	    # ok
+	    array set outArr $out
+	    set xmllist [wrapper::createtag auth \
+	      -attrlist [list xmlns $xmppxmlns(sasl) mechanism $outArr(mechanism)] \
+	      -chdata [encode64 $outArr(output)]]
+	    send $jlibname $xmllist
+	}
+	4 {	    
+	    # continue
+	    array set outArr $out
+	    set xmllist [wrapper::createtag auth \
+	      -attrlist [list xmlns $xmppxmlns(sasl) mechanism $outArr(mechanism)] \
+	      -chdata [encode64 $outArr(output)]]
+	    send $jlibname $xmllist
+	}
+	default {
+	    # This is an error
+	    # We should perhaps send an abort element here.
+	    sasl_final $jlibname error [list sasl-protocol-error $out]
+	}
+    }
+}
+
+proc jlib::sasl_interact {jlibname data} {
+    
+    # empty
+}
+
+# jlib::sasl_callback --
+# 
+#       TclSASL's callback id's seem to be a bit mixed up.
+
+proc jlib::sasl_callback {jlibname data} {
+    
+    upvar ${jlibname}::locals locals
+
+    array set arr $data
+    
+    # @@@ Is 'convertto utf-8' really necessary?
+    
+    switch -- $arr(id) {
+	authname {
+	    # username
+	    set value [encoding convertto utf-8 $locals(username)]
+	}
+	user {
+	    # authzid
+	    set value [encoding convertto utf-8 $locals(myjid2)]
+	}
+	pass {
+	    set value [encoding convertto utf-8 $locals(password)]
+	}
+	getrealm {
+	    set value [encoding convertto utf-8 $locals(server)]
+	}
+	default {
+	    set value ""
+	}
+    }
+    return $value
+}
+
+# jlib::saslmd5_callback --
+# 
+#       The saslmd5 package follow the naming convention in RFC 2831.
+
+proc jlib::saslmd5_callback {jlibname data} {
+    
+    upvar ${jlibname}::locals locals
+
+    array set arr $data
+    
+    switch -- $arr(id) {
+	username {
+	    set value [encoding convertto utf-8 $locals(username)]
+	}
+	pass {
+	    set value [encoding convertto utf-8 $locals(password)]
+	}
+	authzid {
+	    
+	    # xmpp-core sect. 6.1:
+	    # As specified in [SASL], the initiating entity MUST NOT provide an
+	    # authorization identity unless the authorization identity is
+	    # different from the default authorization identity derived from
+	    # the authentication identity as described in [SASL].
+	    
+	    #set value [encoding convertto utf-8 $locals(myjid2)]
+	    set value ""
+	}
+	realm {
+	    set value [encoding convertto utf-8 $locals(server)]
+	}
+	default {
+	    set value ""
+	}
+    }
+    Debug 4 "jlib::saslmd5_callback id=$arr(id), value=$value"
+    
+    return $value
+}
+
+proc jlib::sasl_challenge {jlibname tag xmllist} {
+    
+    Debug 4 "jlib::sasl_challenge"
+    
+    sasl_step $jlibname [wrapper::getcdata $xmllist]
+    return
+}
+
+proc jlib::sasl_step {jlibname serverin64} {
+    
+    upvar ${jlibname}::lib lib
+    upvar ${jlibname}::locals locals
+    variable xmppxmlns
+    variable cyrussasl
+
+    set serverin [decode64 $serverin64]
+    Debug 4 "jlib::sasl_step, serverin=$serverin"
+    
+    # Note that 'step' returns the output if succesful, not a serialized array!
+    if {$cyrussasl} {
+	set code [catch {
+	    $lib(sasl,token) -operation step -input $serverin \
+	      -interact [list [namespace current]::sasl_interact $jlibname]
+	} output]
+    } else {
+	foreach {code output} [$lib(sasl,token) step -input $serverin] {break}
+    }
+    Debug 4 "\t code=$code \n\t output=$output"
+    
+    switch -- $code {
+	0 {	    
+	    # ok
+	    set xmllist [wrapper::createtag response \
+	      -attrlist [list xmlns $xmppxmlns(sasl)] \
+	      -chdata [encode64 $output]]
+	    send $jlibname $xmllist
+	}
+	4 {	    
+	    # continue
+	    set xmllist [wrapper::createtag response \
+	      -attrlist [list xmlns $xmppxmlns(sasl)] \
+	      -chdata [encode64 $output]]
+	    send $jlibname $xmllist
+	}
+	default {
+	    #puts "\t errdetail: [$lib(sasl,token) -operation errdetail]"
+	    sasl_final $jlibname error [list sasl-protocol-error $output]
+	}
+    }
+}
+
+proc jlib::sasl_failure {jlibname tag xmllist} {
+    
+    upvar ${jlibname}::locals locals
+    variable xmppxmlns
+
+    Debug 4 "jlib::sasl_failure"
+    
+    if {[wrapper::getattribute $xmllist xmlns] eq $xmppxmlns(sasl)} {
+	set errE [lindex [wrapper::getchildren $xmllist] 0]
+	if {[llength $errE]} {
+	    set errtag [wrapper::gettag $errE]
+	    set errmsg [sasl_getmsg $errtag]
+	} else {
+	    set errmsg "not-authorized"
+	}
+	sasl_final $jlibname error [list $errtag $errmsg]
+    }
+    return
+}
+
+proc jlib::sasl_success {jlibname tag xmllist} {
+    
+    upvar ${jlibname}::lib lib
+
+    Debug 4 "jlib::sasl_success"
+    
+    # Upon receiving a success indication within the SASL negotiation, the
+    # client MUST send a new stream header to the server, to which the
+    # server MUST respond with a stream header as well as a list of
+    # available stream features.  Specifically, if the server requires the
+    # client to bind a resource to the stream after successful SASL
+    # negotiation, it MUST include an empty <bind/> element qualified by
+    # the 'urn:ietf:params:xml:ns:xmpp-bind' namespace in the stream
+    # features list it presents to the client upon sending the header for
+    # the response stream sent after successful SASL negotiation (but not
+    # before):
+    
+    wrapper::reset $lib(wrap)
+    
+    # We must clear out any server info we've received so far.
+    stream_reset $jlibname
+    
+    if {[catch {
+	sendstream $jlibname -version 1.0
+    } err]} {
+	sasl_final $jlibname error [list network-failure $err]
+	return
+    }
+    sasl_final $jlibname result $xmllist
+
+    return
+    
+    # Wait for the resource binding feature (optional) or session (mandantory):
+    trace_stream_features $jlibname  \
+      [namespace current]::auth_sasl_features_write
+    return
+}
+
+proc jlib::auth_sasl_features_write {jlibname} {
+    
+    upvar ${jlibname}::locals locals
+
+    if {[have_feature $jlibname bind]} {
+	bind_resource $jlibname $locals(resource) \
+	  [namespace current]::resource_bind_cb
+    } else {
+	establish_session $jlibname
+    }
+}
+
+proc jlib::resource_bind_cb {jlibname type subiq} {
+    
+    if {$type eq "error"} {
+	sasl_final $jlibname error $subiq
+    } else {
+	establish_session $jlibname
+    }
+}
+
+proc jlib::establish_session {jlibname} {
+    
+    variable xmppxmlns
+    
+    # Establish the session.
+    set xmllist [wrapper::createtag session \
+      -attrlist [list xmlns $xmppxmlns(session)]]
+    send_iq $jlibname set [list $xmllist] -command \
+      [list [namespace current]::send_session_cb $jlibname]
+}
+
+proc jlib::send_session_cb {jlibname type subiq args} {
+
+    upvar ${jlibname}::locals locals
+    
+    sasl_final $jlibname $type $subiq
+}
+
+proc jlib::sasl_final {jlibname type subiq} {
+    
+    upvar ${jlibname}::locals locals
+    variable xmppxmlns
+    
+    Debug 4 "jlib::sasl_final"
+
+    # We are no longer interested in these.
+    element_deregister $jlibname $xmppxmlns(sasl) [namespace current]::sasl_parse
+
+    uplevel #0 $locals(sasl,cmd) [list $jlibname $type $subiq]
+}
+
+proc jlib::sasl_log {args} {
+    
+    Debug 2 "SASL: $args"
+}
+
+proc jlib::sasl_reset {jlibname} {
+    
+    variable xmppxmlns
+
+    set cmd [trace_stream_features $jlibname]
+    if {$cmd eq "[namespace current]::sasl_features"} {
+	trace_stream_features $jlibname {}
+    }
+    element_deregister $jlibname $xmppxmlns(sasl) [namespace current]::sasl_parse
+}
+
+namespace eval jlib {
+    
+    # This maps Defined Conditions to clear text messages.
+    # RFC 3920 (XMPP core); 6.4 Defined Conditions
+    # Added 'bad-auth' which seems to be a ejabberd anachronism.
+    
+    variable saslmsg
+    array set saslmsg {
+    aborted             {The receiving entity acknowledges an abort element sent by the initiating entity.}
+    incorrect-encoding  {The data provided by the initiating entity could not be processed because the [BASE64] encoding is incorrect.}
+    invalid-authzid     {The authzid provided by the initiating entity is invalid, either because it is incorrectly formatted or because the initiating entity does not have permissions to authorize that ID.}
+    invalid-mechanism   {The initiating entity did not provide a mechanism or requested a mechanism that is not supported by the receiving entity.}
+    mechanism-too-weak  {The mechanism requested by the initiating entity is weaker than server policy permits for that initiating entity.}
+    not-authorized      {The authentication failed because the initiating entity did not provide valid credentials (this includes but is not limited to the case of an unknown username).}
+    temporary-auth-failure {The authentication failed because of a temporary error condition within the receiving entity.}
+    bad-auth            {The authentication failed because the initiating entity did not provide valid credentials (this includes but is not limited to the case of an unknown username).}
+   }
+}
+
+proc jlib::sasl_getmsg {condition} {
+    variable saslmsg
+    
+    if {[info exists saslmsg($condition)]} {
+	return $saslmsg($condition)
+    } else {
+	return $condition
+    }
+}
+
+#-------------------------------------------------------------------------------
diff --git a/lib/jabberlib/jlibtls.tcl b/lib/jabberlib/jlibtls.tcl
new file mode 100644
index 0000000..b5ddb00
--- /dev/null
+++ b/lib/jabberlib/jlibtls.tcl
@@ -0,0 +1,217 @@
+#  jlibtls.tcl --
+#  
+#      This file is part of the jabberlib. It provides support for the
+#      tls network socket security layer.
+#      
+#  Copyright (c) 2004  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: jlibtls.tcl,v 1.19 2007/07/23 15:11:43 matben Exp $
+
+package require tls
+package require jlib
+
+package provide jlibtls 1.0
+
+
+proc jlib::starttls {jlibname cmd args} {
+    
+    upvar ${jlibname}::locals locals
+    variable xmppxmlns
+    
+    Debug 2 "jlib::starttls"
+
+    set locals(tls,cmd) $cmd
+    
+    # Set up callbacks for the xmlns that is of interest to us.
+    element_register $jlibname $xmppxmlns(tls) [namespace current]::tls_parse
+
+    if {[have_feature $jlibname]} {
+	tls_continue $jlibname
+    } else {
+	trace_stream_features $jlibname [namespace current]::tls_features_write
+    }
+}
+
+proc jlib::tls_features_write {jlibname} {
+    
+    Debug 2 "jlib::tls_features_write"
+    
+    trace_stream_features $jlibname {}
+    tls_continue $jlibname
+}
+
+proc jlib::tls_continue {jlibname} {
+    
+    variable xmppxmlns
+
+    Debug 2 "jlib::tls_continue"
+    
+    # Must verify that the server provides a 'starttls' feature.
+    if {![have_feature $jlibname starttls]} {
+	tls_finish $jlibname starttls-nofeature
+    }
+    set xmllist [wrapper::createtag starttls -attrlist [list xmlns $xmppxmlns(tls)]]
+    send $jlibname $xmllist
+    
+    # Wait for 'failure' or 'proceed' element.
+}
+
+proc jlib::tls_parse {jlibname xmldata} {
+    
+    set tag [wrapper::gettag $xmldata]
+    
+    switch -- $tag {
+	proceed {
+	    tls_proceed $jlibname $tag $xmldata
+	}
+	failure {
+	    tls_failure $jlibname $tag $xmldata
+	}
+	default {
+	    tls_finish $jlibname starttls-protocol-error "unrecognized element"
+	}
+    }
+    return
+}
+
+proc jlib::tls_proceed {jlibname tag xmllist} {    
+
+    upvar ${jlibname}::lib lib
+    upvar ${jlibname}::locals locals
+    
+    Debug 2 "jlib::tls_proceed"
+    
+    set sock $lib(sock)
+    
+    # Make it a SSL connection.
+    if {[catch {
+	tls::import $sock -cafile "" -certfile "" -keyfile "" \
+	  -request 1 -server 0 -require 0 -ssl2 no -ssl3 yes -tls1 yes
+    } err]} {
+	close $sock
+	tls_finish $jlibname starttls-failure $err
+    }
+    
+    # We must initiate the handshake before getting any answers.
+    set locals(tls,retry) 0
+    set locals(tls,fevent) [fileevent $sock readable]
+    tls_handshake $jlibname
+}
+
+# jlib::tls_handshake --
+# 
+#       Performs the TLS handshake using filevent readable until completed
+#       or a nonrecoverable error.
+#       This method of using fileevent readable seems independent of
+#       speed of network connection (dialup/broadband) which a fixed
+#       loop with 50ms delay isn't!
+
+proc jlib::tls_handshake {jlibname} {
+    global  errorCode
+    upvar ${jlibname}::lib lib
+    upvar ${jlibname}::locals locals
+    
+    set sock $lib(sock)
+    
+    # Do SSL handshake.
+    if {$locals(tls,retry) > 100} { 
+	close $sock
+	set err "too long retry to setup SSL connection"
+	tls_finish $jlibname starttls-failure $err
+    } elseif {[catch {tls::handshake $sock} complete]} {
+	if {[lindex $errorCode 1] eq "EAGAIN"} {
+	    incr locals(tls,retry)
+	    
+	    # Temporarily hijack these events.
+	    fileevent $sock readable  \
+	      [namespace code [list tls_handshake $jlibname]]
+	} else {
+	    close $sock
+	    tls_finish $jlibname starttls-failure $err
+	}
+    } elseif {$complete} {
+	Debug 2 "\t number of TLS handshakes=$locals(tls,retry)"
+	
+	# Reset the event handler to what it was.
+	fileevent $sock readable $locals(tls,fevent)
+	tls_handshake_fin $jlibname
+    }   
+}
+
+proc jlib::tls_handshake_fin {jlibname} {
+
+    upvar ${jlibname}::lib lib
+
+    wrapper::reset $lib(wrap)
+    
+    # We must clear out any server info we've received so far.
+    stream_reset $jlibname
+    set sock $lib(sock)
+    
+    # The tls package resets the encoding to: -encoding binary
+    if {[catch {
+	fconfigure $sock -encoding utf-8
+	sendstream $jlibname -version 1.0
+    } err]} {
+	tls_finish $jlibname network-failure $err
+	return
+    }
+
+    # Wait for the SASL features. Seems to be the only way to detect success.
+    trace_stream_features $jlibname [namespace current]::tls_features_write_2nd
+    return
+}
+
+proc jlib::tls_features_write_2nd {jlibname} {
+    
+    Debug 2 "jlib::tls_features_write_2nd"
+        
+    tls_finish $jlibname
+}
+
+proc jlib::tls_failure {jlibname tag xmllist} {
+
+    Debug 2 "jlib::tls_failure"
+    
+    # Seems we don't get any additional error info here.
+    tls_finish $jlibname starttls-failure "tls failed"
+}
+
+proc jlib::tls_finish {jlibname {errcode ""} {msg ""}} {
+
+    upvar ${jlibname}::locals locals
+    variable xmppxmlns
+    
+    Debug 2 "jlib::tls_finish errcode=$errcode, msg=$msg"
+
+    trace_stream_features $jlibname {}
+    element_deregister $jlibname $xmppxmlns(tls) [namespace current]::tls_parse
+
+    if {$errcode ne ""} {
+	uplevel #0 $locals(tls,cmd) $jlibname [list error [list $errcode $msg]]
+    } else {
+	uplevel #0 $locals(tls,cmd) $jlibname [list result {}]
+    }
+}
+
+# jlib::tls_reset --
+# 
+# 
+
+proc jlib::tls_reset {jlibname} {
+    
+    variable xmppxmlns
+
+    element_deregister $jlibname $xmppxmlns(tls) [namespace current]::tls_parse
+
+    set cmd [trace_stream_features $jlibname]
+    if {$cmd eq "[namespace current]::tls_features_write"} {
+	trace_stream_features $jlibname {}
+    } elseif {$cmd eq "[namespace current]::tls_features_write_2nd"} {
+	trace_stream_features $jlibname {}
+    }	
+}
+
+#-------------------------------------------------------------------------------
diff --git a/lib/jabberlib/muc.tcl b/lib/jabberlib/muc.tcl
new file mode 100644
index 0000000..40d7c00
--- /dev/null
+++ b/lib/jabberlib/muc.tcl
@@ -0,0 +1,655 @@
+#  muc.tcl --
+#  
+#      This file is part of jabberlib.
+#      It implements the Multi User Chat (MUC) protocol part of the XMPP
+#      protocol as defined by the 'http://jabber.org/protocol/muc*'
+#      namespace.
+#      
+#  Copyright (c) 2003-2005  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: muc.tcl,v 1.40 2007/10/22 11:51:33 matben Exp $
+# 
+############################# USAGE ############################################
+#
+#   NAME
+#      muc - convenience command library for MUC
+#      
+#   OPTIONS
+#	see below for instance command options
+#	
+#   INSTANCE COMMANDS
+#      jlibname muc allroomsin
+#      jlibname muc create roomjid nick callback ?-extras?
+#      jlibname muc destroy roomjid ?-command, -reason, alternativejid?
+#      jlibname muc enter roomjid nick ?-command, -extras, -password?
+#      jlibname muc exit roomjid
+#      jlibname muc getaffiliation roomjid affiliation callback
+#      jlibname muc getrole roomjid role callback
+#      jlibname muc getroom roomjid callback
+#      jlibname muc invite roomjid jid ?-reason?
+#      jlibname muc isroom jid
+#      jlibname muc mynick roomjid
+#      jlibname muc participants roomjid
+#      jlibname muc setaffiliation roomjid nick affiliation ?-command, -reason?
+#      jlibname muc setnick roomjid nick ?-command?
+#      jlibname muc setrole roomjid nick role ?-command, -reason?
+#      jlibname muc setroom roomjid type ?-command, -form?
+#      
+############################# CHANGES ##########################################
+#
+#       0.1         first version
+#       0.2         rewritten as a standalone component
+#       0.3         ensamble command
+#       
+# 050913 INCOMPATIBLE CHANGE! complete reorganization using ensamble command.
+
+package require jlib
+package require jlib::disco
+package require jlib::roster
+
+package provide jlib::muc 0.3
+
+namespace eval jlib::muc {
+    
+    # Globals same for all instances of this jlib.
+    variable debug 0
+    
+    variable xmlns 
+    array set xmlns {
+	"muc"           "http://jabber.org/protocol/muc"
+	"admin"         "http://jabber.org/protocol/muc#admin"
+	"owner"         "http://jabber.org/protocol/muc#owner"
+	"user"          "http://jabber.org/protocol/muc#user"
+    }
+
+    variable muc
+    set muc(affiliationExp) {(owner|admin|member|outcast|none)}
+    set muc(roleExp)        {(moderator|participant|visitor|none)}
+    
+    jlib::disco::registerfeature $xmlns(muc)
+    
+    # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::muc::init --
+# 
+#       Creates a new instance of a muc object.
+#       
+# Arguments:
+#       jlibname:     name of existing jabberlib instance; fully qualified!
+#       args:        
+# 
+# Results:
+#       namespaced instance command
+
+proc jlib::muc::init {jlibname args} {
+    
+    Debug 2 "jlib::muc::init jlibname=$jlibname"
+      
+    # Instance specific namespace.
+    namespace eval ${jlibname}::muc {
+	variable cache
+	variable rooms
+    }
+    upvar ${jlibname}::muc::cache cache
+    upvar ${jlibname}::muc::rooms rooms
+    
+    # Register service.
+    $jlibname service register muc muc
+
+    $jlibname register_reset [namespace current]::reset
+            
+    return
+}
+
+# jlib::muc::cmdproc --
+#
+#       Just dispatches the command to the right procedure.
+#
+# Arguments:
+#       jlibname    name of jabberlib instance.
+#       cmd         the method.
+#       args        all args to the cmd method.
+#       
+# Results:
+#       from the individual command if any.
+
+proc jlib::muc::cmdproc {jlibname cmd args} {
+    return [eval {$cmd $jlibname} $args]
+}
+
+# jlib::muc::invoke_callback --    ?????????????
+# 
+# 
+
+proc jlib::muc::invoke_callback {mucname cmd type subiq} {
+    uplevel #0 $cmd [list $mucname $type $subiq]
+}
+
+# jlib::muc::enter --
+# 
+#       Enter room.
+#       
+# Arguments:
+#       jlibname    name of jabberlib instance.
+#       roomjiid
+#       nick        nick name
+#       args        ?-command callbackProc?
+#                   ?-extras list of xmllist?
+#                   ?-password str?
+#       
+# Results:
+#       none.
+
+proc jlib::muc::enter {jlibname roomjid nick args} {
+    variable xmlns
+    upvar ${jlibname}::muc::cache cache
+    upvar ${jlibname}::muc::rooms rooms
+    
+    set xsub [list]
+    set extras [list]
+    set cmd ""
+    foreach {name value} $args {
+	
+	switch -- $name {
+	    -command {
+		set cmd $value
+	    }
+	    -extras {
+		set extras $value
+	    }
+	    -password {
+		set xsub [list [wrapper::createtag "password" \
+		  -chdata $value]]
+	    }
+	    default {
+		return -code error "Unrecognized option \"$name\""
+	    }
+	}
+    }
+    set jid $roomjid/$nick
+    set xelem [wrapper::createtag "x" -subtags $xsub \
+      -attrlist [list xmlns $xmlns(muc)]]
+    $jlibname send_presence -to $jid -xlist [list $xelem] -extras $extras \
+      -command [list [namespace current]::parse_enter $cmd]
+    set cache($roomjid,mynick) $nick
+    set rooms($roomjid) 1
+    $jlibname service setroomprotocol $roomjid "muc"
+}
+
+# jlib::muc::parse_enter --
+# 
+#       Callback when entering room to make sure there are no error.
+
+proc jlib::muc::parse_enter {cmd jlibname xmldata} {
+    upvar ${jlibname}::muc::cache cache
+
+    set from [wrapper::getattribute $xmldata from]
+    set type [wrapper::getattribute $xmldata type]
+    if {$type eq ""} {
+	set type "available"
+    }    
+    set roomjid [jlib::jidmap [jlib::barejid $from]]
+    if {[string equal $type "error"]} {
+	unset -nocomplain cache($roomjid,mynick)
+    } else {
+	set cache($roomjid,inside) 1
+    }
+    if {$cmd ne ""} {
+	uplevel #0 $cmd [list $jlibname $xmldata]
+    }
+}
+
+# jlib::muc::exit --
+# 
+#       Exit room.
+
+proc jlib::muc::exit {jlibname roomjid} {
+    upvar ${jlibname}::muc::cache cache
+
+    if {[info exists cache($roomjid,mynick)]} {
+	set jid $roomjid/$cache($roomjid,mynick)
+	$jlibname send_presence -to $jid -type "unavailable"
+	unset -nocomplain cache($roomjid,mynick)
+    }
+    unset -nocomplain cache($roomjid,inside)
+    $jlibname roster clearpresence "${roomjid}*"
+}
+
+# jlib::muc::setnick --
+# 
+#       Set new nick name for room.
+
+proc jlib::muc::setnick {jlibname roomjid nick args} {
+    upvar ${jlibname}::muc::cache cache
+    
+    set opts [list]
+    foreach {name value} $args {
+	switch -- $name {
+	    -command {
+		lappend opts $name $value
+	    }
+	    default {
+		return -code error "Unrecognized option \"$name\""
+	    }
+	}
+    }
+    set jid $roomjid/$nick
+    eval {$jlibname send_presence -to $jid} $opts
+    set cache($roomjid,mynick) $nick
+}
+
+# jlib::muc::invite --
+# 
+# 
+
+proc jlib::muc::invite {jlibname roomjid jid args} {
+    variable xmlns
+
+    set opts [list]
+    set children [list]
+    foreach {name value} $args {
+	switch -- $name {
+	    -command {
+		lappend opts $name $value
+	    }
+	    -reason {
+		lappend children [wrapper::createtag  \
+		  [string trimleft $name "-"] -chdata $value]
+	    }
+	    -continue {
+		lappend children [wrapper::createtag "continue"]
+	    }
+	    default {
+		return -code error "Unrecognized option \"$name\""
+	    }
+	}
+    }    
+    set invite [list [wrapper::createtag "invite"  \
+      -attrlist [list to $jid] -subtags $children]]
+    
+    set xelem [wrapper::createtag "x"     \
+      -attrlist [list xmlns $xmlns(user)] \
+      -subtags $invite]
+    eval {$jlibname send_message $roomjid -xlist [list $xelem]} $opts
+}
+
+# jlib::muc::setrole --
+# 
+# 
+
+proc jlib::muc::setrole {jlibname roomjid nick role args} {
+    variable muc
+    variable xmlns
+    
+    if {![regexp $muc(roleExp) $role]} {
+	return -code error "Unrecognized role \"$role\""
+    }
+    set opts [list]
+    set subitem [list]
+    foreach {name value} $args {
+	switch -- $name {
+	    -command {
+		lappend opts -command [concat $value $jlibname]
+	    }
+	    -reason {
+		set subitem [list [wrapper::createtag "reason" -chdata $value]]
+	    }
+	    default {
+		return -code error "Unrecognized option \"$name\""
+	    }
+	}
+    }
+    
+    set subelements [list [wrapper::createtag "item"  \
+      -attrlist [list nick $nick role $role]  \
+      -subtags $subitem]]
+    
+    set xmllist [wrapper::createtag "query" \
+      -attrlist [list xmlns $xmlns(admin)]  \
+      -subtags $subelements]
+    eval {$jlibname send_iq "set" [list $xmllist] -to $roomjid} $opts
+}
+
+# jlib::muc::setaffiliation --
+# 
+# 
+
+proc jlib::muc::setaffiliation {jlibname roomjid nick affiliation args} {
+    variable muc
+    variable xmlns
+    
+    if {![regexp $muc(affiliationExp) $affiliation]} {
+	return -code error "Unrecognized affiliation \"$affiliation\""
+    }
+    set opts [list]
+    set subitem [list]
+    foreach {name value} $args {
+	switch -- $name {
+	    -command {
+		lappend opts -command [concat $value $jlibname]
+	    }
+	    -reason {
+		set subitem [list [wrapper::createtag "reason" -chdata $value]]
+	    }
+	    default {
+		return -code error "Unrecognized option \"$name\""
+	    }
+	}
+    }
+
+    switch -- $affiliation {
+    	owner {
+    	    set ns $xmlns(owner)
+    	}
+    	default {
+    	    set ns $xmlns(admin)
+    	}
+    }
+    
+    set subelements [list [wrapper::createtag "item"  \
+      -attrlist [list nick $nick affiliation $affiliation] \
+      -subtags $subitem]]
+    
+    set xmllist [wrapper::createtag "query" \
+      -attrlist [list xmlns $ns] -subtags $subelements]
+    eval {$jlibname send_iq "set" [list $xmllist] -to $roomjid} $opts
+}
+
+# jlib::muc::getrole --
+# 
+# 
+
+proc jlib::muc::getrole {jlibname roomjid role callback} {
+    variable muc
+    variable xmlns
+    
+    if {![regexp $muc(roleExp) $role]} {
+	return -code error "Unrecognized role \"$role\""
+    }
+    set subelements [list [wrapper::createtag "item" \
+      -attrlist [list role $role]]]
+    
+    set xmllist [wrapper::createtag "query" \
+      -attrlist [list xmlns $xmlns(admin)]  \
+      -subtags $subelements]
+    $jlibname send_iq "get" [list $xmllist] -to $roomjid \
+      -command [concat $callback $jlibname]
+}
+
+# jlib::muc::getaffiliation --
+# 
+# 
+
+proc jlib::muc::getaffiliation {jlibname roomjid affiliation callback} {
+    variable muc
+    variable xmlns
+    
+    if {![regexp $muc(affiliationExp) $affiliation]} {
+	return -code error "Unrecognized role \"$affiliation\""
+    }
+    set subelements [list [wrapper::createtag "item" \
+      -attrlist [list affiliation $affiliation]]]
+
+    switch -- $affiliation {
+    	owner - admin {
+    	    set ns $xmlns(owner)
+    	}
+    	default {
+    	    set ns $xmlns(admin)
+    	}
+    }
+    
+    set xmllist [wrapper::createtag "query" \
+      -attrlist [list xmlns $ns] -subtags $subelements]
+    $jlibname send_iq "get" [list $xmllist] -to $roomjid \
+      -command [concat $callback $jlibname]
+}
+
+# jlib::muc::create --
+# 
+#       The first thing to do when creating a room.
+#       
+# Arguments:
+#       jlibname    name of jabberlib instance.
+#       roomjiid
+#       nick        nick name
+#       command     callbackProc
+#       args        ?-extras list of xmllist?
+#       
+# Results:
+#       none.
+
+proc jlib::muc::create {jlibname roomjid nick command args} {
+    variable xmlns
+    upvar ${jlibname}::muc::cache cache
+    upvar ${jlibname}::muc::rooms rooms
+
+    set extras [list]
+    foreach {name value} $args {
+	
+	switch -- $name {
+	    -extras {
+		set extras $value
+	    }
+	    default {
+		return -code error "Unrecognized option \"$name\""
+	    }
+	}
+    }
+    set jid $roomjid/$nick
+    set xelem [wrapper::createtag "x" -attrlist [list xmlns $xmlns(muc)]]
+    $jlibname send_presence  \
+      -to $jid  -xlist [list $xelem]  -extras $extras  \
+      -command [list [namespace current]::parse_create $command]
+    set cache($roomjid,mynick) $nick
+    set rooms($roomjid) 1
+    $jlibname service setroomprotocol $roomjid "muc"
+}
+
+proc jlib::muc::parse_create {cmd jlibname xmldata} {
+    upvar ${jlibname}::muc::cache cache
+
+    set from [wrapper::getattribute $xmldata from]
+    set type [wrapper::getattribute $xmldata type]
+    if {$type eq ""} {
+	set type "available"
+    }    
+    set roomjid [jlib::jidmap [jlib::barejid $from]]
+    if {[string equal $type "error"]} {
+	unset -nocomplain cache($roomjid,mynick)
+    } else {
+	set cache($roomjid,inside) 1
+    }
+    if {$cmd ne ""} {
+	uplevel #0 $cmd [list $jlibname $xmldata]
+    }
+}
+
+# jlib::muc::setroom --
+# 
+#       Sends an iq set element to room. If -form the 'type' argument is
+#       omitted.
+#       
+# Arguments:
+#       jlibname     name of muc instance.
+#       roomjid     the rooms jid.
+#       type        typically 'submit' or 'cancel'.
+#       args:        
+#           -command 
+#           -form   xmllist starting with the x-element
+#       
+# Results:
+#       None.
+
+proc jlib::muc::setroom {jlibname roomjid type args} {
+    variable xmlns
+
+    set opts [list]
+    set subelements [list]
+    foreach {name value} $args {
+	switch -- $name {
+	    -command {
+		lappend opts -command [concat $value $jlibname]
+	    }
+	    -form {
+		set xelem $value
+	    }
+	    default {
+		return -code error "Unrecognized option \"$name\""
+	    }
+	}
+    }
+    if {[info exists xelem]} {
+        if {[llength $xelem] == 0} {
+   	    set xelem [list [wrapper::createtag "x"  \
+	      -attrlist [list xmlns "jabber:x:data" type $type]]]
+        }
+        set xmllist [wrapper::createtag "query" -subtags $xelem \
+          -attrlist [list xmlns $xmlns(owner)]]
+        eval {$jlibname send_iq "set" [list $xmllist] -to $roomjid} $opts
+    }
+}
+
+# jlib::muc::destroy --
+# 
+# 
+# Arguments:
+#       jlibname     name of muc instance.
+#       roomjid     the rooms jid.
+#       args        -command, -reason, alternativejid.
+#       
+# Results:
+#       None.
+
+proc jlib::muc::destroy {jlibname roomjid args} {
+    variable xmlns
+
+    set opts [list]
+    set subelements [list]
+    foreach {name value} $args {
+	
+	switch -- $name {
+	    -command {
+		lappend opts -command [concat $value $jlibname]
+	    }
+	    -reason {
+		lappend subelements [wrapper::createtag "reason" \
+		  -chdata $value]
+	    }
+	    -alternativejid {
+		lappend subelements [wrapper::createtag "alt" \
+		  -attrlist [list jid $value]]
+	    }
+	    default {
+		return -code error "Unrecognized option \"$name\""
+	    }
+	}
+    }
+      
+    set destroyelem [wrapper::createtag "destroy" -subtags $subelements \
+      -attrlist [list jid $roomjid]]
+
+    set xmllist [wrapper::createtag "query" -subtags [list $destroyelem] \
+      -attrlist [list xmlns $xmlns(owner)]]
+    eval {$jlibname send_iq "set" [list $xmllist] -to $roomjid} $opts
+}
+
+# jlib::muc::getroom --
+# 
+# 
+
+proc jlib::muc::getroom {jlibname roomjid callback} {
+    variable xmlns
+
+    set xmllist [wrapper::createtag "query" \
+      -attrlist [list xmlns $xmlns(owner)]]
+    $jlibname send_iq "get" [list $xmllist] -to $roomjid  \
+      -command [concat $callback $jlibname]
+}
+
+# jlib::muc::mynick --
+# 
+#       Returns own nick name for room, or empty if not there.
+
+proc jlib::muc::mynick {jlibname roomjid} {
+    upvar ${jlibname}::muc::cache cache
+    
+    if {[info exists cache($roomjid,mynick)]} {
+	return $cache($roomjid,mynick)
+    } else {
+	return ""
+    }
+}
+
+# jlib::muc::allroomsin --
+# 
+#       Returns a list of all room jid's we are inside.
+
+proc jlib::muc::allroomsin {jlibname} {
+    upvar ${jlibname}::muc::cache cache
+    
+    set roomList [list]
+    foreach key [array names cache "*,inside"] {
+	regexp {(.+),inside} $key match room
+	lappend roomList $room
+    }
+    return $roomList
+}
+
+proc jlib::muc::isroom {jlibname jid} {    
+    upvar ${jlibname}::muc::rooms rooms
+    
+    if {[info exists rooms($jid)]} {
+	return 1
+    } else {
+	return 0
+    }
+}
+
+# jlib::muc::participants --
+#
+#
+
+proc jlib::muc::participants {jlibname roomjid} {
+    upvar ${jlibname}::muc::cache cache
+    
+    set everyone [list]
+
+    # The rosters presence elements should give us all info we need.
+    foreach userAttr [$jlibname roster getpresence $roomjid -type available] {
+	unset -nocomplain attr
+	array set attr $userAttr
+	lappend everyone $roomjid/$attr(-resource)
+    }
+    return $everyone
+}
+
+proc jlib::muc::reset {jlibname} {    
+    upvar ${jlibname}::muc::cache cache
+    upvar ${jlibname}::muc::rooms rooms
+    
+    unset -nocomplain cache
+    unset -nocomplain rooms
+}
+
+proc jlib::muc::Debug {num str} {
+    variable debug
+    if {$num <= $debug} {
+	puts $str
+    }
+}
+
+# We have to do it here since need the initProc befor doing this.
+
+namespace eval jlib::muc {
+    
+    jlib::ensamble_register muc    \
+      [namespace current]::init    \
+      [namespace current]::cmdproc
+}
+
+#-------------------------------------------------------------------------------
+
diff --git a/lib/jabberlib/pep.tcl b/lib/jabberlib/pep.tcl
new file mode 100644
index 0000000..eece5d6
--- /dev/null
+++ b/lib/jabberlib/pep.tcl
@@ -0,0 +1,389 @@
+#  pep.tcl --
+#
+#      This file is part of the jabberlib. It contains support code
+#      for the Personal Eventing PubSub 
+#      (xmlns='http://jabber.org/protocol/pubsub') XEP-0163.
+#
+#  Copyright (c) 2007 Mats Bengtsson
+#  Copyright (c) 2006 Antonio Cano Damas
+#  
+# This file is distributed under BSD style license.
+#
+# $Id: pep.tcl,v 1.10 2007/09/06 13:20:47 matben Exp $
+#
+############################# USAGE ############################################
+#
+#   INSTANCE COMMANDS
+#      jlibName pep create 
+#      jlibName pep have
+#      jlibName pep publish
+#      jlibName pep retract
+#      jlibName pep subscribe
+#
+################################################################################
+#
+#   With PEP version 1.0 and mutual presence subscriptions we only need:
+#   
+#      jlibName pep have
+#      jlibName pep publish
+#      jlibName pep retract ?-notify 0|1?
+#     
+#   Typical names and nodes:
+#           activity    'http://jabber.org/protocol/activity'
+#           geoloc      'http://jabber.org/protocol/geoloc'
+#           mood        'http://jabber.org/protocol/mood'
+#           tune        'http://jabber.org/protocol/tune'
+#     
+#   NB:  It is currently unclear there should be an id attribute in the item
+#        element since PEP doesn't use it but pubsub do, and the experimental
+#        OpenFire PEP implementation.
+
+package require jlib::disco
+package require jlib::pubsub
+
+package provide jlib::pep 0.3
+
+namespace eval jlib::pep {
+
+    # Common xml namespaces.
+    variable xmlns
+    array set xmlns {
+        node_config "http://jabber.org/protocol/pubsub#node_config"
+    }
+
+    variable state
+}
+
+# jlib::pep::init --
+#
+#       Creates a new instance of the pep object.
+
+proc jlib::pep::init {jlibname} {
+    
+    # Instance specifics arrays.
+    namespace eval ${jlibname}::pep {
+	variable autosub
+	set autosub(presreg) 0
+    }
+}
+
+proc jlib::pep::cmdproc {jlibname cmd args} {
+    return [eval {$cmd $jlibname} $args]
+}
+
+# Setting own PEP --------------------------------------------------------------
+#
+#       Disco server for PEP, disco own bare JID, create pubsub node.
+#       
+#       1) Disco server for pubsub/pep support
+#       2) Create node if not there             (optional)
+#       3) Publish item
+
+# jlib::pep::have --
+# 
+#       Simplified way to know if a JID supports PEP or not.
+#       Typically only needed for the server JID.
+#       The command just gets invoked with: jlibname boolean
+
+proc jlib::pep::have {jlibname jid cmd} {    
+    $jlibname disco get_async info $jid [namespace code [list OnPepDisco $cmd]]    
+}
+
+proc  jlib::pep::OnPepDisco {cmd jlibname type from subiq args} {
+
+    set havepep 0
+    if {$type eq "result"} {
+	set node [wrapper::getattribute $subiq node]
+	
+	# Check if disco returns <identity category='pubsub' type='pep'/>
+	if {[$jlibname disco iscategorytype pubsub/pep $from $node]} {
+	    set havepep 1
+	}
+    }
+    uplevel #0 $cmd [list $jlibname $havepep]
+}
+
+# jlib::pep::create --
+#
+#      Create a PEP node service. 
+#      This shall not be necessary if we want just the default configuration.
+#
+# Arguments:
+#       node    typically xmlns
+#       args:   -access_model   "presence", "open", "roster", or "whitelist" 
+#               -fields         additional list of field elements
+#               -command        tclProc
+#
+# Results:
+#       none
+
+proc jlib::pep::create {jlibname node args} {
+    variable xmlns
+    
+    array set argsA {
+	-access_model presence
+	-command      {}
+	-fields       {}
+    }
+    array set argsA $args
+
+    # Configure setup for PEP node
+    set valueFormE [wrapper::createtag value -chdata $xmlns(node_config)]
+    set fieldFormE [wrapper::createtag field  \
+      -attrlist [list var "FORM_TYPE" type hidden] \
+      -subtags [list $valueFormE]]
+
+    # PEP Values for access_model: roster / presence / open or authorize / whitelist
+    set valueModelE [wrapper::createtag value -chdata $argsA(-access_model)]
+    set fieldModelE [wrapper::createtag field   \
+      -attrlist [list var "pubsub#access_model"] \
+      -subtags [list $valueModelE]]
+
+    set xattr [list xmlns "jabber:x:data" type submit]
+    set xsubE [list $fieldFormE $fieldModelE]
+    set xsubE [concat $xsubE $argsA(-fields)]
+    set xE [wrapper::createtag x -attrlist $xattr -subtags $xsubE]
+
+    $jlibname pubsub create -node $node -configure $xE -command $argsA(-command)
+}
+
+# jlib::pep::publish --
+#
+#       Publish a stanza into the PEP node (create an item to a node)
+#       Typically:
+#       
+#       <publish node='http://jabber.org/protocol/mood'> 
+#           <item>
+#               <mood xmlns='http://jabber.org/protocol/mood'>
+#                   <annoyed/>
+#                   <text>curse my nurse!</text>
+#               </mood>
+#           </item> 
+#       </publish>
+#
+# Arguments:
+#       node    typically xmlns
+#       itemE   XML stanza to publishing
+#       args    for the 'publish subscribe'
+#
+# Results:
+#       none
+
+proc jlib::pep::publish {jlibname node itemE args} {
+    eval {$jlibname pubsub publish $node -items [list $itemE]} $args
+}
+
+# jlib::pep::retract --
+#
+#       Retract a PEP item (Delete an item from a node)
+#
+# Arguments:
+#       node    typically xmlns
+#
+# Results:
+#       none
+
+proc jlib::pep::retract {jlibname node args} {
+    #set itemE [wrapper::createtag item]
+    # Se comment above about this one.
+    set itemE [wrapper::createtag item -attrlist [list id current]]
+    eval {$jlibname pubsub retract $node [list $itemE]} $args
+}
+
+# Others PEP -------------------------------------------------------------------
+# 
+#       In normal circumstances with mutual presence subscriptions we don't
+#       need to do pusub subscribe.
+# 
+#       1) disco bare JID      (not necessary for 1.0)
+#       2) subscribe to node   (not necessary for 1.0)
+#       3) handle events       (pubsub register_event tclProc -node)
+
+# jlib::pep::subscribe --
+# 
+# Arguments:
+#       jid     JID which we want to subscribe to.
+#       node    typically xmlns
+#       args:   anything for the pubsub command, like -command.
+#
+# Results:
+#       none
+
+proc jlib::pep::subscribe {jlibname jid node args} {
+    
+    # If an entity is not subscribed to the account owner's presence, 
+    # it MUST subscribe to a node using....
+    set myjid2 [$jlibname myjid2]
+    eval {$jlibname pubsub subscribe $jid $myjid2 -node $node} $args
+}
+
+# @@@ OUTDATED; BACKUP !!!!!!!!!!!!!!!
+
+# jlib::pep::set_auto_subscribe --
+# 
+#       Subscribe all available users automatically.
+
+proc jlib::pep::set_auto_subscribe {jlibname node args} {    
+    upvar ${jlibname}::pep::autosub  autosub
+
+    array set argsA {
+	-command    {}
+    }
+    array set argsA $args
+    set autosub($node,node) $node
+    set autosub($node,-command) $argsA(-command)
+    
+    # For those where we've already got presence.
+    set jidL [$jlibname roster getusers -type available]
+    foreach jid $jidL {
+	
+	# We may not yet have disco info for this.
+	if {[$jlibname disco iscategorytype gateway/* $jid]} {
+	    continue
+	}
+	
+	# If Juliet's server supports PEP (thereby making juliet@capulet.com 
+	# a virtual pubsub service), it MUST return an identity of "pubsub/pep"
+	$jlibname disco get_async items $jid  \
+	  [list [namespace current]::OnDiscoItems $node]
+    }
+    
+    # And register an event handler for any presence.    
+    if {!$autosub(presreg)} {
+	set autosub(presreg) 1
+	$jlibname presence_register_int available  \
+	  [namespace code [list PresenceEvent $node]]
+    }
+}
+
+proc jlib::pep::list_auto_subscribe {jlibname} {
+    upvar ${jlibname}::pep::autosub  autosub
+    
+    set nodes {}
+    foreach {key node} [array get autosub *,node] {
+	lappend nodes $node
+    }
+    return $nodes
+}
+
+proc jlib::pep::have_auto_subscribe {jlibname node} {
+    upvar ${jlibname}::pep::autosub  autosub
+    
+    return [info exists autosub($node,node)]
+}
+
+proc jlib::pep::unset_auto_subscribe {jlibname node} {
+    upvar ${jlibname}::pep::autosub  autosub
+    
+    array unset autosub $node,*
+    if {![llength [array names autosub *,node]]} {
+	set autosub(presreg) 0
+	$jlibname presence_deregister_int available \
+	  [namespace code [list PresenceEvent $node]]
+    }
+}
+
+proc jlib::pep::PresenceEvent {jlibname xmldata node} {
+    upvar ${jlibname}::pep::autosub  autosub
+    variable state
+    
+    set type [wrapper::getattribute $xmldata type]
+    set from [wrapper::getattribute $xmldata from]
+    if {$type eq ""} {
+        set type "available"
+    }
+    set jid2 [jlib::barejid $from]
+    if {![$jlibname roster isitem $jid2]} {
+        return
+    }
+    if {[$jlibname disco iscategorytype gateway/* $from]} {
+        return
+    }
+    
+    # We should be careful not to disco/publish for each presence change.
+    # @@@ There is a small glitch here if user changes presence before we
+    #     received its disco result.
+    if {![$jlibname disco isdiscoed info $from]} {
+	foreach {key node} [array get autosub $node,*] {
+	    $jlibname disco get_async items $jid2  \
+	      [list [namespace current]::OnDiscoItems $node]
+	}
+    }
+}
+
+proc jlib::pep::OnDiscoItems {node jlibname type from subiq args} {
+    
+    # Get contact PEP nodes.
+    if {$type eq "result"} {
+	set nodes [$jlibname disco nodes $from]
+	if {[lsearch -exact $nodes $node] >= 0} {
+
+	    # NEW PEP:
+	    # If an entity is not subscribed to the account owner's presence, 
+	    # it MUST subscribe to a node using....
+	    set subscribe [$jlibname roster getsubscription $from]
+	    set myjid2 [$jlibname myjid2]
+	    $jlibname pubsub subscribe $from $myjid2 -node $node  \
+	      -command $autosub($node,-command)
+	}
+    }
+}
+
+# We have to do it here since need the initProc before doing this.
+namespace eval jlib::pep {
+
+    jlib::ensamble_register pep  \
+      [namespace current]::init    \
+      [namespace current]::cmdproc
+}
+
+# Test:
+if {0} {
+    package require jlib::pep
+    set jlibname ::jlib::jlib1
+    set moodNode "http://jabber.org/protocol/mood"
+    set mood "neutral"
+    proc cb {args} {puts "---> $args"}
+    set server [$jlibname getserver]
+    set myjid2 [$jlibname  myjid2]
+    $jlibname pubsub register_event cb -node $moodNode
+    $jlibname disco send_get info $server cb
+
+    # List items
+    $jlibname disco send_get items $myjid2 cb
+    $jlibname pubsub items $myjid2 $moodNode
+
+    # Retract item from node
+    set pepE [wrapper::createtag mood -attrlist [list xmlns $moodNode]]
+    set itemE [wrapper::createtag item -subtags [list $pepE]]
+    $jlibname pubsub retract $moodNode [list $itemE]
+    
+    # Delete node
+    $jlibname pubsub delete $myjid2 $moodNode
+
+    # Publish item to node
+    set moodChildEs [list [wrapper::createtag mood]]
+    set moodE [wrapper::createtag mood  \
+      -attrlist [list xmlns $moodNode] -subtags $moodChildEs]
+    set itemE [wrapper::createtag item -subtags [list $moodE]]
+    $jlibname pubsub publish $moodNode -items [list $itemE] -command cb
+        
+    # User
+    set jid matben2@stor.no-ip.org
+    $jlibname disco send_get info $jid cb
+    $jlibname disco send_get items $jid cb    
+    $jlibname roster getsubscription $jid
+    $jlibname pubsub items $jid $moodNode
+    
+    # PEP
+    # Owner
+    $jlibname pep have $server cb
+    $jlibname pep create $moodNode
+    $jlibname pep publish $moodNode $itemE
+    
+    # User
+    $jlibname disco send_get items $jid cb    
+    $jlibname pep subscribe $jid $moodNode
+    
+}
+
diff --git a/lib/jabberlib/pkgIndex.tcl b/lib/jabberlib/pkgIndex.tcl
new file mode 100644
index 0000000..1edaffd
--- /dev/null
+++ b/lib/jabberlib/pkgIndex.tcl
@@ -0,0 +1,41 @@
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script.  It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands.  When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded groupchat      1.0 [list source [file join $dir groupchat.tcl]]
+package ifneeded jlib           2.0 [list source [file join $dir jabberlib.tcl]]
+package ifneeded jlib::http     0.1 [list source [file join $dir jlibhttp.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 saslmd5        1.0 [list source [file join $dir saslmd5.tcl]]
+package ifneeded service        1.0 [list source [file join $dir service.tcl]]
+package ifneeded stanzaerror    1.0 [list source [file join $dir stanzaerror.tcl]]
+package ifneeded streamerror    1.0 [list source [file join $dir streamerror.tcl]]
+package ifneeded tinydom        0.2 [list source [file join $dir tinydom.tcl]]
+package ifneeded wrapper        1.2 [list source [file join $dir wrapper.tcl]]
+
+package ifneeded jlib::avatar      0.1 [list source [file join $dir avatar.tcl]]
+package ifneeded jlib::bind        0.1 [list source [file join $dir bind.tcl]]
+package ifneeded jlib::bytestreams 0.4 [list source [file join $dir bytestreams.tcl]]
+package ifneeded jlib::caps        0.3 [list source [file join $dir caps.tcl]]
+package ifneeded jlib::compress    0.1 [list source [file join $dir compress.tcl]]
+package ifneeded jlib::connect     0.1 [list source [file join $dir connect.tcl]]
+package ifneeded jlib::disco       0.1 [list source [file join $dir disco.tcl]]
+package ifneeded jlib::dns         0.1 [list source [file join $dir jlibdns.tcl]]
+package ifneeded jlib::ftrans      0.1 [list source [file join $dir ftrans.tcl]]
+package ifneeded jlib::ibb         0.1 [list source [file join $dir ibb.tcl]]
+package ifneeded jlib::jingle      0.1 [list source [file join $dir jingle.tcl]]
+package ifneeded jlib::muc         0.3 [list source [file join $dir muc.tcl]]
+package ifneeded jlib::pep         0.3 [list source [file join $dir pep.tcl]]
+package ifneeded jlib::pubsub      0.2 [list source [file join $dir pubsub.tcl]]
+package ifneeded jlib::roster      1.0 [list source [file join $dir roster.tcl]]
+package ifneeded jlib::si          0.1 [list source [file join $dir si.tcl]]
+package ifneeded jlib::sipub       0.2 [list source [file join $dir sipub.tcl]]
+package ifneeded jlib::util        0.1 [list source [file join $dir util.tcl]]
+package ifneeded jlib::vcard       0.1 [list source [file join $dir vcard.tcl]]
diff --git a/lib/jabberlib/pubsub.tcl b/lib/jabberlib/pubsub.tcl
new file mode 100644
index 0000000..d4f485b
--- /dev/null
+++ b/lib/jabberlib/pubsub.tcl
@@ -0,0 +1,709 @@
+#  pubsub.tcl --
+#  
+#      This file is part of the jabberlib. It contains support code
+#      for the pub-sub (xmlns='http://jabber.org/protocol/pubsub') XEP-0060.
+#      
+#  Copyright (c) 2005-2006  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: pubsub.tcl,v 1.21 2008/01/01 09:05:27 matben Exp $
+# 
+############################# USAGE ############################################
+#
+#   INSTANCE COMMANDS
+#      jlibName pubsub affiliations
+#      jlibName pubsub create 
+#      jlibName pubsub delete
+#      jlibName pubsub deregister_event
+#      jlibName pubsub items
+#      jlibName pubsub options
+#      jlibName pubsub publish
+#      jlibName pubsub purge
+#      jlibName pubsub register_event
+#      jlibName pubsub retract
+#      jlibName pubsub subscribe
+#      jlibName pubsub unsubscribe
+#
+################################################################################
+#
+#   BRIEF:
+#   
+#       pubsub-service
+#                 node
+#                     item
+#                     item
+#                     ...
+#                 node
+#                     item
+#                     ...
+#                 ...
+#                     
+#   Owner use case:
+#       
+#       create node
+#       delete node
+#       
+#       publish item to a node
+#       retract (remove) item from a node
+#       
+#   User use case:
+#   
+#       register for events
+#       subscribe to a node
+#       unsubscribe from a node
+#       
+################################################################################
+
+package provide jlib::pubsub 0.2
+
+namespace eval jlib::pubsub {
+    
+    variable debug 0
+    
+    # Common xml namespaces.
+    variable xmlns
+    array set xmlns {
+	pubsub   "http://jabber.org/protocol/pubsub"
+	errors   "http://jabber.org/protocol/pubsub#errors"
+	event    "http://jabber.org/protocol/pubsub#event"
+	owner    "http://jabber.org/protocol/pubsub#owner"
+    }
+}
+
+# jlib::pubsub::init --
+# 
+#       Creates a new instance of the pubsub object.
+#       
+# Arguments:
+#       jlibname:     name of existing jabberlib instance
+# 
+# Results:
+#       namespaced instance command
+
+proc jlib::pubsub::init {jlibname} {
+
+    variable xmlns
+
+    # Instance specific arrays.
+    namespace eval ${jlibname}::pubsub {
+	variable items
+	variable events
+    }
+	
+    # Register event notifier.
+    $jlibname message_register normal $xmlns(event) [namespace code event]
+}
+
+proc jlib::pubsub::cmdproc {jlibname cmd args} {
+    
+    # Which command? Just dispatch the command to the right procedure.
+    return [eval {$cmd $jlibname} $args]
+}
+
+# jlib::pubsub::create --
+# 
+#       Create a new pubsub node.
+#       
+# Arguments:
+#       args: 
+#             -to         (JID) if not indicated, we are using PEP recomendations
+#             -command    tclProc
+#             -configure  0 no configure element
+#                         1 new node with default configuration
+#                         xmldata jabber:x:data element
+#             -node       the nodeID (else we get an instant node)
+# 
+# Results:
+#       none
+
+proc jlib::pubsub::create {jlibname args} {
+    
+    variable xmlns
+    
+    set attr [list]
+    set opts [list]
+    set configure 0
+    foreach {key value} $args {
+	set name [string trimleft $key -]
+	
+	switch -- $key {
+	    -command {
+		lappend opts -command $value
+	    }
+	    -configure {
+		set configure $value
+	    }
+	    -node {
+		lappend attr $name $value
+	    }
+	    -to {
+		lappend opts -to $value
+	    }
+	}
+    }
+    set subtags [list [wrapper::createtag create -attrlist $attr]]
+    if {$configure eq "1"} {
+	lappend subtags [wrapper::createtag configure]
+    } elseif {[wrapper::validxmllist $configure]} {
+	lappend subtags [wrapper::createtag configure -subtags [list $configure]]
+    }
+    set xmllist [list [wrapper::createtag pubsub \
+      -attrlist [list xmlns $xmlns(pubsub)] -subtags $subtags]]
+    eval {jlib::send_iq $jlibname set $xmllist} $opts
+}
+
+# jlib::pubsub::configure --
+# 
+#       Get or set configuration options for a node.
+#       
+# Arguments:
+#           type:   get|set
+#           to:     JID
+#           
+# Results:
+#       none
+
+proc jlib::pubsub::configure {jlibname type to node args} {
+    
+    variable xmlns
+
+    set opts [list -to $to]
+    set xE [list]
+    foreach {key value} $args {
+	switch -- $key {
+	    -command {
+		lappend opts -command $value
+	    }
+	    -x {
+		set xE $value
+	    }
+	}
+    }
+    set subtags [list [wrapper::createtag configure  \
+      -attrlist [list node $node] -subtags [list $xE]]]
+    set xmllist [list [wrapper::createtag pubsub \
+      -attrlist [list xmlns $xmlns(owner)] -subtags $subtags]]
+    eval {jlib::send_iq $jlibname $type $xmllist} $opts
+}
+
+# jlib::pubsub::default --
+# 
+#       Request default configuration options for new nodes.
+
+proc jlib::pubsub::default {jlibname to args} {
+    
+    variable xmlns
+
+    set opts [list -to $to]
+    foreach {key value} $args {
+	switch -- $key {
+	    -command {
+		lappend opts -command $value
+	    }
+	}
+    }
+    set subtags [list [wrapper::createtag default]]
+    set xmllist [list [wrapper::createtag pubsub \
+      -attrlist [list xmlns $xmlns(owner)] -subtags $subtags]]
+    eval {jlib::send_iq $jlibname get $xmllist} $opts
+}
+
+# jlib::pubsub::delete --
+# 
+#       Delete a node.
+
+proc jlib::pubsub::delete {jlibname to node args} {
+    
+    variable xmlns
+
+    set opts [list -to $to]
+    foreach {key value} $args {
+	switch -- $key {
+	    -command {
+		lappend opts -command $value
+	    }
+	}
+    }
+    set subtags [list [wrapper::createtag delete -attrlist [list node $node]]]
+    set xmllist [list [wrapper::createtag pubsub \
+      -attrlist [list xmlns $xmlns(owner)] -subtags $subtags]]
+    eval {jlib::send_iq $jlibname set $xmllist} $opts
+}
+
+# jlib::pubsub::purge --
+# 
+#       Purge all node items. (Deletes all items of a node.)
+
+proc jlib::pubsub::purge {jlibname to node args} {
+    
+    variable xmlns
+
+    set opts [list -to $to]
+    foreach {key value} $args {
+	switch -- $key {
+	    -command {
+		lappend opts -command $value
+	    }
+	}
+    }
+    set subtags [list [wrapper::createtag purge -attrlist [list node $node]]]
+    set xmllist [list [wrapper::createtag pubsub \
+      -attrlist [list xmlns $xmlns(owner)] -subtags $subtags]]
+    eval {jlib::send_iq $jlibname set $xmllist} $opts
+}
+
+# jlib::pubsub::subscriptions --
+# 
+#       Gets or sets subscriptions.
+#       
+# Arguments:
+#       type:   get|set
+#       to:     JID
+#       node:   pubsub nodeID
+#       args:
+#           -command    tclProc
+#           -subscriptions  list of subscription elements
+# Results:
+#       none
+
+proc jlib::pubsub::subscriptions {jlibname type to node args} {
+    
+    variable xmlns
+
+    set opts [list -to $to]
+    set subsEs [list]
+    foreach {key value} $args {
+	switch -- $key {
+	    -command {
+		lappend opts -command $value
+	    }
+	    -subscriptions {
+		set subsEs $value
+	    }
+	}
+    }
+    set subtags [list [wrapper::createtag subscriptions  \
+      -attrlist [list node $node] -subtags $subsEs]]
+    set xmllist [list [wrapper::createtag pubsub \
+      -attrlist [list xmlns $xmlns(owner)] -subtags $subtags]]
+    eval {jlib::send_iq $jlibname $type $xmllist} $opts
+}
+
+# jlib::pubsub::affiliations --
+# 
+#       Gets or sets affiliations.
+#       
+# Arguments:
+#       type:   get|set
+#       to:     JID
+#       node:   pubsub nodeID
+#       args:
+#           -command    tclProc
+#           -affiliations  list of affiliation elements
+# Results:
+#       none
+
+proc jlib::pubsub::affiliations {jlibname type to node args} {
+    
+    variable xmlns
+    
+    set opts [list -to $to]
+    set affEs [list]
+    foreach {key value} $args {
+	switch -- $key {
+	    -command {
+		lappend opts -command $value
+	    }
+	    -affiliations {
+		set affEs $value
+	    }
+	}
+    }
+    set subtags [list [wrapper::createtag affiliations]  \
+      -attrlist [list node $node] -subtags $affEs]]
+    set xmllist [list [wrapper::createtag pubsub \
+      -attrlist [list xmlns $xmlns(pubsub)] -subtags $subtags]]
+    eval {jlib::send_iq $jlibname $type $xmllist} $opts
+}
+
+# jlib::pubsub::items --
+# 
+#       Retrieve items from a node.
+
+proc jlib::pubsub::items {jlibname to node args} {
+    
+    variable xmlns
+
+    set opts [list -to $to]
+    set attr [list node $node]
+    set itemids [list]
+    foreach {key value} $args {
+	set name [string trimleft $key -]
+	
+	switch -- $key {
+	    -command {
+		lappend opts -command $value
+	    }
+	    -itemids {
+		set itemids $value
+	    }
+	    -max_items - -subid {
+		lappend attr $name $value
+	    }
+	}
+    }
+    set items [list]
+    foreach id $itemids {
+	lappend items [wrapper::createtag item -attrlist [list id $id]]
+    }
+    set subtags [list [wrapper::createtag items  \
+      -attrlist $attr -subtags $items]]
+    set xmllist [list [wrapper::createtag pubsub \
+      -attrlist [list xmlns $xmlns(pubsub)] -subtags $subtags]]
+    eval {jlib::send_iq $jlibname get $xmllist} $opts
+}
+
+# jlib::pubsub::options --
+# 
+#       Gets or sets options for a JID+node
+# 
+# Arguments:
+#       type:       set or get
+#       to:         JID for pubsub service
+#       jid:        the subscribed JID 
+#       args:
+#           -command    tclProc
+#           -subid      subscription ID
+#           -xdata
+# 
+# Results:
+#       none
+
+proc jlib::pubsub::options {jlibname type to jid node args} {
+    
+    variable xmlns
+
+    set opts [list -to $to]
+    set attr [list node $node jid $jid]
+    set xdata [list]
+
+    foreach {key value} $args {
+	switch -- $key {
+	    -command {
+		lappend opts -command $value
+	    }
+	    -subid {
+		lappend attr subid $value
+	    }
+	    -xdata {
+		set xdata $value
+	    }
+	}
+    }
+    set optE [list [wrapper::createtag options  \
+      -attrlist $attr -subtags [list $xdata]]]
+    set xmllist [list [wrapper::createtag pubsub \
+      -attrlist [list xmlns $xmlns(pubsub)] -subtags $optE]]
+    eval {jlib::send_iq $jlibname $type $xmllist} $opts
+}
+
+# jlib::pubsub::publish --
+# 
+#       Publish an item to a node.
+#
+# Arguments:
+#       args:
+#             -to         (JID) if not indicated, we are using PEP recomendations
+#             -command    tclProc
+#             -configure  0 no configure element
+#                         1 new node with default configuration
+#                         xmldata jabber:x:data element
+#             -node       the nodeID (else we get an instant node)
+#             -items
+#
+# Results:
+#       none
+
+proc jlib::pubsub::publish {jlibname node args} {
+
+    variable xmlns
+    
+    set opts [list]
+    set itemEs [list]
+    foreach {key value} $args {	
+	switch -- $key {
+	    -command {
+		lappend opts -command $value
+	    }
+	    -items {
+		set itemEs $value
+	    }
+	    -to {
+		lappend opts -to $value
+	    }
+	}
+    }
+    set subtags [list [wrapper::createtag publish \
+      -attrlist [list node $node] -subtags $itemEs]]
+    set xmllist [list [wrapper::createtag pubsub \
+      -attrlist [list xmlns $xmlns(pubsub)] -subtags $subtags]]
+    eval {jlib::send_iq $jlibname set $xmllist} $opts
+}
+
+# jlib::pubsub::retract --
+# 
+#       Delete an item from a node.
+
+proc jlib::pubsub::retract {jlibname node items args} {
+    
+    variable xmlns
+
+    set opts [list]
+    set attr [list node $node]
+
+    foreach {key value} $args {
+	switch -- $key {
+	    -command {
+		lappend opts $name $value
+	    }
+	    -notify {
+		# Must be boolean.
+		lappend attr notify $value
+	    }
+	    -to {
+		lappend opts -to $value
+	    }
+	}
+    }
+    set subtags [list [wrapper::createtag retract \
+      -attrlist $attr -subtags $items]]
+    set xmllist [list [wrapper::createtag pubsub \
+      -attrlist [list xmlns $xmlns(pubsub)] -subtags $subtags]]
+    eval {jlib::send_iq $jlibname set $xmllist} $opts
+}
+
+# jlib::pubsub::subscribe --
+# 
+#       Subscribe to a JID+nodeID.
+#       
+# Arguments:
+#       to:         JID for pubsub service
+#       jid:        the subscribed JID 
+#       args:
+#           -command    tclProc
+#           -node       pubsub nodeID; MUST be there except for root collection
+#                       node
+# 
+# Results:
+#       
+
+proc jlib::pubsub::subscribe {jlibname to jid args} {
+    
+    variable xmlns
+    
+    set opts [list -to $to]
+    set attr [list jid $jid]
+    foreach {key value} $args {
+	switch -- $key {
+	    -command {
+		lappend opts -command $value
+	    }
+	    -node {
+		lappend attr node $value
+	    }
+	}
+    }
+    set subEs [list [wrapper::createtag subscribe -attrlist $attr]]
+    set xmllist [list [wrapper::createtag pubsub \
+      -attrlist [list xmlns $xmlns(pubsub)] -subtags $subEs]]
+    eval {jlib::send_iq $jlibname set $xmllist} $opts
+}
+
+# jlib::pubsub::unsubscribe --
+# 
+#       Unsubscribe to a JID+nodeID.
+
+proc jlib::pubsub::unsubscribe {jlibname to jid node args} {
+    
+    variable xmlns
+    
+    set opts [list -to $to]
+    set attr [list node $node jid $jid]
+    foreach {key value} $args {
+	switch -- $key {
+	    -command {
+		lappend opts -command $value
+	    }
+	    -subid {
+		lappend attr subid $value
+	    }
+	}
+    }
+    set unsubE [list [wrapper::createtag unsubscribe -attrlist $attr]]
+    set xmllist [list [wrapper::createtag pubsub \
+      -attrlist [list xmlns $xmlns(pubsub)] -subtags $unsubE]]
+    eval {jlib::send_iq $jlibname set $xmllist} $opts
+}
+
+# jlib::pubsub::register_event --
+# 
+#       Register for specific pubsub events.
+#       
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       func:       tclProc        
+#       args:       -from
+#                   -node
+#                   -seq      priority 0-100 (D=50)
+#       
+# Results:
+#       none.
+
+# @@@ TODO:
+# <event xmlns='http://jabber.org/protocol/pubsub#event'>
+#    <collection>
+#      <node id='new-node-id'>
+#    </collection>
+# </event> 
+  
+proc jlib::pubsub::register_event {jlibname func args} {
+    
+    upvar ${jlibname}::events events
+    
+    # args: -from, -node
+    set from "*"
+    set node "*"
+    set seq 50
+    
+    foreach {key value} $args {
+	switch -- $key {
+	    -from {
+		set from [jlib::ESC $value]
+	    }
+	    -node {
+		
+		# The pubsub service MUST ensure that the NodeID conforms to 
+		# the Resourceprep profile of Stringprep as described in 
+		# RFC 3920.
+		# @@@ ???
+		set node [jlib::resourceprep $value]
+	    }
+	    -seq {
+		set seq $value
+	    }
+	}
+    }
+    set pattern "$from,$node"
+    lappend events($pattern) [list $func $seq]
+    set events($pattern)  \
+      [lsort -integer -index 1 [lsort -unique $events($pattern)]]
+}
+
+proc jlib::pubsub::deregister_event {jlibname func args} {
+    
+    upvar ${jlibname}::events events
+    
+    set from "*"
+    set node "*"
+
+    foreach {key value} $args {
+	switch -- $key {
+	    -from {
+		set from [jlib::ESC $value]
+	    }
+	    -node {
+		set node [jlib::resourceprep $value]
+	    }
+	}
+    }
+    set pattern "$from,$node"
+    if {[info exists events($pattern)]} {
+	set idx [lsearch -glob $events($pattern) [list $func *]]
+	if {$idx >= 0} {
+	    set events($pattern) [lreplace $events($pattern) $idx $idx]
+	}
+    }
+}
+
+# jlib::pubsub::event --
+# 
+#       The event notifier. Dispatches events to the relevant registered
+#       event handlers.
+#       
+#       Normal events:
+#         <event xmlns='http://jabber.org/protocol/pubsub#event'>
+#           <items node='princely_musings'>
+#             <item id='ae890ac52d0df67ed7cfdf51b644e901'>
+#               ... ENTRY ...
+#             </item>
+#           </items>
+#         </event> 
+
+proc jlib::pubsub::event {jlibname ns msgE args} {
+    
+    variable xmlns
+    upvar ${jlibname}::events events
+
+    array set aargs $args
+    set xmldata $aargs(-xmldata)
+    
+    set from [wrapper::getattribute $xmldata from]
+    set nodes [list]
+    
+    set eventEs [wrapper::getchildswithtagandxmlns $xmldata event $xmlns(event)]
+    foreach eventE $eventEs {
+	set itemsEs [wrapper::getchildswithtag $eventE items]
+	foreach itemsE $itemsEs {
+	    lappend nodes [wrapper::getattribute $itemsE node]
+	}
+    }
+    foreach node $nodes {
+	set key "$from,$node"
+	foreach {pattern value} [array get events] {
+	    if {[string match $pattern $key]} {
+		foreach spec $value {
+		    set func [lindex $spec 0]
+		    set code [catch {
+			uplevel #0 $func [list $jlibname $xmldata]
+		    } ans]
+		    if {$code} {
+			bgerror "jlib::pubsub::event $func failed: $code\n$::errorInfo"
+		    }
+		}
+	    }
+	}
+    }
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::pubsub {
+    
+    jlib::ensamble_register pubsub  \
+      [namespace current]::init     \
+      [namespace current]::cmdproc
+}
+
+if {0} {
+    # Test code.
+    set jlib jlib::jlib1
+    set psjid pubsub.sgi.se
+    set psjid pubsub.devrieze.dyndns.org
+    set myjid [$jlib myjid2]
+    set server [$jlib getserver]
+    set itemE [wrapper::createtag item -attrlist [list id 123456789]]
+    proc cb {args} {puts "---> $args"}
+    set node mats
+    set node home/$server/matben/xyz
+    
+    $jlib pubsub create -to $psjid -node $node -command cb
+    $jlib pubsub register_event cb -from $psjid -node $node
+    $jlib pubsub subscribe $psjid $myjid -node $node -command cb
+    $jlib pubsub subscriptions get $psjid $node -command cb
+    $jlib pubsub publish $node -to $psjid -items [list $itemE]
+
+}
+
+#-------------------------------------------------------------------------------
+
diff --git a/lib/jabberlib/readme b/lib/jabberlib/readme
new file mode 100644
index 0000000..b437d5a
--- /dev/null
+++ b/lib/jabberlib/readme
@@ -0,0 +1,12 @@
+
+All jabberlib sources are distributed under the BSD license.
+
+README
+
+      - Install TclXML as a proper package. Must be patched version!
+
+      - start wish
+
+      - TODO
+
+      - If you run tclsh instead of wish be sure to start the event loop.
diff --git a/lib/jabberlib/roster.tcl b/lib/jabberlib/roster.tcl
new file mode 100644
index 0000000..238221c
--- /dev/null
+++ b/lib/jabberlib/roster.tcl
@@ -0,0 +1,1659 @@
+# roster.tcl --
+#
+#       An object for storing the roster and presence information for a 
+#       jabber client. Is used together with jabberlib.
+#
+# Copyright (c) 2001-2006  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: roster.tcl,v 1.68 2008/03/29 11:55:06 matben Exp $
+# 
+# Note that every jid in the rostA is usually (always) without any resource,
+# but the jid's in the presA are identical to the 'from' attribute, except
+# the presA($jid-2,res) which have any resource stripped off. The 'from' 
+# attribute are (always) with /resource.
+# 
+# All jid's in internal arrays are STRINGPREPed!
+# 
+# Variables used in roster:
+# 
+#       rostA(groups)             : List of all groups the exist in roster.
+#
+#	rostA($jid,item)          : $jid.
+#	
+#	rostA($jid,name)          : Name of $jid.
+#	
+#	rostA($jid,groups)        : Groups $jid is in. Note: PLURAL!
+#
+#	rostA($jid,subscription)  : Subscription of $jid (to|from|both|"")
+#
+#	rostA($jid,ask)           : "Ask" of $jid 
+#                                     (subscribe|unsubscribe|"")
+#                                       
+#	presA($jid-2,res)         : List of resources for this $jid.
+#
+#       presA($from,type)         : One of 'available' or 'unavailable.
+#
+#       presA($from,status)       : The presence status element.
+#
+#       presA($from,priority)     : The presence priority element.
+#
+#       presA($from,show)         : The presence show element.
+#
+#       presA($from,x,xmlns)      : Storage for x elements.
+#                                     xmlns is a namespace but where any
+#                                     http://jabber.org/protocol/ stripped off
+#                  
+#       oldpresA                  : As presA but any previous state.
+#       
+#       state($jid,*)             : Keeps other info not directly related
+#                                   to roster or presence elements.
+#                                      
+############################# USAGE ############################################
+#
+#       Changes to the state of this object should only be made from jabberlib,
+#       and never directly by the client!
+#
+#   NAME
+#      roster - an object for roster and presence information.
+#      
+#   SYNOPSIS
+#      jlibname roster cmd ??
+#      
+#   INSTANCE COMMANDS
+#      jlibname roster availablesince jid
+#      jlibname roster clearpresence ?jidpattern?
+#      jlibname roster getgroups ?jid?
+#      jlibname roster getask jid
+#      jlibname roster getcapsattr jid name
+#      jlibname roster getname jid
+#      jlibname roster getpresence jid ?-resource, -type?
+#      jlibname roster getresources jid
+#      jlibname roster gethighestresource jid
+#      jlibname roster getrosteritem jid
+#      jlibname roster getstatus jid
+#      jlibname roster getsubscription jid
+#      jlibname roster getusers ?-type available|unavailable?
+#      jlibname roster getx jid xmlns
+#      jlibname roster getextras jid xmlns
+#      jlibname roster isavailable jid
+#      jlibname roster isitem jid
+#      jlibname roster haveroster
+#      jlibname roster reset
+#      jlibname roster send_get ?-command tclProc?
+#      jlibname roster send_remove ?-command tclProc?
+#      jlibname roster send_set ?-command tclProc, -name, -groups?
+#      jlibname roster wasavailable jid
+#      
+#   The 'clientCommand' procedure must have the following form:
+#   
+#      clientCommand {jlibname what {jid {}} args}
+#      
+#   where 'what' can be any of: enterroster, exitroster, presence, remove, set.
+#   The args is a list of '-key value' pairs with the following keys for each
+#   'what':
+#       enterroster:   no keys
+#       exitroster:    no keys
+#       presence:    -resource      (required)
+#                    -type          (required)
+#                    -status        (optional)
+#                    -priority      (optional)
+#                    -show          (optional)
+#                    -x             (optional)
+#                    -extras        (optional)
+#       remove:      no keys
+#       set:         -name          (optional)
+#                    -subscription  (optional)
+#                    -groups        (optional)
+#                    -ask           (optional)
+#      
+################################################################################
+
+package require jlib
+
+package provide jlib::roster 1.0
+
+namespace eval jlib::roster {
+    
+    variable rostGlobals
+    
+    # Globals same for all instances of this roster.
+    set rostGlobals(debug) 0
+    
+    # List of all rostA element sub entries. First the actual roster,
+    # with 'rostA($jid,...)'
+    set rostGlobals(tags) {name groups ask subscription} 
+    
+    # ...and the presence arrays: 'presA($jid/$resource,...)'
+    # The list of resources is treated separately (presA($jid,res))
+    set rostGlobals(presTags) {type status priority show x}
+    
+    # Used for sorting resources.
+    variable statusPrio
+    array set statusPrio {
+	chat            1
+	available       2
+	away            3
+	xa              4
+	dnd             5
+	invisible       6
+	unavailable     7
+    }
+
+    # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::roster::roster --
+#
+#       This creates a new instance of a roster.
+#       
+# Arguments:
+#       clientCmd:  callback procedure when internals of roster or
+#                   presence changes.
+#       args:            
+#       
+# Results:
+#       
+  
+proc jlib::roster::init {jlibname args} {
+      
+    # Instance specific namespace.
+    namespace eval ${jlibname}::roster {
+	variable rostA
+	variable presA
+	variable options
+	variable priv
+	
+	set priv(haveroster) 0
+    }
+    
+    # Set simpler variable names.
+    upvar ${jlibname}::roster::rostA rostA
+    upvar ${jlibname}::roster::options options
+    
+    # Register for roster pushes.
+    $jlibname iq_register set "jabber:iq:roster" [namespace code set_handler]
+        
+    # Register for presence. Be sure they are first in order.
+    # @@@ We should have a separate internal register API to avoid any conflicts.
+    $jlibname presence_register_int available   \
+      [namespace code presence_handler] 10
+    $jlibname presence_register_int unavailable \
+      [namespace code presence_handler] 10
+    
+    set rostA(groups) [list]
+    set options(cmd) ""
+    
+    jlib::register_package roster
+}
+
+# jlib::roster::cmdproc --
+#
+#       Just dispatches the command to the right procedure.
+#
+# Arguments:
+#       jlibname:   name of existing jabberlib instance
+#       cmd:        
+#       args:       all args to the cmd procedure.
+#       
+# Results:
+#       none.
+
+proc jlib::roster::cmdproc {jlibname cmd args} {
+    
+    # Which command? Just dispatch the command to the right procedure.
+    return [eval {$cmd $jlibname} $args]
+}
+
+# jlib::roster::register_cmd --
+# 
+#       This sets a client callback command.
+
+proc jlib::roster::register_cmd {jlibname cmd} {
+    upvar ${jlibname}::roster::options options
+        
+    set options(cmd) $cmd
+}
+
+proc jlib::roster::haveroster {jlibname} {
+    upvar ${jlibname}::roster::priv priv
+    
+    return $priv(haveroster)
+}
+
+# jlib::roster::send_get --
+# 
+#       Request our complete roster.
+#       
+# Arguments:
+#       jlibname:   name of existing jabberlib instance
+#       args:       -command tclProc
+#       
+# Results:
+#       none.
+
+proc jlib::roster::send_get {jlibname args} {
+
+    array set argsA {-command {}}
+    array set argsA $args  
+    
+    set queryE [wrapper::createtag "query"  \
+      -attrlist [list xmlns jabber:iq:roster]]
+    jlib::send_iq $jlibname "get" [list $queryE]  \
+      -command [list [namespace current]::send_get_cb $jlibname $argsA(-command)]
+    return
+}
+
+proc jlib::roster::send_get_cb {jlibname cmd type queryE} {
+    
+    if {![string equal $type "error"]} {
+	enterroster $jlibname
+	handle_roster $jlibname $queryE
+	exitroster $jlibname
+    }
+    if {$cmd ne {}} {
+	uplevel #0 $cmd [list $type $queryE]
+    }
+}
+
+# jlib::roster::set_handler --
+# 
+#       This gets called for roster pushes.
+
+proc jlib::roster::set_handler {jlibname from queryE args} {
+    
+    handle_roster $jlibname $queryE
+    
+    # RFC 3921, sect 8.1:
+    # The 'from' and 'to' addresses are OPTIONAL in roster pushes; ...
+    # A client MUST acknowledge each roster push with an IQ stanza of 
+    # type "result"...
+    array set argsA $args
+    if {[info exists argsA(-id)]} {
+	$jlibname send_iq "result" {} -id $argsA(-id)
+    }
+    return 1
+}
+
+proc jlib::roster::handle_roster {jlibname queryE} {
+
+    upvar ${jlibname}::roster::itemA itemA
+
+    foreach itemE [wrapper::getchildren $queryE] {	
+	if {[wrapper::gettag $itemE] ne "item"} {
+	    continue
+	}
+	set subscription "none"
+	set opts [list]
+	set havejid 0
+	foreach {aname avalue} [wrapper::getattrlist $itemE] {
+	    set $aname $avalue
+	    if {$aname eq "jid"} {
+		set havejid 1
+	    } else {
+		lappend opts -$aname $avalue
+	    }
+	}
+	
+	# This shall NEVER happen!
+	if {!$havejid} {
+	    continue
+	}
+	set mjid [jlib::jidmap $jid]
+	if {$subscription eq "remove"} {
+	    unset -nocomplain itemA($mjid)
+	    removeitem $jlibname $jid
+	} else {
+	    set itemA($mjid) $itemE
+	    set groups [list]
+	    foreach groupE [wrapper::getchildswithtag $itemE group] {
+		lappend groups [wrapper::getcdata $groupE]
+	    }
+	    if {[llength $groups]} {
+		lappend opts -groups $groups
+	    }
+	    eval {setitem $jlibname $jid} $opts
+	}
+    }
+}
+
+# jlib::roster::send_set --
+#
+#       To set/add an jid in/to your roster.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        jabber user id to add/set.
+#       args:
+#           -command tclProc
+#           -name $name:     A name to show the user-id as on roster to the user.
+#           -groups $group_list: Groups of user. If you omit this, then the user's
+#                            groups will be set according to the user's options
+#                            stored in the roster object. If user doesn't exist,
+#                            or you haven't got your roster, user's groups will be
+#                            set to "", which means no groups.
+#       
+# Results:
+#       none.
+ 
+proc jlib::roster::send_set {jlibname jid args} {
+
+    upvar ${jlibname}::roster::rostA rostA
+    
+    array set argsA {-command {}}
+    array set argsA $args  
+
+    set mjid [jlib::jidmap $jid]
+
+    # Find group(s).
+    if {[info exists argsA(-groups)]} {
+	set groups $argsA(-groups)
+    } elseif {[info exists rostA($mjid,groups)]} {
+	set groups $rostA($mjid,groups)
+    } else {
+	set groups [list]
+    }
+    
+    set attr [list jid $jid]
+    set name ""
+    if {[info exists argsA(-name)] && [string length $argsA(-name)]} {
+	set name $argsA(-name)
+	lappend attr name $name
+    }
+    set groupEs [list]
+    foreach group $groups {
+	if {$group ne ""} {
+	    lappend groupEs [wrapper::createtag "group" -chdata $group]
+	}
+    }
+    
+    # Roster items get pushed to us. Only any errors need to be taken care of.
+    set itemE [wrapper::createtag "item" -attrlist $attr -subtags $groupEs]
+    set queryE [wrapper::createtag "query"   \
+      -attrlist [list xmlns jabber:iq:roster] -subtags [list $itemE]]
+    jlib::send_iq $jlibname "set" [list $queryE] -command $argsA(-command)
+    return
+}
+
+proc jlib::roster::send_remove {jlibname jid args} {
+
+    array set argsA {-command {}}
+    array set argsA $args  
+    
+    # Roster items get pushed to us. Only any errors need to be taken care of.
+    set itemE [wrapper::createtag "item"  \
+      -attrlist [list jid $jid subscription remove]]
+    set queryE [wrapper::createtag "query"   \
+      -attrlist [list xmlns jabber:iq:roster] -subtags [list $itemE]]
+    jlib::send_iq $jlibname "set" [list $queryE] -command $argsA(-command)
+    return
+}
+
+# jlib::roster::setitem --
+#
+#       Adds or modifies an existing roster item.
+#       Features not set are left as they are; features not set will give
+#       nonexisting array entries, just to differentiate between an empty
+#       element and a nonexisting one.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        2-tier jid, with no /resource, usually.
+#                   Some transports keep a resource part in jid.
+#       args:       a list of '-key value' pairs, where '-key' is any of:
+#                       -name value
+#                       -subscription value
+#                       -groups list        Note: GROUPS in plural!
+#                       -ask value
+#       
+# Results:
+#       none.
+
+proc jlib::roster::setitem {jlibname jid args} {        
+    variable rostGlobals
+    upvar ${jlibname}::roster::rostA rostA
+    upvar ${jlibname}::roster::options options
+    
+    Debug 2 "roster::setitem jid='$jid', args='$args'"
+        
+    set mjid [jlib::jidmap $jid]
+    
+    # Clear out the old state since an 'ask' element may still be lurking.
+    foreach key $rostGlobals(tags) {
+	unset -nocomplain rostA($mjid,$key)
+    }
+    
+    # This array is better than list to keep track of users.
+    set rostA($mjid,item) $mjid
+    
+    # Old values will be overwritten, nonexisting options will result in
+    # nonexisting array entries.
+    foreach {name value} $args {
+	set par [string trimleft $name "-"]
+	set rostA($mjid,$par) $value
+	if {[string equal $par "groups"]} {
+	    foreach gr $value {
+		if {[lsearch -exact $rostA(groups) $gr] < 0} {
+		    lappend rostA(groups) $gr
+		}
+	    }
+	}
+    }
+    
+    # Be sure to evaluate the registered command procedure.
+    if {[string length $options(cmd)]} {
+	uplevel #0 $options(cmd) [list $jlibname set $jid] $args
+    }
+    return
+}
+
+# jlib::roster::removeitem --
+#
+#       Removes an existing roster item and all its presence info.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        2-tier jid with no /resource.
+#       
+# Results:
+#       none.
+
+proc jlib::roster::removeitem {jlibname jid} {       
+    variable rostGlobals
+
+    upvar ${jlibname}::roster::rostA rostA
+    upvar ${jlibname}::roster::presA presA
+    upvar ${jlibname}::roster::oldpresA oldpresA
+    upvar ${jlibname}::roster::options options
+    
+    Debug 2 "roster::removeitem jid='$jid'"
+    
+    set mjid [jlib::jidmap $jid]
+    
+    # Be sure to evaluate the registered command procedure.
+    # Do this BEFORE unsetting the internal state!
+    if {[string length $options(cmd)]} {
+	uplevel #0 $options(cmd) [list $jlibname remove $jid]
+    }
+    
+    # First the roster, then presence...
+    foreach name $rostGlobals(tags) {
+	unset -nocomplain rostA($mjid,$name)
+    }
+    unset -nocomplain rostA($mjid,item)
+    
+    # Be sure to unset all, also jid3 entries!
+    array unset presA [jlib::ESC $mjid]*
+    array unset oldpresA [jlib::ESC $mjid]*
+    return
+}
+
+# jlib::roster::ClearRoster --
+#
+#       Removes all existing roster items but keeps all presence info.(?)
+#       and list of resources.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       
+# Results:
+#       none. Callback evaluated.
+
+proc jlib::roster::ClearRoster {jlibname} {    
+
+    variable rostGlobals
+    upvar ${jlibname}::roster::rostA rostA
+    upvar ${jlibname}::roster::itemA itemA
+    upvar ${jlibname}::roster::options options
+    
+    Debug 2 "roster::ClearRoster"
+        
+    # Remove the roster.
+    foreach {x mjid} [array get rostA *,item] {
+	foreach key $rostGlobals(tags) {
+	    unset -nocomplain rostA($mjid,$key)
+	}
+    }
+    array unset rostA *,item
+    unset -nocomplain itemA
+    
+    # Be sure to evaluate the registered command procedure.
+    if {[string length $options(cmd)]} {
+	uplevel #0 $options(cmd) [list $jlibname enterroster]
+    }
+    return
+}
+
+# jlib::roster::enterroster --
+#
+#       Is called when new roster coming.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       
+# Results:
+#       none.
+
+proc jlib::roster::enterroster {jlibname} {
+
+    ClearRoster $jlibname
+}
+
+# jlib::roster::exitroster --
+#
+#       Is called when finished receiving a roster get command.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       
+# Results:
+#       none. Callback evaluated.
+
+proc jlib::roster::exitroster {jlibname} {    
+
+    upvar ${jlibname}::roster::options options
+    upvar ${jlibname}::roster::priv    priv
+
+    set priv(haveroster) 1
+    
+    # Be sure to evaluate the registered command procedure.
+    if {[string length $options(cmd)]} {
+	uplevel #0 $options(cmd) [list $jlibname exitroster]
+    }
+}
+
+# jlib::roster::reset --
+#
+#       Removes everything stored in the roster object, including all roster
+#       items and any presence information.
+
+proc jlib::roster::reset {jlibname} {
+
+    upvar ${jlibname}::roster::rostA rostA
+    upvar ${jlibname}::roster::presA presA
+    upvar ${jlibname}::roster::priv    priv
+    
+    unset -nocomplain rostA presA
+    set rostA(groups) {}
+    set priv(haveroster) 0
+}
+
+# jlib::roster::clearpresence --
+# 
+#       Removes all presence cached internally for jid glob pattern.
+#       Helpful when exiting a room.
+#       
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jidpattern: glob pattern for items to remove.
+#       
+# Results:
+#       none.
+
+proc jlib::roster::clearpresence {jlibname {jidpattern ""}} {
+
+    upvar ${jlibname}::roster::presA presA
+    upvar ${jlibname}::roster::oldpresA oldpresA
+
+    Debug 2 "roster::clearpresence '$jidpattern'"
+
+    if {$jidpattern eq ""} {
+	unset -nocomplain presA
+    } else {
+	array unset presA $jidpattern
+	array unset oldpresA $jidpattern
+    }
+}
+
+proc jlib::roster::presence_handler {jlibname xmldata} {    
+    presence $jlibname $xmldata
+    return 0
+}
+
+# jlib::roster::presence --
+# 
+#       Registered internal presence handler for 'available' and 'unavailable'
+#       that caches all presence info.
+
+proc jlib::roster::presence {jlibname xmldata} {
+    
+    variable rostGlobals
+    upvar ${jlibname}::roster::rostA rostA
+    upvar ${jlibname}::roster::presA presA
+    upvar ${jlibname}::roster::oldpresA oldpresA
+    upvar ${jlibname}::roster::state state
+
+    Debug 2 "jlib::roster::presence"
+
+    set from [wrapper::getattribute $xmldata from]
+    set type [wrapper::getattribute $xmldata type]
+    if {$type eq ""} {
+	set type "available"
+    }
+
+    # We don't handle subscription types (remove?).
+    if {$type ne "available" && $type ne "unavailable"} {
+	return
+    }
+
+    set mjid [jlib::jidmap $from]
+    jlib::splitjid $mjid mjid2 res
+
+    # Set secs only if unavailable before.
+    if {![info exists presA($mjid,type)]  \
+      || ($presA($mjid,type) eq "unavailable")} {
+	set state($mjid,secs) [clock seconds]
+    }
+    
+    # Keep cache of any old state.
+    # Note special handling of * for array unset - prefix with \\ to quote.
+    array unset oldpresA [jlib::ESC $mjid],*
+    array set oldpresA [array get presA [jlib::ESC $mjid],*]
+    
+    # Clear out the old presence state since elements may still be lurking.
+    array unset presA [jlib::ESC $mjid],*
+
+    # Add to list of resources.
+    set presA($mjid2,res) [lsort -unique [lappend presA($mjid2,res) $res]]
+
+    set presA($mjid,type) $type
+
+    foreach E [wrapper::getchildren $xmldata] {
+	set tag [wrapper::gettag $E]
+	set chdata [wrapper::getcdata $E]
+	
+	switch -- $tag {
+	    priority {
+		if {[string is integer -strict $chdata]} {
+		    set presA($mjid,$tag) $chdata
+		}
+	    }
+	    status {
+		set presA($mjid,$tag) $chdata
+	    }
+	    show {
+		if {[regexp {^(away|chat|dnd|xa)$} $chdata]} {
+		    set presA($mjid,$tag) $chdata
+		}
+	    }
+	    x {
+		set ns [wrapper::getattribute $E xmlns]
+		regexp {http://jabber.org/protocol/(.*)$} $ns - ns
+		set presA($mjid,x,$ns) $E
+	    }
+	    default {
+
+		# This can be anything properly namespaced.
+		set ns [wrapper::getattribute $E xmlns]
+		set presA($mjid,extras,$ns) $E
+	    }
+	}
+    }    
+}
+
+
+# Firts attempt to keep the jid's as they are reported, with no separate
+# resource part.
+
+proc jlib::roster::setpresence2 {jlibname xmldata} { 
+
+
+}
+
+# jlib::roster::getrosteritem --
+#
+#       Returns the state of an existing roster item.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        .
+#       
+# Results:
+#       a list of '-key value' pairs where key is any of: 
+#       name, groups, subscription, ask. Note GROUPS in plural!
+
+proc jlib::roster::getrosteritem {jlibname jid} {    
+
+    variable rostGlobals
+    upvar ${jlibname}::roster::rostA rostA
+    upvar ${jlibname}::roster::options options
+    
+    Debug 2 "roster::getrosteritem jid='$jid'"
+    
+    set mjid [jlib::jidmap $jid]
+    if {![info exists rostA($mjid,item)]} {
+	return {}
+    }
+    set result [list]
+    foreach key $rostGlobals(tags) {
+	if {[info exists rostA($mjid,$key)]} {
+	    lappend result -$key $rostA($mjid,$key)
+	}
+    }
+    return $result
+}
+
+proc jlib::roster::getitem {jlibname jid} {
+ 
+    upvar ${jlibname}::roster::itemA itemA
+
+    set mjid [jlib::jidmap $jid]
+    if {[info exists itemA($mjid)]} {
+	return $itemA($mjid)
+    } else {
+	return {}
+    }
+}
+
+# jlib::roster::isitem --
+# 
+#       Does the jid exist in the roster?
+
+proc jlib::roster::isitem {jlibname jid} {
+    
+    upvar ${jlibname}::roster::rostA rostA
+    
+    set mjid [jlib::jidmap $jid]
+    return [expr {[info exists rostA($mjid,item)] ? 1 : 0}]
+}
+
+# jlib::roster::getrosterjid --
+# 
+#       Returns the matching jid as reported by a roster item.
+#       If given a full JID try match this, else bare JID.
+#       If given a bare JID try match this, else find any matching full JID.
+#       For ordinary users this is a jid2.
+#
+# @@@ NB: For the new xmpp lib we shall have a mapping from the roster JID
+#         to a set of online JID's if any, which shall be completely indpendent
+#         of bare vs. full JID forms!
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        
+#       
+# Results:
+#       a jid or empty if no matching roster item.
+
+proc jlib::roster::getrosterjid {jlibname jid} {
+    
+    upvar ${jlibname}::roster::rostA rostA
+
+    set mjid [jlib::jidmap $jid]
+    if {[info exists rostA($mjid,item)]} {
+	return $jid
+    } else {
+	set mjid2 [jlib::barejid $mjid]
+	if {[info exists rostA($mjid2,item)]} {
+	    return [jlib::barejid $jid]
+	} else {
+	    set name [array names rostA [jlib::ESC $mjid2]*,item]
+	    if {[llength $name] == 1} {
+		# There should only be one.
+		return [string map {",item" ""} $name]
+	    }
+	}
+    }
+    return
+}
+
+# jlib::roster::getusers --
+#
+#       Returns a list of jid's of all existing roster items.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       args:       -type available|unavailable
+#       
+# Results:
+#       list of all 2-tier jid's in roster
+
+proc jlib::roster::getusers {jlibname args} {
+
+    upvar ${jlibname}::roster::rostA rostA
+    upvar ${jlibname}::roster::presA presA    
+    
+    set all {}
+    foreach {x jid} [array get rostA *,item] {
+	lappend all $jid
+    }
+    array set argsA $args
+    set jidlist {}
+    if {$args == {}} {
+	set jidlist $all
+    } elseif {[info exists argsA(-type)]} {
+	set type $argsA(-type)
+	set jidlist {}
+	foreach jid2 $all {
+	    set isavailable 0
+
+	    # Be sure to handle empty resources as well: '1234@icq.host'
+	    foreach key [array names presA "[jlib::ESC $jid2]*,type"] {
+		if {[string equal $presA($key) "available"]} {
+		    set isavailable 1
+		    break
+		}
+	    }
+	    if {$isavailable && [string equal $type "available"]} {
+		lappend jidlist $jid2
+	    } elseif {!$isavailable && [string equal $type "unavailable"]} {
+		lappend jidlist $jid2
+	    }
+	}	
+    }
+    return $jidlist
+}
+
+# jlib::roster::getpresence --
+#
+#       Returns the presence state of an existing roster item.
+#       This is as reported in presence element.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        username@server, without /resource.
+#       args        ?-resource, -type?
+#                   -resource: return presence for this alone,
+#                       else a list for each resource.
+#                       Allow empty resources!!??
+#                   -type: return presence for (un)available only.
+#       
+# Results:
+#       a list of '-key value' pairs where key is any of: 
+#       resource, type, status, priority, show, x.
+#       If the 'resource' in argument is not given,
+#       the result contains a sublist for each resource. IMPORTANT! Bad?
+#       BAD!!!!!!!!!!!!!!!!!!!!!!!!
+
+proc jlib::roster::getpresence {jlibname jid args} {    
+
+    variable rostGlobals
+    upvar ${jlibname}::roster::rostA rostA
+    upvar ${jlibname}::roster::presA presA
+    upvar ${jlibname}::roster::options options
+    
+    Debug 2 "roster::getpresence jid=$jid, args='$args'"
+    
+    set jid [jlib::jidmap $jid]
+    array set argsA $args
+    set haveRes 0
+    if {[info exists argsA(-resource)]} {
+	set haveRes 1
+	set resource $argsA(-resource)
+    }
+    
+    # It may happen that there is no roster item for this jid (groupchat).
+    if {![info exists presA($jid,res)] || ($presA($jid,res) eq "")} {
+	if {[info exists argsA(-type)] &&  \
+	  [string equal $argsA(-type) "available"]} {
+	    return
+	} else {
+	    if {$haveRes} {
+		return [list -resource $resource -type unavailable]
+	    } else {      
+		return [list [list -resource "" -type unavailable]]
+	    }
+	}
+    }
+    
+    set result [list]
+    if {$haveRes} {
+
+	# Return presence only from the specified resource.
+	# Be sure to handle empty resources as well: '1234@icq.host'
+	if {[lsearch -exact $presA($jid,res) $resource] < 0} {
+	    return [list -resource $resource -type unavailable]
+	}
+	set result [list -resource $resource]
+	if {$resource eq ""} {
+	    set jid3 $jid
+	} else {
+	    set jid3 $jid/$resource
+	}
+	if {[info exists argsA(-type)] &&  \
+	  ![string equal $argsA(-type) $presA($jid3,type)]} {
+	    return
+	}
+	foreach key $rostGlobals(presTags) {
+	    if {[info exists presA($jid3,$key)]} {
+		lappend result -$key $presA($jid3,$key)
+	    }
+	}
+    } else {
+	
+	# Get presence for all resources.
+	# Be sure to handle empty resources as well: '1234@icq.host'
+	foreach res $presA($jid,res) {
+	    set thisRes [list -resource $res]
+	    if {$res eq ""} {
+		set jid3 $jid
+	    } else {
+		set jid3 $jid/$res
+	    }
+	    if {[info exists argsA(-type)] &&  \
+	      ![string equal $argsA(-type) $presA($jid3,type)]} {
+		# Empty.
+	    } else {
+		foreach key $rostGlobals(presTags) {
+		    if {[info exists presA($jid3,$key)]} {
+			lappend thisRes -$key $presA($jid3,$key)
+		    }
+		}
+		lappend result $thisRes
+	    }
+	}
+    }
+    return $result
+}
+
+# UNFINISHED!!!!!!!!!!
+# Return empty list or -type unavailable ???
+# '-key value' or 'key value' ???
+# Returns a list of flat arrays
+
+proc jlib::roster::getpresence2 {jlibname jid args} {    
+
+    variable rostGlobals
+    upvar ${jlibname}::roster::rostA rostA
+    upvar ${jlibname}::roster::presA2 presA2
+    upvar ${jlibname}::roster::options options
+    
+    Debug 2 "roster::getpresence2 jid=$jid, args='$args'"
+    
+    array set argsA {
+	-type *
+    }
+    array set argsA $args
+
+    set mjid [jlib::jidmap $jid]
+    jlib::splitjid $mjid jid2 resource
+    set result {}
+    
+    if {$resource eq ""} {
+	
+	# 2-tier jid. Match any resource.
+	set arrlist [concat [array get presA2 [jlib::ESC $mjid],jid] \
+                         [array get presA2 [jlib::ESC $mjid]/*,jid]]
+	foreach {key value} $arrlist {
+	    set thejid $value
+	    set jidresult {}
+	    foreach {akey avalue} [array get presA2 [jlib::ESC $thejid],*] {
+		set thekey [string map [list $thejid, ""] $akey]
+		lappend jidresult -$thekey $avalue
+	    }
+	    if {[llength $jidresult]} {
+		lappend result $jidresult
+	    }
+	}
+    } else {
+	
+	# 3-tier jid. Only exact match.
+	if {[info exists presA2($mjid,type)]} {
+	    if {[string match $argsA(-type) $presA2($mjid,type)]} {
+		set result [list [list -jid $jid -type $presA2($mjid,type)]]
+	    }
+	} else {
+	    set result [list [list -jid $jid -type unavailable]]
+	}
+    }
+    return $result
+}
+
+# jlib::roster::getoldpresence --
+# 
+#       This makes a simplified assumption and uses the full JID.
+
+proc jlib::roster::getoldpresence {jlibname jid} {    
+
+    variable rostGlobals
+    upvar ${jlibname}::roster::rostA rostA
+    upvar ${jlibname}::roster::oldpresA oldpresA
+
+    set jid [jlib::jidmap $jid]
+    
+    if {[info exists oldpresA($jid,type)]} {
+	set result [list]
+	foreach key $rostGlobals(presTags) {
+	    if {[info exists oldpresA($jid,$key)]} {
+		lappend result -$key $oldpresA($jid,$key)
+	    }
+	}	
+    } else {
+	set result [list -type unavailable]
+    }
+    return $result
+}
+
+# jlib::roster::getgroups --
+#
+#       Returns the list of groups for this jid, or an empty list if not 
+#       exists. If no jid, return a list of all groups existing in this roster.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        (optional).
+#       
+# Results:
+#       a list of groups or empty.
+
+proc jlib::roster::getgroups {jlibname {jid {}}} {    
+
+    upvar ${jlibname}::roster::rostA rostA
+   
+    Debug 2 "roster::getgroups jid='$jid'"
+    
+    set jid [jlib::jidmap $jid]
+    if {[string length $jid]} {
+	if {[info exists rostA($jid,groups)]} {
+	    return $rostA($jid,groups)
+	} else {
+	    return
+	}
+    } else {
+	set rostA(groups) [lsort -unique $rostA(groups)]
+	return $rostA(groups)
+    }
+}
+
+# jlib::roster::getname --
+#
+#       Returns the roster name of this jid.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        
+#       
+# Results:
+#       the roster name or empty.
+
+proc jlib::roster::getname {jlibname jid} {
+
+    upvar ${jlibname}::roster::rostA rostA
+       
+    set jid [jlib::jidmap $jid]
+    if {[info exists rostA($jid,name)]} {
+	return $rostA($jid,name)
+    } else {
+	return ""
+    }
+}
+
+# jlib::roster::getsubscription --
+#
+#       Returns the 'subscription' state of this jid.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        
+#       
+# Results:
+#       the 'subscription' state or "none" if no 'subscription' state.
+
+proc jlib::roster::getsubscription {jlibname jid} {
+
+    upvar ${jlibname}::roster::rostA rostA
+       
+    set jid [jlib::jidmap $jid]
+    if {[info exists rostA($jid,subscription)]} {
+	return $rostA($jid,subscription)
+    } else {
+	return none
+    }
+}
+
+# jlib::roster::getask --
+#
+#       Returns the 'ask' state of this jid.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        
+#       
+# Results:
+#       the 'ask' state or empty if no 'ask' state.
+
+proc jlib::roster::getask {jlibname jid} {
+
+    upvar ${jlibname}::roster::rostA rostA
+   
+    Debug 2 "roster::getask jid='$jid'"
+    
+    if {[info exists rostA($jid,ask)]} {
+	return $rostA($jid,ask)
+    } else {
+	return ""
+    }
+}
+
+# jlib::roster::getresources --
+#
+#       Returns a list of all resources for this JID or empty.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        a JID without any resource (jid2) typically.
+#                   it must be the JID which is reported by roster.
+#       args        ?-type?
+#                   -type: return presence for (un)available only.
+#       
+# Results:
+#       a list of all resources for this jid or empty.
+
+proc jlib::roster::getresources {jlibname jid args} {
+
+    upvar ${jlibname}::roster::presA presA
+   
+    Debug 2 "roster::getresources jid='$jid'"
+    array set argsA $args
+    
+    set jid [jlib::jidmap $jid]
+    if {[info exists presA($jid,res)]} {
+	if {[info exists argsA(-type)]} {
+	    
+	    # Need to loop through all resources for this jid.
+	    set resL [list]
+	    set type $argsA(-type)
+	    foreach res $presA($jid,res) {
+
+		# Be sure to handle empty resources as well: '1234@icq.host'
+		if {$res eq ""} {
+		    set jid3 $jid
+		} else {
+		    set jid3 $jid/$res
+		}
+		if {[string equal $argsA(-type) $presA($jid3,type)]} {
+		    lappend resL $res
+		}
+	    }
+	    return $resL
+	} else {
+	    return $presA($jid,res)
+	}
+    } else {
+	
+	# If the roster JID is something like: icq.home.se/registered
+	set jid2 [jlib::barejid $jid]
+	if {[info exists presA($jid2,res)]} {
+	    if {[info exists argsA(-type)]} {
+		
+		# Need to loop through all resources for this jid.
+		set resL [list]
+		set type $argsA(-type)
+		foreach res $presA($jid2,res) {
+    
+		    # Be sure to handle empty resources as well: '1234@icq.host'
+		    if {$res eq ""} {
+			set jid3 $jid2
+		    } else {
+			set jid3 $jid2/$res
+		    }
+		    if {[string equal $argsA(-type) $presA($jid3,type)]} {
+			lappend resL $res
+		    }
+		}
+		return $resL
+	    } else {
+		return $presA($jid2,res)
+	    }
+	} else {
+	    return
+	}
+    }
+}
+
+proc jlib::roster::getmatchingjids2 {jlibname jid args} {
+    
+    upvar ${jlibname}::roster::presA2 presA2
+    
+    set jidlist {}
+    set arrlist [concat [array get presA2 [jlib::ESC $mjid],jid] \
+      [array get presA2 [jlib::ESC $mjid]/*,jid]]
+    foreach {key value} $arrlist {
+	lappend jidlist $value
+    }
+    return $jidlist
+}
+
+# jlib::roster::gethighestresource --
+#
+#       Returns the resource with highest priority for this jid or empty.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        a jid without any resource (jid2).
+#       
+# Results:
+#       a resource for this jid or empty if unavailable.
+
+proc jlib::roster::gethighestresource {jlibname jid} {
+
+    upvar ${jlibname}::roster::presA presA
+    variable statusPrio
+   
+    Debug 2 "roster::gethighestresource jid='$jid'"
+    
+    set jid [jlib::jidmap $jid]
+    set maxResL [list]
+    
+    # @@@ Perhaps this sorting shall be made when receiving presence instead?
+
+    if {[info exists presA($jid,res)]} {
+	
+	# Find the resource corresponding to the highest priority (D=0).
+	set maxPrio -128
+	
+	foreach res $presA($jid,res) {
+
+	    # Be sure to handle empty resources as well: '1234@icq.host'
+	    if {$res eq ""} {
+		set jid3 $jid
+	    } else {
+		set jid3 $jid/$res
+	    }
+	    if {[info exists presA($jid3,type)]} {
+		if {$presA($jid3,type) eq "available"} {
+		    set prio 0
+		    if {[info exists presA($jid3,priority)]} {
+			set prio $presA($jid3,priority)
+		    }
+		    if {$prio > $maxPrio} {
+			set maxPrio $prio
+			set maxResL [list $res]
+		    } elseif {$prio == $maxPrio} {
+			lappend maxResL $res
+		    }
+		}
+	    }
+	}
+    }
+    if {[llength $maxResL] == 1} {
+	set maxRes [lindex $maxResL 0]
+    } elseif {[llength $maxResL] > 1} {
+
+	# Sort according to show attributes.
+	set resIndL [list]
+	foreach res $maxResL {
+	    if {$res eq ""} {
+		set jid3 $jid
+	    } else {
+		set jid3 $jid/$res
+	    }
+	    set show "available"
+	    if {[info exists presA($jid3,show)]} {
+		set show $presA($jid3,show)
+	    }
+	    lappend resIndL [list $res $statusPrio($show)]
+	}
+	set resIndL [lsort -integer -index 1 $resIndL]
+	set maxRes [lindex $resIndL 0 0]
+    } else {
+	set maxRes ""
+    }
+    return $maxRes
+}
+
+proc jlib::roster::getmaxpriorityjid2 {jlibname jid} {
+
+    upvar ${jlibname}::roster::presA2 presA2
+   
+    Debug 2 "roster::getmaxpriorityjid2 jid='$jid'"
+    
+    # Find the resource corresponding to the highest priority (D=0).
+    set maxjid ""
+    set maxpri 0
+    foreach jid3 [getmatchingjids2 $jlibname $jid] {
+	if {[info exists presA2($jid3,priority)]} {
+	    if {$presA2($jid3,priority) > $maxpri} {
+		set maxjid $jid3
+		set maxpri $presA2($jid3,priority)
+	    }
+	}
+    }
+    return $jid3
+}
+
+# jlib::roster::isavailable --
+#
+#       Returns boolean 0/1. Returns 1 only if presence is equal to available.
+#       If 'jid' without resource, return 1 if any is available.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        either 'username$hostname', or 'username$hostname/resource'.
+#       
+# Results:
+#       0/1.
+
+proc jlib::roster::isavailable {jlibname jid} {
+
+    upvar ${jlibname}::roster::presA presA
+   
+    Debug 2 "roster::isavailable jid='$jid'"
+        
+    set jid [jlib::jidmap $jid]
+
+    # If any resource in jid, we get it here.
+    jlib::splitjid $jid jid2 resource
+
+    if {[string length $resource] > 0} {
+	if {[info exists presA($jid2/$resource,type)]} {
+	    if {[string equal $presA($jid2/$resource,type) "available"]} {
+		return 1
+	    } else {
+		return 0
+	    }
+	} else {
+	    return 0
+	}
+    } else {
+	
+	# Be sure to allow for 'user@domain' with empty resource.
+	foreach key [array names presA "[jlib::ESC $jid2]*,type"] {
+	    if {[string equal $presA($key) "available"]} {
+		return 1
+	    }
+	}
+	return 0
+    }
+}
+
+proc jlib::roster::isavailable2 {jlibname jid} {
+
+    upvar ${jlibname}::roster::presA2 presA2
+   
+    Debug 2 "roster::isavailable jid='$jid'"
+	
+    set jid [jlib::jidmap $jid]
+
+    # If any resource in jid, we get it here.
+    jlib::splitjid $jid jid2 resource
+
+    if {[string length $resource] > 0} {
+	if {[info exists presA($jid2/$resource,type)]} {
+	    if {[string equal $presA($jid2/$resource,type) "available"]} {
+		return 1
+	    } else {
+		return 0
+	    }
+	} else {
+	    return 0
+	}
+    } else {
+	
+	# Be sure to allow for 'user@domain' with empty resource.
+	foreach key [array names presA "[jlib::ESC $jid2]*,type"] {
+	    if {[string equal $presA($key) "available"]} {
+		return 1
+	    }
+	}
+	return 0
+    }
+}
+
+# jlib::roster::wasavailable --
+#
+#       As 'isavailable' but for any "old" former presence state.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        either 'username$hostname', or 'username$hostname/resource'.
+#       
+# Results:
+#       0/1.
+
+proc jlib::roster::wasavailable {jlibname jid} {
+
+    upvar ${jlibname}::roster::oldpresA oldpresA
+   
+    Debug 2 "roster::wasavailable jid='$jid'"
+	
+    set jid [jlib::jidmap $jid]
+
+    # If any resource in jid, we get it here.
+    jlib::splitjid $jid jid2 resource
+
+    if {[string length $resource] > 0} {
+	if {[info exists oldpresA($jid2/$resource,type)]} {
+	    if {[string equal $oldpresA($jid2/$resource,type) "available"]} {
+		return 1
+	    } else {
+		return 0
+	    }
+	} else {
+	    return 0
+	}
+    } else {
+	
+	# Be sure to allow for 'user@domain' with empty resource.
+	foreach key [array names oldpresA "[jlib::ESC $jid2]*,type"] {
+	    if {[string equal $oldpresA($key) "available"]} {
+		return 1
+	    }
+	}
+	return 0
+    }
+}
+
+# jlib::roster::anychange --
+#
+#       Returns boolean telling us if any presence attributes as listed
+#       in 'nameList' has changed.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        the JID as reported in presence
+#       nameList:   type | status | priority | show, D=type
+#
+# Results:
+#       0/1.
+
+proc jlib::roster::anychange {jlibname jid {nameList type}} {
+    
+    upvar ${jlibname}::roster::presA presA
+    upvar ${jlibname}::roster::oldpresA oldpresA
+    
+    set jid [jlib::jidmap $jid]
+    
+    foreach name $nameList {
+	set have1 [info exists presA($jid,$name)]
+	set have2 [info exists oldpresA($jid,$name)]	
+	if {$have1 && $have2} {
+	    if {$presA($jid,$name) ne $oldpresA($jid,$name)} {
+		return 1
+	    }
+	} elseif {($have1 && !$have2) || (!$have1 && $have2)} {
+	    return 1
+	} 
+    }
+    return 0
+}
+
+# jlib::roster::gettype --
+# 
+#       Returns "available" or "unavailable".
+
+proc jlib::roster::gettype {jlibname jid} {
+    
+    upvar ${jlibname}::roster::presA presA
+       
+    set jid [jlib::jidmap $jid]    
+    if {[info exists presA($jid,type)]} {
+	return $presA($jid,type)
+    } else {
+	return "unavailable"
+    }
+}
+
+proc jlib::roster::getshow {jlibname jid} {
+      
+    upvar ${jlibname}::roster::presA presA
+       
+    set jid [jlib::jidmap $jid]    
+    if {[info exists presA($jid,show)]} {
+	return $presA($jid,show)
+    } else {
+	return ""
+    }
+}
+proc jlib::roster::getstatus {jlibname jid} {
+      
+    upvar ${jlibname}::roster::presA presA
+       
+    set jid [jlib::jidmap $jid]    
+    if {[info exists presA($jid,status)]} {
+	return $presA($jid,status)
+    } else {
+	return ""
+    }
+}
+
+# jlib::roster::getx --
+#
+#       Returns the xml list for this jid's x element with given xml namespace.
+#       Returns empty if no matching info.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        any jid
+#       xmlns:      the (mandatory) xmlns specifier. Any prefix
+#                   http://jabber.org/protocol/ must be stripped off.
+#                   @@@ BAD!!!!
+#       
+# Results:
+#       xml list or empty.
+
+proc jlib::roster::getx {jlibname jid xmlns} {
+
+    upvar ${jlibname}::roster::presA presA
+   
+    set jid [jlib::jidmap $jid]
+    if {[info exists presA($jid,x,$xmlns)]} {
+	return $presA($jid,x,$xmlns)
+    } else {
+	return
+    }
+}
+
+# jlib::roster::getextras --
+#
+#       Returns the xml list for this jid's extras element with given xml namespace.
+#       Returns empty if no matching info.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        any jid
+#       xmlns:      the (mandatory) full xmlns specifier.
+#       
+# Results:
+#       xml list or empty.
+
+proc jlib::roster::getextras {jlibname jid xmlns} {
+
+    upvar ${jlibname}::roster::presA presA
+   
+    set jid [jlib::jidmap $jid]
+    if {[info exists presA($jid,extras,$xmlns)]} {
+	return $presA($jid,extras,$xmlns)
+    } else {
+	return
+    }
+}
+
+# jlib::roster::getcapsattr --
+# 
+#       Access function for the <c/> caps elements attributes:
+#       
+#       <presence>
+#           <c 
+#               xmlns='http://jabber.org/protocol/caps' 
+#               node='http://coccinella.sourceforge.net/protocol/caps'
+#               ver='0.95.2'
+#               ext='ftrans voip_h323 voip_sip'/>
+#       </presence>
+#       
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        any jid
+#       attrname:   
+#       
+# Results:
+#       the value of the attribute or empty
+
+proc jlib::roster::getcapsattr {jlibname jid attrname} {
+    
+    upvar jlib::jxmlns jxmlns
+    upvar ${jlibname}::roster::presA presA
+
+    set attr ""
+    set jid [jlib::jidmap $jid]
+    set xmlnscaps $jxmlns(caps)
+    if {[info exists presA($jid,extras,$xmlnscaps)]} {
+	set cElem $presA($jid,extras,$xmlnscaps)
+	set attr [wrapper::getattribute $cElem $attrname]
+    }
+    return $attr
+}
+
+proc jlib::roster::havecaps {jlibname jid} {
+    
+    upvar jlib::jxmlns jxmlns
+    upvar ${jlibname}::roster::presA presA
+
+    set xmlnscaps $jxmlns(caps)
+    return [info exists presA($jid,extras,$xmlnscaps)]
+}
+
+# jlib::roster::availablesince --
+# 
+#       Not sure exactly how delay elements are updated when new status set.
+
+proc jlib::roster::availablesince {jlibname jid} {
+    
+    upvar ${jlibname}::roster::presA presA
+    upvar ${jlibname}::roster::state state
+
+    set jid [jlib::jidmap $jid]
+    set xmlns "jabber:x:delay"
+    if {[info exists presA($jid,x,$xmlns)]} {
+	 
+	 # An ISO 8601 point-in-time specification. clock works!
+	 set stamp [wrapper::getattribute $presA($jid,x,$xmlns) stamp]
+	 set time [clock scan $stamp -gmt 1]
+     } elseif {[info exists state($jid,secs)]} {
+	 set time $state($jid,secs)
+     } else {
+	 set time ""
+     }
+     return $time
+}
+
+proc jlib::roster::getpresencesecs {jlibname jid} {
+    
+    upvar ${jlibname}::roster::state state
+
+    set jid [jlib::jidmap $jid]
+    if {[info exists state($jid,secs)]} {
+	return $state($jid,secs)
+    } else {
+	return ""
+    }
+}
+
+proc jlib::roster::Debug {num str} {
+    variable rostGlobals
+    if {$num <= $rostGlobals(debug)} {
+	puts "===========$str"
+    }
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::roster {
+    
+    jlib::ensamble_register roster  \
+      [namespace current]::init    \
+      [namespace current]::cmdproc
+}
+
+#-------------------------------------------------------------------------------
diff --git a/lib/jabberlib/saslmd5.tcl b/lib/jabberlib/saslmd5.tcl
new file mode 100644
index 0000000..de02b40
--- /dev/null
+++ b/lib/jabberlib/saslmd5.tcl
@@ -0,0 +1,484 @@
+#  saslmd5.tcl --
+#  
+#       This package provides a rudimentary implementation of the client side
+#       SASL authentication method using the DIGEST-MD5 mechanism.
+#       SASL [RFC 2222]
+#       DIGEST-MD5 [RFC 2831]
+#       ANONYMOUS []
+#       
+#       It also includes the PLAIN mechanism, so saslmd5 is a misnomer.
+#       
+#  Copyright (c) 2004  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: saslmd5.tcl,v 1.13 2008/02/19 07:30:38 matben Exp $
+
+package require base64
+package require md5 2.0
+
+package provide saslmd5 1.0
+
+
+namespace eval saslmd5 {
+    
+    # These are in order of preference.
+    variable mechanisms [list "DIGEST-MD5" "PLAIN"]
+    # @@@ Enable this when testing. Not production code!
+    #variable mechanisms [list "DIGEST-MD5" "PLAIN" "ANONYMOUS"]
+    variable needed {username authzid pass realm}
+    variable uid 0
+    
+}
+
+# "static" methods.
+
+proc saslmd5::mechanisms {} {
+    variable mechanisms   
+    return $mechanisms
+}
+
+proc saslmd5::info {args} {
+    
+    # empty
+    return {}
+}
+
+proc saslmd5::client_init {args} {
+    
+    # empty
+}
+
+proc saslmd5::decode64 {str} {
+    return [::base64::decode $str]
+}
+
+proc saslmd5::encode64 {str} {
+    
+    # important! no whitespace allowed in response!
+    return [string map [list "\n" ""] [::base64::encode $str]]
+}
+
+# saslmd5::client_new --
+#
+#       Create a new instance for a session.
+#
+# Arguments:
+#	args    -callbacks    {{id proc} ...} with id any of 
+#	                      {username authzid pass realm}
+#	                      note that everyone must be utf-8 encoded!
+#	        -service      name of service (xmpp)
+#	        -serverFQDN   servers fully qualified domain name
+#	        -flags        not used
+#	
+# Results:
+#       token.
+
+proc saslmd5::client_new {args} {    
+    variable uid
+    
+    #puts "saslmd5::client_new"
+    set token [namespace current]::[incr uid]
+    variable $token
+    upvar 0 $token state
+
+    set state(step)       0
+    set state(service)    ""
+    set state(serverFQDN) ""
+    set state(flags)      {}
+    
+    foreach {key value} $args {
+	switch -- $key {
+	    -callbacks {
+		set_callbacks $token $value
+	    }
+	    -service - -serverFQDN - -flags {
+		set state([string trimleft $key -]) $value
+	    }
+	    default {
+		return -code error "unrocognized option \"$key\""
+	    }
+	}
+    }
+    
+    proc $token {cmd args}   \
+      "eval [namespace current]::cmdproc {$token} \$cmd \$args"
+
+    return $token
+}
+
+proc saslmd5::cmdproc {token cmd args} {
+
+    # Which command? Just dispatch the command to the right procedure.
+    return [eval {method_$cmd $token} $args]
+}
+
+# class methods.
+
+# saslmd5::method_start --
+#
+#       Starts negotiating.
+#
+# Arguments:
+#       token       
+#       args        -mechanisms {list of mechanisms}
+#	
+# Results:
+#       {returnCode list-or-error}.
+
+proc saslmd5::method_start {token args} {
+    variable $token
+    upvar 0 $token state
+    variable mechanisms
+    
+    #puts "saslmd5::method_start $args"
+    set state(step) 0
+    
+    foreach {key value} $args {
+	switch -- $key {
+	    -mechanisms {
+		set state(inmechanisms) $value
+	    }
+	    default {
+		# empty
+	    }
+	}
+    }
+    if {![::info exists state(inmechanisms)]} {
+	return [list 1 "missing a \"-mechanisms\" option"]
+    }
+
+    # we must have at least on of the servers announced mechanisms
+    set match 0
+    foreach m $mechanisms {
+	if {[set idx [lsearch -exact $state(inmechanisms) $m]] >= 0} {
+	    set match 1
+	    set mechanism [lindex $state(inmechanisms) $idx]
+	    break
+	}
+    }
+    if {!$match} {
+	return [list 1 "the servers mechanisms \"$state(inmechanisms)\"\
+	  do not match any of the supported mechanisms \"$mechanisms\""]
+    }
+    set state(step) 1
+    
+    switch -- $mechanism {
+	PLAIN {
+	    set output [get_plain_output $token]
+	}
+	DIGEST-MD5 {
+	    set output ""
+	}
+	ANONYMOUS {
+	    set output [get_anonymous_output $token]
+	}
+    }
+	    
+    # continue
+    return [list 4 [list mechanism $mechanism output $output]]
+}
+
+proc saslmd5::get_plain_output {token} {
+    variable $token
+    upvar 0 $token state
+    
+    # SENT: <auth 
+    #           xmlns="urn:ietf:params:xml:ns:xmpp-sasl"
+    #           mechanism="PLAIN">
+    #               somelongstring
+    #       </auth>
+    # where somelongstring is (from Pandion's .js src):
+    #   /* Plaintext algorithm:
+    #    * Base64( UTF8( Addr ) + 0x00 + UTF8( User ) + 0x00 + UTF8( Pass ) )
+    #	 */
+    # User is the username, Addr is the full JID, and Pass is the password.
+
+    request_userpars $token
+    
+    set username $state(upar,username)
+    set pass     $state(upar,pass)
+    set realm    $state(upar,realm)
+
+    set user_lat1  [encoding convertto iso8859-1 $username]
+    set pass_lat1  [encoding convertto iso8859-1 $pass]
+    set realm_lat1 [encoding convertto iso8859-1 $realm]
+    
+    set jid [jlib::joinjid $user_lat1 $realm_lat1 ""]
+    return [binary format a*xa*xa* $jid $user_lat1 $pass_lat1]
+}
+
+proc saslmd5::get_anonymous_output {token} {
+
+    # @@@ Is this correct???
+    return [jlib::generateuuid]
+}
+
+# saslmd5::method_step --
+#
+#       Takes one step when negotiating.
+#
+# Arguments:
+#       token       
+#       args        -input challenge
+#	
+# Results:
+#       {returnCode list-or-error}.
+
+proc saslmd5::method_step {token args} {
+    variable $token
+    upvar 0 $token state
+    
+    #puts "saslmd5::method_step $token, $args"
+    foreach {key value} $args {
+	switch -- $key {
+	    -input {
+		set challenge $value
+	    }
+	}
+    }
+    if {![::info exists challenge]} {
+	return [list 1 "must have -input challenge string"]
+    }
+    
+    if {$state(step) == 0} {
+	return [list 1 "need to call the 'start' procedure first"]
+    } elseif {$state(step) == 1} {
+	if {![iscapable $token]} {	
+	    return [list 1 "missing one or more callbacks"]
+	}
+	array set challarr [parse_challenge $challenge]
+	if {![::info exists challarr(nonce)]} {
+	    return [list 1 "challenge missing 'nonce' attribute"]
+	}
+	if {![::info exists challarr(algorithm)]} {
+	    return [list 1 "challenge missing 'algorithm' attribute"]
+	}
+	request_userpars $token
+	set output [process_challenge $token [array get challarr]]
+	incr state(step)
+	
+	# continue
+	set code 4
+    } else {
+	incr state(step)
+	
+	# success
+	set output ""
+	set code 0
+    }    
+    return [list $code $output]
+}
+
+proc saslmd5::method_setprop {token property value} {
+    variable $token
+    upvar 0 $token state
+
+    # empty
+}
+
+proc saslmd5::method_getprop {token property} {
+    variable $token
+    upvar 0 $token state
+
+    # empty
+    return
+}
+
+proc saslmd5::method_info {args} {
+    
+    # empty
+    return {}
+}
+
+proc saslmd5::set_callbacks {token cblist} {
+    variable $token
+    upvar 0 $token state
+        
+    # some of tclsasl's id's are different from the spec's!
+    # note that everyone must be utf-8 encoded!
+    foreach cbpair $cblist {
+	foreach {id cbproc} $cbpair {
+	    set state(cb,$id) $cbproc
+	}
+    }
+}
+
+proc saslmd5::iscapable {token} {
+    variable $token
+    upvar 0 $token state
+    variable needed
+
+    set capable 1
+    foreach id $needed {
+	if {[::info exists state(cb,$id)] && ($state(cb,$id) != {})} {
+	    # empty
+	} else {
+	    set capable 0
+	    break
+	}
+    }
+    return $capable
+}
+
+# saslmd5::request_userpars --
+# 
+#       Invokes the needed callbacks to get user's parameters.
+
+proc saslmd5::request_userpars {token} {
+    variable $token
+    upvar 0 $token state
+    variable needed
+
+    foreach id $needed {
+	if {[::info exists state(cb,$id)] && ($state(cb,$id) != {})} {
+	    set plist [list id $id]
+	    set state(upar,$id) [uplevel #0 $state(cb,$id) [list $plist]]
+	} else {
+	    return -code error "missing one or more callbacks"
+	}
+    }
+}
+
+# saslmd5::process_challenge --
+# 
+#       Computes an output from a challenge using user's parameters.
+#
+# Arguments:
+#       token       
+#       challenge
+#
+# Results:
+#       the output string as clear text.
+
+proc saslmd5::process_challenge {token challenge} {
+    variable $token
+    upvar 0 $token state
+    
+    array set charr $challenge
+    
+    # users parameters
+    set username $state(upar,username)
+    set authzid  $state(upar,authzid)
+    set pass     $state(upar,pass)
+    set realm    $state(upar,realm)
+    
+    set host     $state(serverFQDN)
+    set service  $state(service)
+        
+    # make a 'cnonce'
+    set bytes ""
+    for {set n 0} {$n < 32} {incr n} {
+	set r [expr {int(256*rand())}]
+	append bytes [binary format c $r]
+    }
+    set cnonce [encode64 $bytes]
+    
+    # other
+    set realm   $host
+    set nonce   $charr(nonce)
+    set nc      "00000001"
+    set diguri  $service/$host
+    set qop     "auth"
+        
+    # build 'response' (2.1.2.1   Response-value in RFC 2831)
+    # try to be a bit general here (from Cyrus SASL)
+    # 
+    # encoding is a bit unclear. 
+    # from RFC 2831:
+    #   If "charset=UTF-8" is present, and all the characters of either 
+    #   "username-value" or "passwd" are in the ISO 8859-1 character set, 
+    #   then it must be converted to ISO 8859-1 before being hashed.
+    # 
+    # from Cyrus SASL:
+    #   if the string is entirely in the 8859-1 subset of UTF-8, then translate
+    #   to 8859-1 prior to MD5
+
+    set user_lat1  [encoding convertto iso8859-1 $username]
+    set realm_lat1 [encoding convertto iso8859-1 $realm]
+    set pass_lat1  [encoding convertto iso8859-1 $pass]
+    set secret     ${user_lat1}:${realm_lat1}:${pass_lat1}
+    set secretmd5  [::md5::md5 $secret]
+    set A1         ${secretmd5}:${nonce}:${cnonce}
+    if {$authzid ne ""} {
+	append A1 :${authzid}
+    }
+    set A2         AUTHENTICATE:${diguri}
+    if {$qop ne "auth"} {
+	append A2 ":00000000000000000000000000000000"
+    }
+    set HA1        [string tolower [::md5::md5 -hex $A1]]
+    set HA2        [string tolower [::md5::md5 -hex $A2]]
+    set KD         ${HA1}:${nonce}
+    if {$qop ne ""} {
+	append KD :${nc}:${cnonce}:${qop}:${HA2}
+    }
+    set response   [string tolower [::md5::md5 -hex $KD]]
+    
+    # build output
+    set output ""
+    append output "username=\"$username\""
+    append output ",realm=\"$realm\""
+    append output ",nonce=\"$nonce\""
+    append output ",cnonce=\"$cnonce\""
+    append output ",nc=\"$nc\""
+    append output ",serv-type=\"$service\""
+    append output ",host=\"$host\""
+    append output ",digest-uri=\"$diguri\""
+    append output ",qop=\"$qop\""
+    append output ",response=\"$response\""
+    append output ",charset=\"utf-8\""
+    if {$authzid ne ""} {
+	append output ",authzid=\"$authzid\""
+    }
+    return $output
+}
+
+# saslmd5::parse_challenge --
+# 
+#       Parses a clear text challenge string into a challenge list.
+
+proc saslmd5::parse_challenge {str} {
+    # RFC 2831 2.1
+    # Char categories as per spec...
+    # Build up a regexp for splitting the challenge into key value pairs.
+
+    set sep "\\\]\\\[\\\\()<>@,;:\\\"\\\?=\\\{\\\} \t"
+    set tok {0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\-\|\~\!\#\$\%\&\*\+\.\^\_\`}
+    set sqot {(?:\'(?:\\.|[^\'\\])*\')}
+    set dqot {(?:\"(?:\\.|[^\"\\])*\")}
+    set parameters {}
+    regsub -all "(\[${tok}\]+)=(${dqot}|(?:\[${tok}\]+))(?:\[${sep}\]+|$)" \
+        $str {\1 \2 } parameters
+    return $parameters
+}
+
+# RFC 2831 2.1
+# Char categories as per spec...
+# Build up a regexp for splitting the challenge into key value pairs.
+
+proc saslmd5::parse_challengePT {str} {
+    puts "str=$str"
+        
+    set sep "\\\]\\\[\\\\()<>@,;:\\\"\\\?= \\\{\\\} \t"
+    set tok {0123456789ABCDEFGHIJKLMNOPQRS TUVWXYZabcdefghijklmnopqrstuvw xyz\-\|\~\!\#\$\%\&\*\+\.\^\_\ `}
+    set sqot {(?:\'(?:\\.|[^\'\\])*\')}
+    set dqot {(?:\"(?:\\.|[^\"\\])*\")}
+    set parameters {}
+    regsub -all "(\[${tok}\]+)=(${dqot}|(?:\[$ {tok}\]+))(?:\[${sep}\]+|$)" \
+      $str {\1 \2 } parameters
+    puts "parameters=$parameters"
+    return $parameters
+}
+
+# Fails when quotes are missing:
+# str=nonce="1142339597",qop="auth",charset=utf-8,algorithm=md5-sess
+# parameters=nonce "1142339597" qop "auth" charset=utf-8,algorithm=md5-sess
+
+proc saslmd5::free {token} {
+    variable $token
+    upvar 0 $token state
+    
+    unset -nocomplain state
+}
+
diff --git a/lib/jabberlib/scripts/README-scripts b/lib/jabberlib/scripts/README-scripts
new file mode 100644
index 0000000..92dc7e6
--- /dev/null
+++ b/lib/jabberlib/scripts/README-scripts
@@ -0,0 +1,11 @@
+
+README-scripts
+--------------
+
+This folder is supposed to contain high level scripts using jabberlib to 
+perform various actions normally implemented at application level, such as:
+
+  o register account
+  o remove account
+  o send message
+
diff --git a/lib/jabberlib/scripts/message.tcl b/lib/jabberlib/scripts/message.tcl
new file mode 100644
index 0000000..5377ac8
--- /dev/null
+++ b/lib/jabberlib/scripts/message.tcl
@@ -0,0 +1,104 @@
+# message.tcl --
+#
+#       Simple script that uses jabberlib to send a message.
+#
+# Copyright (c) 2007  Mats Bengtsson
+# 
+# This file is distributed under BSD style license.
+#  
+# $Id: message.tcl,v 1.2 2007/08/06 07:49:54 matben Exp $
+
+package require jlib
+package require jlib::connect
+
+package provide jlibs::message 0.1
+
+namespace eval jlibs::message {
+    
+    variable sendOpts {-subject -thread -body -type -xlist}
+}
+
+interp alias {} jlibs::message {} jlibs::message::message
+
+# jlibs::message --
+# 
+#       Make a complete new session and send a message.
+#       The options are passed on to 'connect' except:
+#       
+
+proc jlibs::message::message {jid password to cmd args} {
+    variable sendOpts
+    
+    set jlib [jlib::new [namespace code noop]]
+
+    variable $jlib
+    upvar 0 $jlib state
+
+    set state(jid)      $jid
+    set state(password) $password
+    set state(to)       $to
+    set state(cmd)      $cmd
+    set state(args)     $args
+    set state(jlib)     $jlib
+    
+    jlib::util::from args -command
+    jlib::util::from args -noauth  
+    
+    # Extract the message options.
+    foreach name $sendOpts {
+	set state($name) [jlib::util::from args $name]
+    }
+    eval {$jlib connect connect $jid $password \
+      -command [namespace code cmdC]} $args
+    return $jlib
+}
+
+proc jlibs::message::cmdC {jlib status {errcode ""} {errmsg ""}} {
+    variable sendOpts
+    variable $jlib
+    upvar 0 $jlib state
+    
+    if {![info exists state]} {
+	return
+    }
+    if {$status eq "ok"} {
+	set opts [list]
+	foreach name $sendOpts {
+	    if {$state($name) ne ""} {
+		lappend opts $name $state($name)
+	    }
+	}
+	eval {$jlib send_message $state(to)} $opts
+	finish $jlib
+    } elseif {$status eq "error"} {
+	finish $jlib $errcode
+    }    
+}
+
+proc jlibs::message::reset {jlib} {
+    finish $jlib reset
+}
+
+proc jlibs::message::finish {jlib {err ""}} {
+    variable $jlib
+    upvar 0 $jlib state
+    
+    $jlib closestream
+    
+    if {$err ne ""} {
+	uplevel #0 $state(cmd) [list $jlib error $err] 
+    } else {
+	uplevel #0 $state(cmd) [list $jlib ok] 
+    }
+    unset -nocomplain state
+}
+
+proc jlibs::message::noop {args} {}
+
+if {0} {
+    # Test:
+    proc cmd {args} {puts "---> $args"}
+    jlibs::message xyz@localhost xxx matben@localhost cmd -body Hej -subject Hej
+}
+
+
diff --git a/lib/jabberlib/scripts/password.tcl b/lib/jabberlib/scripts/password.tcl
new file mode 100644
index 0000000..5dde657
--- /dev/null
+++ b/lib/jabberlib/scripts/password.tcl
@@ -0,0 +1,105 @@
+# password.tcl --
+#
+#       Simple script that uses jabberlib to change password.
+#
+# Copyright (c) 2007  Mats Bengtsson
+# 
+# This file is distributed under BSD style license.
+#  
+# $Id: password.tcl,v 1.1 2007/08/07 07:51:27 matben Exp $
+
+package require jlib
+package require jlib::connect
+
+package provide jlibs::password 0.1
+
+namespace eval jlibs::password {}
+
+interp alias {} jlibs::password {} jlibs::password::password
+
+# jlibs::password --
+# 
+#       Make a complete new session and change password.
+#       The options are passed on to 'connect' except:
+#       
+
+proc jlibs::password::password {jid password newpassword cmd args} {
+    
+    set jlib [jlib::new [namespace code noop]]
+
+    variable $jlib
+    upvar 0 $jlib state
+
+    set state(jid)         $jid
+    set state(password)    $password
+    set state(newpassword) $newpassword
+    set state(cmd)         $cmd
+    set state(args)        $args
+    set state(jlib)        $jlib
+    
+    jlib::util::from args -command
+    jlib::util::from args -noauth  
+    
+    eval {$jlib connect connect $jid $password \
+      -command [namespace code cmdC]} $args
+    return $jlib
+}
+
+proc jlibs::password::cmdC {jlib status {errcode ""} {errmsg ""}} {
+    variable sendOpts
+    variable $jlib
+    upvar 0 $jlib state
+    
+    if {![info exists state]} {
+	return
+    }
+    if {$status eq "ok"} {
+	jlib::splitjidex $state(jid) node server -
+	$jlib register_set $node $state(password) [namespace code cmdS] \
+	  -to $server
+    } elseif {$status eq "error"} {
+	finish $jlib $errcode
+    }    
+}
+
+proc jlibs::password::cmdS {jlib type iqchild args} {
+    variable $jlib
+    upvar 0 $jlib state
+    
+    if {![info exists state]} {
+	return
+    }
+    if {$type eq "result"} {
+	finish $jlib
+    } else {
+	finish $jlib $iqchild
+    }
+}
+
+proc jlibs::password::reset {jlib} {
+    finish $jlib reset
+}
+
+proc jlibs::password::finish {jlib {err ""}} {
+    variable $jlib
+    upvar 0 $jlib state
+    
+    $jlib closestream
+    
+    if {$err ne ""} {
+	uplevel #0 $state(cmd) [list $jlib error $err] 
+    } else {
+	uplevel #0 $state(cmd) [list $jlib ok] 
+    }
+    unset -nocomplain state
+}
+
+proc jlibs::password::noop {args} {}
+
+if {0} {
+    # Test:
+    proc cmd {args} {puts "---> $args"}
+    jlibs::password xyz@localhost xxx yyy cmd
+}
+
+
diff --git a/lib/jabberlib/scripts/pkgIndex.tcl b/lib/jabberlib/scripts/pkgIndex.tcl
new file mode 100644
index 0000000..e6ef643
--- /dev/null
+++ b/lib/jabberlib/scripts/pkgIndex.tcl
@@ -0,0 +1,13 @@
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script.  It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands.  When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded jlibs::register   0.1 [list source [file join $dir register.tcl]]
+package ifneeded jlibs::unregister 0.1 [list source [file join $dir unregister.tcl]]
+package ifneeded jlibs::message    0.1 [list source [file join $dir message.tcl]]
diff --git a/lib/jabberlib/scripts/register.tcl b/lib/jabberlib/scripts/register.tcl
new file mode 100644
index 0000000..6a1e66b
--- /dev/null
+++ b/lib/jabberlib/scripts/register.tcl
@@ -0,0 +1,118 @@
+# register.tcl --
+#
+#       Simple script that uses jabberlib to register an account.
+#
+# Copyright (c) 2007  Mats Bengtsson
+# 
+# This file is distributed under BSD style license.
+#  
+# $Id: register.tcl,v 1.4 2007/08/07 07:50:25 matben Exp $
+
+package require jlib
+package require jlib::connect
+
+package provide jlibs::register 0.1
+
+namespace eval jlibs::register {}
+
+interp alias {} jlibs::register {} jlibs::register::register
+
+# jlibs::register --
+# 
+#       Make a complete new session and register an account.
+#       The options are passed on to 'connect'.
+
+proc jlibs::register::register {jid password cmd args} {
+    
+    set jlib [jlib::new [namespace code noop]]
+
+    variable $jlib
+    upvar 0 $jlib state
+
+    set state(jid)      $jid
+    set state(password) $password
+    set state(cmd)      $cmd
+    set state(args)     $args
+    set state(jlib)     $jlib
+    
+    jlib::util::from args -command
+    jlib::util::from args -noauth    
+    jlib::splitjidex $jid node server -
+    
+    eval {$jlib connect connect $server {} \
+      -noauth 1 -command [namespace code cmdC]} $args
+    return $jlib
+}
+
+proc jlibs::register::cmdC {jlib status {errcode ""} {errmsg ""}} {
+    variable $jlib
+    upvar 0 $jlib state
+    
+    if {![info exists state]} {
+	return
+    }
+    if {$status eq "ok"} {
+	$jlib register_get [namespace code cmdG] 
+    } elseif {$status eq "error"} {
+	finish $jlib $errcode
+    }    
+}
+
+proc jlibs::register::cmdG {jlib type iqchild} {
+    variable $jlib
+    upvar 0 $jlib state
+
+    if {![info exists state]} {
+	return
+    }
+    if {$type eq "result"} {
+	jlib::splitjidex $state(jid) node server -
+
+	# Assuming minimal registration fields.
+	$jlib register_set $node $state(password) [namespace code cmdS]
+    } else {
+	finish $jlib $iqchild
+    }
+}
+
+proc jlibs::register::cmdS {jlib type iqchild args} {
+    variable $jlib
+    upvar 0 $jlib state
+    
+    if {![info exists state]} {
+	return
+    }
+    if {$type eq "result"} {
+	finish $jlib
+    } else {
+	finish $jlib $iqchild
+    }
+}
+
+proc jlibs::register::reset {jlib} {
+    finish $jlib reset
+}
+
+proc jlibs::register::finish {jlib {err ""}} {
+    variable $jlib
+    upvar 0 $jlib state
+    
+    $jlib closestream
+    
+    if {$err ne ""} {
+	uplevel #0 $state(cmd) [list $jlib error $err] 
+    } else {
+	uplevel #0 $state(cmd) [list $jlib ok] 
+    }
+    unset -nocomplain state
+}
+
+proc jlibs::register::noop {args} {}
+
+if {0} {
+    # Test:
+    proc cmd {args} {puts "---> $args"}
+    jlibs::register xyz@localhost xxx cmd
+}
+
+
diff --git a/lib/jabberlib/scripts/unregister.tcl b/lib/jabberlib/scripts/unregister.tcl
new file mode 100644
index 0000000..9ff5c6d
--- /dev/null
+++ b/lib/jabberlib/scripts/unregister.tcl
@@ -0,0 +1,98 @@
+# unregister.tcl --
+#
+#       Simple script that uses jabberlib to unregister an account.
+#
+# Copyright (c) 2007  Mats Bengtsson
+# 
+# This file is distributed under BSD style license.
+#  
+# $Id: unregister.tcl,v 1.3 2007/08/06 07:49:54 matben Exp $
+
+package require jlib
+package require jlib::connect
+
+package provide jlibs::unregister 0.1
+
+namespace eval jlibs::unregister {}
+
+interp alias {} jlibs::unregister {} jlibs::unregister::unregister
+
+# jlibs::unregister --
+# 
+#       Make a complete new session and unregister an account.
+#       The options are passed on to 'connect'.
+
+proc jlibs::unregister::unregister {jid password cmd args} {
+    
+    #puts "jlibs::unregister::unregister"
+    set jlib [jlib::new [namespace code noop]]
+
+    variable $jlib
+    upvar 0 $jlib state
+
+    set state(jid)      $jid
+    set state(password) $password
+    set state(cmd)      $cmd
+    set state(args)     $args
+    set state(jlib)     $jlib
+    
+    jlib::util::from args -command
+    jlib::util::from args -noauth    
+    
+    eval {$jlib connect connect $jid $password \
+      -command [namespace code cmdC]} $args
+    return $jlib
+}
+
+proc jlibs::unregister::cmdC {jlib status {errcode ""} {errmsg ""}} {
+    variable $jlib
+    upvar 0 $jlib state
+    
+    if {![info exists state]} {
+	return
+    }
+    if {$status eq "ok"} {
+	jlib::splitjidex $state(jid) node server -
+	$jlib register_remove $server [namespace code cmdR] 
+    } elseif {$status eq "error"} {
+	finish $jlib $errcode
+    }    
+}
+
+proc jlibs::unregister::cmdR {jlib type subiq} {
+    
+    if {$type eq "result"} {
+	finish $jlib    
+    } else {
+	finish $jlib $subiq
+    }
+}
+
+proc jlibs::unregister::reset {jlib} {
+    finish $jlib reset
+}
+
+proc jlibs::unregister::finish {jlib {err ""}} {
+    variable $jlib
+    upvar 0 $jlib state
+    
+    #puts "jlibs::unregister::finish"
+    $jlib closestream
+    
+    if {$err ne ""} {
+	uplevel #0 $state(cmd) [list $jlib error $err] 
+    } else {
+	uplevel #0 $state(cmd) [list $jlib ok] 
+    }
+    unset -nocomplain state
+}
+
+proc jlibs::unregister::noop {args} {}
+
+if {0} {
+    # Test:
+    proc cmd {args} {puts "---> $args"}
+    jlibs::unregister xyz@localhost xxx cmd
+}
+
+
diff --git a/lib/jabberlib/service.tcl b/lib/jabberlib/service.tcl
new file mode 100644
index 0000000..f312f10
--- /dev/null
+++ b/lib/jabberlib/service.tcl
@@ -0,0 +1,326 @@
+# service.tcl --
+#
+#       This is an abstraction layer for groupchat protocols gc-1.0/muc.
+#       All except disco/muc are EOL!
+#       
+#  Copyright (c) 2004-2006  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: service.tcl,v 1.27 2008/02/06 13:57:25 matben Exp $
+# 
+############################# USAGE ############################################
+#
+#   NAME
+#      service - protocol independent methods for groupchats/muc
+#                
+#   SYNOPSIS
+#      jlib::service::init jlibName
+#      
+#   INSTANCE COMMANDS
+#      jlibName service allroomsin
+#      jlibName service exitroom room
+#      jlibName service isroom jid
+#      jlibName service nick jid
+#      jlibName service register type name
+#      jlibName service roomparticipants room
+#      jlibName service setroomprotocol jid protocol
+#      jlibName service unregister type name
+# 
+# 
+#   VARIABLES
+#
+# serv:	                             
+#	serv(gcProtoPriority)      : The groupchat protocol priority list.                             
+#	                             
+#       serv(gcprot,$jid)          : Map a groupchat service jid to protocol:
+#       	                     (gc-1.0|muc)
+#
+#       serv(prefgcprot,$jid)      : Stores preferred groupchat protocol that
+#                                    overrides the priority list.
+#     
+############################# CHANGES ##########################################
+#
+#       0.1         first version
+
+package provide service 1.0
+
+namespace eval ::jlib {}
+
+namespace eval jlib::service {
+    
+    # This is an abstraction layer for the groupchat protocols gc-1.0/muc.
+    
+    # Cache the following services in particular.
+    variable services {search register groupchat conference muc}    
+
+    # Maintain a priority list of groupchat protocols in decreasing priority.
+    # Entries must match: ( gc-1.0 | muc )
+    variable groupchatTypeExp {(gc-1.0|muc)}
+}
+
+proc jlib::service {jlibname cmd args} {
+    set ans [eval {[namespace current]::service::${cmd} $jlibname} $args]
+    return $ans
+}
+
+proc jlib::service::init {jlibname} {
+    
+    upvar ${jlibname}::serv serv
+
+    # Init defaults.
+    array set serv {
+	disco    0
+	muc      0
+    }
+	    
+    # Maintain a priority list of groupchat protocols in decreasing priority.
+    # Entries must match: ( gc-1.0 | muc )
+    set serv(gcProtoPriority) {muc gc-1.0}
+}
+
+# jlib::service::register --
+# 
+#       Let components (browse/disco/muc etc.) register that their services
+#       are available.
+
+proc jlib::service::register {jlibname type name} {    
+    upvar ${jlibname}::serv serv
+
+    set serv($type) 1
+    set serv($type,name) $name
+}
+
+proc jlib::service::unregister {jlibname type} {
+    upvar ${jlibname}::serv serv
+
+    set serv($type) 0
+    array unset serv $type,*
+}
+
+proc jlib::service::get {jlibname type} {
+    upvar ${jlibname}::serv serv
+    
+    if {$serv($type)} {
+	return $serv($type,name)
+    } else {
+	return
+    }
+}
+
+#-------------------------------------------------------------------------------
+#
+# A couple of routines that handle the selection of groupchat protocol for
+# each groupchat service.
+# A groupchat service may support more than a single protocol. For instance,
+# the MUC component supports both gc-1.0 and MUC.
+
+# Needs some more verification before using it for a dispatcher.
+
+
+# jlib::service::registergcprotocol --
+# 
+#       Register (sets) a groupchat service jid according to the priorities
+#       presently set. Only called internally!
+
+proc jlib::service::registergcprotocol {jlibname jid gcprot} {
+    upvar ${jlibname}::serv serv
+    
+    Debug 2 "jlib::registergcprotocol jid=$jid, gcprot=$gcprot"
+    set jid [jlib::jidmap $jid]
+    
+    # If we already told jlib to use a groupchat protocol then...
+    if {[info exist serv(prefgcprot,$jid)]} {
+	return
+    }
+    
+    # Set 'serv(gcprot,$jid)' according to the priority list.
+    foreach prot $serv(gcProtoPriority) {
+	
+	# Do we have registered a groupchat protocol with higher priority?
+	if {[info exists serv(gcprot,$jid)] && \
+	  [string equal $serv(gcprot,$jid) $prot]} {
+	    return
+	}
+	if {[string equal $prot $gcprot]} {
+	    set serv(gcprot,$jid) $prot
+	    return
+	}	
+    }
+}
+
+# jlib::service::setroomprotocol --
+# 
+#       Set the groupchat protocol in use for room. This acts only as a
+#       dispatcher for 'service' commands.  
+#       Only called internally when entering a room!
+
+proc jlib::service::setroomprotocol {jlibname roomjid protocol} {
+    variable groupchatTypeExp
+    upvar ${jlibname}::serv serv
+    
+    set roomjid [jlib::jidmap $roomjid]
+    if {![regexp $groupchatTypeExp $protocol]} {
+	return -code error "Unrecognized groupchat protocol \"$protocol\""
+    }
+    set serv(roomprot,$roomjid) $protocol
+}
+
+# jlib::service::isroom --
+# 
+#       Try to figure out if the jid is a room.
+#       If we've browsed it it's been registered in our browse object.
+#       If using agent(s) method, check the agent for this jid
+
+proc jlib::service::isroom {jlibname jid} {    
+    upvar ${jlibname}::serv serv
+    upvar ${jlibname}::locals locals
+    
+    # Check if domain name supports the 'groupchat' service.
+    # disco uses explicit children of conference, and muc cache
+    set isroom 0
+    if {!$isroom && $serv(disco) && [$jlibname disco isdiscoed info $locals(server)]} {
+	set isroom [$jlibname disco isroom $jid]
+    }
+    if {!$isroom && $serv(muc)} {
+	set isroom [$jlibname muc isroom $jid]
+    }
+    if {!$isroom} {
+	set isroom [jlib::groupchat::isroom $jlibname $jid]
+    }
+    return $isroom
+}
+
+# jlib::service::nick --
+#
+#       Return nick name for ANY room participant, or the rooms name
+#       if jid is a room.
+#       Not very useful since old 'conference' protocol has gone but keep
+#       it as an abstraction anyway.
+#       
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        'roomname@conference.jabber.org/nick' typically,
+#                   or just room jid.
+
+proc jlib::service::nick {jlibname jid} {   
+    return [jlib::resourcejid $jid]
+}
+
+# jlib::service::mynick --
+#
+#       A way to get our OWN nickname for a given room independent of protocol.
+#       
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       room:       'roomname@conference.jabber.org' typically.
+#       
+# Results:
+#       mynickname
+
+proc jlib::service::mynick {jlibname room} {
+    upvar ${jlibname}::serv serv
+    
+    set room [jlib::jidmap $room]
+    
+    # All kind of conference components seem to support the old 'gc-1.0'
+    # protocol, and we therefore must query our method for entering the room.
+    if {![info exists serv(roomprot,$room)]} {
+	return -code error "Does not know which protocol to use in $room"
+    }
+    
+    switch -- $serv(roomprot,$room) {
+	gc-1.0 {
+	    set nick [$jlibname groupchat mynick $room]
+	} 
+	muc {
+	    set nick [$jlibname muc mynick $room]
+	} 
+    }
+    return $nick
+}
+
+# jlib::service::setnick --
+
+proc jlib::service::setnick {jlibname room nick args} {
+    upvar ${jlibname}::serv serv
+    
+    set room [jlib::jidmap $room]
+    if {![info exists serv(roomprot,$room)]} {
+	return -code error "Does not know which protocol to use in $room"
+    }
+
+    switch -- $serv(roomprot,$room) {
+	gc-1.0 {
+	    eval {$jlibname groupchat setnick $room $nick} $args
+	} 
+	muc {
+	    eval {$jlibname muc setnick $room $nick} $args
+	} 
+    }
+}
+
+# jlib::service::allroomsin --
+# 
+# 
+
+proc jlib::service::allroomsin {jlibname} {    
+    upvar ${jlibname}::lib lib
+    upvar ${jlibname}::gchat gchat
+    upvar ${jlibname}::serv serv
+
+    set roomList [concat $gchat(allroomsin) \
+      [[namespace parent]::muc::allroomsin $jlibname]]
+    if {$serv(muc)} {
+	set roomList [concat $roomList [$jlibname muc allroomsin]]
+    }
+    return [lsort -unique $roomList]
+}
+
+proc jlib::service::roomparticipants {jlibname room} {
+    upvar ${jlibname}::locals locals
+    upvar ${jlibname}::serv serv
+    
+    set room [jlib::jidmap $room]
+    if {![info exists serv(roomprot,$room)]} {
+	return -code error "Does not know which protocol to use in $room"
+    }
+
+    set everyone {}
+    if {![[namespace current]::isroom $jlibname $room]} {
+	return -code error "The jid \"$room\" is not a room"
+    }
+
+    switch -- $serv(roomprot,$room) {
+	gc-1.0 {
+	    set everyone [[namespace parent]::groupchat::participants $jlibname $room]
+	} 
+	muc {
+	    set everyone [$jlibname muc participants $room]
+	}
+    }
+    return $everyone
+}
+
+proc jlib::service::exitroom {jlibname room} {    
+    upvar ${jlibname}::locals locals
+    upvar ${jlibname}::serv serv
+
+    set room [jlib::jidmap $room]
+    if {![info exists serv(roomprot,$room)]} {
+	#return -code error "Does not know which protocol to use in $room"
+	# Not sure here???
+	set serv(roomprot,$room) "gc-1.0"
+    }
+
+    switch -- $serv(roomprot,$room) {
+	gc-1.0 {
+	    [namespace parent]::groupchat::exit $jlibname $room
+	}
+	muc {
+	    $jlibname muc exit $room
+	}
+    }
+}
+
+#-------------------------------------------------------------------------------
diff --git a/lib/jabberlib/si.tcl b/lib/jabberlib/si.tcl
new file mode 100644
index 0000000..f538825
--- /dev/null
+++ b/lib/jabberlib/si.tcl
@@ -0,0 +1,729 @@
+#  si.tcl --
+#  
+#      This file is part of the jabberlib. 
+#      It provides support for the stream initiation protocol (XEP-0095).
+#      
+#  Copyright (c) 2005-2007  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: si.tcl,v 1.26 2007/11/30 14:38:34 matben Exp $
+# 
+#      There are several layers involved when sending/receiving a file for 
+#      instance. Each layer reports only to the nearest layer above using
+#      callbacks. From top to bottom:
+#      
+#      1) application
+#      2) profiles, file-transfer etc.
+#      3) stream initiation (si)
+#      4) the streams, bytestreams (socks5), ibb, etc.
+#      5) jabberlib
+#      
+#      Each layer divides into two parts, the initiator and target.
+#      Keep different state arrays for initiator (i) and target (t).
+#      The si layer acts as a mediator between the profiles and the streams.
+#      Each profile registers with si, and each stream registers with si.
+#      
+#            profiles ...
+#                 \   |   /
+#                  \  |  /
+#                   \ | /
+#                     si (stream initiation)
+#                   / | \
+#                  /  |  \
+#                 /   |   \
+#             streams ...
+#      
+#       INITIATOR: each transport (stream) registers for open, send & close 
+#           using 'registertransport'. The profiles call these indirectly
+#           through si. The profile gets feedback from streams using direct
+#           callbacks.
+#           
+#       TARGET: each profile (file-transfer) registers for open, read & close
+#           using 'registerprofile'. The transports register for element
+#           handlers for their specific protocol. When activated, the transport
+#           calls si which in turn calls the profile using its registered 
+#           handlers.
+# 
+#                 Initiator:                Target:
+# 
+#       profiles   |    :    :               /|\   :    :
+#                  |    :    :                |    :    :
+#                 \|/   :    :                |    :    :
+#       si        =============  <-------->  =============
+#                  :    |    :                :   /|\   :
+#                  :    |    :                :    |    :
+#       streams    :   \|/   :                :    |    :
+#                       o .......................> o
+# 
+# 
+############################# USAGE ############################################
+#
+#   NAME
+#      si - convenience command library for stream initiation.
+#      
+#   SYNOPSIS
+#      
+#
+#   OPTIONS
+#
+#	
+#   INSTANCE COMMANDS
+#      jlibName si registertransport ...
+#      jlibName si registerprofile ...
+#      jlibName si send_set ...
+#      jlibName si send_data ...
+#      jlibName si send_close ...
+#      jlibName si getstate sid
+#      
+################################################################################
+
+package require jlib			   
+package require jlib::disco
+			  
+package provide jlib::si 0.1
+
+#--- generic si ----------------------------------------------------------------
+
+namespace eval jlib::si {
+
+    variable xmlns
+    set xmlns(si)      "http://jabber.org/protocol/si"
+    set xmlns(neg)     "http://jabber.org/protocol/feature-neg"
+    set xmlns(xdata)   "jabber:x:data"
+    set xmlns(streams) "urn:ietf:params:xml:ns:xmpp-streams"
+    
+    # Storage for registered transports.
+    variable trpt
+    set trpt(list) [list]
+        
+    jlib::disco::registerfeature $xmlns(si)
+
+    # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::si::registertransport --
+# 
+#       Register transports on the initiator (sender) side. 
+#       This is used by the streams that do the actual job.
+#       Typically 'name' and 'ns' are xml namespaces and identical.
+
+proc jlib::si::registertransport {name ns priority openProc closeProc} {
+    variable trpt    
+    #puts "jlib::si::registertransport (i)"
+    
+    lappend trpt(list) [list $name $priority]
+    set trpt(list) [lsort -unique -index 1 $trpt(list)]
+    set trpt($name,ns)    $ns
+    set trpt($name,open)  $openProc
+    set trpt($name,close) $closeProc
+
+    # Keep these in sync.
+    set trpt(names)   [list]
+    set trpt(streams) [list]
+    foreach spec $trpt(list) {
+	set nm [lindex $spec 0]
+	lappend trpt(names)   $nm
+	lappend trpt(streams) $trpt($nm,ns)
+    }
+}
+
+# jlib::si::registerreader --
+# 
+#       This lives on the initiator side.
+#       Each profile must register a reader which is then used by the streams
+#       (transport) when writing data to the network. 
+#       The streams shall limit its control to the data handling alone,
+#       and the major control is still with the profile.
+#       In particular, any close operation is initiated by the profile.
+#       This is merely a layer to dispatch reading actions from the stream 
+#       to the profile.
+#       NB: We could do with only a 'read' proc but this is a cleaner interface.
+
+proc jlib::si::registerreader {profile openProc readProc closeProc} {
+    variable reader
+    #puts "jlib::si::registerreader"
+    
+    set reader($profile,open)  $openProc
+    set reader($profile,read)  $readProc
+    set reader($profile,close) $closeProc
+}
+
+# jlib::si::registerprofile --
+# 
+#       This is used by profiles to register handler when receiving a si set
+#       with the specified profile. It contains handlers for 'set', 'read',
+#       and 'close' streams. These belong to the target side.
+
+proc jlib::si::registerprofile {profile openProc readProc closeProc} {
+    variable prof
+    #puts "jlib::si::registerprofile (t)"
+    
+    set prof($profile,open)  $openProc
+    set prof($profile,read)  $readProc
+    set prof($profile,close) $closeProc
+}
+
+# jlib::si::init --
+# 
+#       Instance init procedure.
+  
+proc jlib::si::init {jlibname args} {
+    variable xmlns
+    #puts "jlib::si::init"
+
+    # Keep different state arrays for initiator (i) and receiver (r).
+    namespace eval ${jlibname}::si {
+	variable istate
+	variable tstate
+    } 
+    $jlibname iq_register set $xmlns(si) [namespace current]::handle_set
+    $jlibname iq_register get $xmlns(si) [namespace current]::handle_get
+}
+
+proc jlib::si::cmdproc {jlibname cmd args} {
+    
+    #puts "jlib::si::cmdproc jlibname=$jlibname, cmd='$cmd', args='$args'"
+
+    # Which command? Just dispatch the command to the right procedure.
+    return [eval {$cmd $jlibname} $args]
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#
+# These are all functions to use by a initiator (sender).
+
+# jlib::si::send_set --
+# 
+#       Makes a stream initiation (open).
+#       It will eventually, if negotiation went ok, invoke the stream
+#       'open' method. 
+#       The 'args' ar transparently delivered to the streams 'open' method.
+
+proc jlib::si::send_set {jlibname jid sid mime profile profileE cmd args} {
+    
+    #puts "jlib::si::send_set (i)"
+    
+    set siE [i_constructor $jlibname $sid $jid $mime $profile $profileE $cmd]
+    jlib::send_iq $jlibname set [list $siE] -to $jid  \
+      -command [list [namespace current]::send_set_cb $jlibname $sid]
+    return
+}
+
+# jlib::si::i_constructor --
+# 
+#       Makes a new si instance. Does everything except delivering it.
+#       Returns the si element.
+
+proc jlib::si::i_constructor {jlibname sid jid mime profile profileE cmd args} {
+    upvar ${jlibname}::si::istate istate
+    
+    set istate($sid,jid)      $jid
+    set istate($sid,mime)     $mime
+    set istate($sid,profile)  $profile
+    set istate($sid,openCmd)  $cmd
+    set istate($sid,args)     $args
+    foreach {key val} $args {
+	set istate($sid,$key) $val
+    }
+    
+    return [element $sid $mime $profile $profileE]
+}
+
+# jlib::si::element --
+# 
+#       Just create the si element. Nothing cached. Stateless.
+
+proc jlib::si::element {sid mime profile profileE} {
+    variable xmlns
+    variable trpt
+    
+    set optionEL [list]
+    foreach name $trpt(names) {
+	set valueE [wrapper::createtag "value" -chdata $trpt($name,ns)]
+	lappend optionEL [wrapper::createtag "option" -subtags [list $valueE]]
+    }
+    set fieldE [wrapper::createtag "field"      \
+      -attrlist {var stream-method type list-single} -subtags $optionEL]
+    set xE [wrapper::createtag "x"              \
+      -attrlist {xmlns jabber:x:data type form} -subtags [list $fieldE]]
+    set featureE [wrapper::createtag "feature"  \
+      -attrlist [list xmlns $xmlns(neg)] -subtags [list $xE]]
+    set siE [wrapper::createtag "si"  \
+      -attrlist [list xmlns $xmlns(si) id $sid mime-type $mime profile $profile] \
+      -subtags [list $profileE $featureE]]
+
+    return $siE
+}
+
+# jlib::si::send_set_cb --
+# 
+#       Our internal callback handler when offered stream initiation.
+
+proc jlib::si::send_set_cb {jlibname sid type iqChild args} {
+    variable xmlns
+    variable trpt
+    upvar ${jlibname}::si::istate istate
+    
+    #puts "jlib::si::send_set_cb (i)"
+    
+    if {[string equal $type "error"]} {
+	eval $istate($sid,openCmd) [list $jlibname $type $sid $iqChild]
+	ifree $jlibname $sid
+	return
+    }
+    eval {i_handler $jlibname $sid $iqChild} $args
+}
+
+# jlib::si::handle_get --
+# 
+#       This handles incoming iq-get/si elements. The 'sid' must already exist
+#       since this belongs to the initiator side! We obtain this call as a
+#       response to an si element sent. It should behave as 'send_set_cb'. 
+
+proc jlib::si::handle_get {jlibname from iqChild args} {
+    upvar ${jlibname}::si::istate istate    
+    #puts "jlib::si::handle_get (i)"
+    
+    array set argsA $args
+    array set attr [wrapper::getattrlist $iqChild]
+    if {![info exists attr(id)]} {
+	return 0
+    }
+    set sid $attr(id)    
+    if {![info exists argsA(-id)]} {
+	return 0
+    }
+    set id $argsA(-id)
+    
+    # Verify that we have actually initiated this stream.
+    if {![info exists istate($sid,jid)]} {
+	jlib::send_iq_error $jlibname $from $id 403 cancel forbidden
+	return 1
+    }
+    eval {i_handler $jlibname $sid $iqChild} $args
+    
+    # We must respond ourselves.
+    $jlibname send_iq result {} -to $from -id $id
+    
+    return 1
+}
+
+# jlib::si::i_handler --
+# 
+#       Handles both responses to an iq-set call and an incoming iq-get.
+
+proc jlib::si::i_handler {jlibname sid iqChild args} {    
+    variable xmlns
+    variable trpt
+    upvar ${jlibname}::si::istate istate
+    #puts "jlib::si::i_handler (i)"
+
+    # Verify that it is consistent.
+    if {![string equal [wrapper::gettag $iqChild] "si"]} {
+	
+	# @@@ errors ?
+	eval $istate($sid,openCmd) [list $jlibname error $sid {}]
+	ifree $jlibname $sid
+	return
+    }
+
+    set value ""
+    set valueE [wrapper::getchilddeep $iqChild [list  \
+      [list "feature" $xmlns(neg)] [list "x" $xmlns(xdata)] "field" "value"]]
+    if {[llength $valueE]} {
+	set value [wrapper::getcdata $valueE]
+    }
+    
+    # Find if matching transport.
+    if {[lsearch -exact $trpt(streams) $value] >= 0} {
+	
+	# Open transport. 
+	# We provide a callback for the transport when open is finished.
+	set istate($sid,stream) $value
+	set jid $istate($sid,jid)
+	set cmd [namespace current]::transport_open_cb
+	eval $trpt($value,open) [list $jlibname $jid $sid]  \
+	  $istate($sid,args)
+    } else {
+	eval $istate($sid,openCmd) [list $jlibname error $sid {}]
+	ifree $jlibname $sid
+    }
+}
+
+# jlib::si::transport_open_cb --
+# 
+#       This is a transports way of reporting result from it's 'open' method.
+
+proc jlib::si::transport_open_cb {jlibname sid type iqChild} {   
+    upvar ${jlibname}::si::istate istate    
+    #puts "jlib::si::transport_open_cb (i)"
+    	
+    # Just report this to the relevant profile.
+    eval $istate($sid,openCmd) [list $jlibname $type $sid $iqChild]
+}
+
+# jlib::si::getstate --
+# 
+#       Just an access function to the internal state variables.
+
+proc jlib::si::getstate {jlibname sid} {
+    upvar ${jlibname}::si::istate istate
+    
+    set arr [list]
+    foreach {key value} [array get istate $sid,*] {
+	set name [string map [list "$sid," ""] $key]
+	lappend arr $name $value
+    }
+    return $arr
+}
+
+# jlib::si::open_data, read_data, close_data --
+# 
+#       These are all used by the streams (transports) to handle the data
+#       stream it needs when transmitting.
+#       This is merely a layer to dispatch reading actions from the stream 
+#       to the profile.
+
+proc jlib::si::open_data {jlibname sid} {
+    variable reader
+    upvar ${jlibname}::si::istate istate
+    #puts "jlib::si::open_data (i)"
+    
+    set profile $istate($sid,profile)
+    $reader($profile,open) $jlibname $sid
+}
+
+proc jlib::si::read_data {jlibname sid} {
+    variable reader
+    upvar ${jlibname}::si::istate istate
+    #puts "jlib::si::read_data (i)"
+    
+    set profile $istate($sid,profile)
+    return [$reader($profile,read) $jlibname $sid]
+}
+
+# This is also used to report any errors from transport to profile.
+
+proc jlib::si::close_data {jlibname sid {err ""}} {
+    variable reader
+    upvar ${jlibname}::si::istate istate
+    #puts "jlib::si::close_data (i)"
+    
+    set profile $istate($sid,profile)
+    $reader($profile,close) $jlibname $sid $err
+}
+
+# jlib::si::send_close --
+# 
+#       Used by profile to close down the stream.
+
+proc jlib::si::send_close {jlibname sid cmd} {
+    variable trpt
+    upvar ${jlibname}::si::istate istate
+    #puts "jlib::si::send_close (i)"
+    
+    set istate($sid,closeCmd) $cmd
+    set stream $istate($sid,stream)
+    eval $trpt($stream,close) [list $jlibname $sid]    
+}
+
+# jlib::si::transport_close_cb --
+# 
+#       Called by tansport when closed operation is completed.
+#       It is called as a response (callback) to 'send_close'.
+#       This is our destructor.
+
+proc jlib::si::transport_close_cb {jlibname sid type iqChild} {
+    upvar ${jlibname}::si::istate istate
+    #puts "jlib::si::transport_close_cb (i)"
+    
+    # Just report this to the relevant profile.
+    eval $istate($sid,closeCmd) [list $jlibname $type $sid $iqChild]
+    
+    ifree $jlibname $sid
+}
+
+proc jlib::si::ifree {jlibname sid} {    
+    upvar ${jlibname}::si::istate istate
+    #puts "jlib::si::ifree (i) sid=$sid"
+
+    array unset istate $sid,*
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#
+# These are all functions to use by a target (receiver) of a stream.
+
+# jlib::si::handle_set --
+# 
+#       Parse incoming si set element. Invokes registered callback for the
+#       profile in question. It is the responsibility of this callback to
+#       deliver the result via the command in its argument.
+
+proc jlib::si::handle_set {jlibname from siE args} {
+    variable xmlns
+    variable trpt
+    variable prof
+    upvar ${jlibname}::si::tstate tstate
+    
+    #puts "jlib::si::handle_set (t)"
+    
+    array set iqattr $args
+    if {![info exists iqattr(-id)]} {
+	return 0
+    }
+    set id $iqattr(-id)
+    
+    # Note: there are two different 'id'!
+    # These are the attributes of the si element.
+    array set attr {
+	id          ""
+	mime-type   ""
+	profile     ""
+    }
+    array set attr [wrapper::getattrlist $siE]
+    set sid     $attr(id)
+    set profile $attr(profile)
+    
+    # This is a profile we don't understand.
+    if {![info exists prof($profile,open)]} {
+	set errE [wrapper::createtag "bad-profile"  \
+	  -attrlist [list xmlns $xmlns(si)]]
+	send_error $jlibname $from $id $sid 400 cancel "bad-request" $errE
+	return 1
+    }
+
+    # Extract all streams and pick one with highest priority.
+    set stream [pick_stream $siE]
+    
+    # No valid stream :-(
+    if {![string length $stream]} {
+	set errE [wrapper::createtag "no-valid-streams"  \
+	  -attrlist [list xmlns $xmlns(si)]]
+	send_error $jlibname $from $id $sid 400 cancel "bad-request" $errE
+	return 1
+    }
+        
+    # Get profile element. Can have any tag but xmlns must be $profile.
+    set profileE [wrapper::getfirstchildwithxmlns $siE $profile]
+    if {![llength $profileE]} {
+	send_error $jlibname $from $id $sid 400 cancel "bad-request"
+	return 1
+    }
+
+    set tstate($sid,profile)   $profile
+    set tstate($sid,stream)    $stream
+    set tstate($sid,mime-type) $attr(mime-type)
+    foreach {key val} $args {
+	set tstate($sid,$key)  $val
+    }
+    set jid $tstate($sid,-from)
+    
+    # Invoke registered handler for this profile.
+    set respCmd [list [namespace current]::profile_response $jlibname $sid]
+    set rc [catch {
+	eval $prof($profile,open) [list $jlibname $sid $jid $siE $respCmd]
+    }]
+    if {$rc == 1} {
+	# error
+	return 0
+    } elseif {$rc == 3 || $rc == 4} {
+	# break or continue
+	return 0
+    }     
+    return 1
+}
+
+# jlib::si::pick_stream --
+# 
+#       Extracts the highest priority stream from an si element. Empty if error.
+
+proc jlib::si::pick_stream {siE} {    
+    variable xmlns
+    variable trpt
+    
+    # Extract all streams and pick one with highest priority.
+    set values [list]
+    set fieldE [wrapper::getchilddeep $siE [list  \
+      [list "feature" $xmlns(neg)] [list "x" $xmlns(xdata)] "field"]]
+    if {[llength $fieldE]} {
+	set optionEL [wrapper::getchildswithtag $fieldE "option"]
+	foreach c $optionEL {
+	    set firstE [lindex [wrapper::getchildren $c] 0]
+	    lappend values [wrapper::getcdata $firstE]
+	}
+    }
+    
+    # Pick first matching since priority ordered.
+    set stream ""
+    foreach name $values {
+	if {[lsearch -exact $trpt(streams) $name] >= 0} {
+	    set stream $name
+	    break
+	}
+    }
+    return $stream
+}
+
+# jlib::si::profile_response --
+# 
+#       Invoked by the registered profile callback.
+#       
+# Arguments:
+#       type        'result' or 'error' if user accepts the stream or not.
+#       profileE    any extra profile element; can be empty.
+
+proc jlib::si::profile_response {jlibname sid type profileE args} {
+    variable xmlns
+    upvar ${jlibname}::si::tstate tstate
+    
+    #puts "jlib::si::profile_response (t) type=$type"
+        
+    set jid $tstate($sid,-from)
+    set id  $tstate($sid,-id)
+
+    # Rejected stream initiation.
+    if {[string equal $type "error"]} {
+	# @@@ We could have a text element here...
+	send_error $jlibname $jid $id $sid 403 cancel forbidden
+    } else {
+
+	# Accepted stream initiation.
+	# Construct si element from selected profile.
+	set siE [t_element $jlibname $sid $profileE]
+	jlib::send_iq $jlibname result [list $siE] -to $jid -id $id
+    }
+    return
+}
+
+# jlib::si::t_element --
+# 
+#       Construct si element from selected profile.
+
+proc jlib::si::t_element {jlibname sid profileE} {    
+    variable xmlns
+    upvar ${jlibname}::si::tstate tstate
+
+    set valueE [wrapper::createtag "value" -chdata $tstate($sid,stream)]
+    set fieldE [wrapper::createtag "field" \
+      -attrlist {var stream-method} -subtags [list $valueE]]
+    set xE [wrapper::createtag "x"          \
+      -attrlist [list xmlns $xmlns(xdata) type submit] -subtags [list $fieldE]]
+    set featureE [wrapper::createtag "feature"  \
+      -attrlist [list xmlns $xmlns(neg)] -subtags [list $xE]]
+
+    # Include 'profileE' if nonempty.
+    set subsiEL [list $featureE]
+    if {[llength $profileE]} {
+	lappend subsiEL $profileE
+    }
+    set siE [wrapper::createtag "si"  \
+      -attrlist [list xmlns $xmlns(si) id $sid] -subtags $subsiEL]
+    return $siE
+}
+
+# jlib::si::reset --
+# 
+#       Used by profile when doing reset.
+
+proc jlib::si::reset {jlibname sid} {
+    upvar ${jlibname}::si::tstate tstate
+    #puts "jlib::si::reset (t)"
+    
+    # @@@ Tell transport we are resetting???
+    # Brute force.
+    
+    tfree $jlibname $sid
+}
+
+# jlib::si::havesi --
+# 
+#       The streams may need to know if we have got a si request (set).
+#       @@@ Perhaps we should have timeout for incoming si requests that
+#           cancels it all.
+
+proc jlib::si::havesi {jlibname sid} {
+    upvar ${jlibname}::si::tstate tstate
+    upvar ${jlibname}::si::istate istate
+
+    if {[info exists tstate($sid,profile)] || [info exists istate($sid,profile)]} {
+	return 1
+    } else {
+	return 0
+    }
+}
+
+# jlib::si::stream_recv --
+# 
+#       Used by transports (streams) to deliver the actual data.
+
+proc jlib::si::stream_recv {jlibname sid data} {    
+    variable prof
+    upvar ${jlibname}::si::tstate tstate
+    #puts "jlib::si::stream_recv (t)"
+    
+    # Each stream should check that we exist before calling us!
+    set profile $tstate($sid,profile)
+    eval $prof($profile,read) [list $jlibname $sid $data]    
+}
+
+# jlib::si::stream_closed --
+# 
+#       This should be the final stage for a succesful transfer.
+#       Called by transports (streams).
+
+proc jlib::si::stream_closed {jlibname sid} {    
+    variable prof
+    upvar ${jlibname}::si::tstate tstate
+    #puts "jlib::si::stream_closed (t)"
+    
+    # Each stream should check that we exist before calling us!
+    set profile $tstate($sid,profile)
+    eval $prof($profile,close) [list $jlibname $sid]
+    tfree $jlibname $sid
+}
+
+# jlib::si::stream_error --
+# 
+#       Called by transports to report an error.
+
+proc jlib::si::stream_error {jlibname sid errmsg} {    
+    variable prof
+    upvar ${jlibname}::si::tstate tstate
+    #puts "jlib::si::stream_error (t)"
+    
+    set profile $tstate($sid,profile)
+    eval $prof($profile,close) [list $jlibname $sid $errmsg]
+    tfree $jlibname $sid
+}
+
+# jlib::si::send_error --
+# 
+#       Reply with iq error element.
+
+proc jlib::si::send_error {jlibname jid id sid errcode errtype stanza {extraElem {}}} {
+    
+    #puts "jlib::si::send_error"
+
+    jlib::send_iq_error $jlibname $jid $id $errcode $errtype $stanza $extraElem
+    tfree $jlibname $sid
+}
+
+proc jlib::si::tfree {jlibname sid} {    
+    upvar ${jlibname}::si::tstate tstate
+    #puts "jlib::si::tfree (t)"
+
+    array unset tstate $sid,*
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::si {
+    
+    jlib::ensamble_register si   \
+      [namespace current]::init  \
+      [namespace current]::cmdproc
+}
+
+#-------------------------------------------------------------------------------
diff --git a/lib/jabberlib/sipub.tcl b/lib/jabberlib/sipub.tcl
new file mode 100644
index 0000000..384442c
--- /dev/null
+++ b/lib/jabberlib/sipub.tcl
@@ -0,0 +1,307 @@
+#  sipub.tcl --
+#  
+#      This file is part of the jabberlib. 
+#      It provides support for the sipub prootocol:
+#      XEP-0137: Publishing Stream Initiation Requests 
+#      
+#  Copyright (c) 2007  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: sipub.tcl,v 1.7 2007/11/25 15:48:54 matben Exp $
+# 
+# NB: There are three different id's floating around:
+#     1) iq-get/result related
+#     2) sipub id (spid)
+#     3) si id (stream id, sid) 
+#     
+# @@@ TODO: Move some code to the profile instead since we have hardcoded
+#           the 'filetransfer' profile.
+
+package require jlib		
+package require jlib::si
+package require jlib::disco
+			  
+package provide jlib::sipub 0.2
+
+namespace eval jlib::sipub {
+
+    variable xmlns
+    set xmlns(sipub) "http://jabber.org/protocol/si-pub"
+	        
+    jlib::disco::registerfeature $xmlns(sipub)
+
+    # We use a static cache array that maps sipub id (spid) to file name and mime.
+    # This seems more practical since the jlib instances may vary between the
+    # sessions.
+    variable cache
+    
+    # Note: jlib::ensamble_register is last in this file!
+}
+
+proc jlib::sipub::init {jlibname args} {
+    variable xmlns
+
+    $jlibname iq_register get $xmlns(sipub) [namespace current]::handle_get
+}
+
+proc jlib::sipub::cmdproc {jlibname cmd args} {
+    return [eval {$cmd $jlibname} $args]
+}
+
+#--- Initiator side ------------------------------------------------------------
+#
+# Initiator and target are dubious names here. With initiator we mean the part
+# that has a file to offer, and target the one who gets it.
+
+# jlib::sipub::set_cache, get_cache --
+# 
+#       Set or get the complete cache. Useful if we store the cache in a file
+#       between sessions.
+
+proc jlib::sipub::set_cache {cacheL} {
+    variable cache
+    array set cache $cacheL
+}
+
+proc jlib::sipub::get_cache {} {
+    variable cache
+    return [array get cache]
+}
+
+# jlib::sipub::newcache --
+# 
+#       This just adds a reference to our cache. Used to construct xmpp uri
+#       for 'recvfile'.
+
+proc jlib::sipub::newcache {fileName mime} {
+    variable cache
+
+    set spid [jlib::generateuuid]
+    set cache($spid,file) $fileName
+    set cache($spid,mime) $mime
+    
+    return $spid
+}
+
+# jlib::sipub::element --
+# 
+#       Makes a sipub element for a local file and adds the reference to cache.
+#       This is the constructor for a sipub object. Each object may generate
+#       any number of file transfers instances, each with its unique 'sid'.
+#       Once a sipub instance is created it can be made to live as long as
+#       the cache is kept.
+#       This shall be called from the profile or application layer.
+#       
+# Results:
+#       sipub element.
+
+# @@@ Shall it have jlibname?
+
+proc jlib::sipub::element {from profile profileE fileName mime} {
+    variable xmlns
+    variable cache
+
+    set spid [jlib::generateuuid]
+    set cache($spid,file) $fileName
+    set cache($spid,mime) $mime
+    
+    set attr [list xmlns $xmlns(sipub) from $from id $spid mime-type $mime \
+      profile $profile]
+    set sipubE [wrapper::createtag "sipub" -attrlist $attr \
+      -subtags [list $profileE]]
+
+    return $sipubE
+}
+
+# jlib::sipub::handle_get --
+# 
+#       Handles incoming iq-get/start sipub stanzas. 
+#       There must be a sipub object with matching id (spid).
+#       This has the corresponding role of the HTTP server side GET request.
+#       
+#       NB: We have hardcoded the 'filetransfer' profile.
+
+proc jlib::sipub::handle_get {jlibname from startE args} {
+    variable xmlns
+    variable cache
+
+    array set argsA $args
+    if {![info exists argsA(-id)]} {
+	return 0
+    }
+    set id $argsA(-id)
+    if {[wrapper::gettag $startE] ne "start"} {
+	return 0
+    }
+    array set attr [wrapper::getattrlist $startE]
+    if {![info exists attr(id)]} {
+	return 0
+    }
+    set spid $attr(id)    
+    if {[info exists cache($spid,file)]} {
+	
+	# We must pick the 'sid' here since it is also used in 'starting'.
+	set sid [jlib::generateuuid]
+	set startingE [wrapper::createtag "starting" \
+	  -attrlist [list xmlns $xmlns(sipub) sid $sid]]
+	$jlibname send_iq result [list $startingE] -id $id -to $from
+
+	# This is the constructor of a file stream.
+	$jlibname filetransfer send $from [namespace code send_cb] -sid $sid \
+	  -file $cache($spid,file) \
+	  -mime $cache($spid,mime)
+    } else {
+	jlib::send_iq_error $jlibname $from $id 405 modify not-acceptable
+    }
+    return 1
+}
+
+proc jlib::sipub::send_cb {jlibname status sid {subiq ""}} {
+    
+    # empty.
+}
+
+#--- Target side ---------------------------------------------------------------
+
+# jlib::sipub::have_sipub --
+# 
+#       Searches an element recursively to see if there is a sipub element.
+
+proc jlib::sipub::have_sipub {xmldata} {
+    variable xmlns
+    
+    return [llength [wrapper::getchilddeep $xmldata \
+      [list [list sipub $xmlns(sipub)]]]]
+}
+
+proc jlib::sipub::get_element {xmldata} {
+    variable xmlns
+    
+    return [wrapper::getchilddeep $xmldata [list [list sipub $xmlns(sipub)]]]
+}
+
+# NB: We have a separate 'start' command in order to catch the response and
+#     obtain the 'sid' which is typically needed to control the file transfer.
+
+# Typical usage:
+# 
+#       jlib sipub start ... cb
+#       proc cb {type startingE} {
+#            set sid [wrapper::getattribute $startingE sid]
+#            jlib sipub set_accept_handler $sid \
+#                -channel ... -command ... -progress ...
+#       }
+
+# jlib::sipub::start --
+# 
+#       Sends a start element. A iq-result/error is expected.
+#       This 'id' must be a matching spid.
+
+proc jlib::sipub::start {jlibname jid id cmd} {
+    variable xmlns
+
+    set startE [wrapper::createtag "start" \
+      -attrlist [list xmlns $xmlns(sipub) id $id]]
+    $jlibname send_iq get [list $startE] -to $jid -command $cmd
+}
+
+# jlib::sipub::set_accept_handler --
+# 
+#       This is normally called as a response to the 'start' command's
+#       callback when we get a sipub 'starting' element.
+#       We shall typically provide -command, -progress, and -channel.
+#       
+# Arguments:
+#       xmldata     complete message element or whatever.
+#       args:       -channel
+#                   -command
+#                   -progress
+#                   
+# Result:
+#       none
+
+proc jlib::sipub::set_accept_handler {jlibname sid args} {
+    variable state
+
+    # This is just kept until we get the si-callback.
+    set state($sid,args) $args
+
+    # We shall be prepared to get the si-set request.
+    $jlibname filetransfer register_sid_handler $sid \
+      [namespace code [list si_handler $sid]]
+    return
+}
+
+proc jlib::sipub::si_handler {sid jlibname jid name size cmd args} {
+    variable state
+    
+    #puts "jlib::sipub::si_handler sid=$sid"
+
+    # We requested this file using 'sipub::get' in the first place so
+    # therefore accept the stream.
+    # We also provide all the arguments -channel etc.
+    uplevel #0 $cmd 1 $state($sid,args)
+    unset state($sid,args)
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::sipub {
+	
+    jlib::ensamble_register sipub  \
+      [namespace current]::init    \
+      [namespace current]::cmdproc
+}
+
+# Test:
+if {0} {
+    package require jlib::sipub
+    set jlib ::jlib::jlib1
+    
+    # Initiator side:
+    set jid matben@localhost
+    set fileName /Users/matben/Desktop/splash.svg
+    set name [file tail $fileName]
+    set size [file size $fileName]
+    set fileE [jlib::ftrans::element $name $size]
+    set sipubE [jlib::sipub::element [$jlib myjid] $jlib::ftrans::xmlns(ftrans) \
+      $fileE $fileName image/svg]
+    
+    $jlib send_message $jid -xlist [list $sipubE]
+    
+    # Target side:
+    package require jlib::sipub
+    set jlib ::jlib::jlib1
+    proc progress {args} {puts "progress: $args"}
+    proc command  {args} {puts "command: $args"}
+    proc msg {jlib xmlns xmldata args} {
+	puts "message: $xmldata"
+	set ::messageE $xmldata
+	return 0
+    }
+    $jlib message_register normal * msg
+    
+    set fileName /Users/matben/Desktop/splash.svg
+    set fd [open $fileName.tmp w]
+    
+    proc start_cb {type startingE} {
+	puts "start_cb type=$type"
+	if {$type eq "result"} {
+	    set sid [wrapper::getattribute $startingE sid]
+	    $::jlib sipub set_accept_handler $sid \
+	      -channel $::fd -command command -progress progress
+	}
+    }
+    set sipubE [wrapper::getchilddeep $messageE \
+      [list [list sipub $jlib::sipub::xmlns(sipub)]]]
+    set from [wrapper::getattribute $sipubE from]
+    if {$from eq ""} {
+	set from [wrapper::getattribute $messageE from]
+    }
+    set spid [wrapper::getattribute $sipubE id]
+    $jlib sipub start $from $spid start_cb
+    
+}
+
+#-------------------------------------------------------------------------------
diff --git a/lib/jabberlib/stanzaerror.tcl b/lib/jabberlib/stanzaerror.tcl
new file mode 100644
index 0000000..36197e7
--- /dev/null
+++ b/lib/jabberlib/stanzaerror.tcl
@@ -0,0 +1,64 @@
+#  stanzaerror.tcl --
+#  
+#      This file is part of the jabberlib. It provides english clear text
+#      messages that gives some detail of 'urn:ietf:params:xml:ns:xmpp-stanzas'.
+#      
+#  Copyright (c) 2004  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: stanzaerror.tcl,v 1.9 2007/09/12 07:20:46 matben Exp $
+# 
+
+package provide stanzaerror 1.0
+
+namespace eval stanzaerror {
+    
+    # This maps Defined Conditions to clear text messages.
+    # Extensible Messaging and Presence Protocol (XMPP): Core (RFC 3920)
+    # 9.3.3 Defined Conditions
+    # Applications use the error tag directly for the key into a message catalog.
+    
+    variable msg
+    array set msg {
+	bad-request	      {The sender has sent XML that is malformed or that cannot be processed.}
+	conflict	      {Access cannot be granted because an existing resource or session exists with the same name or address.}
+	feature-not-implemented	 {The feature requested is not implemented by the recipient or server and therefore cannot be processed.}
+	forbidden             {The requesting entity does not possess the required permissions to perform the action.}
+	gone                  {The recipient or server can no longer be contacted at this address.}
+	internal-server-error {The server could not process the stanza because of a misconfiguration or an otherwise-undefined internal server error.}
+	item-not-found        {The addressed JID or item requested cannot be found.}
+	jid-malformed         {The sending entity has provided or communicated an XMPP address or aspect thereof that does not adhere to the syntax defined in Addressing Scheme.}
+	not-acceptable        {The recipient or server understands the request but is refusing to process it because it does not meet criteria defined by the recipient or server.}
+	not-allowed           {The recipient or server does not allow any entity to perform the action.}
+        not-authorized        {The sender must provide proper credentials before being allowed to perform the action, or has provided improper credentials.}
+	payment-required      {The requesting entity is not authorized to access the requested service because payment is required.}
+	recipient-unavailable {The intended recipient is temporarily unavailable.}
+	redirect              {The recipient or server is redirecting requests for this information to another entity, usually temporarily.}
+	registration-required {The requesting entity is not authorized to access the requested service because registration is required.}
+	remote-server-not-found {A remote server or service specified as part or all of the JID of the intended recipient does not exist.}
+	remote-server-timeout {A remote server or service specified as part or all of the JID of the intended recipient (or required to fulfill a request) could not be contacted within a reasonable amount of time.}
+	resource-constraint   {The server or recipient lacks the system resources necessary to service the request.}
+	service-unavailable   {The server or recipient does not currently provide the requested service.}
+	subscription-required {The requesting entity is not authorized to access the requested service because a subscription is required.}
+	undefined-condition   {The error condition is not one of those defined by the other conditions in this list.}
+	unexpected-request    {The recipient or server understood the request but was not expecting it at this time (e.g., the request was out of order).}
+    }
+}
+
+# stanzaerror::getmsg --
+# 
+#       Return the english clear text message from a defined-condition.
+
+proc stanzaerror::getmsg {condition} {
+    variable msg
+
+    if {[info exists msg($condition)]} {
+	return $msg($condition)
+    } else {
+	return
+    }
+}
+
+#-------------------------------------------------------------------------------
+
diff --git a/lib/jabberlib/streamerror.tcl b/lib/jabberlib/streamerror.tcl
new file mode 100644
index 0000000..9157c7b
--- /dev/null
+++ b/lib/jabberlib/streamerror.tcl
@@ -0,0 +1,75 @@
+#  streamerror.tcl --
+#  
+#      This file is part of the jabberlib. It provides english clear text
+#      messages that gives some detail of 'urn:ietf:params:xml:ns:xmpp-streams'.
+#      
+#  Copyright (c) 2004  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: streamerror.tcl,v 1.7 2007/09/12 13:37:55 matben Exp $
+# 
+
+# The syntax for stream errors is as follows:
+#
+#   <stream:error>
+#      <defined-condition xmlns='urn:ietf:params:xml:ns:xmpp-streams'/>
+#      <text xmlns='urn:ietf:params:xml:ns:xmpp-streams'>
+#        OPTIONAL descriptive text
+#      </text>
+#      [OPTIONAL application-specific condition element]
+#   </stream:error>
+
+package provide streamerror 1.0
+
+namespace eval streamerror {
+    
+    # This maps Defined Conditions to clear text messages.
+    # draft-ietf-xmpp-core23; 4.7.3 Defined Conditions
+    # Applications use the error tag directly for the key into a message catalog.
+    
+    variable msg
+    array set msg {
+	bad-format            {The entity has sent XML that cannot be processed.}
+	bad-namespace-prefix  {The entity has sent a namespace prefix that is unsupported, or has sent no namespace prefix on an element that requires such a prefix.}
+	conflict              {The server is closing the active stream for this entity because a new stream has been initiated that conflicts with the existing stream.}
+	connection-timeout    {The entity has not generated any traffic over the stream for some period of time.}
+	host-gone             {The value of the 'to' attribute provided by the initiating entity in the stream header corresponds to a hostname that is no longer hosted by the server.}
+	host-unknown          {The value of the 'to' attribute provided by the initiating entity in the stream header does not correspond to a hostname that is hosted by the server.}
+	improper-addressing   {A stanza sent between two servers lacks a 'to' or 'from' attribute.}
+	internal-server-error {The server has experienced a misconfiguration or an otherwise-undefined internal error that prevents it from servicing the stream.}
+	invalid-from          {The JID or hostname provided in a 'from' address does not match an authorized JID or validated domain negotiated between servers via SASL or dialback, or between a client and a server via authentication and resource binding.}
+	invalid-id            {The stream ID or dialback ID is invalid or does not match an ID previously provided.}
+	invalid-namespace     {The streams namespace name is something other than "http://etherx.jabber.org/streams" or the dialback namespace name is something other than "jabber:server:dialback".}
+	invalid-xml           {The entity has sent invalid XML over the stream to a server that performs validation.}
+	not-authorized        {The entity has attempted to send data before the stream has been authenticated, or otherwise is not authorized to perform an action related to stream negotiation; the receiving entity MUST NOT process the offending stanza before sending the stream error.}
+	policy-violation      {The entity has violated some local service policy; the server MAY choose to specify the policy in the <text/> element or an application-specific condition element.}
+	remote-connection-failed {The server is unable to properly connect to a remote entity that is required for authentication or authorization.}
+	resource-constraint   {The server lacks the system resources necessary to service the stream.}
+	restricted-xml        {The entity has attempted to send restricted XML features such as a comment, processing instruction, DTD, entity reference, or unescaped character.}
+	see-other-host        {The server will not provide service to the initiating entity but is redirecting traffic to another host; the server SHOULD specify the alternate hostname or IP address (which MUST be a valid domain identifier) as the XML character data of the <see-other-host/> element.}
+	system-shutdown       {The server is being shut down and all active streams are being closed.}
+	undefined-condition {The error condition is not one of those defined by the other conditions in this list; this error condition SHOULD be used only in conjunction with an application-specific condition.}
+	unsupported-encoding  {The initiating entity has encoded the stream in an encoding that is not supported by the server.}
+	unsupported-stanza-type {The initiating entity has sent a first-level child of the stream that is not supported by the server.}
+	unsupported-version   {The value of the 'version' attribute provided by the initiating entity in the stream header specifies a version of XMPP that is not supported by the server.}
+	xml-not-well-formed   {The initiating entity has sent XML that is not well-formed as defined by [XML].}
+    }
+}
+
+# streamerror::getmsg --
+# 
+#       Return the english clear text message from a defined-condition.
+
+proc streamerror::getmsg {condition} {
+    variable msg
+
+    if {[info exists msg($condition)]} {
+	return $msg($condition)
+    } else {
+	return
+    }
+}
+
+#-------------------------------------------------------------------------------
+
diff --git a/lib/jabberlib/tinydom.tcl b/lib/jabberlib/tinydom.tcl
new file mode 100644
index 0000000..e7a4aa9
--- /dev/null
+++ b/lib/jabberlib/tinydom.tcl
@@ -0,0 +1,159 @@
+#  tinydom.tcl ---
+#  
+#      This file is part of The Coccinella application. It implements 
+#      a tiny DOM model which wraps xml into tcl lists.
+#
+#  Copyright (c) 2003  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#  
+# $Id: tinydom.tcl,v 1.14 2008/03/26 13:11:34 matben Exp $
+
+package require xml
+
+package provide tinydom 0.2
+
+# This is an attempt to make a minimal DOM thing to store xml data as
+# a hierarchical list which is better suited to Tcl.
+# @@@ Try make a common syntax with wrapper.
+
+namespace eval tinydom {
+    variable uid 0
+    variable cache
+}
+
+proc tinydom::parse {xml args} {
+    variable uid
+    variable cache
+
+    array set argsA {
+	-package xml
+    }
+    array set argsA $args
+    switch -- $argsA(-package) {
+	xml {
+	    set xmlparser [xml::parser]
+	}
+	qdxml {
+	    package require qdxml
+	    set xmlparser [qdxml::create]
+	}
+	default {
+	    return -code error "unknown -package \"$argsA(-package)\""
+	}
+    }
+
+    # Store in internal array and return token which is the array index.
+    set token [namespace current]::[incr uid]
+    upvar #0 $token state
+    
+    set state(1) [list]
+    set state(level) 0
+    
+    $xmlparser configure -reportempty 1   \
+      -elementstartcommand  [namespace code [list ElementStart $token]] \
+      -elementendcommand    [namespace code [list ElementEnd $token]]   \
+      -characterdatacommand [namespace code [list CHdata $token]]       \
+      -ignorewhitespace     1
+    $xmlparser parse $xml
+
+    set cache($token) $state(1)
+    unset state
+    return $token
+}
+
+proc tinydom::ElementStart {token tag attrlist args} {
+    upvar #0 $token state
+
+    array set argsA $args
+    if {[info exists argsA(-namespacedecls)]} {
+	lappend attrlist xmlns [lindex $argsA(-namespacedecls) 0]
+    }
+    set state([incr state(level)]) [list $tag $attrlist 0 {} {}]
+}
+
+proc tinydom::ElementEnd {token tagname args} {
+    upvar #0 $token state
+
+    set level $state(level)
+    if {$level > 1} {
+    
+	# Insert the child tree in the parent tree.
+	Append $token [expr $level-1] $state($level)
+    }
+    incr state(level) -1
+}
+
+proc tinydom::CHdata {token chdata} {
+    upvar #0 $token state
+
+    set level $state(level)
+    set cdata [lindex $state($level) 3]
+    append cdata [xmldecrypt $chdata]
+    lset state($level) 3 $cdata
+}
+
+proc tinydom::Append {token plevel childtree} {
+    upvar #0 $token state
+    
+    # Get child list at parent level (level).
+    set childlist [lindex $state($plevel) 4]
+    lappend childlist $childtree
+    
+    # Build the new parent tree.
+    lset state($plevel) 4 $childlist
+}
+
+proc tinydom::xmldecrypt {chdata} {
+
+    return [string map {
+	{&amp;} {&} {&lt;} {<} {&gt;} {>} {&quot;} {"} {&apos;} {'}} $chdata]   
+}
+
+proc tinydom::documentElement {token} {
+    variable cache
+    return $cache($token)
+}
+
+proc tinydom::tagname {xmllist} {
+    return [lindex $xmllist 0]
+}
+
+proc tinydom::attrlist {xmllist} {
+    return [lindex $xmllist 1]
+}
+
+proc tinydom::chdata {xmllist} {
+    return [lindex $xmllist 3]
+}
+
+proc tinydom::children {xmllist} {
+    return [lindex $xmllist 4]
+}
+
+proc tinydom::getattribute {xmllist attrname} {
+    foreach {attr val} [lindex $xmllist 1] {
+	if {[string equal $attr $attrname]} {
+	    return $val
+	}
+    }
+    return
+}
+
+proc tinydom::getfirstchildwithtag {xmllist tag} {    
+    set c [list]
+    foreach celem [lindex $xmllist 4] {
+	if {[string equal [lindex $celem 0] $tag]} {
+	    set c $celem
+	    break
+	}
+    }
+    return $c
+}
+
+proc tinydom::cleanup {token} {
+    variable cache
+    unset -nocomplain cache($token)
+}
+
+#-------------------------------------------------------------------------------
diff --git a/lib/jabberlib/util.tcl b/lib/jabberlib/util.tcl
new file mode 100644
index 0000000..7fbe342
--- /dev/null
+++ b/lib/jabberlib/util.tcl
@@ -0,0 +1,66 @@
+#  util.tcl --
+#  
+#      This file is part of the jabberlib. 
+#      It provides small utility functions.
+#      
+#  Copyright (c) 2006  Mats Bengtsson
+# 
+# This file is distributed under BSD style license.
+#  
+# $Id: util.tcl,v 1.6 2007/09/06 13:20:47 matben Exp $
+
+package provide jlib::util 0.1
+
+namespace eval jlib::util {}
+
+# Standin for a 8.5 feature.
+if {![llength [info commands lassign]]} {
+    proc lassign {vals args} {uplevel 1 [list foreach $args $vals break] }
+}
+
+# jlib::util::lintersect --
+# 
+#       Picks out the common list elements from two lists, their intersection.
+
+proc jlib::util::lintersect {list1 list2} {
+    set lans [list]
+    foreach l $list1 {
+	if {[lsearch -exact $list2 $l] >= 0} {
+	    lappend lans $l
+	}
+    }
+    return $lans
+}
+
+# jlib::util::lprune --
+# 
+#       Removes element from list, silently.
+
+proc jlib::util::lprune {listName elem} {
+    upvar $listName listValue    
+    set idx [lsearch -exact $listValue $elem]
+    if {$idx >= 0} {
+	uplevel [list set $listName [lreplace $listValue $idx $idx]]
+    }
+    return
+}
+
+# jlib::util::from --
+# 
+#       The from command plucks an option value from a list of options and their 
+#       values. If it is found, it and its value are removed from the list, 
+#       and the value is returned. 
+
+proc jlib::util::from {argvName option {defvalue ""}} {
+    upvar $argvName argv
+
+    set ioption [lsearch -exact $argv $option]
+    if {$ioption == -1} {
+	return $defvalue
+    } else {
+	set ivalue [expr {$ioption + 1}]
+	set value [lindex $argv $ivalue]
+	set argv [lreplace $argv $ioption $ivalue] 
+	return $value
+    }
+}
diff --git a/lib/jabberlib/vcard.tcl b/lib/jabberlib/vcard.tcl
new file mode 100644
index 0000000..5c57555
--- /dev/null
+++ b/lib/jabberlib/vcard.tcl
@@ -0,0 +1,449 @@
+#  vcard.tcl --
+#  
+#      This file is part of the jabberlib.
+#      It handles vcard stuff and provides cache for it as well.
+#      
+#  Copyright (c) 2005-2006  Mats Bengtsson
+# 
+# This file is distributed under BSD style license.
+#  
+# $Id: vcard.tcl,v 1.14 2007/11/10 15:44:59 matben Exp $
+# 
+############################# USAGE ############################################
+#
+#   NAME
+#      vcard - convenience command library for the vcard extension.
+#      
+#   SYNOPSIS
+#      jlib::vcard::init jlibName ?-opt value ...?
+#	
+#   INSTANCE COMMANDS
+#      jlibname vcard send_get jid callbackProc
+#      jlibname vcard send_set jid callbackProc
+#      jlibname vcard get_async jid callbackProc
+#      jlibname vcard has_cache jid
+#      jlibname vcard get_cache jid
+#      
+################################################################################
+
+package require jlib
+
+package provide jlib::vcard 0.1
+
+namespace eval jlib::vcard {
+
+    # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::vcard::init --
+# 
+#       Creates a new instance of a vcard object.
+#       
+# Arguments:
+#       jlibname:     name of existing jabberlib instance
+#       args:
+# 
+# Results:
+#       namespaced instance command
+
+proc jlib::vcard::init {jlibname args} {
+    
+    variable xmlns
+    set xmlns(vcard) "vcard-temp"
+	
+    # Instance specific arrays.
+    namespace eval ${jlibname}::vcard {
+	variable state
+    }
+    upvar ${jlibname}::vcard::state state
+    
+    set state(cache) 1
+    
+    return
+}
+
+# jlib::vcard::cmdproc --
+#
+#       Just dispatches the command to the right procedure.
+#
+# Arguments:
+#       jlibname:   name of existing jabberlib instance
+#       cmd:        
+#       args:       all args to the cmd procedure.
+#       
+# Results:
+#       none.
+
+proc jlib::vcard::cmdproc {jlibname cmd args} {
+    
+    # Which command? Just dispatch the command to the right procedure.
+    return [eval {$cmd $jlibname} $args]
+}
+
+# jlib::vcard::send_get --
+#
+#       It implements the 'jabber:iq:vcard-temp' get method.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       jid:        bare JID for other users, full jid for ourself.
+#       cmd:        client command to be executed at the iq "result" element.
+#       
+# Results:
+#       none.
+
+proc jlib::vcard::send_get {jlibname jid cmd} {
+    variable xmlns
+    upvar ${jlibname}::vcard::state state
+
+    set mjid [jlib::jidmap $jid]
+    set state(pending,$mjid) 1
+    set attrlist [list xmlns $xmlns(vcard)]    
+    set xmllist [wrapper::createtag "vCard" -attrlist $attrlist]
+    jlib::send_iq $jlibname "get" [list $xmllist] -to $jid -command   \
+      [list [namespace current]::send_get_cb $jlibname $jid $cmd]    
+    return
+}
+
+# jlib::vcard::send_get_cb --
+# 
+#       Cache vcard info from above and call up.
+
+proc jlib::vcard::send_get_cb {jlibname jid cmd type subiq} {
+    upvar ${jlibname}::vcard::state state
+    
+    set mjid [jlib::jidmap $jid]
+    unset -nocomplain state(pending,$mjid)
+    if {$state(cache)} {
+	set state(cache,$mjid) $subiq
+    }
+    InvokeStacked $jlibname $jid $type $subiq
+    
+    uplevel #0 $cmd [list $jlibname $type $subiq]
+}
+
+# jlib::vcard::get_async --
+# 
+#       Get vcard async using 'cmd' callback. 
+#       If cached it is returned directly using 'cmd', if pending the cmd
+#       is invoked when getting result, else we do a send_get.
+
+proc jlib::vcard::get_async {jlibname jid cmd} {
+    upvar ${jlibname}::vcard::state state
+
+    set mjid [jlib::jidmap $jid]
+    if {[info exists state(cache,$mjid)]} {
+	uplevel #0 $cmd [list $jlibname result $state(cache,$mjid)]
+    } elseif {[info exists state(pending,$mjid)]} {
+	lappend state(invoke,$mjid) $cmd
+    } else {
+	send_get $jlibname $jid $cmd
+    }
+    return
+}
+
+proc jlib::vcard::InvokeStacked {jlibname jid type subiq} {
+    upvar ${jlibname}::vcard::state state
+
+    set mjid [jlib::jidmap $jid]
+    if {[info exists state(invoke,$mjid)]} {
+	foreach cmd $state(invoke,$mjid) {
+	    uplevel #0 $cmd [list $jlibname $type $subiq]
+	}
+	unset -nocomplain state(invoke,$mjid)
+    }
+}
+
+# jlib::vcard::get_own_async --
+# 
+#       Getting and setting owns vcard is special since lacks to attribute.
+
+proc jlib::vcard::get_own_async {jlibname cmd} {
+    upvar ${jlibname}::vcard::state state
+
+    set jid [$jlibname myjid2]
+    set mjid [jlib::jidmap $jid]
+    if {[info exists state(cache,$mjid)]} {
+	uplevel #0 $cmd [list $jlibname result $state(cache,$mjid)]
+    } elseif {[info exists state(pending,$mjid)]} {
+	lappend state(invoke,$mjid) $cmd
+    } else {
+	send_get_own $jlibname $cmd
+    }
+    return
+}
+
+proc jlib::vcard::send_get_own {jlibname cmd} {
+    variable xmlns
+
+    # A user may retrieve his or her own vCard by sending XML of the 
+    # following form to his or her own JID (the 'to' attribute SHOULD NOT 
+    # be included).
+    set attrlist [list xmlns $xmlns(vcard)]    
+    set xmllist [wrapper::createtag "vCard" -attrlist $attrlist]
+    jlib::send_iq $jlibname "get" [list $xmllist] -command   \
+      [list [namespace current]::send_get_own_cb $jlibname $cmd]
+}
+
+proc jlib::vcard::send_get_own_cb {jlibname cmd type subiq} {
+    upvar ${jlibname}::vcard::state state
+    
+    set jid [$jlibname myjid2]
+    set mjid [jlib::jidmap $jid]
+    unset -nocomplain state(pending,$mjid)
+    if {$state(cache)} {
+	set state(cache,$mjid) $subiq
+    }    
+    InvokeStacked $jlibname $jid $type $subiq
+
+    uplevel #0 $cmd [list $jlibname $type $subiq]
+}
+
+# jlib::vcard::set_my_photo --
+# 
+#       A utility to set our vCard photo.
+#       If photo empty then remove photo from vCard.
+#       
+#       @@@ TODO: Perhaps we should use a cached vCard instead of getting it
+#                 each time? The cache would only need one request and then
+#                 set each time we set our usual vCard.
+
+proc jlib::vcard::set_my_photo {jlibname photo mime cmd} {
+    
+    send_get_own $jlibname  \
+      [list [namespace current]::get_my_photo_cb $photo $mime $cmd]
+}
+
+proc jlib::vcard::get_my_photo_cb {photo mime cmd jlibname type subiq} {
+    variable xmlns
+    
+    # Replace or set an element:
+    # 
+    # <PHOTO>
+    #     <TYPE>image/jpeg</TYPE>
+    #     <BINVAL>Base64-encoded-avatar-file-here!</BINVAL>
+    # </PHOTO> 
+
+    if {$type eq "result"} {
+	if {[string length $photo]} {
+	    set newphoto 1
+	    set vcardE $subiq
+	    	    
+	    # Replace or add photo. But only if different.
+	    set photoE [wrapper::getfirstchildwithtag $vcardE "PHOTO"]
+	    if {[llength $photoE]} {
+		set binE [wrapper::getfirstchildwithtag $photoE "BINVAL"]
+		if {[llength $binE]} {
+		    set sphoto [wrapper::getcdata $binE]
+		    
+		    # Base64 code can contain undefined spaces: decode!
+		    set sdata [::base64::decode $sphoto]
+		    set data  [::base64::decode $photo]
+		    if {[string equal $sdata $data]} {
+			set newphoto 0
+		    }
+		}
+	    }
+	    if {$newphoto} {
+		lappend subElems [wrapper::createtag "TYPE" -chdata $mime]
+		lappend subElems [wrapper::createtag "BINVAL" -chdata $photo]
+		set photoE [wrapper::createtag "PHOTO" -subtags $subElems]
+		if {$vcardE eq {}} {
+		    set xmllist [wrapper::createtag "vCard"  \
+		      -attrlist [list xmlns $xmlns(vcard)]   \
+		      -subtags [list $photoE]]
+		} else {
+		    set xmllist [wrapper::setchildwithtag $vcardE $photoE]
+		}
+		jlib::send_iq $jlibname "set" [list $xmllist] -command \
+		  [list [namespace current]::set_my_photo_cb $jlibname $cmd]
+	    }
+	} else {
+	    
+	    # Remove any photo. If there is no PHOTO no need to set.
+	    set photoE [wrapper::getfirstchildwithtag $subiq "PHOTO"]
+	    if {[llength $photoE]} {
+		set xmllist [wrapper::deletechildswithtag $subiq "PHOTO"]
+		jlib::send_iq $jlibname "set" [list $xmllist] -command \
+		  [list [namespace current]::set_my_photo_cb $jlibname $cmd]    
+	    }
+	}
+    } else {
+	uplevel #0 $cmd [list $jlibname $type $subiq]
+    }
+}
+
+proc jlib::vcard::set_my_photo_cb {jlibname cmd type subiq} {
+    
+    uplevel #0 $cmd [list $jlibname $type $subiq]
+}
+
+proc jlib::vcard::has_cache {jlibname jid} {
+    upvar ${jlibname}::vcard::state state
+    
+    set mjid [jlib::jidmap $jid]
+    return [info exists state(cache,$mjid)] 
+}
+
+proc jlib::vcard::get_cache {jlibname jid} {
+    upvar ${jlibname}::vcard::state state
+    
+    set mjid [jlib::jidmap $jid]
+    if {[info exists state(cache,$mjid)]} {
+	return $state(cache,$mjid)
+    } else {
+	return
+    }
+}
+
+# jlib::vcard::send_set, createvcard --
+#
+#       Sends our vCard to the server. Internally we use all lower case
+#       but the spec (XEP-0054) says that all tags be all upper case.
+#
+# Arguments:
+#       jlibname:   the instance of this jlib.
+#       cmd:        client command to be executed at the iq "result" element.
+#       args:       All keys are named so that the element hierarchy becomes
+#                   vcardElement_subElement_subsubElement ... and so on;
+#                   all lower case.
+#                   
+# Results:
+#       none.
+
+proc jlib::vcard::send_set {jlibname cmd args} {
+    upvar ${jlibname}::vcard::state state
+    
+    set jid [$jlibname myjid2]
+    set xmllist [eval {create $jlibname} $args]
+    set state(cache,$jid) $xmllist
+    jlib::send_iq $jlibname "set" [list $xmllist] -command \
+      [list [namespace current]::send_set_cb $jlibname $cmd]    
+    return
+}
+
+proc jlib::vcard::create {jlibname args} {
+    variable xmlns
+    
+    set attrlist [list xmlns $xmlns(vcard)]    
+    
+    # Form all the sub elements by inspecting the -key.
+    array set arr $args
+    set subE [list]
+    
+    # All "sub" elements with no children.
+    foreach tag {fn nickname bday url title role desc} {
+	if {[info exists arr(-$tag)]} {
+	    lappend subE [wrapper::createtag [string toupper $tag] \
+	      -chdata $arr(-$tag)]
+	}
+    }
+    if {[info exists arr(-email_internet_pref)]} {
+	set elem [list]
+	lappend elem [wrapper::createtag "INTERNET"]
+	lappend elem [wrapper::createtag "PREF"]
+	lappend subE [wrapper::createtag "EMAIL" \
+	  -chdata $arr(-email_internet_pref) -subtags $elem]
+    }
+    if {[info exists arr(-email_internet)]} {
+	foreach email $arr(-email_internet) {
+	    set elem [list]
+	    lappend elem [wrapper::createtag "INTERNET"]
+	    lappend subE [wrapper::createtag "EMAIL" \
+	      -chdata $email -subtags $elem]
+	}
+    }
+    
+    # All "subsub" elements.
+    foreach tag {n org} {
+	set elem [list]
+	foreach key [array names arr "-${tag}_*"] {
+	    regexp -- "-${tag}_(.+)" $key match sub
+	    lappend elem [wrapper::createtag [string toupper $sub] \
+	      -chdata $arr($key)]
+	}
+    
+	# Insert subsub elements where they belong.
+	if {[llength $elem]} {
+	    lappend subE [wrapper::createtag [string toupper $tag] \
+	      -subtags $elem]
+	}
+    }
+    
+    # The <adr><home/>, <adr><work/> sub elements.
+    foreach tag {adr_home adr_work} {
+	regexp -- {([^_]+)_(.+)} $tag match head sub
+	set elem [list [wrapper::createtag [string toupper $sub]]]
+	set haveThisTag 0
+	foreach key [array names arr "-${tag}_*"] {
+	    set haveThisTag 1
+	    regexp -- "-${tag}_(.+)" $key match sub
+	    lappend elem [wrapper::createtag [string toupper $sub] \
+	      -chdata $arr($key)]
+	}		
+	if {$haveThisTag} {
+	    lappend subE [wrapper::createtag [string toupper $head] \
+	      -subtags $elem]
+	}
+    }	
+    
+    # The <tel> sub elements.
+    foreach tag [array names arr "-tel_*"] {
+	if {[regexp -- {-tel_([^_]+)_([^_]+)} $tag match second third]} {
+	    set elem {}
+	    lappend elem [wrapper::createtag [string toupper $second]]
+	    lappend elem [wrapper::createtag [string toupper $third]]
+	    lappend subE [wrapper::createtag "TEL" -chdata $arr($tag) \
+	      -subtags $elem]
+	}
+    }
+    
+    # The <photo> sub elements.
+    if {[info exists arr(-photo_binval)]} {
+	set elem {}
+	lappend elem [wrapper::createtag "BINVAL" -chdata $arr(-photo_binval)]
+	if {[info exists arr(-photo_type)]} {
+	    lappend elem [wrapper::createtag "TYPE" -chdata $arr(-photo_type)]
+	}
+	lappend subE [wrapper::createtag "PHOTO" -subtags $elem]
+    }
+    
+    return [wrapper::createtag "vCard" -attrlist $attrlist -subtags $subE]
+}
+
+proc jlib::vcard::send_set_cb {jlibname cmd type subiq args} {
+    
+    uplevel #0 $cmd [list $jlibname $type $subiq]
+}
+
+proc jlib::vcard::cache {jlibname args} {
+    upvar ${jlibname}::vcard::state state
+    
+    if {[llength $args] == 1} {
+	set state(cache) [lindex $args 0]
+    }
+    return $state(cache)
+}
+
+proc jlib::vcard::clear {jlibname {jid ""}} {
+    upvar ${jlibname}::vcard::state state
+    
+    if {$jid eq ""} {
+	array unset state "cache,*"
+    } else {
+	set mjid [jlib::jidmap $jid]
+	array unset state "cache,[jlib::ESC $mjid]"
+    }
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::vcard {
+
+    jlib::ensamble_register vcard  \
+      [namespace current]::init    \
+      [namespace current]::cmdproc
+}
+
+
+
diff --git a/lib/jabberlib/wrapper.tcl b/lib/jabberlib/wrapper.tcl
new file mode 100644
index 0000000..179adb7
--- /dev/null
+++ b/lib/jabberlib/wrapper.tcl
@@ -0,0 +1,1062 @@
+################################################################################
+#
+# wrapper.tcl 
+#
+# This file defines wrapper procedures.  These
+# procedures are called by functions in jabberlib, and
+# they in turn call the TclXML library functions.
+#
+#  Copyright (c) 2002-2008  Mats Bengtsson
+#  
+# This file is distributed under BSD style license.
+#
+# $Id: wrapper.tcl,v 1.41 2008/03/26 15:37:23 matben Exp $
+# 
+# ########################### INTERNALS ########################################
+# 
+# The whole parse tree is stored as a hierarchy of lists as:
+# 
+#       parent = {tag attrlist isempty cdata {child1 child2 ...}}
+#       
+# where the childs are in turn a list of identical structure:      
+# 
+#       child1 = {tag attrlist isempty cdata {grandchild1 grandchild2 ...}}
+#       child2 = {tag attrlist isempty cdata {grandchild1 grandchild2 ...}}
+#       
+# etc.
+#       
+# ########################### USAGE ############################################
+#
+#   NAME
+#      wrapper::new - a wrapper for the TclXML parser.
+#   SYNOPSIS
+#      wrapper::new streamstartcmd streamendcmd parsecmd errorcmd
+#   OPTIONS
+#      none
+#   COMMANDS
+#      wrapper::reset wrapID
+#      wrapper::createxml xmllist
+#      wrapper::createtag tagname ?args?
+#      wrapper::getattr attrlist attrname
+#      wrapper::setattr attrlist attrname value
+#      wrapper::parse id xml
+#      wrapper::xmlcrypt chdata
+#      wrapper::gettag xmllist
+#      wrapper::getattrlist xmllist
+#      wrapper::getisempty xmllist
+#      wrapper::getcdata xmllist
+#      wrapper::getchildren xmllist
+#      wrapper::getattribute xmllist attrname
+#      wrapper::setattrlist xmllist attrlist
+#      wrapper::setcdata xmllist cdata
+#      wrapper::splitxml xmllist tagVar attrVar cdataVar childVar
+#
+# ########################### LIMITATIONS ######################################
+# 
+# Mixed elements of character data and elements are not working.
+# 
+# ########################### CHANGES ##########################################
+#
+#       0.*      by Kerem HADIMLI and Todd Bradley
+#       1.0a1    complete rewrite, and first release by Mats Bengtsson
+#       1.0a2    a few fixes
+#       1.0a3    wrapper::reset was not right, -ignorewhitespace, 
+#                -defaultexpandinternalentities
+#       1.0b1    added wrapper::parse command, configured for expat, 
+#                return break at stream end
+#       1.0b2    fix to make parser reentrant
+#       030910   added accessor functions to get/set xmllist elements
+#       031103   added splitxml command
+
+
+if {[catch {package require tdom}]} {
+    package require xml 3.1
+}
+
+namespace eval wrapper {
+
+    # The public interface.
+    namespace export what
+
+    # Keep all internal data in this array, with 'id' as first index.
+    variable wrapper
+    
+    # Running id that is never reused; start from 0.
+    set wrapper(uid) 0
+    
+    # Keep all 'id's in this list.
+    set wrapper(list) [list]
+    
+    variable xmldefaults {-isempty 1 -attrlist {} -chdata {} -subtags {}}
+}
+
+# wrapper::new --
+#
+#       Contains initializations needed for the wrapper.
+#       Sets up callbacks via the XML parser.
+#       
+# Arguments:
+#       streamstartcmd:   callback when level one start tag received
+#       streamendcmd:     callback when level one end tag received
+#       parsecmd:         callback when level two end tag received
+#       errorcmd          callback when receiving an error from the XML parser.
+#                         Must all be fully qualified names.
+#       
+# Results:
+#       A unique wrapper id.
+
+proc wrapper::new {streamstartcmd streamendcmd parsecmd errorcmd} {
+    variable wrapper
+    
+    # Handle id of the wrapper.
+    set id wrap[incr wrapper(uid)]
+    lappend wrapper(list) $id
+    
+    set wrapper($id,streamstartcmd) $streamstartcmd
+    set wrapper($id,streamendcmd) $streamendcmd
+    set wrapper($id,parsecmd) $parsecmd
+    set wrapper($id,errorcmd) $errorcmd
+    
+    # Create the actual XML parser. It is created in our present namespace,
+    # at least for the tcl parser!!!
+
+    if {[llength [package provide tdom]]} {
+	#set wrapper($id,parser) [xml::parser -namespace 1]
+	set wrapper($id,parser) [expat -namespace 1]
+	set wrapper($id,class) "tdom"
+	$wrapper($id,parser) configure \
+	  -final 0  \
+	  -elementstartcommand  [list [namespace current]::elementstart $id]  \
+	  -elementendcommand    [list [namespace current]::elementend $id]    \
+	  -characterdatacommand [list [namespace current]::chdata $id]        \
+	  -ignorewhitespace 0
+    } else {
+	set wrapper($id,parser) [xml::parser]
+    
+	# Investigate which parser class we've got, and act consequently.
+	set classes [::xml::parserclass info names]
+	if {[lsearch $classes "expat"] >= 0} {
+	    set wrapper($id,class) "expat"
+	    $wrapper($id,parser) configure   \
+	      -final 0    \
+	      -reportempty 1   \
+	      -elementstartcommand  [list [namespace current]::elementstart $id]   \
+	      -elementendcommand    [list [namespace current]::elementend $id]     \
+	      -characterdatacommand [list [namespace current]::chdata $id]         \
+	      -ignorewhitespace     1                                              \
+	      -defaultexpandinternalentities 0
+	} else {
+	    set wrapper($id,class) "tcl"
+	    $wrapper($id,parser) configure   \
+	      -final 0    \
+	      -reportempty 1   \
+	      -elementstartcommand  [list [namespace current]::elementstart $id]   \
+	      -elementendcommand    [list [namespace current]::elementend $id]     \
+	      -characterdatacommand [list [namespace current]::chdata $id]         \
+	      -errorcommand         [list [namespace current]::xmlerror $id]       \
+	      -ignorewhitespace     1                                              \
+	      -defaultexpandinternalentities 0
+	}
+    }
+    
+    # Experiment.
+    if {0} {
+	package require qdxml
+	set token [qdxml::create \
+	  -elementstartcommand  [list [namespace current]::elementstart $id]   \
+	  -elementendcommand    [list [namespace current]::elementend $id]     \
+	  -characterdatacommand [list [namespace current]::chdata $id]]
+	set wrapper($id,parser) $token
+    }
+    
+    # Current level; 0 before root tag; 1 just after root tag, 2 after 
+    # command tag, etc.
+    set wrapper($id,level) 0
+    set wrapper($id,levelonetag) ""
+    
+    # Level 1 is the main tag, <stream:stream>, and level 2
+    # is the command tag, such as <message>. We don't handle level 1 xmldata.
+    set wrapper($id,tree,2) [list]
+    
+    set wrapper($id,refcount) 0
+    set wrapper($id,stack) ""
+
+    return $id
+}
+
+# wrapper::parse --
+#
+#       For parsing xml. 
+#       
+# Arguments:
+#       id:          the wrapper id.
+#       xml:         raw xml data to be parsed.
+#       
+# Results:
+#       none.
+
+proc wrapper::parse {id xml} {
+    variable wrapper
+
+    # This is not as innocent as it looks; the 'tcl' parser proc is created in
+    # the creators namespace (wrapper::), but the 'expat' parser ???
+    parsereentrant $id $xml
+    return
+}
+
+# wrapper::parsereentrant --
+# 
+#       Forces parsing to be serialized in an event driven environment.
+#       If we read xml from socket and happen to trigger a read (and parse)
+#       event right from an element callback, everyhting will be out of sync.
+#       
+# Arguments:
+#       id:          the wrapper id
+#       xml:         raw xml data to be parsed.
+#       
+# Results:
+#       none.
+
+proc wrapper::parsereentrant {id xml} {
+    variable wrapper
+    
+    set p $wrapper($id,parser)   
+    set refcount [incr wrapper($id,refcount)]
+    
+    if {$refcount == 1} {
+	
+	# This is the main entry: do parse original xml.
+	$p parse $xml
+	
+	# Parse everything on the stack (until empty?).
+	while {[string length $wrapper($id,stack)] > 0} {
+	    set tmp $wrapper($id,stack)
+	    set wrapper($id,stack) ""
+	    $p parse $tmp
+	}
+    } else {
+	
+	# Reentry, put on stack for delayed execution.
+	append wrapper($id,stack) $xml
+    }
+    
+    # If we was reset from callback 'refcount' can have been reset to 0.
+    incr wrapper($id,refcount) -1
+    if {$wrapper($id,refcount) < 0} {
+	set wrapper($id,refcount) 0
+    }
+    return
+}
+
+# wrapper::elementstart --
+#
+#       Callback proc for all element start.
+#       
+# Arguments:
+#       id:          the wrapper id.
+#       tagname:     the element (tag) name.
+#       attrlist:    list of attributes {key value key value ...}
+#       args:        additional arguments given by the parser.
+#       
+# Results:
+#       none.
+
+proc wrapper::elementstart {id tagname attrlist args} {
+    variable wrapper
+
+    # Check args, to see if empty element and/or namespace. 
+    # Put xmlns in attribute list.
+    array set argsarr $args
+    set isempty 0
+    if {[info exists argsarr(-empty)]} {
+	set isempty $argsarr(-empty)
+    }
+    if {[info exists argsarr(-namespacedecls)]} {
+	lappend attrlist xmlns [lindex $argsarr(-namespacedecls) 0]
+    }
+    
+    if {$wrapper($id,class) eq "tdom"} {
+	if {[set ndx [string last : $tagname]] != -1} {
+	    set ns [string range $tagname 0 [expr {$ndx - 1}]]
+	    set tagname [string range $tagname [incr ndx] end]
+	    lappend attrlist xmlns $ns
+	}
+    }
+
+    if {$wrapper($id,level) == 0} {
+	
+	# We got a root tag, such as <stream:stream>
+	set wrapper($id,level) 1
+	set wrapper($id,levelonetag) $tagname 
+	set wrapper($id,tree,1) [list $tagname $attrlist $isempty {} {}]
+	
+	# Do the registered callback at the global level.
+	uplevel #0 $wrapper($id,streamstartcmd) $attrlist
+	
+    } else {
+	
+	# This is either a level 2 command tag, such as 'presence', 'iq', or 'message',
+	# or we have got a new tag beyond level 2.
+	# It is time to start building the parse tree.
+	set level [incr wrapper($id,level)]
+	set wrapper($id,tree,$level) [list $tagname $attrlist $isempty {} {}]
+    }
+}
+
+# wrapper::elementend --
+#
+#       Callback proc for all element ends.
+#       
+# Arguments:
+#       id:          the wrapper id.
+#       tagname:     the element (tag) name.
+#       args:        additional arguments given by the parser.
+#       
+# Results:
+#       none.
+
+proc wrapper::elementend {id tagname args} {
+    variable wrapper
+
+    # tclxml doesn't do the reset properly but continues to send us endtags.
+    # qdxml behaves better!
+    if {!$wrapper($id,level)} {
+	return
+    }
+    
+    # Check args, to see if empty element
+    set isempty 0
+    set ind [lsearch -exact $args {-empty}]
+    if {$ind >= 0} {
+	set isempty [lindex $args [expr {$ind + 1}]]
+    }
+    if {$wrapper($id,level) == 1} {
+	
+	# End of the root tag (</stream:stream>).
+	# Do the registered callback at the global level.
+	uplevel #0 $wrapper($id,streamendcmd)
+	
+	incr wrapper($id,level) -1
+	
+	# We are in the middle of parsing, need to break.
+	reset $id
+	return -code 3
+    } else {
+	
+	# We are finshed with this child tree.
+	set childlevel $wrapper($id,level)
+	
+	# Insert the child tree in the parent tree.
+	# Avoid adding to the level 1 else we just consume memory forever [PT]
+	set level [incr wrapper($id,level) -1]
+	if {$level > 1} {
+	    append_child $id $level $wrapper($id,tree,$childlevel)
+	} elseif {$level == 1} {
+	    
+	    # We've got an end tag of a command tag, and it's time to
+	    # deliver our parse tree to the registered callback proc.
+	    uplevel #0 $wrapper($id,parsecmd) [list $wrapper($id,tree,2)]
+	}
+    }
+}
+
+# wrapper::append_child --
+#
+#       Inserts a child element data in level temp data.
+#       
+# Arguments:
+#       id:          the wrapper id.
+#       level:       the parent level, child is level+1.
+#       childtree:   the tree to append.
+#       
+# Results:
+#       none.
+
+proc wrapper::append_child {id level childtree} {
+    variable wrapper
+
+    # Get child list at parent level (level).
+    set childlist [lindex $wrapper($id,tree,$level) 4]
+    lappend childlist $childtree
+    
+    # Build the new parent tree.
+    set wrapper($id,tree,$level) [lreplace $wrapper($id,tree,$level) 4 4  \
+      $childlist]
+}
+
+# wrapper::chdata --
+#
+#       Appends character data to the tree level xml chdata.
+#       It makes also internal entity replacements on character data.
+#       Callback from the XML parser.
+#       
+# Arguments:
+#       id:          the wrapper id.
+#       chardata:    the character data.
+#       
+# Results:
+#       none.
+
+proc wrapper::chdata {id chardata} {   
+    variable wrapper
+
+    set level $wrapper($id,level)
+    
+    # If we receive CHDATA before any root element, 
+    # or after the last root element, discard.
+    if {$level <= 0} {
+	return
+    }
+    set chdata [lindex $wrapper($id,tree,$level) 3]
+    
+    # Make standard entity replacements.
+    append chdata [xmldecrypt $chardata]
+    set wrapper($id,tree,$level)    \
+      [lreplace $wrapper($id,tree,$level) 3 3 "$chdata"]
+}
+
+# wrapper::free -- 
+# 
+#      tdom doesn't permit freeing a parser from within a callback. So 
+#      we keep trying until it works. 
+# 
+
+proc wrapper::free {id} { 
+    if {[catch {$id free}]} { 
+	after 100 [list [namespace origin free] $id] 
+    } 
+} 
+
+# wrapper::reset --
+#
+#       Resets the wrapper and XML parser to be prepared for a fresh new 
+#       document.
+#       If done while parsing be sure to return a break (3) from callback.
+#       
+# Arguments:
+#       id:          the wrapper id.
+#       
+# Results:
+#       none.
+
+proc wrapper::reset {id} {   
+    variable wrapper
+    
+    if {$wrapper($id,class) eq "tdom"} {
+	
+	# We cannot reset a tdom expat parser from within a callback. However,
+	# we can always replace it with a new one.
+	set old $wrapper($id,parser)
+	after idle [list [namespace origin free] $old]
+	#set wrapper($id,parser) [xml::parser -namespace 1]
+	set wrapper($id,parser) [expat -namespace 1]
+	
+	$wrapper($id,parser) configure  \
+	  -final 0  \
+	  -elementstartcommand  [list [namespace current]::elementstart $id]   \
+	  -elementendcommand    [list [namespace current]::elementend $id]     \
+	  -characterdatacommand [list [namespace current]::chdata $id]         \
+	  -ignorewhitespace 0
+    } else {
+    
+	# This resets the actual XML parser. Not sure this is actually needed.
+	$wrapper($id,parser) reset
+	
+	# Unfortunately it also removes all our callbacks and options.
+	if {$wrapper($id,class) eq "expat"} {
+	    $wrapper($id,parser) configure   \
+	      -final 0    \
+	      -reportempty 1   \
+	      -elementstartcommand  [list [namespace current]::elementstart $id]   \
+	      -elementendcommand    [list [namespace current]::elementend $id]     \
+	      -characterdatacommand [list [namespace current]::chdata $id]         \
+	      -ignorewhitespace     1                                              \
+	      -defaultexpandinternalentities 0
+	} else {
+	    $wrapper($id,parser) configure   \
+	      -final 0    \
+	      -reportempty 1   \
+	      -elementstartcommand  [list [namespace current]::elementstart $id]   \
+	      -elementendcommand    [list [namespace current]::elementend $id]     \
+	      -characterdatacommand [list [namespace current]::chdata $id]         \
+	      -errorcommand         [list [namespace current]::xmlerror $id]       \
+	      -ignorewhitespace     1                                              \
+	      -defaultexpandinternalentities 0
+	}
+    }
+
+    # Cleanup internal state vars.
+    array unset wrapper $id,tree,*
+    
+    # Reset also our internal wrapper to its initial position.
+    set wrapper($id,level) 0
+    set wrapper($id,levelonetag) ""
+    set wrapper($id,tree,2) [list] 
+
+    set wrapper($id,refcount) 0
+    set wrapper($id,stack) ""
+}
+
+# wrapper::xmlerror --
+#
+#       Callback from the XML parser when error received. Resets wrapper,
+#       and makes a 'streamend' command callback.
+#
+# Arguments:
+#       id:          the wrapper id.
+#       
+# Results:
+#       none.
+
+proc wrapper::xmlerror {id args} {
+    variable wrapper
+
+    uplevel #0 $wrapper($id,errorcmd) $args
+}
+
+# wrapper::createxml --
+#
+#       Creates raw xml data from a hierarchical list of xml code.
+#       This proc gets called recursively for each child.
+#       It makes also internal entity replacements on character data.
+#       Mixed elements aren't treated correctly generally.
+#       
+# Arguments:
+#       xmllist     a list of xml code in the format described in the header.
+#       
+# Results:
+#       raw xml data.
+
+proc wrapper::createxml {xmllist} {
+        
+    # Extract the XML data items.
+    foreach {tag attrlist isempty chdata childlist} $xmllist { break }
+    set attrlist [xmlcrypt $attrlist]
+    set rawxml "<$tag"
+    foreach {attr value} $attrlist {
+	append rawxml " $attr='$value'"
+    }
+    if {$isempty} {
+	append rawxml "/>"
+    } else {
+	append rawxml ">"
+	
+	# Call ourselves recursively for each child element. 
+	# There is an arbitrary choice here where childs are put before PCDATA.
+	foreach child $childlist {
+	    append rawxml [createxml $child]
+	}
+	
+	# Make standard entity replacements.
+	if {[string length $chdata]} {
+	    append rawxml [xmlcrypt $chdata]
+	}
+	append rawxml "</$tag>"
+    }
+    return $rawxml
+}
+
+# wrapper::formatxml, formattag --
+# 
+#       Creates formatted raw xml data from a xml list.
+
+proc wrapper::formatxml {xmllist args} {
+    variable tabs
+    variable nl
+    variable prefix
+    
+    array set argsA {
+	-prefix ""
+    }
+    array set argsA $args
+    set prefix $argsA(-prefix)
+    set nl ""
+    set tabs ""
+    formattag $xmllist
+}
+
+proc wrapper::formattag {xmllist} {
+    variable tabs
+    variable nl
+    variable prefix
+    
+    foreach {tag attrlist isempty chdata childlist} $xmllist { break }
+    set attrlist [xmlcrypt $attrlist]
+    set rawxml "$nl$prefix$tabs<$tag"
+    foreach {attr value} $attrlist {
+	append rawxml " $attr='$value'"
+    }
+    set nl "\n"
+    if {$isempty} {
+	append rawxml "/>"
+    } else {
+	append rawxml ">"
+	if {[llength $childlist]} {
+	    append tabs "\t"
+	    foreach child $childlist {
+		append rawxml [formattag $child]
+	    }
+	    set tabs [string range $tabs 0 end-1]
+	    append rawxml "$nl$prefix$tabs</$tag>"
+	} else {
+	    if {[string length $chdata]} {
+		append rawxml [xmlcrypt $chdata]
+	    }
+	    append rawxml "</$tag>"
+	}
+    }
+    return $rawxml
+}
+
+# wrapper::createtag --
+#
+#       Build an element list given the tag and the args.
+#
+# Arguments:
+#       tagname:    the name of this element.
+#       args:       
+#           -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)
+#	    -attrlist {attr1 value1 attr2 value2 ..}   Vars is a list 
+#                             consisting of attr/value pairs, as shown.
+#	    -chdata $chdata   ChData of tag (default: "").
+#	    -subtags {$subchilds $subchilds ...} is a list containing xmldata
+#                             of $tagname's subtags. (default: no sub-tags)
+#       
+# Results:
+#       a list suitable for wrapper::createxml.
+
+proc wrapper::createtag {tagname args} {
+    variable xmldefaults
+    
+    # Fill in the defaults.
+    array set xmlarr $xmldefaults
+    
+    # Override the defults with actual values.
+    if {[llength $args]} {
+	array set xmlarr $args
+    }
+    if {[string length $xmlarr(-chdata)] || [llength $xmlarr(-subtags)]} {
+	set xmlarr(-isempty) 0
+    }
+    
+    # Build sub elements list.
+    set sublist [list]
+    foreach child $xmlarr(-subtags) {
+	lappend sublist $child
+    }
+    set xmllist [list $tagname $xmlarr(-attrlist) $xmlarr(-isempty)  \
+      $xmlarr(-chdata) $sublist]
+    return $xmllist
+}
+
+# wrapper::validxmllist --
+# 
+#       Makes a primitive check to see if this is a valid xmllist.
+
+proc wrapper::validxmllist {xmllist} {
+    return [expr ([llength $xmllist] == 5) ? 1 : 0]
+}
+
+# wrapper::getattr --
+#
+#       This proc returns the value of 'attrname' from 'attrlist'.
+#
+# Arguments:
+#       attrlist:   a list of key value pairs for the attributes.
+#       attrname:   the name of the attribute which value we query.
+#       
+# Results:
+#       value of the attribute or empty.
+
+proc wrapper::getattr {attrlist attrname} {
+
+    foreach {attr val} $attrlist {
+	if {[string equal $attr $attrname]} {
+	    return $val
+	}
+    }
+    return
+}
+
+proc wrapper::getattribute {xmllist attrname} {
+
+    foreach {attr val} [lindex $xmllist 1] {
+	if {[string equal $attr $attrname]} {
+	    return $val
+	}
+    }
+    return
+}
+
+proc wrapper::isattr {attrlist attrname} {
+
+    foreach {attr val} $attrlist {
+	if {[string equal $attr $attrname]} {
+	    return 1
+	}
+    }
+    return 0
+}
+
+proc wrapper::isattribute {xmllist attrname} {
+
+    foreach {attr val} [lindex $xmllist 1] {
+	if {[string equal $attr $attrname]} {
+	    return 1
+	}
+    }
+    return 0
+}
+
+proc wrapper::setattr {attrlist attrname value} {
+
+    array set attrArr $attrlist
+    set attrArr($attrname) $value
+    return [array get attrArr]
+}
+
+# wrapper::gettag, getattrlist, getisempty, getcdata, getchildren  --
+#
+#       Accessor functions for 'xmllist'.
+#       {tag attrlist isempty cdata {grandchild1 grandchild2 ...}}
+#
+# Arguments:
+#       xmllist:    an xml hierarchical list.
+#       
+# Results:
+#       list of childrens if any.
+
+proc wrapper::gettag {xmllist} {
+    return [lindex $xmllist 0]
+}
+
+proc wrapper::getattrlist {xmllist} {
+    return [lindex $xmllist 1]
+}
+
+proc wrapper::getisempty {xmllist} {
+    return [lindex $xmllist 2]
+}
+
+proc wrapper::getcdata {xmllist} {
+    return [lindex $xmllist 3]
+}
+
+proc wrapper::getchildren {xmllist} {
+    return [lindex $xmllist 4]
+}
+
+proc wrapper::splitxml {xmllist tagVar attrVar cdataVar childVar} {
+    
+    foreach {tag attr empty cdata children} $xmllist break
+    uplevel 1 [list set $tagVar $tag]
+    uplevel 1 [list set $attrVar $attr]
+    uplevel 1 [list set $cdataVar $cdata]
+    uplevel 1 [list set $childVar $children]    
+}
+
+proc wrapper::getchildswithtag {xmllist tag} {
+    
+    set clist [list]
+    foreach celem [lindex $xmllist 4] {
+	if {[string equal [lindex $celem 0] $tag]} {
+	    lappend clist $celem
+	}
+    }
+    return $clist
+}
+
+proc wrapper::getfirstchildwithtag {xmllist tag} {
+    
+    set c [list]
+    foreach celem [lindex $xmllist 4] {
+	if {[string equal [lindex $celem 0] $tag]} {
+	    set c $celem
+	    break
+	}
+    }
+    return $c
+}
+
+proc wrapper::havechildtag {xmllist tag} {
+    return [llength [getfirstchildwithtag $xmllist $tag]]
+}
+
+proc wrapper::getfirstchildwithxmlns {xmllist ns} {
+    
+    set c [list]
+    foreach celem [lindex $xmllist 4] {
+	unset -nocomplain attr
+	array set attr [lindex $celem 1]
+	if {[info exists attr(xmlns)] && [string equal $attr(xmlns) $ns]} {
+	    set c $celem
+	    break
+	}
+    }
+    return $c
+}
+
+proc wrapper::getchildswithtagandxmlns {xmllist tag ns} {
+
+    set clist [list]
+    foreach celem [lindex $xmllist 4] {
+	if {[string equal [lindex $celem 0] $tag]} {
+	    unset -nocomplain attr
+	    array set attr [lindex $celem 1]
+	    if {[info exists attr(xmlns)] && [string equal $attr(xmlns) $ns]} {
+		lappend clist $celem
+	    }
+	}
+    }
+    return $clist
+}
+
+proc wrapper::getfirstchild {xmllist tag ns} {
+    
+    set elem [list]
+    foreach celem [lindex $xmllist 4] {
+	if {[string equal [lindex $celem 0] $tag]} {
+	    unset -nocomplain attr
+	    array set attr [lindex $celem 1]
+	    if {[info exists attr(xmlns)] && [string equal $attr(xmlns) $ns]} {
+		set elem $celem
+		break
+	    }
+	}
+    }
+    return $elem
+}
+
+proc wrapper::getfromchilds {childs tag} {
+    
+    set clist [list]
+    foreach celem $childs {
+	if {[string equal [lindex $celem 0] $tag]} {
+	    lappend clist $celem
+	}
+    }
+    return $clist
+}
+
+proc wrapper::deletefromchilds {childs tag} {
+    
+    set clist [list]
+    foreach celem $childs {
+	if {![string equal [lindex $celem 0] $tag]} {
+	    lappend clist $celem
+	}
+    }
+    return $clist
+}
+
+proc wrapper::getnamespacefromchilds {childs tag ns} {
+    
+    set clist [list]
+    foreach celem $childs {
+	if {[string equal [lindex $celem 0] $tag]} {
+	    unset -nocomplain attr
+	    array set attr [lindex $celem 1]
+	    if {[info exists attr(xmlns)] && [string equal $attr(xmlns) $ns]} {
+		lappend clist $celem
+		break
+	    }
+	}
+    }
+    return $clist
+}
+
+# wrapper::getchilddeep --
+# 
+#       Searches recursively for the first child with matching tags and 
+#       optionally matching xmlns attributes.
+#       
+# Arguments:
+#       xmllist:    an xml hierarchical list.
+#       specs:      {{tag ?xmlns?} {tag ?xmlns?} ...}
+#       
+# Results:
+#       first found matching child element or empty if not found
+
+proc wrapper::getchilddeep {xmllist specs} {
+    
+    set xlist $xmllist
+    
+    foreach cspec $specs {
+	set tag   [lindex $cspec 0]
+	set xmlns [lindex $cspec 1]
+	set match 0
+	
+	foreach c [lindex $xlist 4] {
+	    if {[string equal $tag [lindex $c 0]]} {
+		if {[string length $xmlns]} {
+		    array unset attr
+		    array set attr [lindex $c 1]
+		    if {[info exists attr(xmlns)] && \
+		      [string equal $xmlns $attr(xmlns)]} {
+			set xlist $c
+			set match 1
+			break
+		    } else {
+			# tag matched but not xmlns; go for next child.
+			continue
+		    }
+		}
+		set xlist $c
+		set match 1
+		break
+	    }
+	}
+	# No matches found.
+	if {!$match} {
+	    return
+	}
+    }
+    return $xlist
+}
+
+proc wrapper::setattrlist {xmllist attrlist} { 
+    return [lreplace $xmllist 1 1 $attrlist]
+}
+
+proc wrapper::setcdata {xmllist cdata} {
+    return [lreplace $xmllist 3 3 $cdata]
+}
+
+proc wrapper::setchildlist {xmllist childlist} {
+    return [lreplace $xmllist 4 4 $childlist]
+}
+
+# wrapper::setchildwithtag --
+# 
+#       Replaces any element with same tag. 
+#       If not there it will be added.
+#       xmllist must be nonempty.
+
+proc wrapper::setchildwithtag {xmllist elem} {
+    set tag [lindex $elem 0]
+    set clist [list]
+    foreach c [lindex $xmllist 4] {
+	if {[lindex $c 0] ne $tag} {
+	    lappend clist $c
+	}
+    }
+    lappend clist $elem
+    # IMPORTANT:
+    lset xmllist 2 0
+    return [lreplace $xmllist 4 4 $clist]
+}
+
+# wrapper::deletechildswithtag --
+# 
+#       Deletes any element with tag.
+#       xmllist must be nonempty.
+
+proc wrapper::deletechildswithtag {xmllist tag} {
+    set clist [list]
+    foreach c [lindex $xmllist 4] {
+	if {[lindex $c 0] ne $tag} {
+	    lappend clist $c
+	}
+    }
+    return [lreplace $xmllist 4 4 $clist]
+}
+
+# wrapper::xmlcrypt --
+#
+#       Makes standard XML entity replacements.
+#
+# Arguments:
+#       chdata:     character data.
+#       
+# Results:
+#       chdata with XML standard entities replaced.
+
+proc wrapper::xmlcrypt {chdata} {
+    
+    # RFC 3454 (STRINGPREP):
+    # C.2.1 ASCII control characters
+    #    0000-001F; [CONTROL CHARACTERS]
+    #    007F; DELETE
+    
+    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 " "
+		        \x7F " "} $chdata]
+}
+
+# wrapper::xmldecrypt --
+#
+#       Replaces the XML standard entities with real characters.
+#
+# Arguments:
+#       chdata:     character data.
+#       
+# Results:
+#       chdata without any XML standard entities.
+
+proc wrapper::xmldecrypt {chdata} {
+
+    return [string map {
+	{&amp;} {&} {&lt;} {<} {&gt;} {>} {&quot;} {"} {&apos;} {'}} $chdata]
+    #'"
+}
+
+# wrapper::parse_xmllist_to_array --
+#
+#       Takes a hierarchical list of xml data and parses the character data
+#       into array elements. The array key of each element is constructed as:
+#       rootTag_subTag_subSubTag.
+#       Repetitative elements are not parsed correctly.
+#       Mixed elements of chdata and tags are not allowed.
+#       This is typically called without a 'key' argument.
+#
+# Arguments:
+#       xmllist:    a hierarchical list of xml data as defined above.
+#       arrName:
+#       key:        (optional) the rootTag, typically only used internally.
+#       
+# Results:
+#       none. Array elements filled.
+
+proc wrapper::parse_xmllist_to_array {xmllist arrName {key {}}} {
+
+    upvar #0 $arrName locArr
+    
+    # Return if empty element.
+    if {[lindex $xmllist 2]} {
+	return
+    }
+    if {[string length $key]} {
+	set und {_}
+    } else {
+	set und {}
+    }
+    
+    set childs [lindex $xmllist 4]
+    if {[llength $childs]} {
+	foreach c $childs {
+	    set newkey "${key}${und}[lindex $c 0]"
+	    
+	    # Call ourselves recursively.
+	    parse_xmllist_to_array $c $arrName $newkey
+	}
+    } else {
+	
+	# This is a leaf of the tree structure.
+	set locArr($key) [lindex $xmllist 3]
+    }
+    return
+}
+
+#-------------------------------------------------------------------------------
+package provide wrapper 1.2
+    
diff --git a/lib/log/log.tcl b/lib/log/log.tcl
new file mode 100644
index 0000000..a9f42ae
--- /dev/null
+++ b/lib/log/log.tcl
@@ -0,0 +1,851 @@
+# log.tcl --
+#
+#	Tcl implementation of a general logging facility
+#	(Reaped from Pool_Base and modified to fit into tcllib)
+#
+# Copyright (c) 2001 by ActiveState Tool Corp.
+# See the file license.terms.
+
+package require Tcl 8
+package provide log 1.2
+
+# ### ### ### ######### ######### #########
+
+namespace eval ::log {
+    namespace export levels lv2longform lv2color lv2priority 
+    namespace export lv2cmd lv2channel lvCompare
+    namespace export lvSuppress lvSuppressLE lvIsSuppressed
+    namespace export lvCmd lvCmdForall
+    namespace export lvChannel lvChannelForall lvColor lvColorForall
+    namespace export log logMsg logError
+
+    # The known log-levels.
+
+    variable levels [list \
+	    emergency \
+	    alert \
+	    critical \
+	    error \
+	    warning \
+	    notice \
+	    info \
+	    debug]
+
+    # Array mapping from all unique prefixes for log levels to their
+    # corresponding long form.
+
+    # *future* Use a procedure from 'textutil' to calculate the
+    #          prefixes and to fill the map.
+
+    variable  levelMap
+    array set levelMap {
+	a		alert
+	al		alert
+	ale		alert
+	aler		alert
+	alert		alert
+	c		critical
+	cr		critical
+	cri		critical
+	crit		critical
+	criti		critical
+	critic		critical
+	critica		critical
+	critical	critical
+	d		debug
+	de		debug
+	deb		debug
+	debu		debug
+	debug		debug
+	em		emergency
+	eme		emergency
+	emer		emergency
+	emerg		emergency
+	emerge		emergency
+	emergen		emergency
+	emergenc	emergency
+	emergency	emergency
+	er		error
+	err		error
+	erro		error
+	error		error
+	i		info
+	in		info
+	inf		info
+	info		info
+	n		notice
+	no		notice
+	not		notice
+	noti		notice
+	notic		notice
+	notice		notice
+	w		warning
+	wa		warning
+	war		warning
+	warn		warning
+	warni		warning
+	warnin		warning
+	warning		warning
+    }
+
+    # Map from log-levels to the commands to execute when a message
+    # with that level arrives in the system. The standard command for
+    # all levels is '::log::Puts' which writes the message to either
+    # stdout or stderr, depending on the level. The decision about the
+    # channel is stored in another map and modifiable by the user of
+    # the package.
+
+    variable  cmdMap
+    array set cmdMap {}
+
+    variable lv
+    foreach  lv $levels {set cmdMap($lv) ::log::Puts}
+    unset    lv
+
+    # Map from log-levels to the channels ::log::Puts shall write
+    # messages with that level to. The map can be queried and changed
+    # by the user.
+
+    variable  channelMap
+    array set channelMap {
+	emergency  stderr
+	alert      stderr
+	critical   stderr
+	error      stderr
+	warning    stdout
+	notice     stdout
+	info       stdout
+	debug      stdout
+    }
+
+    # Graphical user interfaces may want to colorize messages based
+    # upon their level. The following array stores a map from levels
+    # to colors. The map can be queried and changed by the user.
+
+    variable  colorMap
+    array set colorMap {
+	emergency red
+	alert     red
+	critical  red
+	error     red
+	warning   yellow
+	notice    seagreen
+	info      {}
+	debug     lightsteelblue
+    }
+
+    # To allow an easy comparison of the relative importance of a
+    # level the following array maps from levels to a numerical
+    # priority. The higher the number the more important the
+    # level. The user cannot change this map (for now). This package
+    # uses the priorities to allow the user to supress messages based
+    # upon their levels.
+
+    variable  priorityMap
+    array set priorityMap {
+	emergency 7
+	alert     6
+	critical  5
+	error     4
+	warning   3
+	notice    2
+	info      1
+	debug     0
+    }
+
+    # The following array is internal and holds the information about
+    # which levels are suppressed, i.e. may not be written.
+    #
+    # 0 - messages with with level are written out.
+    # 1 - messages with this level are suppressed.
+
+    variable  suppressed
+    array set suppressed {
+	emergency 0
+	alert     0
+	critical  0
+	error     0
+	warning   0
+	notice    0
+	info      0
+	debug     0
+    }
+
+    # Internal static information. Map from levels to a string of
+    # spaces. The number of spaces in each string is just enough to
+    # make all level names together with their string of the same
+    # length.
+
+    variable  fill
+    array set fill {
+	emergency ""	alert "    "	critical " "	error "    "
+	warning "  "	notice "   "	info "     "	debug "    "
+    }
+}
+
+
+# log::levels --
+#
+#	Retrieves the names of all known levels.
+#
+# Arguments:
+#	None.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	A list containing the names of all known levels,
+#	alphabetically sorted.
+
+proc ::log::levels {} {
+    variable levels
+    return [lsort $levels]
+}
+
+# log::lv2longform --
+#
+#	Converts any unique abbreviation of a level name to the full
+#	level name.
+#
+# Arguments:
+#	level	The prefix of a level name to convert.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	Returns the full name to the specified abbreviation or an
+#	error.
+
+proc ::log::lv2longform {level} {
+    variable levelMap
+
+    if {[info exists levelMap($level)]} {
+	return $levelMap($level)
+    }
+
+    return -code error "\"$level\" is no unique abbreviation of a level name"
+}
+
+# log::lv2color --
+#
+#	Converts any level name including unique abbreviations to the
+#	corresponding color.
+#
+# Arguments:
+#	level	The level to convert into a color.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	The name of a color or an error.
+
+proc ::log::lv2color {level} {
+    variable colorMap
+    set level [lv2longform $level]
+    return $colorMap($level)
+}
+
+# log::lv2priority --
+#
+#	Converts any level name including unique abbreviations to the
+#	corresponding priority.
+#
+# Arguments:
+#	level	The level to convert into a priority.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	The numerical priority of the level or an error.
+
+proc ::log::lv2priority {level} {
+    variable priorityMap
+    set level [lv2longform $level]
+    return $priorityMap($level)
+}
+
+# log::lv2cmd --
+#
+#	Converts any level name including unique abbreviations to the
+#	command prefix used to write messages with that level.
+#
+# Arguments:
+#	level	The level to convert into a command prefix.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	A string containing a command prefix or an error.
+
+proc ::log::lv2cmd {level} {
+    variable cmdMap
+    set level [lv2longform $level]
+    return $cmdMap($level)
+}
+
+# log::lv2channel --
+#
+#	Converts any level name including unique abbreviations to the
+#	channel used by ::log::Puts to write messages with that level.
+#
+# Arguments:
+#	level	The level to convert into a channel.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	A string containing a channel handle or an error.
+
+proc ::log::lv2channel {level} {
+    variable channelMap
+    set level [lv2longform $level]
+    return $channelMap($level)
+}
+
+# log::lvCompare --
+#
+#	Compares two levels (including unique abbreviations) with
+#	respect to their priority. This command can be used by the
+#	-command option of lsort.
+#
+# Arguments:
+#	level1	The first of the levels to compare.
+#	level2	The second of the levels to compare.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	One of -1, 0 or 1 or an error. A result of -1 signals that
+#	level1 is of less priority than level2. 0 signals that both
+#	levels have the same priority. 1 signals that level1 has
+#	higher priority than level2.
+
+proc ::log::lvCompare {level1 level2} {
+    variable priorityMap
+
+    set level1 $priorityMap([lv2longform $level1])
+    set level2 $priorityMap([lv2longform $level2])
+
+    if {$level1 < $level2} {
+	return -1
+    } elseif {$level1 > $level2} {
+	return 1
+    } else {
+	return 0
+    }
+}
+
+# log::lvSuppress --
+#
+#	(Un)suppresses the output of messages having the specified
+#	level. Unique abbreviations for the level are allowed here
+#	too.
+#
+# Arguments:
+#	level		The name of the level to suppress or
+#			unsuppress. Unique abbreviations are allowed
+#			too.
+#	suppress	Boolean flag. Optional. Defaults to the value
+#			1, which means to suppress the level. The
+#			value 0 on the other hand unsuppresses the
+#			level.
+#
+# Side Effects:
+#	See above.
+#
+# Results:
+#	None.
+
+proc ::log::lvSuppress {level {suppress 1}} {
+    variable suppressed
+    set level [lv2longform $level]
+
+    switch -exact -- $suppress {
+	0 - 1 {} default {
+	    return -code error "\"$suppress\" is not a member of \{0, 1\}"
+	}
+    }
+
+    set suppressed($level) $suppress
+    return
+}
+
+# log::lvSuppressLE --
+#
+#	(Un)suppresses the output of messages having the specified
+#	level or one of lesser priority. Unique abbreviations for the
+#	level are allowed here too.
+#
+# Arguments:
+#	level		The name of the level to suppress or
+#			unsuppress. Unique abbreviations are allowed
+#			too.
+#	suppress	Boolean flag. Optional. Defaults to the value
+#			1, which means to suppress the specified
+#			levels. The value 0 on the other hand
+#			unsuppresses the levels.
+#
+# Side Effects:
+#	See above.
+#
+# Results:
+#	None.
+
+proc ::log::lvSuppressLE {level {suppress 1}} {
+    variable suppressed
+    variable levels
+    variable priorityMap
+
+    set level [lv2longform $level]
+
+    switch -exact -- $suppress {
+	0 - 1 {} default {
+	    return -code error "\"$suppress\" is not a member of \{0, 1\}"
+	}
+    }
+
+    set prio  [lv2priority $level]
+
+    foreach l $levels {
+	if {$priorityMap($l) <= $prio} {
+	    set suppressed($l) $suppress
+	}
+    }
+    return
+}
+
+# log::lvIsSuppressed --
+#
+#	Asks the package wether the specified level is currently
+#	suppressed. Unique abbreviations of level names are allowed.
+#
+# Arguments:
+#	level	The level to query.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	None.
+
+proc ::log::lvIsSuppressed {level} {
+    variable suppressed
+    set level [lv2longform $level]
+    return $suppressed($level)
+}
+
+# log::lvCmd --
+#
+#	Defines for the specified level with which command to write
+#	the messages having this level. Unique abbreviations of level
+#	names are allowed. The command is actually a command prefix
+#	and this facility will append 2 arguments before calling it,
+#	the level of the message and the message itself, in this
+#	order.
+#
+# Arguments:
+#	level	The level the command prefix is for.
+#	cmd	The command prefix to use for the specified level.
+#
+# Side Effects:
+#	See above.
+#
+# Results:
+#	None.
+
+proc ::log::lvCmd {level cmd} {
+    variable cmdMap
+    set level [lv2longform $level]
+    set cmdMap($level) $cmd
+    return
+}
+
+# log::lvCmdForall --
+#
+#	Defines for all known levels with which command to write the
+#	messages having this level. The command is actually a command
+#	prefix and this facility will append 2 arguments before
+#	calling it, the level of the message and the message itself,
+#	in this order.
+#
+# Arguments:
+#	cmd	The command prefix to use for all levels.
+#
+# Side Effects:
+#	See above.
+#
+# Results:
+#	None.
+
+proc ::log::lvCmdForall {cmd} {
+    variable cmdMap
+    variable levels
+
+    foreach l $levels {
+	set cmdMap($l) $cmd
+    }
+    return
+}
+
+# log::lvChannel --
+#
+#	Defines for the specified level into which channel ::log::Puts
+#	(the standard command) shall write the messages having this
+#	level. Unique abbreviations of level names are allowed. The
+#	command is actually a command prefix and this facility will
+#	append 2 arguments before calling it, the level of the message
+#	and the message itself, in this order.
+#
+# Arguments:
+#	level	The level the channel is for.
+#	chan	The channel to use for the specified level.
+#
+# Side Effects:
+#	See above.
+#
+# Results:
+#	None.
+
+proc ::log::lvChannel {level chan} {
+    variable channelMap
+    set level [lv2longform $level]
+    set channelMap($level) $chan
+    return
+}
+
+# log::lvChannelForall --
+#
+#	Defines for all known levels with which which channel
+#	::log::Puts (the standard command) shall write the messages
+#	having this level. The command is actually a command prefix
+#	and this facility will append 2 arguments before calling it,
+#	the level of the message and the message itself, in this
+#	order.
+#
+# Arguments:
+#	chan	The channel to use for all levels.
+#
+# Side Effects:
+#	See above.
+#
+# Results:
+#	None.
+
+proc ::log::lvChannelForall {chan} {
+    variable channelMap
+    variable levels
+
+    foreach l $levels {
+	set channelMap($l) $chan
+    }
+    return
+}
+
+# log::lvColor --
+#
+#	Defines for the specified level the color to return for it in
+#	a call to ::log::lv2color. Unique abbreviations of level names
+#	are allowed.
+#
+# Arguments:
+#	level	The level the color is for.
+#	color	The color to use for the specified level.
+#
+# Side Effects:
+#	See above.
+#
+# Results:
+#	None.
+
+proc ::log::lvColor {level color} {
+    variable colorMap
+    set level [lv2longform $level]
+    set colorMap($level) $color
+    return
+}
+
+# log::lvColorForall --
+#
+#	Defines for all known levels the color to return for it in a
+#	call to ::log::lv2color. Unique abbreviations of level names
+#	are allowed.
+#
+# Arguments:
+#	color	The color to use for all levels.
+#
+# Side Effects:
+#	See above.
+#
+# Results:
+#	None.
+
+proc ::log::lvColorForall {color} {
+    variable colorMap
+    variable levels
+
+    foreach l $levels {
+	set colorMap($l) $color
+    }
+    return
+}
+
+# log::logarray --
+#
+#	Similar to parray, except that the contents of the array
+#	printed out through the log system instead of directly
+#	to stdout.
+#
+#	See also 'log::log' for a general explanation
+#
+# Arguments:
+#	level		The level of the message.
+#	arrayvar	The name of the array varaibe to dump
+#	pattern		Optional pattern to restrict the dump
+#			to certain elements in the array.
+#
+# Side Effects:
+#	See above.
+#
+# Results:
+#	None.
+
+proc ::log::logarray {level arrayvar {pattern *}} {
+    variable cmdMap
+
+    if {[lvIsSuppressed $level]} {
+	# Ignore messages for suppressed levels.
+	return
+    }
+
+    set level [lv2longform $level]
+
+    set cmd $cmdMap($level)
+    if {$cmd == {}} {
+	# Ignore messages for levels without a command
+	return
+    }
+
+    upvar 1 $arrayvar array
+    if {![array exists array]} {
+        error "\"$arrayvar\" isn't an array"
+    }
+    set maxl 0
+    foreach name [lsort [array names array $pattern]] {
+        if {[string length $name] > $maxl} {
+            set maxl [string length $name]
+        }
+    }
+    set maxl [expr {$maxl + [string length $arrayvar] + 2}]
+    foreach name [lsort [array names array $pattern]] {
+        set nameString [format %s(%s) $arrayvar $name]
+
+	eval [linsert $cmd end $level \
+		[format "%-*s = %s" $maxl $nameString $array($name)]]
+    }
+    return
+}
+
+# log::loghex --
+#
+#	Like 'log::log', except that the logged data is assumed to
+#	be binary and is logged as a block of hex numbers.
+#
+#	See also 'log::log' for a general explanation
+#
+# Arguments:
+#	level	The level of the message.
+#	text	Message printed before the hex block
+#	data	Binary data to show as hex.
+#
+# Side Effects:
+#	See above.
+#
+# Results:
+#	None.
+
+proc ::log::loghex {level text data} {
+    variable cmdMap
+
+    if {[lvIsSuppressed $level]} {
+	# Ignore messages for suppressed levels.
+	return
+    }
+
+    set level [lv2longform $level]
+
+    set cmd $cmdMap($level)
+    if {$cmd == {}} {
+	# Ignore messages for levels without a command
+	return
+    }
+
+    # Format the messages and print them.
+
+    set len [string length $data]
+
+    eval [linsert $cmd end $level "$text ($len bytes):"]
+
+    set address ""
+    set hexnums ""
+    set ascii   ""
+
+    for {set i 0} {$i < $len} {incr i} {
+        set v [string index $data $i]
+        binary scan $v H2 hex
+        binary scan $v c  num
+        set num [expr {($num + 0x100) % 0x100}]
+
+        set text .
+        if {$num > 31} {set text $v} 
+
+        if {($i % 16) == 0} {
+            if {$address != ""} {
+                eval [linsert $cmd end $level [format "%4s  %-48s  |%s|" $address $hexnums $ascii]]
+                set address ""
+                set hexnums ""
+                set ascii   ""
+            }
+            append address [format "%04d" $i]
+        }
+        append hexnums "$hex "
+        append ascii   $text
+    }
+    if {$address != ""} {
+	eval [linsert $cmd end $level [format "%4s  %-48s  |%s|" $address $hexnums $ascii]]
+    }
+    eval [linsert $cmd end $level ""]
+    return
+}
+
+# log::log --
+#
+#	Log a message according to the specifications for commands,
+#	channels and suppression. In other words: The command will do
+#	nothing if the specified level is suppressed. If it is not
+#	suppressed the actual logging is delegated to the specified
+#	command. If there is no command specified for the level the
+#	message won't be logged. The standard command ::log::Puts will
+#	write the message to the channel specified for the given
+#	level. If no channel is specified for the level the message
+#	won't be logged. Unique abbreviations of level names are
+#	allowed. Errors in the actual logging command are *not*
+#	catched, but propagated to the caller, as they may indicate
+#	misconfigurations of the log facility or errors in the callers
+#	code itself.
+#
+# Arguments:
+#	level	The level of the message.
+#	text	The message to log.
+#
+# Side Effects:
+#	See above.
+#
+# Results:
+#	None.
+
+proc ::log::log {level text} {
+    variable cmdMap
+
+    if {[lvIsSuppressed $level]} {
+	# Ignore messages for suppressed levels.
+	return
+    }
+
+    set level [lv2longform $level]
+
+    set cmd $cmdMap($level)
+    if {$cmd == {}} {
+	# Ignore messages for levels without a command
+	return
+    }
+
+    # Delegate actual logging to the command.
+    # Handle multi-line messages correctly.
+
+    foreach line [split $text \n] {
+	eval [linsert $cmd end $level $line]
+    }
+    return
+}
+
+# log::logMsg --
+#
+#	Convenience wrapper around ::log::log. Equivalent to
+#	'::log::log info text'.
+#
+# Arguments:
+#	text	The message to log.
+#
+# Side Effects:
+#	See ::log::log.
+#
+# Results:
+#	None.
+
+proc ::log::logMsg {text} {
+    log info $text
+}
+
+# log::logError --
+#
+#	Convenience wrapper around ::log::log. Equivalent to
+#	'::log::log error text'.
+#
+# Arguments:
+#	text	The message to log.
+#
+# Side Effects:
+#	See ::log::log.
+#
+# Results:
+#	None.
+
+proc ::log::logError {text} {
+    log error $text
+}
+
+
+# log::Puts --
+#
+#	Standard log command, writing messages and levels to
+#	user-specified channels. Assumes that the supression checks
+#	were done by the caller. Expects full level names,
+#	abbreviations are *not allowed*.
+#
+# Arguments:
+#	level	The level of the message. 
+#	text	The message to log.
+#
+# Side Effects:
+#	Writes into channels.
+#
+# Results:
+#	None.
+
+proc ::log::Puts {level text} {
+    variable channelMap
+    variable fill
+
+    set chan $channelMap($level)
+    if {$chan == {}} {
+	# Ignore levels without channel.
+	return
+    }
+
+    puts $chan "$level$fill($level) $text"
+    return
+}
+
+# ### ### ### ######### ######### #########
+## Initialization code. Disable logging for the lower levels by
+## default.
+
+## log::lvSuppressLE emergency
+log::lvSuppressLE warning
diff --git a/lib/log/logger.tcl b/lib/log/logger.tcl
new file mode 100644
index 0000000..7e69481
--- /dev/null
+++ b/lib/log/logger.tcl
@@ -0,0 +1,1206 @@
+# logger.tcl --
+#
+#   Tcl implementation of a general logging facility.
+#
+# Copyright (c) 2003      by David N. Welton <davidw@dedasys.com>
+# Copyright (c) 2004-2007 by Michael Schlenker <mic42@users.sourceforge.net>
+# Copyright (c) 2006      by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# See the file license.terms.
+
+# The logger package provides an 'object oriented' log facility that
+# lets you have trees of services, that inherit from one another.
+# This is accomplished through the use of Tcl namespaces.
+
+
+package require Tcl 8.2
+package provide logger 0.8
+
+namespace eval ::logger {
+    namespace eval tree {}
+    namespace export init enable disable services servicecmd import
+
+    # The active services.
+    variable services {}
+
+    # The log 'levels'.
+    variable levels [list debug info notice warn error critical alert emergency]
+    
+    # The default global log level used for new logging services
+    variable enabled "debug"
+
+    # Tcl return codes (in numeric order)
+    variable RETURN_CODES   [list "ok" "error" "return" "break" "continue"]
+}
+
+# ::logger::_nsExists --
+#
+#   Workaround for missing namespace exists in Tcl 8.2 and 8.3.
+#
+
+if {[package vcompare [package provide Tcl] 8.4] < 0} {
+    proc ::logger::_nsExists {ns} {
+        expr {![catch {namespace parent $ns}]}
+    }
+} else {
+    proc ::logger::_nsExists {ns} {
+        namespace exists $ns
+    }
+}
+
+# ::logger::_cmdPrefixExists --
+#
+# Utility function to check if a given callback prefix exists,
+# this should catch all oddities in prefix names, including spaces, 
+# glob patterns, non normalized namespaces etc.
+#
+# Arguments:
+#   prefix - The command prefix to check
+#   
+# Results:
+#   1 or 0 for yes or no
+#
+proc ::logger::_cmdPrefixExists {prefix} {
+    set cmd [lindex $prefix 0]
+    set full [namespace eval :: namespace which [list $cmd]]
+    if {[string equal $full ""]} {return 0} else {return 1}
+    # normalize namespaces
+    set ns [namespace qualifiers $cmd]
+    set cmd ${ns}::[namespace tail $cmd]
+    set matches [::info commands ${ns}::*]
+    if {[lsearch -exact $matches $cmd] != -1} {return 1}
+    return 0
+}
+
+# ::logger::walk --
+#
+#   Walk namespaces, starting in 'start', and evaluate 'code' in
+#   them.
+#
+# Arguments:
+#   start - namespace to start in.
+#   code - code to execute in namespaces walked.
+#
+# Side Effects:
+#   Side effects of code executed.
+#
+# Results:
+#   None.
+
+proc ::logger::walk { start code } {
+    set children [namespace children $start]
+    foreach c $children {
+    logger::walk $c $code
+    namespace eval $c $code
+    }
+}
+
+proc ::logger::init {service} {
+    variable levels
+    variable services
+    variable enabled
+        
+    # We create a 'tree' namespace to house all the services, so
+    # they are in a 'safe' namespace sandbox, and won't overwrite
+    # any commands.
+    namespace eval tree::${service} {
+        variable service
+        variable levels
+        variable oldname
+        variable enabled
+    }
+
+    lappend services $service
+
+    set [namespace current]::tree::${service}::service $service
+    set [namespace current]::tree::${service}::levels $levels
+    set [namespace current]::tree::${service}::oldname $service
+    set [namespace current]::tree::${service}::enabled $enabled
+    
+    namespace eval tree::${service} {
+    # Callback to use when the service in question is shut down.
+    variable delcallback [namespace current]::no-op
+
+    # Callback when the loglevel is changed
+    variable levelchangecallback [namespace current]::no-op
+    
+    # State variable to decide when to call levelcallback
+    variable inSetLevel 0
+    
+    # The currently configured levelcommands
+    variable lvlcmds 
+    array set lvlcmds {}
+
+    # List of procedures registered via the trace command
+    variable traceList ""
+
+    # Flag indicating whether or not tracing is currently enabled
+    variable tracingEnabled 0
+
+    # We use this to disable a service completely.  In Tcl 8.4
+    # or greater, by using this, disabled log calls are a
+    # no-op!
+
+    proc no-op args {}
+
+
+    proc stdoutcmd {level text} {
+        variable service
+        puts "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'"
+    }
+
+    proc stderrcmd {level text} {
+        variable service
+        puts stderr "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'"
+    }
+
+
+    # setlevel --
+    #
+    #   This command differs from enable and disable in that
+    #   it disables all the levels below that selected, and
+    #   then enables all levels above it, which enable/disable
+    #   do not do.
+    #
+    # Arguments:
+    #   lv - the level, as defined in $levels.
+    #
+    # Side Effects:
+    #   Runs disable for the level, and then enable, in order
+    #   to ensure that all levels are set correctly.
+    #
+    # Results:
+    #   None.
+
+
+    proc setlevel {lv} {
+        variable inSetLevel 1
+        set oldlvl [currentloglevel]
+        
+        # do not allow enable and disable to do recursion
+        if {[catch {
+            disable $lv 0
+            set newlvl [enable $lv 0]
+        } msg] == 1} {
+            return -code error -errorcode $::errorCode $msg
+        }
+        # do the recursion here
+        logger::walk [namespace current] [list setlevel $lv]
+        
+        set inSetLevel 0
+        lvlchangewrapper $oldlvl $newlvl
+        return
+    }
+
+    # enable --
+    #
+    #   Enable a particular 'level', and above, for the
+    #   service, and its 'children'.
+    #
+    # Arguments:
+    #   lv - the level, as defined in $levels.
+    #
+    # Side Effects:
+    #   Enables logging for the particular level, and all
+    #   above it (those more important).  It also walks
+    #   through all services that are 'children' and enables
+    #   them at the same level or above.
+    #
+    # Results:
+    #   None.
+
+    proc enable {lv {recursion 1}} {
+        variable levels
+        set lvnum [lsearch -exact $levels $lv]
+        if { $lvnum == -1 } {
+        return -code error "Invalid level '$lv' - levels are $levels"
+        }
+
+        variable enabled
+        set newlevel $enabled
+        set elnum [lsearch -exact $levels $enabled]
+        if {($elnum == -1) || ($elnum > $lvnum)} {
+            set newlevel $lv
+        }
+                
+        variable service
+        while { $lvnum <  [llength $levels] } {
+        interp alias {} [namespace current]::[lindex $levels $lvnum] \
+            {} [namespace current]::[lindex $levels $lvnum]cmd
+        incr lvnum
+        }
+        
+        if {$recursion} {
+            logger::walk [namespace current] [list enable $lv]
+        }
+        lvlchangewrapper $enabled $newlevel
+        set enabled $newlevel
+    }
+
+    # disable --
+    #
+    #   Disable a particular 'level', and below, for the
+    #   service, and its 'children'.
+    #
+    # Arguments:
+    #   lv - the level, as defined in $levels.
+    #
+    # Side Effects:
+    #   Disables logging for the particular level, and all
+    #   below it (those less important).  It also walks
+    #   through all services that are 'children' and disables
+    #   them at the same level or below.
+    #
+    # Results:
+    #   None.
+
+    proc disable {lv {recursion 1}} {
+        variable levels
+        set lvnum [lsearch -exact $levels $lv]
+        if { $lvnum == -1 } {
+        return -code error "Invalid level '$lv' - levels are $levels"
+        }
+
+        variable enabled
+        set newlevel $enabled
+        set elnum [lsearch -exact $levels $enabled]
+        if {($elnum > -1) && ($elnum <= $lvnum)} {
+            if {$lvnum+1 >= [llength $levels]} {
+                set newlevel "none"
+            } else {
+                set newlevel [lindex $levels [expr {$lvnum+1}]]
+            }
+        }
+        
+        while { $lvnum >= 0 } {
+        
+        interp alias {} [namespace current]::[lindex $levels $lvnum] {} \
+            [namespace current]::no-op
+        incr lvnum -1
+        }
+        if {$recursion} {
+            logger::walk [namespace current] [list disable $lv]
+        }
+        lvlchangewrapper $enabled $newlevel
+        set enabled $newlevel
+    }
+
+    # currentloglevel --
+    #
+    #   Get the currently enabled log level for this service.
+    #
+    # Arguments:
+    #   none
+    #
+    # Side Effects:
+    #   none
+    #
+    # Results:
+    #   current log level
+    #
+
+    proc currentloglevel {} {
+        variable enabled
+        return $enabled
+    }
+
+    # lvlchangeproc --
+    #
+    #   Set or introspect a callback for when the logger instance 
+    #   changes its loglevel.
+    #
+    # Arguments:
+    #   cmd - the Tcl command to call, it is called with two parameters, old and new log level.
+    #   or none for introspection
+    #
+    # Side Effects:
+    #   None.
+    #
+    # Results:
+    #   If no arguments are given return the current callback cmd.
+
+    proc lvlchangeproc {args} {
+        variable levelchangecallback
+        
+        switch -exact -- [llength [::info level 0]] {
+                1   {return $levelchangecallback}
+                2   {
+                     if {[::logger::_cmdPrefixExists [lindex $args 0]]} {
+                        set levelchangecallback [lindex $args 0]
+                     } else {
+                        return -code error "Invalid cmd '[lindex $args 0]' - does not exist"
+                     }    
+                    }
+                default {
+                    return -code error "Wrong # of arguments. Usage: \${log}::lvlchangeproc ?cmd?"
+                }
+        }
+    }
+
+    proc lvlchangewrapper {old new} {
+        variable inSetLevel
+        
+        # we are called after disable and enable are finished 
+        if {$inSetLevel} {return}
+        
+        # no action if level does not change
+        if {[string equal $old $new]} {return}
+        
+        variable levelchangecallback
+        # no action if levelchangecallback isn't a valid command
+        if {[::logger::_cmdPrefixExists $levelchangecallback]} {
+        catch {
+            uplevel \#0 [linsert $levelchangecallback end $old $new]
+        }
+        }
+    }
+    
+    # logproc --
+    #
+    #   Command used to create a procedure that is executed to
+    #   perform the logging.  This could write to disk, out to
+    #   the network, or something else.
+    #   If two arguments are given, use an existing command.
+    #   If three arguments are given, create a proc.
+    #
+    # Arguments:
+    #   lv - the level to log, which must be one of $levels.
+    #   args - either zero, one or two arguments.
+    #          if zero this returns the current command registered 
+    #          if one, this is a cmd name that is called for this level
+    #          if two, these are an argument and proc body
+    #
+    # Side Effects:
+    #   Creates a logging command to take care of the details
+    #   of logging an event.
+    #
+    # Results:
+    #   If called with zero length args, returns the name of the currently
+    #   configured logging procedure.
+    #   
+    #
+
+    proc logproc {lv args} {
+        variable levels
+        variable lvlcmds
+        
+        set lvnum [lsearch -exact $levels $lv]
+        if { ($lvnum == -1) && ($lv != "trace") } {
+        return -code error "Invalid level '$lv' - levels are $levels"
+        }
+        switch -exact -- [llength $args] {
+        0  {
+            return $lvlcmds($lv)
+           }
+        1  {
+            set cmd [lindex $args 0]
+            if {[string equal "[namespace current]::${lv}cmd" $cmd]} {return} 
+            if {[llength [::info commands $cmd]]} {
+                proc ${lv}cmd {args} "uplevel 1 \[list $cmd \[lindex \$args end\]\]"
+            } else {
+                return -code error "Invalid cmd '$cmd' - does not exist"
+            }
+            set lvlcmds($lv) $cmd
+        }
+        2  {
+            foreach {arg body} $args {break}
+            proc ${lv}cmd {args} "_setservicename \$args; 
+                                      set val \[${lv}customcmd \[lindex \$args end\]\] ; 
+                                      _restoreservice; set val"
+            proc ${lv}customcmd $arg $body
+            set lvlcmds($lv) [namespace current]::${lv}customcmd
+        }
+        default {
+            return -code error "Usage: \${log}::logproc level ?cmd?\nor \${log}::logproc level argname body"
+        }
+        }
+    }
+
+
+    # delproc --
+    #
+    #   Set or introspect a callback for when the logger instance 
+    #   is deleted.
+    #
+    # Arguments:
+    #   cmd - the Tcl command to call.
+    #   or none for introspection
+    #
+    # Side Effects:
+    #   None.
+    #
+    # Results:
+    #   If no arguments are given return the current callback cmd.
+
+    proc delproc {args} {
+        variable delcallback
+        
+        switch -exact -- [llength [::info level 0]] {
+                1   {return $delcallback}
+                2   { if {[::logger::_cmdPrefixExists [lindex $args 0]]} {
+                            set delcallback [lindex $args 0]
+                      } else {
+                        return -code error "Invalid cmd '[lindex $args 0]' - does not exist"                      
+                      }
+                    }
+                default {
+                    return -code error "Wrong # of arguments. Usage: \${log}::delproc ?cmd?"
+                }
+        }
+    }
+
+
+    # delete --
+    #
+    #   Delete the namespace and its children.
+
+    proc delete {} {
+        variable delcallback
+        variable service
+        
+        logger::walk [namespace current] delete
+        if {[::logger::_cmdPrefixExists $delcallback]} {
+             uplevel \#0 [lrange $delcallback 0 end]  
+        } 
+        # clean up the global services list
+        set idx [lsearch -exact [logger::services] $service]
+        if {$idx !=-1} {
+            set ::logger::services [lreplace [logger::services] $idx $idx]
+        }
+        
+        namespace delete [namespace current]
+        
+    }
+
+    # services --
+    #
+    #   Return all child services 
+    
+    proc services {} {
+        variable service
+        
+        set children [list]
+        foreach srv [logger::services] {
+            if {[string match "${service}::*" $srv]} {
+                lappend children $srv
+            }
+        }
+        return $children
+    }
+
+    # servicename --
+    #
+    #   Return the name of the service
+    
+    proc servicename {} {
+        variable service
+        return $service
+    }
+    
+    proc _setservicename {arg} {
+        variable service
+        variable oldname
+        if {[llength $arg] <= 1} {
+            return
+        } else {
+            set oldname $service
+            set service [lindex $arg end-1]
+        }
+    }
+        
+    proc _restoreservice {} {
+        variable service
+        variable oldname
+        set service $oldname
+        return
+    }
+    
+    proc trace { action args } {
+        variable service
+
+        # Allow other boolean values (true, false, yes, no, 0, 1) to be used
+        # as synonymns for "on" and "off".
+
+        if {[string is boolean $action]} {
+            set xaction [expr {($action && 1) ? "on" : "off"}]
+        } else {
+            set xaction $action
+        }
+
+        # Check for required arguments for actions/subcommands and dispatch
+        # to the appropriate procedure.
+
+        switch -- $xaction {
+            "status" {
+                return [uplevel 1 [list logger::_trace_status $service $args]]
+            }
+            "on" {
+                if {[llength $args]} {
+                    return -code error "wrong # args: should be \"trace on\""
+                }
+                return [logger::_trace_on $service]
+            }
+            "off" {
+                if {[llength $args]} {
+                    return -code error "wrong # args: should be \"trace off\""
+                }
+                return [logger::_trace_off $service]
+            }
+            "add" {
+                if {![llength $args]} {
+                    return -code error \
+                        "wrong # args: should be \"trace add ?-ns? <proc> ...\""
+                }
+                return [uplevel 1 [list ::logger::_trace_add $service $args]]
+            }
+            "remove" {
+                if {![llength $args]} {
+                    return -code error \
+                        "wrong # args: should be \"trace remove ?-ns? <proc> ...\""
+                }
+                return [uplevel 1 [list ::logger::_trace_remove $service $args]]
+            }
+
+            default {
+	        return -code error \
+                    "Invalid action \"$action\": must be status, add, remove,\
+                    on, or off"
+            }
+        }
+    }
+
+    # Walk the parent service namespaces to see first, if they
+    # exist, and if any are enabled, and then, as a
+    # consequence, enable this one
+    # too.
+
+    enable $enabled
+    variable parent [namespace parent]
+    while {[string compare $parent "::logger::tree"]} {
+        # If the 'enabled' variable doesn't exist, create the
+        # whole thing.
+        if { ! [::info exists ${parent}::enabled] } {
+        
+        logger::init [string range $parent 16 end]
+        }
+        set enabled [set ${parent}::enabled]
+        enable $enabled
+        set parent [namespace parent $parent]
+    }
+    }
+
+    # Now create the commands for different levels.
+
+    namespace eval tree::${service} {
+    set parent [namespace parent]
+
+    # We 'inherit' the commands from the parents.  This
+    # means that, if you want to share the same methods with
+    # children, they should be instantiated after the parent's
+    # methods have been defined.
+    if {[string compare $parent "::logger::tree"]} {
+        foreach lvl [::logger::levels] {
+            # OPTIMIZE: do not allow multiple aliases in the hierarchy
+            #           they can always be replaced by more efficient
+            #           direct aliases to the target procs.
+            interp alias {} [namespace current]::${lvl}cmd {} ${parent}::${lvl}cmd $service
+        }
+        # inherit the starting loglevel of the parent service
+        setlevel [${parent}::currentloglevel]
+
+    } else {
+        foreach lvl [concat [::logger::levels] "trace"] {
+            proc ${lvl}cmd {args} "_setservicename \$args ; 
+                                   set val \[stdoutcmd $lvl \[lindex \$args end\]\] ; 
+                                   _restoreservice; set val"
+            set lvlcmds($lvl) [namespace current]::${lvl}cmd
+        }
+    }
+    }
+    
+    
+    return ::logger::tree::${service}
+}
+
+# ::logger::services --
+#
+#   Returns a list of all active services.
+#
+# Arguments:
+#   None.
+#
+# Side Effects:
+#   None.
+#
+# Results:
+#   List of active services.
+
+proc ::logger::services {} {
+    variable services
+    return $services
+}
+
+# ::logger::enable --
+#
+#   Global enable for a certain level.  NOTE - this implementation
+#   isn't terribly effective at the moment, because it might hit
+#   children before their parents, who will then walk down the
+#   tree attempting to disable the children again.
+#
+# Arguments:
+#   lv - level above which to enable logging.
+#
+# Side Effects:
+#   Enables logging in a given level, and all higher levels.
+#
+# Results:
+#   None.
+
+proc ::logger::enable {lv} {
+    variable services
+    if {[catch {
+        foreach sv $services {
+        ::logger::tree::${sv}::enable $lv
+        }
+    } msg] == 1} {
+        return -code error -errorcode $::errorCode $msg
+    }
+}
+
+proc ::logger::disable {lv} {
+    variable services
+    if {[catch {
+        foreach sv $services {
+        ::logger::tree::${sv}::disable $lv
+        }
+    } msg] == 1} {
+        return -code error -errorcode $::errorCode $msg
+    }
+}
+
+proc ::logger::setlevel {lv} {
+    variable services
+    variable enabled
+    variable levels
+    if {[lsearch -exact $levels $lv] == -1} {
+        return -code error "Invalid level '$lv' - levels are $levels"
+    } 
+    set enabled $lv    
+    if {[catch {
+        foreach sv $services {
+        ::logger::tree::${sv}::setlevel $lv
+        }
+    } msg] == 1} {
+        return -code error -errorcode $::errorCode $msg
+    }
+}
+
+# ::logger::levels --
+#
+#   Introspect the available log levels.  Provided so a caller does
+#   not need to know implementation details or code the list
+#   himself.
+#
+# Arguments:
+#   None.
+#
+# Side Effects:
+#   None.
+#
+# Results:
+#   levels - The list of valid log levels accepted by enable and disable
+
+proc ::logger::levels {} {
+    variable levels
+    return $levels
+}
+
+# ::logger::servicecmd --
+#
+#   Get the command token for a given service name.
+#
+# Arguments:
+#   service - name of the service.
+#
+# Side Effects:
+#   none
+#
+# Results:
+#   log - namespace token for this service
+
+proc ::logger::servicecmd {service} {
+    variable services
+    if {[lsearch -exact $services $service] == -1} {
+        return -code error "Service \"$service\" does not exist."
+    }
+    return "::logger::tree::${service}"
+}
+
+# ::logger::import --
+#
+#   Import the logging commands.
+#
+# Arguments:
+#   service - name of the service.
+#
+# Side Effects:
+#   creates aliases in the target namespace
+#
+# Results:
+#   none
+
+proc ::logger::import {args} {
+    variable services
+    
+    if {[llength $args] == 0 || [llength $args] > 7} {
+    return -code error "Wrong # of arguments: \"logger::import ?-all?\
+                        ?-force?\
+                        ?-prefix prefix? ?-namespace namespace? service\""
+    }
+    
+    # process options
+    #
+    set import_all 0
+    set force 0
+    set prefix ""
+    set ns [uplevel 1 namespace current]
+    while {[llength $args] > 1} {
+        set opt [lindex $args 0]
+        set args [lrange $args 1 end]
+        switch  -exact -- $opt {
+            -all    { set import_all 1}
+            -prefix { set prefix [lindex $args 0]
+                      set args [lrange $args 1 end]        
+                    }
+            -namespace {
+                      set ns [lindex $args 0]
+                      set args [lrange $args 1 end]
+            }
+            -force {
+                     set force 1
+            }
+            default {
+                return -code error "Unknown argument: \"$opt\" :\nUsage:\
+                \"logger::import ?-all? ?-force?\
+                        ?-prefix prefix? ?-namespace namespace? service\""
+            }
+        }
+    }
+    
+    #
+    # build the list of commands to import
+    #
+    
+    set cmds [logger::levels]
+    lappend cmds "trace"
+    if {$import_all} {
+        lappend cmds setlevel enable disable logproc delproc services 
+        lappend cmds servicename currentloglevel delete
+    }
+    
+    #
+    # check the service argument
+    #
+    
+    set service [lindex $args 0]
+    if {[lsearch -exact $services $service] == -1} {
+            return -code error "Service \"$service\" does not exist."
+    }
+
+    #
+    # setup the namespace for the import
+    #
+
+    set sourcens [logger::servicecmd $service]     
+    set localns  [uplevel 1 namespace current]
+    
+    if {[string match ::* $ns]} {
+        set importns $ns
+    } else {
+        set importns ${localns}::$ns
+    }    
+
+    # fake namespace exists for Tcl 8.2 - 8.3
+    if {![_nsExists $importns]} {
+        namespace eval $importns {}
+    } 
+
+    
+    #
+    # prepare the import
+    #
+    
+    set imports ""
+    foreach cmd $cmds {
+        set cmdname ${importns}::${prefix}$cmd
+        set collision [llength [info commands $cmdname]]
+        if {$collision && !$force} {
+            return -code error "can't import command \"$cmdname\": already exists"
+        }
+        lappend imports ${importns}::${prefix}$cmd ${sourcens}::${cmd}
+    }
+    
+    #
+    # and execute the aliasing after checking all is well
+    #
+    
+    foreach {target source} $imports {
+        proc $target {args} "uplevel 1 \[linsert \$args 0 $source \]"
+    }
+}
+
+# ::logger::initNamespace --
+#
+#   Creates a logger for the specified namespace and makes the log
+#   commands available to said namespace as well. Allows the initial
+#   setting of a default log level.
+#
+# Arguments:
+#   ns    - Namespace to initialize, is also the service name, modulo a ::-prefix
+#   level - Initial log level, optional, defaults to 'warn'.
+#
+# Side Effects:
+#   creates aliases in the target namespace
+#
+# Results:
+#   none
+
+proc ::logger::initNamespace {ns {level warn}} {
+    set service [string trimleft $ns :]
+    namespace eval $ns [list ::logger::init $service]
+    namespace eval $ns [list ::logger::import -force -all -namespace log $service]
+    namespace eval $ns [list log::setlevel $level]
+    return
+}
+
+# This procedure handles the "logger::trace status" command.  Given no
+# arguments, returns a list of all procedures that have been registered
+# via "logger::trace add".  Given one or more procedure names, it will
+# return 1 if all were registered, or 0 if any were not.
+
+proc ::logger::_trace_status { service procList } {
+    upvar #0 ::logger::tree::${service}::traceList traceList
+
+    # If no procedure names were given, just return the registered list
+
+    if {![llength $procList]} {
+        return $traceList
+    }
+
+    # Get caller's namespace for qualifying unqualified procedure names
+
+    set caller_ns [uplevel 1 namespace current]
+    set caller_ns [string trimright $caller_ns ":"]
+
+    # Search for any specified proc names that are *not* registered
+
+    foreach procName $procList {
+        # Make sure the procedure namespace is qualified
+
+        if {![string match "::*" $procName]} {
+            set procName ${caller_ns}::$procName
+        }
+
+        # Check if the procedure has been registered for tracing
+
+        if {[lsearch -exact $traceList $procName] == -1} {
+	    return 0
+        }
+    }
+
+    return 1
+}
+
+# This procedure handles the "logger::trace on" command.  If tracing
+# is turned off, it will enable Tcl trace handlers for all of the procedures
+# registered via "logger::trace add".  Does nothing if tracing is already
+# turned on.
+
+proc ::logger::_trace_on { service } {
+    set tcl_version [package provide Tcl]
+
+    if {[package vcompare $tcl_version "8.4"] < 0} {
+        return -code error \
+            "execution tracing is not available in Tcl $tcl_version"
+    }
+
+    namespace eval ::logger::tree::${service} {
+        if {!$tracingEnabled} {
+            set tracingEnabled 1
+            ::logger::_enable_traces $service $traceList
+        }
+    }
+
+    return 1
+}
+
+# This procedure handles the "logger::trace off" command.  If tracing
+# is turned on, it will disable Tcl trace handlers for all of the procedures
+# registered via "logger::trace add", leaving them in the list so they
+# tracing on all of them can be enabled again with "logger::trace on".
+# Does nothing if tracing is already turned off.
+
+proc ::logger::_trace_off { service } {
+    namespace eval ::logger::tree::${service} {
+        if {$tracingEnabled} {
+            ::logger::_disable_traces $service $traceList
+            set tracingEnabled 0
+        }
+    }
+
+    return 1
+}
+
+# This procedure is used by the logger::trace add and remove commands to
+# process the arguments in a common fashion.  If the -ns switch is given
+# first, this procedure will return a list of all existing procedures in
+# all of the namespaces given in remaining arguments.  Otherwise, each
+# argument is taken to be either a pattern for a glob-style search of
+# procedure names or, failing that, a namespace, in which case this
+# procedure returns a list of all the procedures matching the given
+# pattern (or all in the named namespace, if no procedures match).
+
+proc ::logger::_trace_get_proclist { inputList } {
+    set procList ""
+
+    if {[string equal [lindex $inputList 0] "-ns"]} {
+	# Verify that at least one target namespace was supplied
+
+	set inputList [lrange $inputList 1 end]
+	if {![llength $inputList]} {
+	    return -code error "Must specify at least one namespace target"
+	}
+
+	# Rebuild the argument list to contain namespace procedures
+
+	foreach namespace $inputList {
+            # Don't allow tracing of the logger (or child) namespaces
+
+	    if {![string match "::logger::*" $namespace]} {
+		set nsProcList  [::info procs ${namespace}::*]
+                set procList    [concat $procList $nsProcList]
+            }
+	}
+    } else {
+        # Search for procs or namespaces matching each of the specified
+        # patterns.
+
+        foreach pattern $inputList {
+	    set matches [uplevel 1 ::info proc $pattern]
+
+	    if {![llength $matches]} {
+	        if {[uplevel 1 namespace exists $pattern]} {
+		    set matches [::info procs ${pattern}::*]
+	        }
+
+                # Matched procs will be qualified due to above pattern
+
+                set procList [concat $procList $matches]
+            } elseif {[string match "::*" $pattern]} {
+                # Patterns were pre-qualified - add them directly
+
+                set procList [concat $procList $matches]
+            } else {
+                # Qualify each proc with the namespace it was in
+
+                set ns [uplevel 1 namespace current]
+                if {$ns == "::"} {
+                    set ns ""
+                }
+                foreach proc $matches {
+                    lappend procList ${ns}::$proc
+                }
+            }
+        }
+    }
+
+    return $procList
+}
+
+# This procedure handles the "logger::trace add" command.  If the tracing
+# feature is enabled, it will enable the Tcl entry and leave trace handlers
+# for each procedure specified that isn't already being traced.  Each
+# procedure is added to the list of procedures that the logger trace feature
+# should log when tracing is enabled.
+
+proc ::logger::_trace_add { service procList } {
+    upvar #0 ::logger::tree::${service}::traceList traceList
+
+    # Handle -ns switch and glob search patterns for procedure names
+
+    set procList [uplevel 1 [list logger::_trace_get_proclist $procList]]
+
+    # Enable tracing for each procedure that has not previously been
+    # specified via logger::trace add.  If tracing is off, this will just
+    # store the name of the procedure for later when tracing is turned on.
+
+    foreach procName $procList {
+        if {[lsearch -exact $traceList $procName] == -1} {
+            lappend traceList $procName
+            ::logger::_enable_traces $service [list $procName]
+        }
+    }
+}
+
+# This procedure handles the "logger::trace remove" command.  If the tracing
+# feature is enabled, it will remove the Tcl entry and leave trace handlers
+# for each procedure specified.  Each procedure is removed from the list
+# of procedures that the logger trace feature should log when tracing is
+# enabled.
+
+proc ::logger::_trace_remove { service procList } {
+    upvar #0 ::logger::tree::${service}::traceList traceList
+
+    # Handle -ns switch and glob search patterns for procedure names
+
+    set procList [uplevel 1 [list logger::_trace_get_proclist $procList]]
+
+    # Disable tracing for each proc that previously had been specified
+    # via logger::trace add.  If tracing is off, this will just
+    # remove the name of the procedure from the trace list so that it
+    # will be excluded when tracing is turned on.
+
+    foreach procName $procList {
+        set index [lsearch -exact $traceList $procName]
+        if {$index != -1} {
+            set traceList [lreplace $traceList $index $index]
+            ::logger::_disable_traces $service [list $procName]
+        }
+    }
+}
+
+# This procedure enables Tcl trace handlers for all procedures specified.
+# It is used both to enable Tcl's tracing for a single procedure when
+# removed via "logger::trace add", as well as to enable all traces
+# via "logger::trace on".
+
+proc ::logger::_enable_traces { service procList } {
+    upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled
+
+    if {$tracingEnabled} {
+        foreach procName $procList {
+            ::trace add execution $procName enter \
+                [list ::logger::_trace_enter $service]
+            ::trace add execution $procName leave \
+                [list ::logger::_trace_leave $service]
+        }
+    }
+}
+
+# This procedure disables Tcl trace handlers for all procedures specified.
+# It is used both to disable Tcl's tracing for a single procedure when
+# removed via "logger::trace remove", as well as to disable all traces
+# via "logger::trace off".
+
+proc ::logger::_disable_traces { service procList } {
+    upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled
+
+    if {$tracingEnabled} {
+        foreach procName $procList {
+            ::trace remove execution $procName enter \
+                [list ::logger::_trace_enter $service]
+            ::trace remove execution $procName leave \
+                [list ::logger::_trace_leave $service]
+        }
+    }
+}
+
+########################################################################
+# Trace Handlers
+########################################################################
+
+# This procedure is invoked upon entry into a procedure being traced
+# via "logger::trace add" when tracing is enabled via "logger::trace on"
+# to log information about how the procedure was called.
+
+proc ::logger::_trace_enter { service cmd op } {
+    # Parse the command
+    set procName [uplevel 1 namespace origin [lindex $cmd 0]]
+    set args     [lrange $cmd 1 end]
+
+    # Display the message prefix
+    set callerLvl [expr {[::info level] - 1}]
+    set calledLvl [::info level]
+
+    lappend message "proc" $procName
+    lappend message "level" $calledLvl
+    lappend message "script" [uplevel ::info script]
+
+    # Display the caller information
+    set caller ""
+    if {$callerLvl >= 1} {
+	# Display the name of the caller proc w/prepended namespace
+	catch {
+	    set callerProcName [lindex [::info level $callerLvl] 0]
+	    set caller [uplevel 2 namespace origin $callerProcName]
+	}
+    }
+
+    lappend message "caller" $caller
+
+    # Display the argument names and values
+    set argSpec [uplevel 1 ::info args $procName]
+    set argList ""
+    if {[llength $argSpec]} {
+	foreach argName $argSpec {
+            lappend argList $argName
+
+	    if {$argName == "args"} {
+                lappend argList $args
+                break
+	    } else {
+	        lappend argList [lindex $args 0]
+	        set args [lrange $args 1 end]
+            }
+	}
+    }
+
+    lappend message "procargs" $argList
+    set message [list $op $message]
+
+    ::logger::tree::${service}::tracecmd $message
+}
+
+# This procedure is invoked upon leaving into a procedure being traced
+# via "logger::trace add" when tracing is enabled via "logger::trace on"
+# to log information about the result of the procedure call.
+
+proc ::logger::_trace_leave { service cmd status rc op } {
+    variable RETURN_CODES
+
+    # Parse the command
+    set procName [uplevel 1 namespace origin [lindex $cmd 0]]
+
+    # Gather the caller information
+    set callerLvl [expr {[::info level] - 1}]
+    set calledLvl [::info level]
+
+    lappend message "proc" $procName "level" $calledLvl
+    lappend message "script" [uplevel ::info script]
+
+    # Get the name of the proc being returned to w/prepended namespace
+    set caller ""
+    catch {
+        set callerProcName [lindex [::info level $callerLvl] 0]
+        set caller [uplevel 2 namespace origin $callerProcName]
+    }
+
+    lappend message "caller" $caller
+
+    # Convert the return code from numeric to verbal
+
+    if {$status < [llength $RETURN_CODES]} {
+        set status [lindex $RETURN_CODES $status]
+    }
+
+    lappend message "status" $status
+    lappend message "result" $rc
+
+    # Display the leave message
+
+    set message [list $op $message]
+    ::logger::tree::${service}::tracecmd $message
+
+    return 1
+}
+
diff --git a/lib/log/loggerAppender.tcl b/lib/log/loggerAppender.tcl
new file mode 100644
index 0000000..6bbd24a
--- /dev/null
+++ b/lib/log/loggerAppender.tcl
@@ -0,0 +1,449 @@
+##Library Header
+#
+# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+#	::logger::appender
+#
+# Purpose:
+#	collection of appenders for tcllib logger
+#
+# Author:
+#	 Aamer Akhter / aakhter@cisco.com
+#
+# Support Alias:
+#       aakhter@cisco.com
+#
+# Usage:
+#	package require logger::appender
+#
+# Description:
+#	set of logger templates
+#      
+# Requirements:
+#       package require logger
+#       package require md5
+#
+# Variables:
+#       namespace   ::loggerExtension::
+#       id:         CVS ID: keyword extraction
+#       version:    current version of package
+#       packageDir: directory where package is located
+#       log:        instance log
+#
+# Notes:
+#       1.	
+#
+# Keywords:
+#	
+#
+# Category: 
+#       
+#
+# End of Header
+
+package require md5
+
+namespace eval ::logger::appender {
+    variable  fgcolor
+    array set fgcolor {
+	red      {31m}
+	red-bold {1;31m}
+	black    {m}
+	blue     {1m}
+	green    {32m}
+	yellow   {33m}
+	cyan     {36m}
+    }
+
+    variable  levelToColor
+    array set levelToColor {
+	debug     cyan
+	info      blue
+	notice    black
+	warn      red
+	error     red
+	critical  red-bold
+	alert     red-bold
+	emergency red-bold
+    }
+}
+
+
+
+##Procedure Header
+# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+#	::logger::appender::console
+#
+# Purpose:
+#	 
+#
+# Synopsis:
+#       ::logger::appender::console -level <level> -service <service> [options]
+#
+# Arguments:
+#       -level <level>
+#            name of level to fill in as 'priority' in log proc
+#       -service <service>
+#            name of service to fill in as 'category' in log proc
+#       -appenderArgs <appenderArgs>
+#            any additional args in list form
+#       -conversionPattern <conversionPattern>
+#            log pattern to use (see genLogProc)
+#       -procName <procName>
+#            explicitly set the proc name
+#       -procNameVar <procNameVar>
+#            name of variable to set in the calling context
+#            variable has name of proc 
+#
+#
+# Return Values:
+#	a runnable command 
+#
+# Description:
+#         
+#
+# Examples:
+#	
+#
+# Notes:
+#	1.
+#
+# End of Procedure Header 
+
+
+proc ::logger::appender::console {args} {
+    set usage {console 
+	?-level level?
+	?-service service? 
+	?-appenderArgs appenderArgs?
+    }
+    set bargs $args
+    set conversionPattern {\[%d\] \[%c\] \[%M\] \[%p\] %m}
+    while {[llength $args] > 1} {
+        set opt [lindex $args 0]
+        set args [lrange $args 1 end]
+        switch  -exact -- $opt {
+            -level { set level [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    -service { set service [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    -appenderArgs {
+		set appenderArgs [lindex $args 0]
+		set args [lrange $args 1 end]
+		set args [concat $args $appenderArgs]
+	    }
+	    -conversionPattern {
+		set conversionPattern [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    -procName {
+		set procName [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    -procNameVar {
+		set procNameVar [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+            default {
+                return -code error [msgcat::mc "Unknown argument: \"%s\" :\nUsage:\
+                %s" $opt $usage]
+            }
+        }
+    }
+    if {![info exists procName]} {
+	set procName [genProcName $bargs]
+    }
+    if {[info exists procNameVar]} {
+	upvar $procNameVar myProcNameVar
+    }
+    set procText \
+	[ ::logger::utils::createLogProc \
+	      -procName $procName \
+	      -conversionPattern $conversionPattern \
+	      -category $service \
+	      -priority $level ]
+    set myProcNameVar $procName
+    return $procText
+}
+
+
+
+##Procedure Header
+# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+#	::logger::appender::colorConsole
+#
+# Purpose:
+#	 
+#
+# Synopsis:
+#       ::logger::appender::console -level <level> -service <service> [options]
+#
+# Arguments:
+#       -level <level>
+#            name of level to fill in as 'priority' in log proc
+#       -service <service>
+#            name of service to fill in as 'category' in log proc
+#       -appenderArgs <appenderArgs>
+#            any additional args in list form
+#       -conversionPattern <conversionPattern>
+#            log pattern to use (see genLogProc)
+#       -procName <procName>
+#            explicitly set the proc name
+#       -procNameVar <procNameVar>
+#            name of variable to set in the calling context
+#            variable has name of proc 
+#
+#
+# Return Values:
+#	a runnable command 
+#
+# Description:
+#       provides colorized logs
+#
+# Examples:
+#	
+#
+# Notes:
+#	1.
+#
+# End of Procedure Header 
+
+
+proc ::logger::appender::colorConsole {args} {
+    variable fgcolor
+    set usage {console 
+	?-level level?
+	?-service service? 
+	?-appenderArgs appenderArgs?
+    }
+    set bargs $args
+    set conversionPattern {\[%d\] \[%c\] \[%M\] \[%p\] %m}
+    upvar 0 ::logger::appender::levelToColor colorMap
+    while {[llength $args] > 1} {
+        set opt [lindex $args 0]
+        set args [lrange $args 1 end]
+        switch  -exact -- $opt {
+            -level { set level [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    -service { set service [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    -appenderArgs {
+		set appenderArgs [lindex $args 0]
+		set args [lrange $args 1 end]
+		set args [concat $args $appenderArgs]
+	    }
+	    -conversionPattern {
+		set conversionPattern [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    -procName {
+		set procName [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    -procNameVar {
+		set procNameVar [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+            default {
+                return -code error [msgcat::mc "Unknown argument: \"%s\" :\nUsage:\
+                %s" $opt $usage]
+            }
+        }
+    }
+    if {![info exists procName]} {
+	set procName [genProcName $bargs]
+    }
+    upvar $procNameVar myProcNameVar
+    if {[info exists level]} {
+	#apply color
+	set colorCode $colorMap($level)
+	append newCPattern {\033\[} $fgcolor($colorCode) $conversionPattern {\033\[0m}
+	set conversionPattern $newCPattern
+    }
+    set procText \
+	[ ::logger::utils::createLogProc \
+	      -procName $procName \
+	      -conversionPattern $conversionPattern \
+	      -category $service \
+	      -priority $level ]
+    set myProcNameVar $procName
+    return $procText
+}
+
+##Procedure Header
+# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+#       ::logger::appender::fileAppend
+#
+# Purpose:
+#
+#
+# Synopsis:
+#       ::logger::appender::fileAppend -level <level> -service <service> -outputChannel <channel> [options]
+#
+# Arguments:
+#       -level <level>
+#            name of level to fill in as 'priority' in log proc
+#       -service <service>
+#            name of service to fill in as 'category' in log proc
+#       -appenderArgs <appenderArgs>
+#            any additional args in list form
+#       -conversionPattern <conversionPattern>
+#            log pattern to use (see genLogProc)
+#       -procName <procName>
+#            explicitly set the proc name
+#       -procNameVar <procNameVar>
+#            name of variable to set in the calling context
+#            variable has name of proc
+#       -outputChannel <channel>
+#            name of output channel (eg stdout, file handle)
+#
+#
+# Return Values:
+#       a runnable command
+#
+# Description:
+#
+#
+# Examples:
+#
+#
+# Notes:
+#       1.
+#
+# End of Procedure Header
+
+
+proc ::logger::appender::fileAppend {args} {
+    set usage {console
+	?-level level?
+	?-service service?
+	?-outputChannel channel?
+	?-appenderArgs appenderArgs?
+    }
+    set bargs $args
+    set conversionPattern {\[%d\] \[%c\] \[%M\] \[%p\] %m}
+    while {[llength $args] > 1} {
+	set opt [lindex $args 0]
+	set args [lrange $args 1 end]
+	switch  -exact -- $opt {
+	    -level { set level [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    -service { set service [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    -appenderArgs {
+		set appenderArgs [lindex $args 0]
+		set args [lrange $args 1 end]
+		set args [concat $args $appenderArgs]
+	    }
+	    -conversionPattern {
+		set conversionPattern [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    -procName {
+		set procName [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    -procNameVar {
+		set procNameVar [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    -outputChannel {
+		set outputChannel [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    default {
+		return -code error [msgcat::mc "Unknown argument: \"%s\" :\nUsage:\
+  	                 %s" $opt $usage]
+	    }
+	}
+    }
+    if {![info exists procName]} {
+	set procName [genProcName $bargs]
+    }
+    if {[info exists procNameVar]} {
+	upvar $procNameVar myProcNameVar
+    }
+    set procText \
+	[ ::logger::utils::createLogProc \
+	      -procName $procName \
+	      -conversionPattern $conversionPattern \
+	      -category $service \
+	      -outputChannel $outputChannel \
+	      -priority $level ]
+    set myProcNameVar $procName
+    return $procText
+}
+  	 
+
+
+
+##Internal Procedure Header
+# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+#       ::logger::appender::genProcName
+#
+# Purpose:
+#        
+#
+# Synopsis:
+#       ::logger::appender::genProcName <args>
+#
+# Arguments:
+#       <formatString>
+#            string composed of formatting chars (see description)
+#
+#
+# Return Values:
+#       a runnable command 
+#
+# Description:
+#         
+#
+# Examples:
+#       ::loggerExtension::new param1
+#       ::loggerExtension::new param2
+#       ::loggerExtension::new param3 <option1>
+#
+#
+# Sample Input:
+#       (Optional) Sample of input to the proc provided by its argument values.
+#
+# Sample Output:
+#       (Optional) For procs that output to files, provide 
+#       sample of format of output produced.
+# Notes:
+#       1.
+#
+# End of Procedure Header 
+
+
+proc ::logger::appender::genProcName {args} {
+    set name [md5::md5 -hex $args]
+    return "::logger::appender::logProc-$name"
+}
+
+
+package provide logger::appender 1.3
+
+# ;;; Local Variables: ***
+# ;;; mode: tcl ***
+# ;;; End: ***
diff --git a/lib/log/loggerUtils.tcl b/lib/log/loggerUtils.tcl
new file mode 100644
index 0000000..7c4d859
--- /dev/null
+++ b/lib/log/loggerUtils.tcl
@@ -0,0 +1,544 @@
+##Library Header
+#
+# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+#	::logger::utils::
+#
+# Purpose:
+#	an extension to the tcllib logger module
+#
+# Author:
+#	 Aamer Akhter / aakhter@cisco.com
+#
+# Support Alias:
+#       aakhter@cisco.com
+#
+# Usage:
+#	package require logger::utils
+#
+# Description:
+#	this extension adds template based appenders
+#
+# Requirements:
+#       package require logger
+#
+# Variables:
+#       namespace   ::logger::utils::
+#       id:         CVS ID: keyword extraction
+#       version:    current version of package
+#       packageDir: directory where package is located
+#       log:        instance log
+#
+# Notes:
+#       1.
+#
+# Keywords:
+#
+#
+# Category:
+#
+#
+# End of Header
+
+package require Tcl 8.4
+package require logger
+package require logger::appender
+package require msgcat
+
+namespace eval ::logger::utils {
+
+    variable packageDir [file dirname [info script]]
+    variable log        [logger::init logger::utils]
+
+    logger::import -force -namespace log logger::utils
+
+    # @mdgen OWNER: msgs/*.msg
+    ::msgcat::mcload [file join $packageDir msgs]
+}
+
+##Internal Procedure Header
+# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+#	::logger::utils::createFormatCmd
+#
+# Purpose:
+#
+#
+# Synopsis:
+#       ::logger::utils::createFormatCmd <formatString>
+#
+# Arguments:
+#       <formatString>
+#            string composed of formatting chars (see description)
+#
+#
+# Return Values:
+#	a runnable command
+#
+# Description:
+#       createFormatCmd translates <formatString> into an expandable
+#       command string.
+#
+#       The following are the known substitutions (from log4perl):
+#            %c category of the logging event
+#            %C fully qualified name of logging event
+#            %d current date in yyyy/MM/dd hh:mm:ss
+#            %H hostname
+#            %m message to be logged
+#            %M method where logging event was issued
+#            %p priority of logging event
+#            %P pid of current process
+#
+#
+# Examples:
+#       ::logger::new param1
+#       ::logger::new param2
+#       ::logger::new param3 <option1>
+#
+#
+# Sample Input:
+#	(Optional) Sample of input to the proc provided by its argument values.
+#
+# Sample Output:
+#	(Optional) For procs that output to files, provide
+#	sample of format of output produced.
+# Notes:
+#	1.
+#
+# End of Procedure Header
+
+
+proc ::logger::utils::createFormatCmd {text args} {
+    variable log
+    array set opt $args
+
+    regsub -all -- \
+	{%P} \
+	$text \
+	[pid] \
+	text
+
+    regsub -all -- \
+	{%H} \
+	$text \
+	[info hostname] \
+	text
+
+
+    #the %d subst has to happen at the end
+    regsub -all -- \
+	{%d} \
+	$text \
+	{[clock format [clock seconds] -format {%Y/%m/%d %H:%M:%S}]} \
+	text
+
+    if {[info exists opt(-category)]} {
+	regsub -all -- \
+	    {%c} \
+	    $text \
+	    $opt(-category) \
+	    text
+
+	regsub -all -- \
+	    {%C} \
+	    $text \
+	    [lindex [split $opt(-category) :: ] 0] \
+	    text
+    }
+
+    if {[info exists opt(-priority)]} {
+	regsub -all -- \
+	    {%p} \
+	    $text \
+	    $opt(-priority) \
+	    text
+    }
+
+    return $text
+}
+
+
+
+##Procedure Header
+# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+#	::logger::utils::createLogProc
+#
+# Purpose:
+#
+#
+# Synopsis:
+#       ::logger::utils::createLogProc -procName <procName> [options]
+#
+# Arguments:
+#       -procName <procName>
+#            name of proc to create
+#       -conversionPattern <pattern>
+#            see createFormatCmd for <pattern>
+#       -category <category>
+#            the category (service)
+#       -priority <priority>
+#            the priority (level)
+#       -outputChannel <channel>
+#            channel to output on (default stdout)
+#
+#
+# Return Values:
+#	a runnable command
+#
+# Description:
+#       createFormatCmd translates <formatString> into an expandable
+#       command string.
+#
+#       The following are the known substitutions (from log4perl):
+#            %c category of the logging event
+#            %C fully qualified name of logging event
+#            %d current date in yyyy/MM/dd hh:mm:ss
+#            %H hostname
+#            %m message to be logged
+#            %M method where logging event was issued
+#            %p priority of logging event
+#            %P pid of current process
+#
+#
+# Examples:
+#
+#
+# Sample Input:
+#	(Optional) Sample of input to the proc provided by its argument values.
+#
+# Sample Output:
+#	(Optional) For procs that output to files, provide
+#	sample of format of output produced.
+# Notes:
+#	1.
+#
+# End of Procedure Header
+
+
+proc ::logger::utils::createLogProc {args} {
+    variable log
+    array set opt $args
+
+    set formatText ""
+    set methodText ""
+    if {[info exists opt(-conversionPattern)]} {
+	set text $opt(-conversionPattern)
+
+	regsub -all -- \
+	    {%P} \
+	    $text \
+	    [pid] \
+	    text
+
+	regsub -all -- \
+	    {%H} \
+	    $text \
+	    [info hostname] \
+	    text
+
+	if {[info exists opt(-category)]} {
+	    regsub -all -- \
+		{%c} \
+		$text \
+		$opt(-category) \
+		text
+
+	    regsub -all -- \
+		{%C} \
+		$text \
+		[lindex [split $opt(-category) :: ] 0] \
+		text
+	}
+
+	if {[info exists opt(-priority)]} {
+	    regsub -all -- \
+		{%p} \
+		$text \
+		$opt(-priority) \
+		text
+	}
+
+
+	if {[regexp {%M} $text]} {
+	    set methodText {
+		if {[info level] < 2} {
+		    set method "global"
+		} else {
+		    set method [lindex [info level -1] 0]
+		}
+
+	    }
+
+	    regsub -all -- \
+		{%M} \
+		$text \
+		{$method} \
+		text
+	}
+
+	regsub -all -- \
+	    {%m} \
+	    $text \
+	    {$text} \
+	    text
+
+	regsub -all -- \
+	    {%d} \
+	    $text \
+	    {[clock format [clock seconds] -format {%Y/%m/%d %H:%M:%S}]} \
+	    text
+
+    }
+
+    if {[info exists opt(-outputChannel)]} {
+	set outputChannel $opt(-outputChannel)
+    } else {
+	set outputChannel stdout
+    }
+
+    set formatText $text
+    set outputCommand puts
+
+    set procText {
+	proc $opt(-procName) {text} {
+	    $methodText
+	    $outputCommand $outputChannel \"$formatText\"
+	}
+    }
+
+    set procText [subst $procText]
+    return $procText
+}
+
+
+##Procedure Header
+# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+#	::logger::utils::applyAppender
+#
+# Purpose:
+#
+#
+# Synopsis:
+#       ::logger::utils::applyAppender -appender <appenderType> [options]
+#
+# Arguments:
+#       -service <logger service names>
+#       -serviceCmd <logger serviceCmds>
+#            name of logger instance to modify
+#            -serviceCmd takes as input the return of logger::init
+#
+#       -appender <appenderType>
+#            type of appender to use
+#             console|colorConsole...
+#
+#       -conversionPattern <pattern>
+#            see createLogProc for format
+#            if not provided the default pattern
+#            is used:
+#             {\[%d\] \[%c\] \[%M\] \[%p\] %m}
+#
+#       -levels <levels to apply to>
+#            list of levels to apply this appender to
+#            by default all levels are applied to
+#
+# Return Values:
+#
+#
+# Description:
+#       applyAppender will create an appender for the specified
+#       logger services. If not service is specified then the
+#       appender will be added as the default appender for
+#       the specified levels. If no levels are specified, then
+#       all levels are assumed.
+#
+#       The following are the known substitutions (from log4perl):
+#            %c category of the logging event
+#            %C fully qualified name of logging event
+#            %d current date in yyyy/MM/dd hh:mm:ss
+#            %H hostname
+#            %m message to be logged
+#            %M method where logging event was issued
+#            %p priority of logging event
+#            %P pid of current process
+#
+#
+# Examples:
+#        % set log [logger::init testLog]
+#        ::logger::tree::testLog
+#        % logger::utils::applyAppender -appender console -serviceCmd $log
+#        % ${log}::error "this is error"
+#        [2005/08/22 10:14:13] [testLog] [global] [error] this is error
+#
+#
+# End of Procedure Header
+
+
+proc ::logger::utils::applyAppender {args} {
+    set usage {logger::utils::applyAppender
+	-appender appender
+	?-instance?
+	?-levels levels?
+	?-appenderArgs appenderArgs?
+    }
+    set levels [logger::levels]
+    set appenderArgs {}
+    set bargs $args
+    while {[llength $args] > 1} {
+        set opt [lindex $args 0]
+        set args [lrange $args 1 end]
+        switch  -exact -- $opt {
+            -appender { set appender [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    -serviceCmd { set serviceCmd [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    -service { set serviceCmd [logger::servicecmd [lindex $args 0]]
+		set args [lrange $args 1 end]
+	    }
+            -levels { set levels [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	    -appenderArgs {
+		set appenderArgs [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+            default {
+                return -code error [msgcat::mc "Unknown argument: \"%s\" :\nUsage:\
+                %s" $opt $usage]
+            }
+        }
+    }
+
+    set appender ::logger::appender::${appender}
+    if {[info commands $appender] == {}} {
+	return -code error [msgcat::mc "could not find appender '%s'" $appender]
+    }
+
+    #if service is not specified make all future services with this appender
+    # spec
+    if {![info exists serviceCmd]} {
+	set ::logger::utils::autoApplyAppenderArgs $bargs
+	#add trace
+	#check to see if trace is already set
+	if {[lsearch [trace info execution logger::init] \
+		 {leave ::logger::utils::autoApplyAppender} ] == -1} {
+	    trace add execution ::logger::init leave ::logger::utils::autoApplyAppender
+	}
+	return
+    }
+
+
+    #foreach service specified, apply the appender for each of the levels
+    # specified
+    foreach srvCmd $serviceCmd {
+
+	foreach lvl $levels {
+	    set procText [$appender -appenderArgs $appenderArgs \
+			      -level $lvl \
+			      -service [${srvCmd}::servicename] \
+			      -procNameVar procName
+			 ]
+	    eval $procText
+	    ${srvCmd}::logproc $lvl $procName
+	}
+    }
+}
+
+
+##Internal Procedure Header
+# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+#	::logger::utils::autoApplyAppender
+#
+# Purpose:
+#
+#
+# Synopsis:
+#       ::logger::utils::autoApplyAppender <command> <command-string> <log> <op> <args>
+#
+# Arguments:
+#       <command>
+#       <command-string>
+#       <log>
+#            servicecmd generated by logger:init
+#       <op>
+#       <args>
+#
+# Return Values:
+#	<log>
+#
+# Description:
+#       autoApplyAppender is designed to be added via trace leave
+#       to logger::init calls
+#
+#       autoApplyAppender will look at preconfigred state (via applyAppender)
+#       to autocreate appenders for newly created logger instances
+#
+# Examples:
+#	logger::utils::applyAppender -appender console
+#	set log [logger::init applyAppender-3]
+#	${log}::error "this is error"
+#
+#
+# Sample Input:
+#
+# Sample Output:
+#
+# Notes:
+#	1.
+#
+# End of Procedure Header
+
+
+proc ::logger::utils::autoApplyAppender {command command-string log op args} {
+    variable autoApplyAppenderArgs
+    set bAppArgs $autoApplyAppenderArgs
+    set levels [logger::levels]
+    set appenderArgs {}
+    while {[llength $bAppArgs] > 1} {
+        set opt [lindex $bAppArgs 0]
+        set bAppArgs [lrange $bAppArgs 1 end]
+        switch  -exact -- $opt {
+            -appender { set appender [lindex $bAppArgs 0]
+		set bAppArgs [lrange $bAppArgs 1 end]
+	    }
+            -levels { set levels [lindex $bAppArgs 0]
+		set bAppArgs [lrange $bAppArgs 1 end]
+	    }
+	    -appenderArgs {
+		set appenderArgs [lindex $bAppArgs 0]
+		set bAppArgs [lrange $bAppArgs 1 end]
+	    }
+            default {
+                return -code error [msgcat::mc "Unknown argument: \"%s\" :\nUsage:\
+                %s" $opt $usage]
+            }
+        }
+    }
+    if {![info exists appender]} {
+	return -code error [msgcat::mc "need to specify -appender"]
+    }
+    logger::utils::applyAppender -appender $appender -serviceCmd $log \
+	-levels $levels -appenderArgs $appenderArgs
+    return $log
+}
+
+
+package provide logger::utils 1.3
+
+# ;;; Local Variables: ***
+# ;;; mode: tcl ***
+# ;;; End: ***
diff --git a/lib/log/loggerperformance b/lib/log/loggerperformance
new file mode 100644
index 0000000..d9d9b0b
--- /dev/null
+++ b/lib/log/loggerperformance
@@ -0,0 +1,79 @@
+# -*- tcl -*-
+# loggerperformance.tcl
+
+# $Id: loggerperformance,v 1.2 2004/01/15 06:36:13 andreas_kupries Exp $
+
+# This code is for benchmarking the performance of the log tools.
+
+set auto_path "[file dirname [info script]] $auto_path"
+package require logger
+package require log
+
+# Set up logger
+set log [logger::init date]
+
+# Create a custom log routine, so we don't deal with the overhead of
+# the default one, which does some system calls itself.
+
+${log}::logproc notice txt {
+    puts "$txt"
+}
+
+# Basic output.
+proc Test1 {} {
+    set date [clock format [clock seconds]]
+    puts "Date is now $date"
+}
+
+# No output at all.  This is the benchmark by which 'turned off' log
+# systems should be judged.
+proc Test2 {} {
+    set date [clock format [clock seconds]]
+}
+
+# Use logger.
+proc Test3 {} {
+    set date [clock format [clock seconds]]
+    ${::log}::notice "Date is now $date"
+}
+
+# Use log.
+proc Test4 {} {
+    set date [clock format [clock seconds]]
+    log::log notice "Date is now $date"
+}
+
+set res1 [time {
+    Test1
+} 1000]
+
+set res2 [time {
+    Test2
+} 1000]
+
+set res3 [time {
+    Test3
+} 1000]
+
+${log}::disable notice
+
+set res4 [time {
+    Test3
+} 1000]
+
+set res5 [time {
+    Test4
+} 1000]
+
+log::lvSuppressLE notice
+
+set res6 [time {
+    Test4
+} 1000]
+
+puts "Puts output:		$res1"
+puts "No output:		$res2"
+puts "Logger:			$res3"
+puts "Logger disabled: 	$res4"
+puts "Log: 			$res5"
+puts "Log disabled: 		$res6"
diff --git a/lib/log/msgs/en.msg b/lib/log/msgs/en.msg
new file mode 100644
index 0000000..9b6df9e
--- /dev/null
+++ b/lib/log/msgs/en.msg
@@ -0,0 +1,7 @@
+# -*- tcl -*-
+package require    msgcat
+namespace import ::msgcat::*
+
+mcset en "Unknown argument: \"%s\" :\nUsage: %s" "Unknown argument: \"%s\" :\nUsage: %s"
+mcset en "could not find appender '%s'"          "could not find appender '%s'"
+mcset en "need to specify -appender"             "need to specify -appender"
diff --git a/lib/log/pkgIndex.tcl b/lib/log/pkgIndex.tcl
new file mode 100644
index 0000000..9158b68
--- /dev/null
+++ b/lib/log/pkgIndex.tcl
@@ -0,0 +1,9 @@
+if {![package vsatisfies [package provide Tcl] 8]} {return}
+package ifneeded log 1.2 [list source [file join $dir log.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded logger           0.8 [list source [file join $dir logger.tcl]]
+package ifneeded logger::appender 1.3   [list source [file join $dir loggerAppender.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded logger::utils    1.3   [list source [file join $dir loggerUtils.tcl]]
diff --git a/lib/md5/md5.tcl b/lib/md5/md5.tcl
new file mode 100644
index 0000000..418c782
--- /dev/null
+++ b/lib/md5/md5.tcl
@@ -0,0 +1,454 @@
+##################################################
+#
+# md5.tcl - MD5 in Tcl
+# Author: Don Libes <libes@nist.gov>, July 1999
+# Version 1.2.0
+#
+# MD5  defined by RFC 1321, "The MD5 Message-Digest Algorithm"
+# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
+#
+# Most of the comments below come right out of RFC 1321; That's why
+# they have such peculiar numbers.  In addition, I have retained
+# original syntax, bugs in documentation (yes, really), etc. from the
+# RFC.  All remaining bugs are mine.
+#
+# HMAC implementation by D. J. Hagberg <dhagberg@millibits.com> and
+# is based on C code in RFC 2104.
+#
+# For more info, see: http://expect.nist.gov/md5pure
+#
+# - Don
+#
+# Modified by Miguel Sofer to use inlines and simple variables
+##################################################
+
+# @mdgen EXCLUDE: md5c.tcl
+
+package require Tcl 8.2
+namespace eval ::md5 {
+}
+
+if {![catch {package require Trf 2.0}] && ![catch {::md5 -- test}]} {
+    # Trf is available, so implement the functionality provided here
+    # in terms of calls to Trf for speed.
+
+    proc ::md5::md5 {msg} {
+	string tolower [::hex -mode encode -- [::md5 -- $msg]]
+    }
+
+    # hmac: hash for message authentication
+
+    # MD5 of Trf and MD5 as defined by this package have slightly
+    # different results. Trf returns the digest in binary, here we get
+    # it as hex-string. In the computation of the HMAC the latter
+    # requires back conversion into binary in some places. With Trf we
+    # can use omit these.
+
+    proc ::md5::hmac {key text} {
+	# if key is longer than 64 bytes, reset it to MD5(key).  If shorter, 
+	# pad it out with null (\x00) chars.
+	set keyLen [string length $key]
+	if {$keyLen > 64} {
+	    #old: set key [binary format H32 [md5 $key]]
+	    set key [::md5 -- $key]
+	    set keyLen [string length $key]
+	}
+    
+	# ensure the key is padded out to 64 chars with nulls.
+	set padLen [expr {64 - $keyLen}]
+	append key [binary format "a$padLen" {}]
+
+	# Split apart the key into a list of 16 little-endian words
+	binary scan $key i16 blocks
+
+	# XOR key with ipad and opad values
+	set k_ipad {}
+	set k_opad {}
+	foreach i $blocks {
+	    append k_ipad [binary format i [expr {$i ^ 0x36363636}]]
+	    append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]]
+	}
+    
+	# Perform inner md5, appending its results to the outer key
+	append k_ipad $text
+	#old: append k_opad [binary format H* [md5 $k_ipad]]
+	append k_opad [::md5 -- $k_ipad]
+
+	# Perform outer md5
+	#old: md5 $k_opad
+	string tolower [::hex -mode encode -- [::md5 -- $k_opad]]
+    }
+
+} else {
+    # Without Trf use the all-tcl implementation by Don Libes.
+
+    # T will be inlined after the definition of md5body
+
+    # test md5
+    #
+    # This proc is not necessary during runtime and may be omitted if you
+    # are simply inserting this file into a production program.
+    #
+    proc ::md5::test {} {
+	foreach {msg expected} {
+	    ""
+	    "d41d8cd98f00b204e9800998ecf8427e"
+	    "a"
+	    "0cc175b9c0f1b6a831c399e269772661"
+	    "abc"
+	    "900150983cd24fb0d6963f7d28e17f72"
+	    "message digest"
+	    "f96b697d7cb7938d525a2f31aaf161d0"
+	    "abcdefghijklmnopqrstuvwxyz"
+	    "c3fcd3d76192e4007dfb496cca67e13b"
+	    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+	    "d174ab98d277d9f5a5611c2c9f419d9f"
+	    "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+	    "57edf4a22be3c955ac49da2e2107b67a"
+	} {
+	    puts "testing: md5 \"$msg\""
+	    set computed [md5 $msg]
+	    puts "expected: $expected"
+	    puts "computed: $computed"
+	    if {0 != [string compare $computed $expected]} {
+		puts "FAILED"
+	    } else {
+		puts "SUCCEEDED"
+	    }
+	}
+    }
+
+    # time md5
+    #
+    # This proc is not necessary during runtime and may be omitted if you
+    # are simply inserting this file into a production program.
+    #
+    proc ::md5::time {} {
+	foreach len {10 50 100 500 1000 5000 10000} {
+	    set time [::time {md5 [format %$len.0s ""]} 100]
+	    set msec [lindex $time 0]
+	    puts "input length $len: [expr {$msec/1000}] milliseconds per interation"
+	}
+    }
+
+    #
+    # We just define the body of md5pure::md5 here; later we
+    # regsub to inline a few function calls for speed
+    #
+
+    set ::md5::md5body {
+
+	#
+	# 3.1 Step 1. Append Padding Bits
+	#
+
+	set msgLen [string length $msg]
+
+	set padLen [expr {56 - $msgLen%64}]
+	if {$msgLen % 64 > 56} {
+	    incr padLen 64
+	}
+
+	# pad even if no padding required
+	if {$padLen == 0} {
+	    incr padLen 64
+	}
+
+	# append single 1b followed by 0b's
+	append msg [binary format "a$padLen" \200]
+
+	#
+	# 3.2 Step 2. Append Length
+	#
+
+	# RFC doesn't say whether to use little- or big-endian
+	# code demonstrates little-endian
+	# This step limits our input to size 2^32b or 2^24B
+	append msg [binary format "i1i1" [expr {8*$msgLen}] 0]
+	
+	#
+	# 3.3 Step 3. Initialize MD Buffer
+	#
+
+	set A [expr 0x67452301]
+	set B [expr 0xefcdab89]
+	set C [expr 0x98badcfe]
+	set D [expr 0x10325476]
+
+	#
+	# 3.4 Step 4. Process Message in 16-Word Blocks
+	#
+
+	# process each 16-word block
+	# RFC doesn't say whether to use little- or big-endian
+	# code says little-endian
+	binary scan $msg i* blocks
+
+	# loop over the message taking 16 blocks at a time
+
+	foreach {X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15} $blocks {
+
+	    # Save A as AA, B as BB, C as CC, and D as DD.
+	    set AA $A
+	    set BB $B
+	    set CC $C
+	    set DD $D
+
+	    # Round 1.
+	    # Let [abcd k s i] denote the operation
+	    #      a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s).
+	    # [ABCD  0  7  1]  [DABC  1 12  2]  [CDAB  2 17  3]  [BCDA  3 22  4]
+	    set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X0  + $T01}]  7]}]
+	    set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X1  + $T02}] 12]}]
+	    set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X2  + $T03}] 17]}]
+	    set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X3  + $T04}] 22]}]
+	    # [ABCD  4  7  5]  [DABC  5 12  6]  [CDAB  6 17  7]  [BCDA  7 22  8]
+	    set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X4  + $T05}]  7]}]
+	    set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X5  + $T06}] 12]}]
+	    set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X6  + $T07}] 17]}]
+	    set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X7  + $T08}] 22]}]
+	    # [ABCD  8  7  9]  [DABC  9 12 10]  [CDAB 10 17 11]  [BCDA 11 22 12]
+	    set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X8  + $T09}]  7]}]
+	    set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X9  + $T10}] 12]}]
+	    set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X10 + $T11}] 17]}]
+	    set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X11 + $T12}] 22]}]
+	    # [ABCD 12  7 13]  [DABC 13 12 14]  [CDAB 14 17 15]  [BCDA 15 22 16]
+	    set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X12 + $T13}]  7]}]
+	    set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X13 + $T14}] 12]}]
+	    set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X14 + $T15}] 17]}]
+	    set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X15 + $T16}] 22]}]
+
+	    # Round 2.
+	    # Let [abcd k s i] denote the operation
+	    #      a = b + ((a + G(b,c,d) + X[k] + T[i]) <<< s).
+	    # Do the following 16 operations.
+	    # [ABCD  1  5 17]  [DABC  6  9 18]  [CDAB 11 14 19]  [BCDA  0 20 20]
+	    set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X1  + $T17}]  5]}]
+	    set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X6  + $T18}]  9]}]
+	    set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X11 + $T19}] 14]}]
+	    set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X0  + $T20}] 20]}]
+	    # [ABCD  5  5 21]  [DABC 10  9 22]  [CDAB 15 14 23]  [BCDA  4 20 24]
+	    set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X5  + $T21}]  5]}]
+	    set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X10 + $T22}]  9]}]
+	    set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X15 + $T23}] 14]}]
+	    set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X4  + $T24}] 20]}]
+	    # [ABCD  9  5 25]  [DABC 14  9 26]  [CDAB  3 14 27]  [BCDA  8 20 28]
+	    set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X9  + $T25}]  5]}]
+	    set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X14 + $T26}]  9]}]
+	    set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X3  + $T27}] 14]}]
+	    set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X8  + $T28}] 20]}]
+	    # [ABCD 13  5 29]  [DABC  2  9 30]  [CDAB  7 14 31]  [BCDA 12 20 32]
+	    set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X13 + $T29}]  5]}]
+	    set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X2  + $T30}]  9]}]
+	    set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X7  + $T31}] 14]}]
+	    set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X12 + $T32}] 20]}]
+
+	    # Round 3.
+	    # Let [abcd k s t] [sic] denote the operation
+	    #     a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s).
+	    # Do the following 16 operations.
+	    # [ABCD  5  4 33]  [DABC  8 11 34]  [CDAB 11 16 35]  [BCDA 14 23 36]
+	    set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X5  + $T33}]  4]}]
+	    set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X8  + $T34}] 11]}]
+	    set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X11 + $T35}] 16]}]
+	    set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X14 + $T36}] 23]}]
+	    # [ABCD  1  4 37]  [DABC  4 11 38]  [CDAB  7 16 39]  [BCDA 10 23 40]
+	    set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X1  + $T37}]  4]}]
+	    set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X4  + $T38}] 11]}]
+	    set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X7  + $T39}] 16]}]
+	    set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X10 + $T40}] 23]}]
+	    # [ABCD 13  4 41]  [DABC  0 11 42]  [CDAB  3 16 43]  [BCDA  6 23 44]
+	    set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X13 + $T41}]  4]}]
+	    set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X0  + $T42}] 11]}]
+	    set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X3  + $T43}] 16]}]
+	    set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X6  + $T44}] 23]}]
+	    # [ABCD  9  4 45]  [DABC 12 11 46]  [CDAB 15 16 47]  [BCDA  2 23 48]
+	    set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X9  + $T45}]  4]}]
+	    set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X12 + $T46}] 11]}]
+	    set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X15 + $T47}] 16]}]
+	    set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X2  + $T48}] 23]}]
+
+	    # Round 4.
+	    # Let [abcd k s t] [sic] denote the operation
+	    #     a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s).
+	    # Do the following 16 operations.
+	    # [ABCD  0  6 49]  [DABC  7 10 50]  [CDAB 14 15 51]  [BCDA  5 21 52]
+	    set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X0  + $T49}]  6]}]
+	    set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X7  + $T50}] 10]}]
+	    set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X14 + $T51}] 15]}]
+	    set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X5  + $T52}] 21]}]
+	    # [ABCD 12  6 53]  [DABC  3 10 54]  [CDAB 10 15 55]  [BCDA  1 21 56]
+	    set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X12 + $T53}]  6]}]
+	    set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X3  + $T54}] 10]}]
+	    set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X10 + $T55}] 15]}]
+	    set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X1  + $T56}] 21]}]
+	    # [ABCD  8  6 57]  [DABC 15 10 58]  [CDAB  6 15 59]  [BCDA 13 21 60]
+	    set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X8  + $T57}]  6]}]
+	    set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X15 + $T58}] 10]}]
+	    set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X6  + $T59}] 15]}]
+	    set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X13 + $T60}] 21]}]
+	    # [ABCD  4  6 61]  [DABC 11 10 62]  [CDAB  2 15 63]  [BCDA  9 21 64]
+	    set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X4  + $T61}]  6]}]
+	    set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X11 + $T62}] 10]}]
+	    set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X2  + $T63}] 15]}]
+	    set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X9  + $T64}] 21]}]
+
+	    # Then perform the following additions. (That is increment each
+	    #   of the four registers by the value it had before this block
+	    #   was started.)
+	    incr A $AA
+	    incr B $BB
+	    incr C $CC
+	    incr D $DD
+	}
+	# 3.5 Step 5. Output
+
+	# ... begin with the low-order byte of A, and end with the high-order byte
+	# of D.
+
+	return [bytes $A][bytes $B][bytes $C][bytes $D]
+    }
+
+    #
+    # Here we inline/regsub the functions F, G, H, I and <<< 
+    #
+
+    namespace eval ::md5 {
+	#proc md5pure::F {x y z} {expr {(($x & $y) | ((~$x) & $z))}}
+	regsub -all -- {\[ *F +(\$.) +(\$.) +(\$.) *\]} $md5body {((\1 \& \2) | ((~\1) \& \3))} md5body
+
+	#proc md5pure::G {x y z} {expr {(($x & $z) | ($y & (~$z)))}}
+	regsub -all -- {\[ *G +(\$.) +(\$.) +(\$.) *\]} $md5body {((\1 \& \3) | (\2 \& (~\3)))} md5body
+
+	#proc md5pure::H {x y z} {expr {$x ^ $y ^ $z}}
+	regsub -all -- {\[ *H +(\$.) +(\$.) +(\$.) *\]} $md5body {(\1 ^ \2 ^ \3)} md5body
+
+	#proc md5pure::I {x y z} {expr {$y ^ ($x | (~$z))}}
+	regsub -all -- {\[ *I +(\$.) +(\$.) +(\$.) *\]} $md5body {(\2 ^ (\1 | (~\3)))} md5body
+
+	# bitwise left-rotate
+	if {0} {
+	    proc md5pure::<<< {x i} {
+		# This works by bitwise-ORing together right piece and left
+		# piece so that the (original) right piece becomes the left
+		# piece and vice versa.
+		#
+		# The (original) right piece is a simple left shift.
+		# The (original) left piece should be a simple right shift
+		# but Tcl does sign extension on right shifts so we
+		# shift it 1 bit, mask off the sign, and finally shift
+		# it the rest of the way.
+		
+		# expr {($x << $i) | ((($x >> 1) & 0x7fffffff) >> (31-$i))}
+
+		#
+		# New version, faster when inlining
+		# We replace inline (computing at compile time):
+		#   R$i -> (32 - $i)
+		#   S$i -> (0x7fffffff >> (31-$i))
+		#
+
+		expr { ($x << $i) | (($x >> [set R$i]) & [set S$i])}
+	    }
+	}
+	# inline <<<
+	regsub -all -- {\[ *<<< +\[ *expr +({[^\}]*})\] +([0-9]+) *\]} $md5body {(([set x [expr \1]] << \2) |  (($x >> R\2) \& S\2))} md5body
+
+	# now replace the R and S
+	set map {}
+	foreach i { 
+	    7 12 17 22
+	    5  9 14 20
+	    4 11 16 23
+	    6 10 15 21 
+	} {
+	    lappend map R$i [expr {32 - $i}] S$i [expr {0x7fffffff >> (31-$i)}]
+	}
+	
+	# inline the values of T
+	foreach \
+		tName {
+	    T01 T02 T03 T04 T05 T06 T07 T08 T09 T10 
+	    T11 T12 T13 T14 T15 T16 T17 T18 T19 T20 
+	    T21 T22 T23 T24 T25 T26 T27 T28 T29 T30 
+	    T31 T32 T33 T34 T35 T36 T37 T38 T39 T40 
+	    T41 T42 T43 T44 T45 T46 T47 T48 T49 T50 
+	    T51 T52 T53 T54 T55 T56 T57 T58 T59 T60 
+	    T61 T62 T63 T64 } \
+		tVal {
+	    0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee
+	    0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501
+	    0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be
+	    0x6b901122 0xfd987193 0xa679438e 0x49b40821
+
+	    0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa
+	    0xd62f105d 0x2441453  0xd8a1e681 0xe7d3fbc8
+	    0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed
+	    0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a
+
+	    0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c
+	    0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70
+	    0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05
+	    0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665
+
+	    0xf4292244 0x432aff97 0xab9423a7 0xfc93a039
+	    0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1
+	    0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1
+	    0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391
+	} {
+	    lappend map \$$tName $tVal
+	}
+	set md5body [string map $map $md5body]
+	
+
+	# Finally, define the proc
+	proc md5 {msg} $md5body
+
+	# unset auxiliary variables
+	unset md5body tName tVal map
+    }
+
+    proc ::md5::byte0 {i} {expr {0xff & $i}}
+    proc ::md5::byte1 {i} {expr {(0xff00 & $i) >> 8}}
+    proc ::md5::byte2 {i} {expr {(0xff0000 & $i) >> 16}}
+    proc ::md5::byte3 {i} {expr {((0xff000000 & $i) >> 24) & 0xff}}
+
+    proc ::md5::bytes {i} {
+	format %0.2x%0.2x%0.2x%0.2x [byte0 $i] [byte1 $i] [byte2 $i] [byte3 $i]
+    }
+
+    # hmac: hash for message authentication
+    proc ::md5::hmac {key text} {
+	# if key is longer than 64 bytes, reset it to MD5(key).  If shorter, 
+	# pad it out with null (\x00) chars.
+	set keyLen [string length $key]
+	if {$keyLen > 64} {
+	    set key [binary format H32 [md5 $key]]
+	    set keyLen [string length $key]
+	}
+
+	# ensure the key is padded out to 64 chars with nulls.
+	set padLen [expr {64 - $keyLen}]
+	append key [binary format "a$padLen" {}]
+	
+	# Split apart the key into a list of 16 little-endian words
+	binary scan $key i16 blocks
+
+	# XOR key with ipad and opad values
+	set k_ipad {}
+	set k_opad {}
+	foreach i $blocks {
+	    append k_ipad [binary format i [expr {$i ^ 0x36363636}]]
+	    append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]]
+	}
+    
+	# Perform inner md5, appending its results to the outer key
+	append k_ipad $text
+	append k_opad [binary format H* [md5 $k_ipad]]
+
+	# Perform outer md5
+	md5 $k_opad
+    }
+}
+
+package provide md5 1.4.4
diff --git a/lib/md5/md5x.tcl b/lib/md5/md5x.tcl
new file mode 100644
index 0000000..9b48162
--- /dev/null
+++ b/lib/md5/md5x.tcl
@@ -0,0 +1,714 @@
+# md5.tcl - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# MD5  defined by RFC 1321, "The MD5 Message-Digest Algorithm"
+# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
+#
+# This is an implementation of MD5 based upon the example code given in
+# RFC 1321 and upon the tcllib MD4 implementation and taking some ideas
+# from the earlier tcllib md5 version by Don Libes.
+#
+# This implementation permits incremental updating of the hash and 
+# provides support for external compiled implementations either using
+# critcl (md5c) or Trf.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+# $Id: md5x.tcl,v 1.17 2006/09/19 23:36:17 andreas_kupries Exp $
+
+package require Tcl 8.2;                # tcl minimum version
+
+namespace eval ::md5 {
+    variable version 2.0.5
+    variable rcsid {$Id: md5x.tcl,v 1.17 2006/09/19 23:36:17 andreas_kupries Exp $}
+    variable accel
+    array set accel {critcl 0 cryptkit 0 trf 0}
+
+    namespace export md5 hmac MD5Init MD5Update MD5Final
+
+    variable uid
+    if {![info exists uid]} {
+        set uid 0
+    }
+}
+
+# -------------------------------------------------------------------------
+
+# MD5Init --
+#
+#   Create and initialize an MD5 state variable. This will be
+#   cleaned up when we call MD5Final
+#
+proc ::md5::MD5Init {} {
+    variable accel
+    variable uid
+    set token [namespace current]::[incr uid]
+    upvar #0 $token state
+
+    # RFC1321:3.3 - Initialize MD5 state structure
+    array set state \
+        [list \
+             A [expr {0x67452301}] \
+             B [expr {0xefcdab89}] \
+             C [expr {0x98badcfe}] \
+             D [expr {0x10325476}] \
+             n 0 i "" ]
+    if {$accel(cryptkit)} {
+        cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_MD5
+    } elseif {$accel(trf)} {
+        set s {}
+        switch -exact -- $::tcl_platform(platform) {
+            windows { set s [open NUL w] }
+            unix    { set s [open /dev/null w] }
+        }
+        if {$s != {}} {
+            fconfigure $s -translation binary -buffering none
+            ::md5 -attach $s -mode write \
+                -read-type variable \
+                -read-destination [subst $token](trfread) \
+                -write-type variable \
+                -write-destination [subst $token](trfwrite)
+            array set state [list trfread 0 trfwrite 0 trf $s]
+        }
+    }
+    return $token
+}
+
+# MD5Update --
+#
+#   This is called to add more data into the hash. You may call this
+#   as many times as you require. Note that passing in "ABC" is equivalent
+#   to passing these letters in as separate calls -- hence this proc 
+#   permits hashing of chunked data
+#
+#   If we have a C-based implementation available, then we will use
+#   it here in preference to the pure-Tcl implementation.
+#
+proc ::md5::MD5Update {token data} {
+    variable accel
+    upvar #0 $token state
+
+    if {$accel(critcl)} {
+        if {[info exists state(md5c)]} {
+            set state(md5c) [md5c $data $state(md5c)]
+        } else {
+            set state(md5c) [md5c $data]
+        }
+        return
+    } elseif {[info exists state(ckctx)]} {
+        if {[string length $data] > 0} {
+            cryptkit::cryptEncrypt $state(ckctx) $data
+        }
+        return
+    } elseif {[info exists state(trf)]} {
+        puts -nonewline $state(trf) $data
+        return
+    }
+
+    # Update the state values
+    incr state(n) [string length $data]
+    append state(i) $data
+
+    # Calculate the hash for any complete blocks
+    set len [string length $state(i)]
+    for {set n 0} {($n + 64) <= $len} {} {
+        MD5Hash $token [string range $state(i) $n [incr n 64]]
+    }
+
+    # Adjust the state for the blocks completed.
+    set state(i) [string range $state(i) $n end]
+    return
+}
+
+# MD5Final --
+#
+#    This procedure is used to close the current hash and returns the
+#    hash data. Once this procedure has been called the hash context
+#    is freed and cannot be used again.
+#
+#    Note that the output is 128 bits represented as binary data.
+#
+proc ::md5::MD5Final {token} {
+    upvar #0 $token state
+
+    # Check for either of the C-compiled versions.
+    if {[info exists state(md5c)]} {
+        set r $state(md5c)
+        unset state
+        return $r
+    } elseif {[info exists state(ckctx)]} {
+        cryptkit::cryptEncrypt $state(ckctx) ""
+        cryptkit::cryptGetAttributeString $state(ckctx) \
+            CRYPT_CTXINFO_HASHVALUE r 16
+        cryptkit::cryptDestroyContext $state(ckctx)
+        # If nothing was hashed, we get no r variable set!
+        if {[info exists r]} {
+            unset state
+            return $r
+        }
+    } elseif {[info exists state(trf)]} {
+        close $state(trf)
+        set r $state(trfwrite)
+        unset state
+        return $r
+    }
+
+    # RFC1321:3.1 - Padding
+    #
+    set len [string length $state(i)]
+    set pad [expr {56 - ($len % 64)}]
+    if {$len % 64 > 56} {
+        incr pad 64
+    }
+    if {$pad == 0} {
+        incr pad 64
+    }
+    append state(i) [binary format a$pad \x80]
+
+    # RFC1321:3.2 - Append length in bits as little-endian wide int.
+    append state(i) [binary format ii [expr {8 * $state(n)}] 0]
+
+    # Calculate the hash for the remaining block.
+    set len [string length $state(i)]
+    for {set n 0} {($n + 64) <= $len} {} {
+        MD5Hash $token [string range $state(i) $n [incr n 64]]
+    }
+
+    # RFC1321:3.5 - Output
+    set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)]
+    unset state
+    return $r
+}
+
+# -------------------------------------------------------------------------
+# HMAC Hashed Message Authentication (RFC 2104)
+#
+# hmac = H(K xor opad, H(K xor ipad, text))
+#
+
+# HMACInit --
+#
+#    This is equivalent to the MD5Init procedure except that a key is
+#    added into the algorithm
+#
+proc ::md5::HMACInit {K} {
+
+    # Key K is adjusted to be 64 bytes long. If K is larger, then use
+    # the MD5 digest of K and pad this instead.
+    set len [string length $K]
+    if {$len > 64} {
+        set tok [MD5Init]
+        MD5Update $tok $K
+        set K [MD5Final $tok]
+        set len [string length $K]
+    }
+    set pad [expr {64 - $len}]
+    append K [string repeat \0 $pad]
+
+    # Cacluate the padding buffers.
+    set Ki {}
+    set Ko {}
+    binary scan $K i16 Ks
+    foreach k $Ks {
+        append Ki [binary format i [expr {$k ^ 0x36363636}]]
+        append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]]
+    }
+
+    set tok [MD5Init]
+    MD5Update $tok $Ki;                 # initialize with the inner pad
+    
+    # preserve the Ko value for the final stage.
+    # FRINK: nocheck
+    set [subst $tok](Ko) $Ko
+
+    return $tok
+}
+
+# HMACUpdate --
+#
+#    Identical to calling MD5Update
+#
+proc ::md5::HMACUpdate {token data} {
+    MD5Update $token $data
+    return
+}
+
+# HMACFinal --
+#
+#    This is equivalent to the MD5Final procedure. The hash context is
+#    closed and the binary representation of the hash result is returned.
+#
+proc ::md5::HMACFinal {token} {
+    upvar #0 $token state
+
+    set tok [MD5Init];                  # init the outer hashing function
+    MD5Update $tok $state(Ko);          # prepare with the outer pad.
+    MD5Update $tok [MD5Final $token];   # hash the inner result
+    return [MD5Final $tok]
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#  This is the core MD5 algorithm. It is a lot like the MD4 algorithm but
+#  includes an extra round and a set of constant modifiers throughout.
+# 
+# Note:
+#  This function body is substituted later on to inline some of the 
+#  procedures and to make is a bit more comprehensible.
+#
+set ::md5::MD5Hash_body {
+    variable $token
+    upvar 0 $token state
+
+    # RFC1321:3.4 - Process Message in 16-Word Blocks
+    binary scan $msg i* blocks
+    foreach {X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15} $blocks {
+        set A $state(A)
+        set B $state(B)
+        set C $state(C)
+        set D $state(D)
+
+        # Round 1
+        # Let [abcd k s i] denote the operation
+        #   a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s).
+        # Do the following 16 operations.
+        # [ABCD  0  7  1]  [DABC  1 12  2]  [CDAB  2 17  3]  [BCDA  3 22  4]
+        set A [expr {$B + (($A + [F $B $C $D] + $X0 + $T01) <<< 7)}]
+        set D [expr {$A + (($D + [F $A $B $C] + $X1 + $T02) <<< 12)}]
+        set C [expr {$D + (($C + [F $D $A $B] + $X2 + $T03) <<< 17)}]
+        set B [expr {$C + (($B + [F $C $D $A] + $X3 + $T04) <<< 22)}]
+        # [ABCD  4  7  5]  [DABC  5 12  6]  [CDAB  6 17  7]  [BCDA  7 22  8]
+        set A [expr {$B + (($A + [F $B $C $D] + $X4 + $T05) <<< 7)}]
+        set D [expr {$A + (($D + [F $A $B $C] + $X5 + $T06) <<< 12)}]
+        set C [expr {$D + (($C + [F $D $A $B] + $X6 + $T07) <<< 17)}]
+        set B [expr {$C + (($B + [F $C $D $A] + $X7 + $T08) <<< 22)}]
+        # [ABCD  8  7  9]  [DABC  9 12 10]  [CDAB 10 17 11]  [BCDA 11 22 12]
+        set A [expr {$B + (($A + [F $B $C $D] + $X8 + $T09) <<< 7)}]
+        set D [expr {$A + (($D + [F $A $B $C] + $X9 + $T10) <<< 12)}]
+        set C [expr {$D + (($C + [F $D $A $B] + $X10 + $T11) <<< 17)}]
+        set B [expr {$C + (($B + [F $C $D $A] + $X11 + $T12) <<< 22)}]
+        # [ABCD 12  7 13]  [DABC 13 12 14]  [CDAB 14 17 15]  [BCDA 15 22 16]
+        set A [expr {$B + (($A + [F $B $C $D] + $X12 + $T13) <<< 7)}]
+        set D [expr {$A + (($D + [F $A $B $C] + $X13 + $T14) <<< 12)}]
+        set C [expr {$D + (($C + [F $D $A $B] + $X14 + $T15) <<< 17)}]
+        set B [expr {$C + (($B + [F $C $D $A] + $X15 + $T16) <<< 22)}]
+
+        # Round 2.
+        # Let [abcd k s i] denote the operation
+        #   a = b + ((a + G(b,c,d) + X[k] + Ti) <<< s)
+        # Do the following 16 operations.
+        # [ABCD  1  5 17]  [DABC  6  9 18]  [CDAB 11 14 19]  [BCDA  0 20 20]
+        set A [expr {$B + (($A + [G $B $C $D] + $X1  + $T17) <<<  5)}]
+        set D [expr {$A + (($D + [G $A $B $C] + $X6  + $T18) <<<  9)}]
+        set C [expr {$D + (($C + [G $D $A $B] + $X11 + $T19) <<< 14)}]
+        set B [expr {$C + (($B + [G $C $D $A] + $X0  + $T20) <<< 20)}]
+        # [ABCD  5  5 21]  [DABC 10  9 22]  [CDAB 15 14 23]  [BCDA  4 20 24]
+        set A [expr {$B + (($A + [G $B $C $D] + $X5  + $T21) <<<  5)}]
+        set D [expr {$A + (($D + [G $A $B $C] + $X10 + $T22) <<<  9)}]
+        set C [expr {$D + (($C + [G $D $A $B] + $X15 + $T23) <<< 14)}]
+        set B [expr {$C + (($B + [G $C $D $A] + $X4  + $T24) <<< 20)}]
+        # [ABCD  9  5 25]  [DABC 14  9 26]  [CDAB  3 14 27]  [BCDA  8 20 28]
+        set A [expr {$B + (($A + [G $B $C $D] + $X9  + $T25) <<<  5)}]
+        set D [expr {$A + (($D + [G $A $B $C] + $X14 + $T26) <<<  9)}]
+        set C [expr {$D + (($C + [G $D $A $B] + $X3  + $T27) <<< 14)}]
+        set B [expr {$C + (($B + [G $C $D $A] + $X8  + $T28) <<< 20)}]
+        # [ABCD 13  5 29]  [DABC  2  9 30]  [CDAB  7 14 31]  [BCDA 12 20 32]
+        set A [expr {$B + (($A + [G $B $C $D] + $X13 + $T29) <<<  5)}]
+        set D [expr {$A + (($D + [G $A $B $C] + $X2  + $T30) <<<  9)}]
+        set C [expr {$D + (($C + [G $D $A $B] + $X7  + $T31) <<< 14)}]
+        set B [expr {$C + (($B + [G $C $D $A] + $X12 + $T32) <<< 20)}]
+        
+        # Round 3.
+        # Let [abcd k s i] denote the operation
+        #   a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s)
+        # Do the following 16 operations.
+        # [ABCD  5  4 33]  [DABC  8 11 34]  [CDAB 11 16 35]  [BCDA 14 23 36]
+        set A [expr {$B + (($A + [H $B $C $D] + $X5  + $T33) <<<  4)}]
+        set D [expr {$A + (($D + [H $A $B $C] + $X8  + $T34) <<< 11)}]
+        set C [expr {$D + (($C + [H $D $A $B] + $X11 + $T35) <<< 16)}]
+        set B [expr {$C + (($B + [H $C $D $A] + $X14 + $T36) <<< 23)}]
+        # [ABCD  1  4 37]  [DABC  4 11 38]  [CDAB  7 16 39]  [BCDA 10 23 40]
+        set A [expr {$B + (($A + [H $B $C $D] + $X1  + $T37) <<<  4)}]
+        set D [expr {$A + (($D + [H $A $B $C] + $X4  + $T38) <<< 11)}]
+        set C [expr {$D + (($C + [H $D $A $B] + $X7  + $T39) <<< 16)}]
+        set B [expr {$C + (($B + [H $C $D $A] + $X10 + $T40) <<< 23)}]
+        # [ABCD 13  4 41]  [DABC  0 11 42]  [CDAB  3 16 43]  [BCDA  6 23 44]
+        set A [expr {$B + (($A + [H $B $C $D] + $X13 + $T41) <<<  4)}]
+        set D [expr {$A + (($D + [H $A $B $C] + $X0  + $T42) <<< 11)}]
+        set C [expr {$D + (($C + [H $D $A $B] + $X3  + $T43) <<< 16)}]
+        set B [expr {$C + (($B + [H $C $D $A] + $X6  + $T44) <<< 23)}]
+        # [ABCD  9  4 45]  [DABC 12 11 46]  [CDAB 15 16 47]  [BCDA  2 23 48]
+        set A [expr {$B + (($A + [H $B $C $D] + $X9  + $T45) <<<  4)}]
+        set D [expr {$A + (($D + [H $A $B $C] + $X12 + $T46) <<< 11)}]
+        set C [expr {$D + (($C + [H $D $A $B] + $X15 + $T47) <<< 16)}]
+        set B [expr {$C + (($B + [H $C $D $A] + $X2  + $T48) <<< 23)}]
+
+        # Round 4.
+        # Let [abcd k s i] denote the operation
+        #   a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s)
+        # Do the following 16 operations.
+        # [ABCD  0  6 49]  [DABC  7 10 50]  [CDAB 14 15 51]  [BCDA  5 21 52]
+        set A [expr {$B + (($A + [I $B $C $D] + $X0  + $T49) <<<  6)}]
+        set D [expr {$A + (($D + [I $A $B $C] + $X7  + $T50) <<< 10)}]
+        set C [expr {$D + (($C + [I $D $A $B] + $X14 + $T51) <<< 15)}]
+        set B [expr {$C + (($B + [I $C $D $A] + $X5  + $T52) <<< 21)}]
+        # [ABCD 12  6 53]  [DABC  3 10 54]  [CDAB 10 15 55]  [BCDA  1 21 56]
+        set A [expr {$B + (($A + [I $B $C $D] + $X12 + $T53) <<<  6)}]
+        set D [expr {$A + (($D + [I $A $B $C] + $X3  + $T54) <<< 10)}]
+        set C [expr {$D + (($C + [I $D $A $B] + $X10 + $T55) <<< 15)}]
+        set B [expr {$C + (($B + [I $C $D $A] + $X1  + $T56) <<< 21)}]
+        # [ABCD  8  6 57]  [DABC 15 10 58]  [CDAB  6 15 59]  [BCDA 13 21 60]
+        set A [expr {$B + (($A + [I $B $C $D] + $X8  + $T57) <<<  6)}]
+        set D [expr {$A + (($D + [I $A $B $C] + $X15 + $T58) <<< 10)}]
+        set C [expr {$D + (($C + [I $D $A $B] + $X6  + $T59) <<< 15)}]
+        set B [expr {$C + (($B + [I $C $D $A] + $X13 + $T60) <<< 21)}]
+        # [ABCD  4  6 61]  [DABC 11 10 62]  [CDAB  2 15 63]  [BCDA  9 21 64]
+        set A [expr {$B + (($A + [I $B $C $D] + $X4  + $T61) <<<  6)}]
+        set D [expr {$A + (($D + [I $A $B $C] + $X11 + $T62) <<< 10)}]
+        set C [expr {$D + (($C + [I $D $A $B] + $X2  + $T63) <<< 15)}]
+        set B [expr {$C + (($B + [I $C $D $A] + $X9  + $T64) <<< 21)}]
+
+        # Then perform the following additions. (That is, increment each
+        # of the four registers by the value it had before this block
+        # was started.)
+        incr state(A) $A
+        incr state(B) $B
+        incr state(C) $C
+        incr state(D) $D
+    }
+
+    return
+}
+
+proc ::md5::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}}
+proc ::md5::bytes {v} { 
+    #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v]
+    format %c%c%c%c \
+        [expr {0xFF & $v}] \
+        [expr {(0xFF00 & $v) >> 8}] \
+        [expr {(0xFF0000 & $v) >> 16}] \
+        [expr {((0xFF000000 & $v) >> 24) & 0xFF}]
+}
+
+# 32bit rotate-left
+proc ::md5::<<< {v n} {
+    return [expr {((($v << $n) \
+                        | (($v >> (32 - $n)) \
+                               & (0x7FFFFFFF >> (31 - $n))))) \
+                      & 0xFFFFFFFF}]
+}
+
+# Convert our <<< pseudo-operator into a procedure call.
+regsub -all -line \
+    {\[expr {(\$[ABCD]) \+ \(\((.*)\)\s+<<<\s+(\d+)\)}\]} \
+    $::md5::MD5Hash_body \
+    {[expr {int(\1 + [<<< [expr {\2}] \3])}]} \
+    ::md5::MD5Hash_bodyX
+
+# RFC1321:3.4 - function F
+proc ::md5::F {X Y Z} {
+    return [expr {($X & $Y) | ((~$X) & $Z)}]
+}
+
+# Inline the F function
+regsub -all -line \
+    {\[F (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+    $::md5::MD5Hash_bodyX \
+    {( (\1 \& \2) | ((~\1) \& \3) )} \
+    ::md5::MD5Hash_bodyX
+    
+# RFC1321:3.4 - function G
+proc ::md5::G {X Y Z} {
+    return [expr {(($X & $Z) | ($Y & (~$Z)))}]
+}
+
+# Inline the G function
+regsub -all -line \
+    {\[G (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+    $::md5::MD5Hash_bodyX \
+    {(((\1 \& \3) | (\2 \& (~\3))))} \
+    ::md5::MD5Hash_bodyX
+
+# RFC1321:3.4 - function H
+proc ::md5::H {X Y Z} {
+    return [expr {$X ^ $Y ^ $Z}]
+}
+
+# Inline the H function
+regsub -all -line \
+    {\[H (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+    $::md5::MD5Hash_bodyX \
+    {(\1 ^ \2 ^ \3)} \
+    ::md5::MD5Hash_bodyX
+
+# RFC1321:3.4 - function I
+proc ::md5::I {X Y Z} {
+    return [expr {$Y ^ ($X | (~$Z))}]
+}
+
+# Inline the I function
+regsub -all -line \
+    {\[I (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+    $::md5::MD5Hash_bodyX \
+    {(\2 ^ (\1 | (~\3)))} \
+    ::md5::MD5Hash_bodyX
+
+
+# RFC 1321:3.4 step 4: inline the set of constant modifiers.
+namespace eval md5 {
+    foreach tName {
+        T01 T02 T03 T04 T05 T06 T07 T08 T09 T10 
+        T11 T12 T13 T14 T15 T16 T17 T18 T19 T20 
+        T21 T22 T23 T24 T25 T26 T27 T28 T29 T30 
+        T31 T32 T33 T34 T35 T36 T37 T38 T39 T40 
+        T41 T42 T43 T44 T45 T46 T47 T48 T49 T50 
+        T51 T52 T53 T54 T55 T56 T57 T58 T59 T60 
+        T61 T62 T63 T64 
+    }  tVal {
+        0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee
+        0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501
+        0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be
+        0x6b901122 0xfd987193 0xa679438e 0x49b40821
+        
+        0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa
+        0xd62f105d 0x2441453  0xd8a1e681 0xe7d3fbc8
+        0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed
+        0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a
+        
+        0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c
+        0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70
+        0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05
+        0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665
+        
+        0xf4292244 0x432aff97 0xab9423a7 0xfc93a039
+        0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1
+        0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1
+        0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391
+    } {
+        lappend map \$$tName $tVal
+    }
+    set ::md5::MD5Hash_bodyX [string map $map $::md5::MD5Hash_bodyX]
+    unset map
+}
+
+# Define the MD5 hashing procedure with inline functions.
+proc ::md5::MD5Hash {token msg} $::md5::MD5Hash_bodyX
+
+# -------------------------------------------------------------------------
+
+if {[package provide Trf] != {}} {
+    interp alias {} ::md5::Hex {} ::hex -mode encode --
+} else {
+    proc ::md5::Hex {data} {
+        binary scan $data H* result
+        return [string toupper $result]
+    }
+}
+
+# -------------------------------------------------------------------------
+
+# LoadAccelerator --
+#
+#	This package can make use of a number of compiled extensions to
+#	accelerate the digest computation. This procedure manages the
+#	use of these extensions within the package. During normal usage
+#	this should not be called, but the test package manipulates the
+#	list of enabled accelerators.
+#
+proc ::md5::LoadAccelerator {name} {
+    variable accel
+    set r 0
+    switch -exact -- $name {
+        critcl {
+            if {![catch {package require tcllibc}]
+                || ![catch {package require md5c}]} {
+                set r [expr {[info command ::md5::md5c] != {}}]
+            }
+        }
+        cryptkit {
+            if {![catch {package require cryptkit}]} {
+                set r [expr {![catch {cryptkit::cryptInit}]}]
+            }
+        }
+        trf {
+            if {![catch {package require Trf}]} {
+                set r [expr {![catch {::md5 aa} msg]}]
+            }
+        }
+        default {
+            return -code error "invalid accelerator package:\
+                must be one of [join [array names accel] {, }]"
+        }
+    }
+    set accel($name) $r
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  Pop the nth element off a list. Used in options processing.
+#
+proc ::md5::Pop {varname {nth 0}} {
+    upvar $varname args
+    set r [lindex $args $nth]
+    set args [lreplace $args $nth $nth]
+    return $r
+}
+
+# -------------------------------------------------------------------------
+
+# fileevent handler for chunked file hashing.
+#
+proc ::md5::Chunk {token channel {chunksize 4096}} {
+    upvar #0 $token state
+    
+    if {[eof $channel]} {
+        fileevent $channel readable {}
+        set state(reading) 0
+    }
+        
+    MD5Update $token [read $channel $chunksize]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::md5::md5 {args} {
+    array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
+    while {[string match -* [set option [lindex $args 0]]]} {
+        switch -glob -- $option {
+            -hex       { set opts(-hex) 1 }
+            -file*     { set opts(-filename) [Pop args 1] }
+            -channel   { set opts(-channel) [Pop args 1] }
+            -chunksize { set opts(-chunksize) [Pop args 1] }
+            default {
+                if {[llength $args] == 1} { break }
+                if {[string compare $option "--"] == 0} { Pop args; break }
+                set err [join [lsort [array names opts]] ", "]
+                return -code error "bad option $option:\
+                    must be one of $err\nlen: [llength $args]"
+            }
+        }
+        Pop args
+    }
+
+    if {$opts(-filename) != {}} {
+        set opts(-channel) [open $opts(-filename) r]
+        fconfigure $opts(-channel) -translation binary
+    }
+
+    if {$opts(-channel) == {}} {
+
+        if {[llength $args] != 1} {
+            return -code error "wrong # args:\
+                should be \"md5 ?-hex? -filename file | string\""
+        }
+        set tok [MD5Init]
+        MD5Update $tok [lindex $args 0]
+        set r [MD5Final $tok]
+
+    } else {
+
+        set tok [MD5Init]
+        # FRINK: nocheck
+        set [subst $tok](reading) 1
+        fileevent $opts(-channel) readable \
+            [list [namespace origin Chunk] \
+                 $tok $opts(-channel) $opts(-chunksize)]
+        vwait [subst $tok](reading)
+        set r [MD5Final $tok]
+
+        # If we opened the channel - we should close it too.
+        if {$opts(-filename) != {}} {
+            close $opts(-channel)
+        }
+    }
+    
+    if {$opts(-hex)} {
+        set r [Hex $r]
+    }
+    return $r
+}
+
+# -------------------------------------------------------------------------
+
+proc ::md5::hmac {args} {
+    array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
+    while {[string match -* [set option [lindex $args 0]]]} {
+        switch -glob -- $option {
+            -key       { set opts(-key) [Pop args 1] }
+            -hex       { set opts(-hex) 1 }
+            -file*     { set opts(-filename) [Pop args 1] }
+            -channel   { set opts(-channel) [Pop args 1] }
+            -chunksize { set opts(-chunksize) [Pop args 1] }
+            default {
+                if {[llength $args] == 1} { break }
+                if {[string compare $option "--"] == 0} { Pop args; break }
+                set err [join [lsort [array names opts]] ", "]
+                return -code error "bad option $option:\
+                    must be one of $err"
+            }
+        }
+        Pop args
+    }
+
+    if {![info exists opts(-key)]} {
+        return -code error "wrong # args:\
+            should be \"hmac ?-hex? -key key -filename file | string\""
+    }
+
+    if {$opts(-filename) != {}} {
+        set opts(-channel) [open $opts(-filename) r]
+        fconfigure $opts(-channel) -translation binary
+    }
+
+    if {$opts(-channel) == {}} {
+
+        if {[llength $args] != 1} {
+            return -code error "wrong # args:\
+                should be \"hmac ?-hex? -key key -filename file | string\""
+        }
+        set tok [HMACInit $opts(-key)]
+        HMACUpdate $tok [lindex $args 0]
+        set r [HMACFinal $tok]
+
+    } else {
+
+        set tok [HMACInit $opts(-key)]
+        # FRINK: nocheck
+        set [subst $tok](reading) 1
+        fileevent $opts(-channel) readable \
+            [list [namespace origin Chunk] \
+                 $tok $opts(-channel) $opts(-chunksize)]
+        vwait [subst $tok](reading)
+        set r [HMACFinal $tok]
+
+        # If we opened the channel - we should close it too.
+        if {$opts(-filename) != {}} {
+            close $opts(-channel)
+        }
+    }
+    
+    if {$opts(-hex)} {
+        set r [Hex $r]
+    }
+    return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help.
+namespace eval ::md5 {
+    foreach e {critcl cryptkit trf} { if {[LoadAccelerator $e]} { break } }
+}
+
+package provide md5 $::md5::version
+
+# -------------------------------------------------------------------------
+# Local Variables:
+#   mode: tcl
+#   indent-tabs-mode: nil
+# End:
+
+
diff --git a/lib/md5/pkgIndex.tcl b/lib/md5/pkgIndex.tcl
new file mode 100644
index 0000000..1c436f0
--- /dev/null
+++ b/lib/md5/pkgIndex.tcl
@@ -0,0 +1,3 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded md5 2.0.5 [list source [file join $dir md5x.tcl]]
+package ifneeded md5 1.4.4 [list source [file join $dir md5.tcl]]
diff --git a/lib/sha1/pkgIndex.tcl b/lib/sha1/pkgIndex.tcl
new file mode 100644
index 0000000..297187e
--- /dev/null
+++ b/lib/sha1/pkgIndex.tcl
@@ -0,0 +1,14 @@
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script.  It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands.  When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded sha256 1.0.2 [list source [file join $dir sha256.tcl]]
+package ifneeded sha1   2.0.3 [list source [file join $dir sha1.tcl]]
+package ifneeded sha1   1.1.0 [list source [file join $dir sha1v1.tcl]]
diff --git a/lib/sha1/sha1.tcl b/lib/sha1/sha1.tcl
new file mode 100644
index 0000000..125c8f6
--- /dev/null
+++ b/lib/sha1/sha1.tcl
@@ -0,0 +1,818 @@
+# sha1.tcl - 
+#
+# Copyright (C) 2001 Don Libes <libes@nist.gov>
+# Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# SHA1 defined by FIPS 180-1, "The SHA1 Message-Digest Algorithm"
+# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
+#
+# This is an implementation of SHA1 based upon the example code given in
+# FIPS 180-1 and upon the tcllib MD4 implementation and taking some ideas
+# and methods from the earlier tcllib sha1 version by Don Libes.
+#
+# This implementation permits incremental updating of the hash and 
+# provides support for external compiled implementations either using
+# critcl (sha1c) or Trf.
+#
+# ref: http://www.itl.nist.gov/fipspubs/fip180-1.htm
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+# $Id: sha1.tcl,v 1.21 2007/05/03 21:41:10 andreas_kupries Exp $
+
+# @mdgen EXCLUDE: sha1c.tcl
+
+package require Tcl 8.2;                # tcl minimum version
+
+namespace eval ::sha1 {
+    variable  version 2.0.3
+    variable  rcsid {$Id: sha1.tcl,v 1.21 2007/05/03 21:41:10 andreas_kupries Exp $}
+
+    variable  accel
+    array set accel {tcl 0 critcl 0 cryptkit 0 trf 0}
+    variable  loaded {}
+    variable  active
+    array set active {tcl 0 critcl 0 cryptkit 0 trf 0}
+
+    namespace export sha1 hmac SHA1Init SHA1Update SHA1Final
+
+    variable uid
+    if {![info exists uid]} {
+        set uid 0
+    }
+}
+
+# -------------------------------------------------------------------------
+# Management of sha1 implementations.
+
+# LoadAccelerator --
+#
+#	This package can make use of a number of compiled extensions to
+#	accelerate the digest computation. This procedure manages the
+#	use of these extensions within the package. During normal usage
+#	this should not be called, but the test package manipulates the
+#	list of enabled accelerators.
+#
+proc ::sha1::LoadAccelerator {name} {
+    variable accel
+    set r 0
+    switch -exact -- $name {
+        tcl {
+            # Already present (this file)
+            set r 1
+        }
+        critcl {
+            if {![catch {package require tcllibc}]
+                || ![catch {package require sha1c}]} {
+                set r [expr {[info command ::sha1::sha1c] != {}}]
+            }
+        }
+        cryptkit {
+            if {![catch {package require cryptkit}]} {
+                set r [expr {![catch {cryptkit::cryptInit}]}]
+            }
+        }
+        trf {
+            if {![catch {package require Trf}]} {
+                set r [expr {![catch {::sha1 aa} msg]}]
+            }
+        }
+        default {
+            return -code error "invalid accelerator $key:\
+                must be one of [join [KnownImplementations] {, }]"
+        }
+    }
+    set accel($name) $r
+    return $r
+}
+
+# ::sha1::Implementations --
+#
+#	Determines which implementations are
+#	present, i.e. loaded.
+#
+# Arguments:
+#	None.
+#
+# Results:
+#	A list of implementation keys.
+
+proc ::sha1::Implementations {} {
+    variable accel
+    set res {}
+    foreach n [array names accel] {
+	if {!$accel($n)} continue
+	lappend res $n
+    }
+    return $res
+}
+
+# ::sha1::KnownImplementations --
+#
+#	Determines which implementations are known
+#	as possible implementations.
+#
+# Arguments:
+#	None.
+#
+# Results:
+#	A list of implementation keys. In the order
+#	of preference, most prefered first.
+
+proc ::sha1::KnownImplementations {} {
+    return {critcl cryptkit trf tcl}
+}
+
+proc ::sha1::Names {} {
+    return {
+	critcl   {tcllibc based}
+        cryptkit {cryptkit based}
+        trf      {Trf based}
+	tcl      {pure Tcl}
+    }
+}
+
+# ::sha1::SwitchTo --
+#
+#	Activates a loaded named implementation.
+#
+# Arguments:
+#	key	Name of the implementation to activate.
+#
+# Results:
+#	None.
+
+proc ::sha1::SwitchTo {key} {
+    variable accel
+    variable active
+    variable loaded
+
+    if {[string equal $key $loaded]} {
+	# No change, nothing to do.
+	return
+    } elseif {![string equal $key ""]} {
+	# Validate the target implementation of the switch.
+
+	if {![info exists accel($key)]} {
+	    return -code error "Unable to activate unknown implementation \"$key\""
+	} elseif {![info exists accel($key)] || !$accel($key)} {
+	    return -code error "Unable to activate missing implementation \"$key\""
+	}
+    }
+
+    if {![string equal $loaded ""]} {
+        set active($loaded) 0
+    }
+    if {![string equal $key ""]} {
+        set active($key) 1
+    }
+
+    # Remember the active implementation, for deactivation by future
+    # switches.
+
+    set loaded $key
+    return
+}
+
+# -------------------------------------------------------------------------
+
+# SHA1Init --
+#
+#   Create and initialize an SHA1 state variable. This will be
+#   cleaned up when we call SHA1Final
+#
+
+proc ::sha1::SHA1Init {} {
+    variable active
+    variable uid
+    set token [namespace current]::[incr uid]
+    upvar #0 $token state
+
+    # FIPS 180-1: 7 - Initialize the hash state
+    array set state \
+        [list \
+             A [expr {int(0x67452301)}] \
+             B [expr {int(0xEFCDAB89)}] \
+             C [expr {int(0x98BADCFE)}] \
+             D [expr {int(0x10325476)}] \
+             E [expr {int(0xC3D2E1F0)}] \
+             n 0 i "" ]
+    if {$active(cryptkit)} {
+        cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_SHA
+    } elseif {$active(trf)} {
+        set s {}
+        switch -exact -- $::tcl_platform(platform) {
+            windows { set s [open NUL w] }
+            unix    { set s [open /dev/null w] }
+        }
+        if {$s != {}} {
+            fconfigure $s -translation binary -buffering none
+            ::sha1 -attach $s -mode write \
+                -read-type variable \
+                -read-destination [subst $token](trfread) \
+                -write-type variable \
+                -write-destination [subst $token](trfwrite)
+            array set state [list trfread 0 trfwrite 0 trf $s]
+        }
+    }
+    return $token
+}
+
+# SHA1Update --
+#
+#   This is called to add more data into the hash. You may call this
+#   as many times as you require. Note that passing in "ABC" is equivalent
+#   to passing these letters in as separate calls -- hence this proc 
+#   permits hashing of chunked data
+#
+#   If we have a C-based implementation available, then we will use
+#   it here in preference to the pure-Tcl implementation.
+#
+proc ::sha1::SHA1Update {token data} {
+    variable active
+    upvar #0 $token state
+
+    if {$active(critcl)} {
+        if {[info exists state(sha1c)]} {
+            set state(sha1c) [sha1c $data $state(sha1c)]
+        } else {
+            set state(sha1c) [sha1c $data]
+        }
+        return
+    } elseif {[info exists state(ckctx)]} {
+        if {[string length $data] > 0} {
+            cryptkit::cryptEncrypt $state(ckctx) $data
+        }
+        return
+    } elseif {[info exists state(trf)]} {
+        puts -nonewline $state(trf) $data
+        return
+    }
+
+    # Update the state values
+    incr state(n) [string length $data]
+    append state(i) $data
+
+    # Calculate the hash for any complete blocks
+    set len [string length $state(i)]
+    for {set n 0} {($n + 64) <= $len} {} {
+        SHA1Transform $token [string range $state(i) $n [incr n 64]]
+    }
+
+    # Adjust the state for the blocks completed.
+    set state(i) [string range $state(i) $n end]
+    return
+}
+
+# SHA1Final --
+#
+#    This procedure is used to close the current hash and returns the
+#    hash data. Once this procedure has been called the hash context
+#    is freed and cannot be used again.
+#
+#    Note that the output is 160 bits represented as binary data.
+#
+proc ::sha1::SHA1Final {token} {
+    upvar #0 $token state
+
+    # Check for either of the C-compiled versions.
+    if {[info exists state(sha1c)]} {
+        set r $state(sha1c)
+        unset state
+        return $r
+    } elseif {[info exists state(ckctx)]} {
+        cryptkit::cryptEncrypt $state(ckctx) ""
+        cryptkit::cryptGetAttributeString $state(ckctx) \
+            CRYPT_CTXINFO_HASHVALUE r 20
+        cryptkit::cryptDestroyContext $state(ckctx)
+        # If nothing was hashed, we get no r variable set!
+        if {[info exists r]} {
+            unset state
+            return $r
+        }
+    } elseif {[info exists state(trf)]} {
+        close $state(trf)
+        set r $state(trfwrite)
+        unset state
+        return $r
+    }
+
+    # Padding
+    #
+    set len [string length $state(i)]
+    set pad [expr {56 - ($len % 64)}]
+    if {$len % 64 > 56} {
+        incr pad 64
+    }
+    if {$pad == 0} {
+        incr pad 64
+    }
+    append state(i) [binary format a$pad \x80]
+
+    # Append length in bits as big-endian wide int.
+    set dlen [expr {8 * $state(n)}]
+    append state(i) [binary format II 0 $dlen]
+
+    # Calculate the hash for the remaining block.
+    set len [string length $state(i)]
+    for {set n 0} {($n + 64) <= $len} {} {
+        SHA1Transform $token [string range $state(i) $n [incr n 64]]
+    }
+
+    # Output
+    set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)][bytes $state(E)]
+    unset state
+    return $r
+}
+
+# -------------------------------------------------------------------------
+# HMAC Hashed Message Authentication (RFC 2104)
+#
+# hmac = H(K xor opad, H(K xor ipad, text))
+#
+
+# HMACInit --
+#
+#    This is equivalent to the SHA1Init procedure except that a key is
+#    added into the algorithm
+#
+proc ::sha1::HMACInit {K} {
+
+    # Key K is adjusted to be 64 bytes long. If K is larger, then use
+    # the SHA1 digest of K and pad this instead.
+    set len [string length $K]
+    if {$len > 64} {
+        set tok [SHA1Init]
+        SHA1Update $tok $K
+        set K [SHA1Final $tok]
+        set len [string length $K]
+    }
+    set pad [expr {64 - $len}]
+    append K [string repeat \0 $pad]
+
+    # Cacluate the padding buffers.
+    set Ki {}
+    set Ko {}
+    binary scan $K i16 Ks
+    foreach k $Ks {
+        append Ki [binary format i [expr {$k ^ 0x36363636}]]
+        append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]]
+    }
+
+    set tok [SHA1Init]
+    SHA1Update $tok $Ki;                 # initialize with the inner pad
+    
+    # preserve the Ko value for the final stage.
+    # FRINK: nocheck
+    set [subst $tok](Ko) $Ko
+
+    return $tok
+}
+
+# HMACUpdate --
+#
+#    Identical to calling SHA1Update
+#
+proc ::sha1::HMACUpdate {token data} {
+    SHA1Update $token $data
+    return
+}
+
+# HMACFinal --
+#
+#    This is equivalent to the SHA1Final procedure. The hash context is
+#    closed and the binary representation of the hash result is returned.
+#
+proc ::sha1::HMACFinal {token} {
+    upvar #0 $token state
+
+    set tok [SHA1Init];                 # init the outer hashing function
+    SHA1Update $tok $state(Ko);         # prepare with the outer pad.
+    SHA1Update $tok [SHA1Final $token]; # hash the inner result
+    return [SHA1Final $tok]
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#  This is the core SHA1 algorithm. It is a lot like the MD4 algorithm but
+#  includes an extra round and a set of constant modifiers throughout.
+#
+set ::sha1::SHA1Transform_body {
+    upvar #0 $token state
+
+    # FIPS 180-1: 7a: Process Message in 16-Word Blocks
+    binary scan $msg I* blocks
+    set blockLen [llength $blocks]
+    for {set i 0} {$i < $blockLen} {incr i 16} {
+        set W [lrange $blocks $i [expr {$i+15}]]
+        
+        # FIPS 180-1: 7b: Expand the input into 80 words
+        # For t = 16 to 79 
+        #   let Wt = (Wt-3 ^ Wt-8 ^ Wt-14 ^ Wt-16) <<< 1
+        set t3  12
+        set t8   7
+        set t14  1
+        set t16 -1
+        for {set t 16} {$t < 80} {incr t} {
+            set x [expr {[lindex $W [incr t3]] ^ [lindex $W [incr t8]] ^ \
+                             [lindex $W [incr t14]] ^ [lindex $W [incr t16]]}]
+            lappend W [expr {int(($x << 1) | (($x >> 31) & 1))}]
+        }
+        
+        # FIPS 180-1: 7c: Copy hash state.
+        set A $state(A)
+        set B $state(B)
+        set C $state(C)
+        set D $state(D)
+        set E $state(E)
+
+        # FIPS 180-1: 7d: Do permutation rounds
+        # For t = 0 to 79 do
+        #   TEMP = (A<<<5) + ft(B,C,D) + E + Wt + Kt;
+        #   E = D; D = C; C = S30(B); B = A; A = TEMP;
+
+        # Round 1: ft(B,C,D) = (B & C) | (~B & D) ( 0 <= t <= 19)
+        for {set t 0} {$t < 20} {incr t} {
+            set TEMP [F1 $A $B $C $D $E [lindex $W $t]]
+            set E $D
+            set D $C
+            set C [rotl32 $B 30]
+            set B $A
+            set A $TEMP
+        }
+
+        # Round 2: ft(B,C,D) = (B ^ C ^ D) ( 20 <= t <= 39)
+        for {} {$t < 40} {incr t} {
+            set TEMP [F2 $A $B $C $D $E [lindex $W $t]]
+            set E $D
+            set D $C
+            set C [rotl32 $B 30]
+            set B $A
+            set A $TEMP
+        }
+
+        # Round 3: ft(B,C,D) = ((B & C) | (B & D) | (C & D)) ( 40 <= t <= 59)
+        for {} {$t < 60} {incr t} {
+            set TEMP [F3 $A $B $C $D $E [lindex $W $t]]
+            set E $D
+            set D $C
+            set C [rotl32 $B 30]
+            set B $A
+            set A $TEMP
+         }
+
+        # Round 4: ft(B,C,D) = (B ^ C ^ D) ( 60 <= t <= 79)
+        for {} {$t < 80} {incr t} {
+            set TEMP [F4 $A $B $C $D $E [lindex $W $t]]
+            set E $D
+            set D $C
+            set C [rotl32 $B 30]
+            set B $A
+            set A $TEMP
+        }
+
+        # Then perform the following additions. (That is, increment each
+        # of the four registers by the value it had before this block
+        # was started.)
+        incr state(A) $A
+        incr state(B) $B
+        incr state(C) $C
+        incr state(D) $D
+        incr state(E) $E
+    }
+
+    return
+}
+
+proc ::sha1::F1 {A B C D E W} {
+    expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \
+               + ($D ^ ($B & ($C ^ $D))) + $E + $W + 0x5a827999) & 0xffffffff}
+}
+
+proc ::sha1::F2 {A B C D E W} {
+    expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \
+               + ($B ^ $C ^ $D) + $E + $W + 0x6ed9eba1) & 0xffffffff}
+}
+
+proc ::sha1::F3 {A B C D E W} {
+    expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \
+               + (($B & $C) | ($D & ($B | $C))) + $E + $W + 0x8f1bbcdc) & 0xffffffff}
+}
+
+proc ::sha1::F4 {A B C D E W} {
+    expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \
+               + ($B ^ $C ^ $D) + $E + $W + 0xca62c1d6) & 0xffffffff}
+}
+
+proc ::sha1::rotl32 {v n} {
+    return [expr {((($v << $n) \
+                        | (($v >> (32 - $n)) \
+                               & (0x7FFFFFFF >> (31 - $n))))) \
+                      & 0xFFFFFFFF}]
+}
+
+
+# -------------------------------------------------------------------------
+# 
+# In order to get this code to go as fast as possible while leaving
+# the main code readable we can substitute the above function bodies
+# into the transform procedure. This inlines the code for us an avoids
+# a procedure call overhead within the loops.
+#
+# We can do some minor tweaking to improve speed on Tcl < 8.5 where we
+# know our arithmetic is limited to 64 bits. On > 8.5 we may have 
+# unconstrained integer arithmetic and must avoid letting it run away.
+#
+
+regsub -all -line \
+    {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+    $::sha1::SHA1Transform_body \
+    {[expr {(rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999) \& 0xffffffff}]} \
+    ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+    {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+    $::sha1::SHA1Transform_body_tmp \
+    {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1) \& 0xffffffff}]} \
+    ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+    {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+    $::sha1::SHA1Transform_body_tmp \
+    {[expr {(rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc) \& 0xffffffff}]} \
+    ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+    {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+    $::sha1::SHA1Transform_body_tmp \
+    {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6) \& 0xffffffff}]} \
+    ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+    {rotl32\(\$A,5\)} \
+    $::sha1::SHA1Transform_body_tmp \
+    {((($A << 5) \& 0xffffffff) | (($A >> 27) \& 0x1f))} \
+    ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+    {\[rotl32 \$B 30\]} \
+    $::sha1::SHA1Transform_body_tmp \
+    {[expr {int(($B << 30) | (($B >> 2) \& 0x3fffffff))}]} \
+    ::sha1::SHA1Transform_body_tmp
+#
+# Version 2 avoids a few truncations to 32 bits in non-essential places.
+#
+regsub -all -line \
+    {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+    $::sha1::SHA1Transform_body \
+    {[expr {rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999}]} \
+    ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+    {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+    $::sha1::SHA1Transform_body_tmp2 \
+    {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1}]} \
+    ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+    {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+    $::sha1::SHA1Transform_body_tmp2 \
+    {[expr {rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc}]} \
+    ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+    {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+    $::sha1::SHA1Transform_body_tmp2 \
+    {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6}]} \
+    ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+    {rotl32\(\$A,5\)} \
+    $::sha1::SHA1Transform_body_tmp2 \
+    {(($A << 5) | (($A >> 27) \& 0x1f))} \
+    ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+    {\[rotl32 \$B 30\]} \
+    $::sha1::SHA1Transform_body_tmp2 \
+    {[expr {($B << 30) | (($B >> 2) \& 0x3fffffff)}]} \
+    ::sha1::SHA1Transform_body_tmp2
+
+if {[package vsatisfies [package provide Tcl] 8.5]} {
+    proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp
+} else {
+    proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp2
+}
+
+unset ::sha1::SHA1Transform_body
+unset ::sha1::SHA1Transform_body_tmp
+unset ::sha1::SHA1Transform_body_tmp2
+
+# -------------------------------------------------------------------------
+
+proc ::sha1::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}}
+proc ::sha1::bytes {v} { 
+    #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v]
+    format %c%c%c%c \
+        [expr {((0xFF000000 & $v) >> 24) & 0xFF}] \
+        [expr {(0xFF0000 & $v) >> 16}] \
+        [expr {(0xFF00 & $v) >> 8}] \
+        [expr {0xFF & $v}]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::sha1::Hex {data} {
+    binary scan $data H* result
+    return $result
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  Pop the nth element off a list. Used in options processing.
+#
+proc ::sha1::Pop {varname {nth 0}} {
+    upvar $varname args
+    set r [lindex $args $nth]
+    set args [lreplace $args $nth $nth]
+    return $r
+}
+
+# -------------------------------------------------------------------------
+
+# fileevent handler for chunked file hashing.
+#
+proc ::sha1::Chunk {token channel {chunksize 4096}} {
+    upvar #0 $token state
+    
+    if {[eof $channel]} {
+        fileevent $channel readable {}
+        set state(reading) 0
+    }
+        
+    SHA1Update $token [read $channel $chunksize]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::sha1::sha1 {args} {
+    array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
+    if {[llength $args] == 1} {
+        set opts(-hex) 1
+    } else {
+        while {[string match -* [set option [lindex $args 0]]]} {
+            switch -glob -- $option {
+                -hex       { set opts(-hex) 1 }
+                -bin       { set opts(-hex) 0 }
+                -file*     { set opts(-filename) [Pop args 1] }
+                -channel   { set opts(-channel) [Pop args 1] }
+                -chunksize { set opts(-chunksize) [Pop args 1] }
+                default {
+                    if {[llength $args] == 1} { break }
+                    if {[string compare $option "--"] == 0} { Pop args; break }
+                    set err [join [lsort [concat -bin [array names opts]]] ", "]
+                    return -code error "bad option $option:\
+                    must be one of $err"
+                }
+            }
+            Pop args
+        }
+    }
+
+    if {$opts(-filename) != {}} {
+        set opts(-channel) [open $opts(-filename) r]
+        fconfigure $opts(-channel) -translation binary
+    }
+
+    if {$opts(-channel) == {}} {
+
+        if {[llength $args] != 1} {
+            return -code error "wrong # args:\
+                should be \"sha1 ?-hex? -filename file | string\""
+        }
+        set tok [SHA1Init]
+        SHA1Update $tok [lindex $args 0]
+        set r [SHA1Final $tok]
+
+    } else {
+
+        set tok [SHA1Init]
+        # FRINK: nocheck
+        set [subst $tok](reading) 1
+        fileevent $opts(-channel) readable \
+            [list [namespace origin Chunk] \
+                 $tok $opts(-channel) $opts(-chunksize)]
+        # FRINK: nocheck
+        vwait [subst $tok](reading)
+        set r [SHA1Final $tok]
+
+        # If we opened the channel - we should close it too.
+        if {$opts(-filename) != {}} {
+            close $opts(-channel)
+        }
+    }
+    
+    if {$opts(-hex)} {
+        set r [Hex $r]
+    }
+    return $r
+}
+
+# -------------------------------------------------------------------------
+
+proc ::sha1::hmac {args} {
+    array set opts {-hex 1 -filename {} -channel {} -chunksize 4096}
+    if {[llength $args] != 2} {
+        while {[string match -* [set option [lindex $args 0]]]} {
+            switch -glob -- $option {
+                -key       { set opts(-key) [Pop args 1] }
+                -hex       { set opts(-hex) 1 }
+                -bin       { set opts(-hex) 0 }
+                -file*     { set opts(-filename) [Pop args 1] }
+                -channel   { set opts(-channel) [Pop args 1] }
+                -chunksize { set opts(-chunksize) [Pop args 1] }
+                default {
+                    if {[llength $args] == 1} { break }
+                    if {[string compare $option "--"] == 0} { Pop args; break }
+                    set err [join [lsort [array names opts]] ", "]
+                    return -code error "bad option $option:\
+                    must be one of $err"
+                }
+            }
+            Pop args
+        }
+    }
+
+    if {[llength $args] == 2} {
+        set opts(-key) [Pop args]
+    }
+
+    if {![info exists opts(-key)]} {
+        return -code error "wrong # args:\
+            should be \"hmac ?-hex? -key key -filename file | string\""
+    }
+
+    if {$opts(-filename) != {}} {
+        set opts(-channel) [open $opts(-filename) r]
+        fconfigure $opts(-channel) -translation binary
+    }
+
+    if {$opts(-channel) == {}} {
+
+        if {[llength $args] != 1} {
+            return -code error "wrong # args:\
+                should be \"hmac ?-hex? -key key -filename file | string\""
+        }
+        set tok [HMACInit $opts(-key)]
+        HMACUpdate $tok [lindex $args 0]
+        set r [HMACFinal $tok]
+
+    } else {
+
+        set tok [HMACInit $opts(-key)]
+        # FRINK: nocheck
+        set [subst $tok](reading) 1
+        fileevent $opts(-channel) readable \
+            [list [namespace origin Chunk] \
+                 $tok $opts(-channel) $opts(-chunksize)]
+        # FRINK: nocheck
+        vwait [subst $tok](reading)
+        set r [HMACFinal $tok]
+
+        # If we opened the channel - we should close it too.
+        if {$opts(-filename) != {}} {
+            close $opts(-channel)
+        }
+    }
+    
+    if {$opts(-hex)} {
+        set r [Hex $r]
+    }
+    return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help.
+namespace eval ::sha1 {
+    variable e {}
+    foreach e [KnownImplementations] {
+	if {[LoadAccelerator $e]} {
+	    SwitchTo $e
+	    break
+	}
+    }
+    unset e
+}
+
+package provide sha1 $::sha1::version
+
+# -------------------------------------------------------------------------
+# Local Variables:
+#   mode: tcl
+#   indent-tabs-mode: nil
+# End:
diff --git a/lib/sha1/sha1v1.tcl b/lib/sha1/sha1v1.tcl
new file mode 100644
index 0000000..057560d
--- /dev/null
+++ b/lib/sha1/sha1v1.tcl
@@ -0,0 +1,713 @@
+# sha1.tcl - 
+#
+# Copyright (C) 2001 Don Libes <libes@nist.gov>
+# Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# SHA1 defined by FIPS 180-1, "The SHA1 Message-Digest Algorithm"
+# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
+#
+# This is an implementation of SHA1 based upon the example code given in
+# FIPS 180-1 and upon the tcllib MD4 implementation and taking some ideas
+# and methods from the earlier tcllib sha1 version by Don Libes.
+#
+# This implementation permits incremental updating of the hash and 
+# provides support for external compiled implementations either using
+# critcl (sha1c) or Trf.
+#
+# ref: http://www.itl.nist.gov/fipspubs/fip180-1.htm
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+# $Id: sha1v1.tcl,v 1.1 2006/03/12 22:46:13 andreas_kupries Exp $
+
+# @mdgen EXCLUDE: sha1c.tcl
+
+package require Tcl 8.2;                # tcl minimum version
+
+namespace eval ::sha1 {
+    variable version 1.1.0
+    variable rcsid {$Id: sha1v1.tcl,v 1.1 2006/03/12 22:46:13 andreas_kupries Exp $}
+    variable accel
+    array set accel {critcl 0 cryptkit 0 trf 0}
+
+    namespace export sha1 hmac SHA1Init SHA1Update SHA1Final
+
+    variable uid
+    if {![info exists uid]} {
+        set uid 0
+    }
+}
+
+# -------------------------------------------------------------------------
+
+# SHA1Init --
+#
+#   Create and initialize an SHA1 state variable. This will be
+#   cleaned up when we call SHA1Final
+#
+proc ::sha1::SHA1Init {} {
+    variable accel
+    variable uid
+    set token [namespace current]::[incr uid]
+    upvar #0 $token state
+
+    # FIPS 180-1: 7 - Initialize the hash state
+    array set state \
+        [list \
+             A [expr {int(0x67452301)}] \
+             B [expr {int(0xEFCDAB89)}] \
+             C [expr {int(0x98BADCFE)}] \
+             D [expr {int(0x10325476)}] \
+             E [expr {int(0xC3D2E1F0)}] \
+             n 0 i "" ]
+    if {$accel(cryptkit)} {
+        cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_SHA
+    } elseif {$accel(trf)} {
+        set s {}
+        switch -exact -- $::tcl_platform(platform) {
+            windows { set s [open NUL w] }
+            unix    { set s [open /dev/null w] }
+        }
+        if {$s != {}} {
+            fconfigure $s -translation binary -buffering none
+            ::sha1 -attach $s -mode write \
+                -read-type variable \
+                -read-destination [subst $token](trfread) \
+                -write-type variable \
+                -write-destination [subst $token](trfwrite)
+            array set state [list trfread 0 trfwrite 0 trf $s]
+        }
+    }
+    return $token
+}
+
+# SHA1Update --
+#
+#   This is called to add more data into the hash. You may call this
+#   as many times as you require. Note that passing in "ABC" is equivalent
+#   to passing these letters in as separate calls -- hence this proc 
+#   permits hashing of chunked data
+#
+#   If we have a C-based implementation available, then we will use
+#   it here in preference to the pure-Tcl implementation.
+#
+proc ::sha1::SHA1Update {token data} {
+    variable accel
+    upvar #0 $token state
+
+    if {$accel(critcl)} {
+        if {[info exists state(sha1c)]} {
+            set state(sha1c) [sha1c $data $state(sha1c)]
+        } else {
+            set state(sha1c) [sha1c $data]
+        }
+        return
+    } elseif {[info exists state(ckctx)]} {
+        if {[string length $data] > 0} {
+            cryptkit::cryptEncrypt $state(ckctx) $data
+        }
+        return
+    } elseif {[info exists state(trf)]} {
+        puts -nonewline $state(trf) $data
+        return
+    }
+
+    # Update the state values
+    incr state(n) [string length $data]
+    append state(i) $data
+
+    # Calculate the hash for any complete blocks
+    set len [string length $state(i)]
+    for {set n 0} {($n + 64) <= $len} {} {
+        SHA1Transform $token [string range $state(i) $n [incr n 64]]
+    }
+
+    # Adjust the state for the blocks completed.
+    set state(i) [string range $state(i) $n end]
+    return
+}
+
+# SHA1Final --
+#
+#    This procedure is used to close the current hash and returns the
+#    hash data. Once this procedure has been called the hash context
+#    is freed and cannot be used again.
+#
+#    Note that the output is 160 bits represented as binary data.
+#
+proc ::sha1::SHA1Final {token} {
+    upvar #0 $token state
+
+    # Check for either of the C-compiled versions.
+    if {[info exists state(sha1c)]} {
+        set r $state(sha1c)
+        unset state
+        return $r
+    } elseif {[info exists state(ckctx)]} {
+        cryptkit::cryptEncrypt $state(ckctx) ""
+        cryptkit::cryptGetAttributeString $state(ckctx) \
+            CRYPT_CTXINFO_HASHVALUE r 20
+        cryptkit::cryptDestroyContext $state(ckctx)
+        # If nothing was hashed, we get no r variable set!
+        if {[info exists r]} {
+            unset state
+            return $r
+        }
+    } elseif {[info exists state(trf)]} {
+        close $state(trf)
+        set r $state(trfwrite)
+        unset state
+        return $r
+    }
+
+    # Padding
+    #
+    set len [string length $state(i)]
+    set pad [expr {56 - ($len % 64)}]
+    if {$len % 64 > 56} {
+        incr pad 64
+    }
+    if {$pad == 0} {
+        incr pad 64
+    }
+    append state(i) [binary format a$pad \x80]
+
+    # Append length in bits as big-endian wide int.
+    set dlen [expr {8 * $state(n)}]
+    append state(i) [binary format II 0 $dlen]
+
+    # Calculate the hash for the remaining block.
+    set len [string length $state(i)]
+    for {set n 0} {($n + 64) <= $len} {} {
+        SHA1Transform $token [string range $state(i) $n [incr n 64]]
+    }
+
+    # Output
+    set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)][bytes $state(E)]
+    unset state
+    return $r
+}
+
+# -------------------------------------------------------------------------
+# HMAC Hashed Message Authentication (RFC 2104)
+#
+# hmac = H(K xor opad, H(K xor ipad, text))
+#
+
+# HMACInit --
+#
+#    This is equivalent to the SHA1Init procedure except that a key is
+#    added into the algorithm
+#
+proc ::sha1::HMACInit {K} {
+
+    # Key K is adjusted to be 64 bytes long. If K is larger, then use
+    # the SHA1 digest of K and pad this instead.
+    set len [string length $K]
+    if {$len > 64} {
+        set tok [SHA1Init]
+        SHA1Update $tok $K
+        set K [SHA1Final $tok]
+        set len [string length $K]
+    }
+    set pad [expr {64 - $len}]
+    append K [string repeat \0 $pad]
+
+    # Cacluate the padding buffers.
+    set Ki {}
+    set Ko {}
+    binary scan $K i16 Ks
+    foreach k $Ks {
+        append Ki [binary format i [expr {$k ^ 0x36363636}]]
+        append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]]
+    }
+
+    set tok [SHA1Init]
+    SHA1Update $tok $Ki;                 # initialize with the inner pad
+    
+    # preserve the Ko value for the final stage.
+    # FRINK: nocheck
+    set [subst $tok](Ko) $Ko
+
+    return $tok
+}
+
+# HMACUpdate --
+#
+#    Identical to calling SHA1Update
+#
+proc ::sha1::HMACUpdate {token data} {
+    SHA1Update $token $data
+    return
+}
+
+# HMACFinal --
+#
+#    This is equivalent to the SHA1Final procedure. The hash context is
+#    closed and the binary representation of the hash result is returned.
+#
+proc ::sha1::HMACFinal {token} {
+    upvar #0 $token state
+
+    set tok [SHA1Init];                 # init the outer hashing function
+    SHA1Update $tok $state(Ko);         # prepare with the outer pad.
+    SHA1Update $tok [SHA1Final $token]; # hash the inner result
+    return [SHA1Final $tok]
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#  This is the core SHA1 algorithm. It is a lot like the MD4 algorithm but
+#  includes an extra round and a set of constant modifiers throughout.
+#
+set ::sha1::SHA1Transform_body {
+    upvar #0 $token state
+
+    # FIPS 180-1: 7a: Process Message in 16-Word Blocks
+    binary scan $msg I* blocks
+    set blockLen [llength $blocks]
+    for {set i 0} {$i < $blockLen} {incr i 16} {
+        set W [lrange $blocks $i [expr {$i+15}]]
+        
+        # FIPS 180-1: 7b: Expand the input into 80 words
+        # For t = 16 to 79 
+        #   let Wt = (Wt-3 ^ Wt-8 ^ Wt-14 ^ Wt-16) <<< 1
+        set t3  12
+        set t8   7
+        set t14  1
+        set t16 -1
+        for {set t 16} {$t < 80} {incr t} {
+            set x [expr {[lindex $W [incr t3]] ^ [lindex $W [incr t8]] ^ \
+                             [lindex $W [incr t14]] ^ [lindex $W [incr t16]]}]
+            lappend W [expr {int(($x << 1) | (($x >> 31) & 1))}]
+        }
+        
+        # FIPS 180-1: 7c: Copy hash state.
+        set A $state(A)
+        set B $state(B)
+        set C $state(C)
+        set D $state(D)
+        set E $state(E)
+
+        # FIPS 180-1: 7d: Do permutation rounds
+        # For t = 0 to 79 do
+        #   TEMP = (A<<<5) + ft(B,C,D) + E + Wt + Kt;
+        #   E = D; D = C; C = S30(B); B = A; A = TEMP;
+
+        # Round 1: ft(B,C,D) = (B & C) | (~B & D) ( 0 <= t <= 19)
+        for {set t 0} {$t < 20} {incr t} {
+            set TEMP [F1 $A $B $C $D $E [lindex $W $t]]
+            set E $D
+            set D $C
+            set C [rotl32 $B 30]
+            set B $A
+            set A $TEMP
+        }
+
+        # Round 2: ft(B,C,D) = (B ^ C ^ D) ( 20 <= t <= 39)
+        for {} {$t < 40} {incr t} {
+            set TEMP [F2 $A $B $C $D $E [lindex $W $t]]
+            set E $D
+            set D $C
+            set C [rotl32 $B 30]
+            set B $A
+            set A $TEMP
+        }
+
+        # Round 3: ft(B,C,D) = ((B & C) | (B & D) | (C & D)) ( 40 <= t <= 59)
+        for {} {$t < 60} {incr t} {
+            set TEMP [F3 $A $B $C $D $E [lindex $W $t]]
+            set E $D
+            set D $C
+            set C [rotl32 $B 30]
+            set B $A
+            set A $TEMP
+         }
+
+        # Round 4: ft(B,C,D) = (B ^ C ^ D) ( 60 <= t <= 79)
+        for {} {$t < 80} {incr t} {
+            set TEMP [F4 $A $B $C $D $E [lindex $W $t]]
+            set E $D
+            set D $C
+            set C [rotl32 $B 30]
+            set B $A
+            set A $TEMP
+        }
+
+        # Then perform the following additions. (That is, increment each
+        # of the four registers by the value it had before this block
+        # was started.)
+        incr state(A) $A
+        incr state(B) $B
+        incr state(C) $C
+        incr state(D) $D
+        incr state(E) $E
+    }
+
+    return
+}
+
+proc ::sha1::F1 {A B C D E W} {
+    expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \
+               + ($D ^ ($B & ($C ^ $D))) + $E + $W + 0x5a827999) & 0xffffffff}
+}
+
+proc ::sha1::F2 {A B C D E W} {
+    expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \
+               + ($B ^ $C ^ $D) + $E + $W + 0x6ed9eba1) & 0xffffffff}
+}
+
+proc ::sha1::F3 {A B C D E W} {
+    expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \
+               + (($B & $C) | ($D & ($B | $C))) + $E + $W + 0x8f1bbcdc) & 0xffffffff}
+}
+
+proc ::sha1::F4 {A B C D E W} {
+    expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \
+               + ($B ^ $C ^ $D) + $E + $W + 0xca62c1d6) & 0xffffffff}
+}
+
+proc ::sha1::rotl32 {v n} {
+    return [expr {((($v << $n) \
+                        | (($v >> (32 - $n)) \
+                               & (0x7FFFFFFF >> (31 - $n))))) \
+                      & 0xFFFFFFFF}]
+}
+
+
+# -------------------------------------------------------------------------
+# 
+# In order to get this code to go as fast as possible while leaving
+# the main code readable we can substitute the above function bodies
+# into the transform procedure. This inlines the code for us an avoids
+# a procedure call overhead within the loops.
+#
+# We can do some minor tweaking to improve speed on Tcl < 8.5 where we
+# know our arithmetic is limited to 64 bits. On > 8.5 we may have 
+# unconstrained integer arithmetic and must avoid letting it run away.
+#
+
+regsub -all -line \
+    {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+    $::sha1::SHA1Transform_body \
+    {[expr {(rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999) \& 0xffffffff}]} \
+    ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+    {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+    $::sha1::SHA1Transform_body_tmp \
+    {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1) \& 0xffffffff}]} \
+    ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+    {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+    $::sha1::SHA1Transform_body_tmp \
+    {[expr {(rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc) \& 0xffffffff}]} \
+    ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+    {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+    $::sha1::SHA1Transform_body_tmp \
+    {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6) \& 0xffffffff}]} \
+    ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+    {rotl32\(\$A,5\)} \
+    $::sha1::SHA1Transform_body_tmp \
+    {((($A << 5) \& 0xffffffff) | (($A >> 27) \& 0x1f))} \
+    ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+    {\[rotl32 \$B 30\]} \
+    $::sha1::SHA1Transform_body_tmp \
+    {[expr {int(($B << 30) | (($B >> 2) \& 0x3fffffff))}]} \
+    ::sha1::SHA1Transform_body_tmp
+#
+# Version 2 avoids a few truncations to 32 bits in non-essential places.
+#
+regsub -all -line \
+    {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+    $::sha1::SHA1Transform_body \
+    {[expr {rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999}]} \
+    ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+    {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+    $::sha1::SHA1Transform_body_tmp2 \
+    {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1}]} \
+    ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+    {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+    $::sha1::SHA1Transform_body_tmp2 \
+    {[expr {rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc}]} \
+    ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+    {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+    $::sha1::SHA1Transform_body_tmp2 \
+    {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6}]} \
+    ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+    {rotl32\(\$A,5\)} \
+    $::sha1::SHA1Transform_body_tmp2 \
+    {(($A << 5) | (($A >> 27) \& 0x1f))} \
+    ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+    {\[rotl32 \$B 30\]} \
+    $::sha1::SHA1Transform_body_tmp2 \
+    {[expr {($B << 30) | (($B >> 2) \& 0x3fffffff)}]} \
+    ::sha1::SHA1Transform_body_tmp2
+
+if {[package vsatisfies [package provide Tcl] 8.5]} {
+    proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp
+} else {
+    proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp2
+}
+
+unset ::sha1::SHA1Transform_body_tmp
+unset ::sha1::SHA1Transform_body_tmp2
+
+# -------------------------------------------------------------------------
+
+proc ::sha1::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}}
+proc ::sha1::bytes {v} { 
+    #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v]
+    format %c%c%c%c \
+        [expr {((0xFF000000 & $v) >> 24) & 0xFF}] \
+        [expr {(0xFF0000 & $v) >> 16}] \
+        [expr {(0xFF00 & $v) >> 8}] \
+        [expr {0xFF & $v}]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::sha1::Hex {data} {
+    binary scan $data H* result
+    return $result
+}
+
+# -------------------------------------------------------------------------
+
+# LoadAccelerator --
+#
+#	This package can make use of a number of compiled extensions to
+#	accelerate the digest computation. This procedure manages the
+#	use of these extensions within the package. During normal usage
+#	this should not be called, but the test package manipulates the
+#	list of enabled accelerators.
+#
+proc ::sha1::LoadAccelerator {name} {
+    variable accel
+    set r 0
+    switch -exact -- $name {
+        critcl {
+            if {![catch {package require tcllibc}]
+                || ![catch {package require sha1c}]} {
+                set r [expr {[info command ::sha1::sha1c] != {}}]
+            }
+        }
+        cryptkit {
+            if {![catch {package require cryptkit}]} {
+                set r [expr {![catch {cryptkit::cryptInit}]}]
+            }
+        }
+        trf {
+            if {![catch {package require Trf}]} {
+                set r [expr {![catch {::sha1 aa} msg]}]
+            }
+        }
+        default {
+            return -code error "invalid accelerator package:\
+                must be one of [join [array names accel] {, }]"
+        }
+    }
+    set accel($name) $r
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  Pop the nth element off a list. Used in options processing.
+#
+proc ::sha1::Pop {varname {nth 0}} {
+    upvar $varname args
+    set r [lindex $args $nth]
+    set args [lreplace $args $nth $nth]
+    return $r
+}
+
+# -------------------------------------------------------------------------
+
+# fileevent handler for chunked file hashing.
+#
+proc ::sha1::Chunk {token channel {chunksize 4096}} {
+    upvar #0 $token state
+    
+    if {[eof $channel]} {
+        fileevent $channel readable {}
+        set state(reading) 0
+    }
+        
+    SHA1Update $token [read $channel $chunksize]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::sha1::sha1 {args} {
+    array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
+    if {[llength $args] == 1} {
+        set opts(-hex) 1
+    } else {
+        while {[string match -* [set option [lindex $args 0]]]} {
+            switch -glob -- $option {
+                -hex       { set opts(-hex) 1 }
+                -bin       { set opts(-hex) 0 }
+                -file*     { set opts(-filename) [Pop args 1] }
+                -channel   { set opts(-channel) [Pop args 1] }
+                -chunksize { set opts(-chunksize) [Pop args 1] }
+                default {
+                    if {[llength $args] == 1} { break }
+                    if {[string compare $option "--"] == 0} { Pop args; break }
+                    set err [join [lsort [concat -bin [array names opts]]] ", "]
+                    return -code error "bad option $option:\
+                    must be one of $err"
+                }
+            }
+            Pop args
+        }
+    }
+
+    if {$opts(-filename) != {}} {
+        set opts(-channel) [open $opts(-filename) r]
+        fconfigure $opts(-channel) -translation binary
+    }
+
+    if {$opts(-channel) == {}} {
+
+        if {[llength $args] != 1} {
+            return -code error "wrong # args:\
+                should be \"sha1 ?-hex? -filename file | string\""
+        }
+        set tok [SHA1Init]
+        SHA1Update $tok [lindex $args 0]
+        set r [SHA1Final $tok]
+
+    } else {
+
+        set tok [SHA1Init]
+        # FRINK: nocheck
+        set [subst $tok](reading) 1
+        fileevent $opts(-channel) readable \
+            [list [namespace origin Chunk] \
+                 $tok $opts(-channel) $opts(-chunksize)]
+        # FRINK: nocheck
+        vwait [subst $tok](reading)
+        set r [SHA1Final $tok]
+
+        # If we opened the channel - we should close it too.
+        if {$opts(-filename) != {}} {
+            close $opts(-channel)
+        }
+    }
+    
+    if {$opts(-hex)} {
+        set r [Hex $r]
+    }
+    return $r
+}
+
+# -------------------------------------------------------------------------
+
+proc ::sha1::hmac {args} {
+    array set opts {-hex 1 -filename {} -channel {} -chunksize 4096}
+    if {[llength $args] != 2} {
+        while {[string match -* [set option [lindex $args 0]]]} {
+            switch -glob -- $option {
+                -key       { set opts(-key) [Pop args 1] }
+                -hex       { set opts(-hex) 1 }
+                -bin       { set opts(-hex) 0 }
+                -file*     { set opts(-filename) [Pop args 1] }
+                -channel   { set opts(-channel) [Pop args 1] }
+                -chunksize { set opts(-chunksize) [Pop args 1] }
+                default {
+                    if {[llength $args] == 1} { break }
+                    if {[string compare $option "--"] == 0} { Pop args; break }
+                    set err [join [lsort [array names opts]] ", "]
+                    return -code error "bad option $option:\
+                    must be one of $err"
+                }
+            }
+            Pop args
+        }
+    }
+
+    if {[llength $args] == 2} {
+        set opts(-key) [Pop args]
+    }
+
+    if {![info exists opts(-key)]} {
+        return -code error "wrong # args:\
+            should be \"hmac ?-hex? -key key -filename file | string\""
+    }
+
+    if {$opts(-filename) != {}} {
+        set opts(-channel) [open $opts(-filename) r]
+        fconfigure $opts(-channel) -translation binary
+    }
+
+    if {$opts(-channel) == {}} {
+
+        if {[llength $args] != 1} {
+            return -code error "wrong # args:\
+                should be \"hmac ?-hex? -key key -filename file | string\""
+        }
+        set tok [HMACInit $opts(-key)]
+        HMACUpdate $tok [lindex $args 0]
+        set r [HMACFinal $tok]
+
+    } else {
+
+        set tok [HMACInit $opts(-key)]
+        # FRINK: nocheck
+        set [subst $tok](reading) 1
+        fileevent $opts(-channel) readable \
+            [list [namespace origin Chunk] \
+                 $tok $opts(-channel) $opts(-chunksize)]
+        # FRINK: nocheck
+        vwait [subst $tok](reading)
+        set r [HMACFinal $tok]
+
+        # If we opened the channel - we should close it too.
+        if {$opts(-filename) != {}} {
+            close $opts(-channel)
+        }
+    }
+    
+    if {$opts(-hex)} {
+        set r [Hex $r]
+    }
+    return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help.
+namespace eval ::sha1 {
+    foreach e {critcl cryptkit trf} { if {[LoadAccelerator $e]} { break } }
+}
+
+package provide sha1 $::sha1::version
+
+# -------------------------------------------------------------------------
+# Local Variables:
+#   mode: tcl
+#   indent-tabs-mode: nil
+# End:
+
+
diff --git a/lib/tclxml3.1/pkgIndex.tcl b/lib/tclxml3.1/pkgIndex.tcl
new file mode 100644
index 0000000..4c7428d
--- /dev/null
+++ b/lib/tclxml3.1/pkgIndex.tcl
@@ -0,0 +1,97 @@
+# Tcl package index file - handcrafted
+#
+# $Id: pkgIndex.tcl.in,v 1.13 2003/12/03 20:06:34 balls Exp $
+
+package ifneeded xml::c       3.1 [list load   [file join $dir Tclxml30.dll]]
+package ifneeded xml::tcl     3.1 [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]]
+
+# The C parsers are provided through their own packages and indices,
+# and thus do not have to be listed here. This index may require them
+# in certain places, but does not provide them. This is part of the
+# work refactoring the build system of TclXML to create clean
+# packages, and not require a jumble (jungle?) of things in one Makefile.
+#
+#package ifneeded xml::expat  3.1 [list load   [file join $dir @expat_TCL_LIB_FILE@]]
+#package ifneeded xml::xerces 2.0       [list load   [file join $dir @xerces_TCL_LIB_FILE@]]
+#package ifneeded xml::libxml2 3.1 [list load   [file join $dir @TclXML_libxml2_LIB_FILE@]]
+
+namespace eval ::xml {}
+
+# Requesting a specific package means we want it to be the default parser class.
+# This is achieved by loading it last.
+
+# expat and libxml2 packages must have xml::c package loaded
+package ifneeded expat 3.1 {
+    package require xml::c 3.1
+    package require xmldefs
+    package require xml::tclparser 3.1
+    catch {package require xml::libxml2 3.1}
+    package require xml::expat     3.1
+    package provide expat          3.1
+}
+package ifneeded libxml2 3.1 {
+    package require xml::c 3.1
+    package require xmldefs
+    package require xml::tclparser 3.1
+    catch {package require xml::expat 3.1}
+    package require xml::libxml2   3.1
+    package provide libxml2        3.1
+}
+
+# tclparser works with either xml::c or xml::tcl
+package ifneeded tclparser 3.1 {
+    if {[catch {package require xml::c 3.1}]} {
+	# No point in trying to load expat or libxml2
+	package require xml::tcl       3.1
+	package require xmldefs
+	package require xml::tclparser 3.1
+    } else {
+	package require xmldefs
+	catch {package require xml::expat   3.1}
+	catch {package require xml::libxml2 3.1}
+	package require xml::tclparser
+    }
+    package provide tclparser 3.1
+}
+
+# use tcl only (mainly for testing)
+package ifneeded puretclparser 3.1 {
+    package require xml::tcl       3.1
+    package require xmldefs
+    package require xml::tclparser 3.1
+    package provide puretclparser  3.1
+}                                        
+
+# Requesting the generic package leaves the choice of default parser automatic
+
+package ifneeded xml 3.1 {
+    if {[catch {package require xml::c 3.1}]} {
+	package require xml::tcl       3.1
+	package require xmldefs
+	# Only choice is tclparser
+	package require xml::tclparser 3.1
+    } else {
+	package require xmldefs
+	package require xml::tclparser    3.1
+	# libxml2 is favoured since it provides more features
+	catch {package require xml::expat 3.1}
+	catch {package require xml::libxml2 3.1}
+    }
+    package provide xml 3.1
+}
+
+if {[info tclversion] <= 8.0} {
+    package ifneeded sgml           1.9       [list source [file join $dir sgml-8.0.tcl]]
+    package ifneeded xmldefs        3.1 [list source [file join $dir xml-8.0.tcl]]
+    package ifneeded xml::tclparser 3.1 [list source [file join $dir tclparser-8.0.tcl]]
+} else {
+    package ifneeded sgml           1.9       [list source [file join $dir sgml-8.1.tcl]]
+    package ifneeded xmldefs        3.1 [list source [file join $dir xml-8.1.tcl]]
+    package ifneeded xml::tclparser 3.1 [list source [file join $dir tclparser-8.1.tcl]]
+}
+
+
+
diff --git a/lib/tclxml3.1/sgml-8.1.tcl b/lib/tclxml3.1/sgml-8.1.tcl
new file mode 100644
index 0000000..5e65bf8
--- /dev/null
+++ b/lib/tclxml3.1/sgml-8.1.tcl
@@ -0,0 +1,143 @@
+# sgml-8.1.tcl --
+#
+#	This file provides generic parsing services for SGML-based
+#	languages, namely HTML and XML.
+#	This file supports Tcl 8.1 characters and regular expressions.
+#
+#	NB.  It is a misnomer.  There is no support for parsing
+#	arbitrary SGML as such.
+#
+# Copyright (c) 1998-2003 Zveno Pty Ltd
+# http://www.zveno.com/
+#
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: sgml-8.1.tcl,v 1.7 2003/12/09 04:43:15 balls Exp $
+
+package require Tcl 8.1
+
+package provide sgml 1.9
+
+namespace eval sgml {
+
+    # Convenience routine
+    proc cl x {
+	return "\[$x\]"
+    }
+
+    # Define various regular expressions
+
+    # Character classes
+    variable Char \t\n\r\ -\uD7FF\uE000-\uFFFD\u10000-\u10FFFF
+    variable BaseChar \u0041-\u005A\u0061-\u007A\u00C0-\u00D6\u00D8-\u00F6\u00F8-\u00FF\u0100-\u0131\u0134-\u013E\u0141-\u0148\u014A-\u017E\u0180-\u01C3\u01CD-\u01F0\u01F4-\u01F5\u01FA-\u0217\u0250-\u02A8\u02BB-\u02C1\u0386\u0388-\u038A\u038C\u038E-\u03A1\u03A3-\u03CE\u03D0-\u03D6\u03DA\u03DC\u03DE\u03E0\u03E2-\u03F3\u0401-\u040C\u040E-\u044F\u0451-\u045C\u045E-\u0481\u0490-\u04C4\u04C7-\u04C8\u04CB-\u04CC\u04D0-\u04EB\u04EE-\u04F5\u04F8-\u04F9\u0531-\u0556\u0559\u0561-\u0586\u05D0-\u05EA\u05F0-\u05F2\u0621-\u063A\u0641-\u064A\u0671-\u06B7\u06BA-\u06BE\u06C0-\u06CE\u06D0-\u06D3\u06D5\u06E5-\u06E6\u0905-\u0939\u093D\u0958-\u0961\u0985-\u098C\u098F-\u0990\u0993-\u09A8\u09AA-\u09B0\u09B2\u09B6-\u09B9\u09DC-\u09DD\u09DF-\u09E1\u09F0-\u09F1\u0A05-\u0A0A\u0A0F-\u0A10\u0A13-\u0A28\u0A2A-\u0A30\u0A32-\u0A33\u0A35-\u0A36\u0A38-\u0A39\u0A59-\u0A5C\u0A5E\u0A72-\u0A74\u0A85-\u0A8B\u0A8D\u0A8F-\u0A91\u0A93-\u0AA8\u0AAA-\u0AB0\u0AB2-\u0AB3\u0AB5-\u0AB9\u0ABD\u0AE0\u0B05-\u0B0C\u0B0F-\u0B10\u0B13-\u0B28\u0B2A-\u0B30\u0B32-\u0B33\u0B36-\u0B39\u0B3D\u0B5C-\u0B5D\u0B5F-\u0B61\u0B85-\u0B8A\u0B8E-\u0B90\u0B92-\u0B95\u0B99-\u0B9A\u0B9C\u0B9E-\u0B9F\u0BA3-\u0BA4\u0BA8-\u0BAA\u0BAE-\u0BB5\u0BB7-\u0BB9\u0C05-\u0C0C\u0C0E-\u0C10\u0C12-\u0C28\u0C2A-\u0C33\u0C35-\u0C39\u0C60-\u0C61\u0C85-\u0C8C\u0C8E-\u0C90\u0C92-\u0CA8\u0CAA-\u0CB3\u0CB5-\u0CB9\u0CDE\u0CE0-\u0CE1\u0D05-\u0D0C\u0D0E-\u0D10\u0D12-\u0D28\u0D2A-\u0D39\u0D60-\u0D61\u0E01-\u0E2E\u0E30\u0E32-\u0E33\u0E40-\u0E45\u0E81-\u0E82\u0E84\u0E87-\u0E88\u0E8A\u0E8D\u0E94-\u0E97\u0E99-\u0E9F\u0EA1-\u0EA3\u0EA5\u0EA7\u0EAA-\u0EAB\u0EAD-\u0EAE\u0EB0\u0EB2-\u0EB3\u0EBD\u0EC0-\u0EC4\u0F40-\u0F47\u0F49-\u0F69\u10A0-\u10C5\u10D0-\u10F6\u1100\u1102-\u1103\u1105-\u1107\u1109\u110B-\u110C\u110E-\u1112\u113C\u113E\u1140\u114C\u114E\u1150\u1154-\u1155\u1159\u115F-\u1161\u1163\u1165\u1167\u1169\u116D-\u116E\u1172-\u1173\u1175\u119E\u11A8\u11AB\u11AE-\u11AF\u11B7-\u11B8\u11BA\u11BC-\u11C2\u11EB\u11F0\u11F9\u1E00-\u1E9B\u1EA0-\u1EF9\u1F00-\u1F15\u1F18-\u1F1D\u1F20-\u1F45\u1F48-\u1F4D\u1F50-\u1F57\u1F59\u1F5B\u1F5D\u1F5F-\u1F7D\u1F80-\u1FB4\u1FB6-\u1FBC\u1FBE\u1FC2-\u1FC4\u1FC6-\u1FCC\u1FD0-\u1FD3\u1FD6-\u1FDB\u1FE0-\u1FEC\u1FF2-\u1FF4\u1FF6-\u1FFC\u2126\u212A-\u212B\u212E\u2180-\u2182\u3041-\u3094\u30A1-\u30FA\u3105-\u312C\uAC00-\uD7A3  
+    variable Ideographic \u4E00-\u9FA5\u3007\u3021-\u3029
+    variable CombiningChar \u0300-\u0345\u0360-\u0361\u0483-\u0486\u0591-\u05A1\u05A3-\u05B9\u05BB-\u05BD\u05BF\u05C1-\u05C2\u05C4\u064B-\u0652\u0670\u06D6-\u06DC\u06DD-\u06DF\u06E0-\u06E4\u06E7-\u06E8\u06EA-\u06ED\u0901-\u0903\u093C\u093E-\u094C\u094D\u0951-\u0954\u0962-\u0963\u0981-\u0983\u09BC\u09BE\u09BF\u09C0-\u09C4\u09C7-\u09C8\u09CB-\u09CD\u09D7\u09E2-\u09E3\u0A02\u0A3C\u0A3E\u0A3F\u0A40-\u0A42\u0A47-\u0A48\u0A4B-\u0A4D\u0A70-\u0A71\u0A81-\u0A83\u0ABC\u0ABE-\u0AC5\u0AC7-\u0AC9\u0ACB-\u0ACD\u0B01-\u0B03\u0B3C\u0B3E-\u0B43\u0B47-\u0B48\u0B4B-\u0B4D\u0B56-\u0B57\u0B82-\u0B83\u0BBE-\u0BC2\u0BC6-\u0BC8\u0BCA-\u0BCD\u0BD7\u0C01-\u0C03\u0C3E-\u0C44\u0C46-\u0C48\u0C4A-\u0C4D\u0C55-\u0C56\u0C82-\u0C83\u0CBE-\u0CC4\u0CC6-\u0CC8\u0CCA-\u0CCD\u0CD5-\u0CD6\u0D02-\u0D03\u0D3E-\u0D43\u0D46-\u0D48\u0D4A-\u0D4D\u0D57\u0E31\u0E34-\u0E3A\u0E47-\u0E4E\u0EB1\u0EB4-\u0EB9\u0EBB-\u0EBC\u0EC8-\u0ECD\u0F18-\u0F19\u0F35\u0F37\u0F39\u0F3E\u0F3F\u0F71-\u0F84\u0F86-\u0F8B\u0F90-\u0F95\u0F97\u0F99-\u0FAD\u0FB1-\u0FB7\u0FB9\u20D0-\u20DC\u20E1\u302A-\u302F\u3099\u309A
+    variable Digit \u0030-\u0039\u0660-\u0669\u06F0-\u06F9\u0966-\u096F\u09E6-\u09EF\u0A66-\u0A6F\u0AE6-\u0AEF\u0B66-\u0B6F\u0BE7-\u0BEF\u0C66-\u0C6F\u0CE6-\u0CEF\u0D66-\u0D6F\u0E50-\u0E59\u0ED0-\u0ED9\u0F20-\u0F29
+    variable Extender \u00B7\u02D0\u02D1\u0387\u0640\u0E46\u0EC6\u3005\u3031-\u3035\u309D-\u309E\u30FC-\u30FE
+    variable Letter $BaseChar|$Ideographic
+
+    # white space
+    variable Wsp " \t\r\n"
+    variable noWsp [cl ^$Wsp]
+
+    # Various XML names
+    variable NameChar \[-$Letter$Digit._:$CombiningChar$Extender\]
+    variable Name \[_:$BaseChar$Ideographic\]$NameChar*
+    variable Names ${Name}(?:$Wsp$Name)*
+    variable Nmtoken $NameChar+
+    variable Nmtokens ${Nmtoken}(?:$Wsp$Nmtoken)*
+
+    # table of predefined entities for XML
+
+    variable EntityPredef
+    array set EntityPredef {
+	lt <   gt >   amp &   quot \"   apos '
+    }
+
+}
+
+# These regular expressions are defined here once for better performance
+
+namespace eval sgml {
+    variable Wsp
+
+    # Watch out for case-sensitivity
+
+    set attlist_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#REQUIRED|#IMPLIED)
+    set attlist_enum_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*\\(([cl ^)]*)\\)[cl $Wsp]*("([cl ^")]*)")? ;# "
+    set attlist_fixed_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#FIXED)[cl $Wsp]*([cl ^$Wsp]+)
+
+    set param_entity_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^"$Wsp]*)[cl $Wsp]*"([cl ^"]*)"
+
+    set notation_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(.*)
+
+}
+
+### Utility procedures
+
+# sgml::noop --
+#
+#	A do-nothing proc
+#
+# Arguments:
+#	args	arguments
+#
+# Results:
+#	Nothing.
+
+proc sgml::noop args {
+    return 0
+}
+
+# sgml::identity --
+#
+#	Identity function.
+#
+# Arguments:
+#	a	arbitrary argument
+#
+# Results:
+#	$a
+
+proc sgml::identity a {
+    return $a
+}
+
+# sgml::Error --
+#
+#	Throw an error
+#
+# Arguments:
+#	args	arguments
+#
+# Results:
+#	Error return condition.
+
+proc sgml::Error args {
+    uplevel return -code error [list $args]
+}
+
+### Following procedures are based on html_library
+
+# sgml::zapWhite --
+#
+#	Convert multiple white space into a single space.
+#
+# Arguments:
+#	data	plain text
+#
+# Results:
+#	As above
+
+proc sgml::zapWhite data {
+    regsub -all "\[ \t\r\n\]+" $data { } data
+    return $data
+}
+
+proc sgml::Boolean value {
+    regsub {1|true|yes|on} $value 1 value
+    regsub {0|false|no|off} $value 0 value
+    return $value
+}
+
diff --git a/lib/tclxml3.1/sgmlparser.tcl b/lib/tclxml3.1/sgmlparser.tcl
new file mode 100644
index 0000000..72776d9
--- /dev/null
+++ b/lib/tclxml3.1/sgmlparser.tcl
@@ -0,0 +1,2816 @@
+# sgmlparser.tcl --
+#
+#	This file provides the generic part of a parser for SGML-based
+#	languages, namely HTML and XML.
+#
+#	NB.  It is a misnomer.  There is no support for parsing
+#	arbitrary SGML as such.
+#
+#	See sgml.tcl for variable definitions.
+#
+# Copyright (c) 1998-2003 Zveno Pty Ltd
+# http://www.zveno.com/
+#
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: sgmlparser.tcl,v 1.32 2003/12/09 04:43:15 balls Exp $
+
+package require sgml 1.9
+
+package require uri 1.1
+
+package provide sgmlparser 1.0
+
+namespace eval sgml {
+    namespace export tokenise parseEvent
+
+    namespace export parseDTD
+
+    # NB. Most namespace variables are defined in sgml-8.[01].tcl
+    # to account for differences between versions of Tcl.
+    # This especially includes the regular expressions used.
+
+    variable ParseEventNum
+    if {![info exists ParseEventNum]} {
+	set ParseEventNum 0
+    }
+    variable ParseDTDnum
+    if {![info exists ParseDTDNum]} {
+	set ParseDTDNum 0
+    }
+
+    variable declExpr [cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*)
+    variable EntityExpr [cl $::sgml::Wsp]*(%[cl $::sgml::Wsp])?[cl $::sgml::Wsp]*($::sgml::Name)[cl $::sgml::Wsp]+(.*)
+
+    #variable MarkupDeclExpr <([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*)>
+    #variable MarkupDeclSub "} {\\1} {\\2} {\\3} {"
+    variable MarkupDeclExpr <[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^>]*)>
+    variable MarkupDeclSub "\} {\\1} {\\2} \{"
+
+    variable ExternalEntityExpr ^(PUBLIC|SYSTEM)[cl $::sgml::Wsp]+("|')(.*?)\\2([cl $::sgml::Wsp]+("|')(.*?)\\2)?([cl $::sgml::Wsp]+NDATA[cl $::sgml::Wsp]+($::xml::Name))?\$
+
+    variable StdOptions
+    array set StdOptions [list \
+	-elementstartcommand		[namespace current]::noop	\
+	-elementendcommand		[namespace current]::noop	\
+	-characterdatacommand		[namespace current]::noop	\
+	-processinginstructioncommand	[namespace current]::noop	\
+	-externalentitycommand		{}				\
+	-xmldeclcommand			[namespace current]::noop	\
+	-doctypecommand			[namespace current]::noop	\
+	-commentcommand			[namespace current]::noop	\
+	-entitydeclcommand		[namespace current]::noop	\
+	-unparsedentitydeclcommand	[namespace current]::noop	\
+	-parameterentitydeclcommand	[namespace current]::noop	\
+	-notationdeclcommand		[namespace current]::noop	\
+	-elementdeclcommand		[namespace current]::noop	\
+	-attlistdeclcommand		[namespace current]::noop	\
+	-paramentityparsing		1				\
+	-defaultexpandinternalentities	1				\
+	-startdoctypedeclcommand	[namespace current]::noop	\
+	-enddoctypedeclcommand		[namespace current]::noop	\
+	-entityreferencecommand		{}				\
+	-warningcommand			[namespace current]::noop	\
+	-errorcommand			[namespace current]::Error	\
+	-final				1				\
+	-validate			0				\
+	-baseuri			{}				\
+	-name				{}				\
+	-cmd				{}				\
+	-emptyelement			[namespace current]::EmptyElement	\
+	-parseattributelistcommand	[namespace current]::noop	\
+	-parseentitydeclcommand		[namespace current]::noop	\
+	-normalize			1				\
+	-internaldtd			{}				\
+	-reportempty			0				\
+	-ignorewhitespace		0				\
+    ]
+}
+
+# sgml::tokenise --
+#
+#	Transform the given HTML/XML text into a Tcl list.
+#
+# Arguments:
+#	sgml		text to tokenize
+#	elemExpr	RE to recognise tags
+#	elemSub		transform for matched tags
+#	args		options
+#
+# Valid Options:
+#       -internaldtdvariable
+#	-final		boolean		True if no more data is to be supplied
+#	-statevariable	varName		Name of a variable used to store info
+#
+# Results:
+#	Returns a Tcl list representing the document.
+
+proc sgml::tokenise {sgml elemExpr elemSub args} {
+    array set options {-final 1}
+    array set options $args
+    set options(-final) [Boolean $options(-final)]
+
+    # If the data is not final then there must be a variable to store
+    # unused data.
+    if {!$options(-final) && ![info exists options(-statevariable)]} {
+	return -code error {option "-statevariable" required if not final}
+    }
+
+    # Pre-process stage
+    #
+    # Extract the internal DTD subset, if any
+
+    catch {upvar #0 $options(-internaldtdvariable) dtd}
+    if {[regexp {<!DOCTYPE[^[<]+\[([^]]+)\]} $sgml discard dtd]} {
+	regsub {(<!DOCTYPE[^[<]+)(\[[^]]+\])} $sgml {\1\&xml:intdtd;} sgml
+    }
+
+    # Protect Tcl special characters
+    regsub -all {([{}\\])} $sgml {\\\1} sgml
+
+    # Do the translation
+
+    if {[info exists options(-statevariable)]} {
+	# Mats: Several rewrites here to handle -final 0 option.
+	# If any cached unparsed xml (state(leftover)), prepend it.
+	upvar #0 $options(-statevariable) state
+	if {[string length $state(leftover)]} {
+	    regsub -all $elemExpr $state(leftover)$sgml $elemSub sgml
+	    set state(leftover) {}
+	} else {
+	    regsub -all $elemExpr $sgml $elemSub sgml
+	}
+	set sgml "{} {} {} \{$sgml\}"
+
+	# Performance note (Tcl 8.0):
+	#	Use of lindex, lreplace will cause parsing to list object
+
+	# This RE only fixes chopped inside tags, not chopped text.
+	if {[regexp {^([^<]*)(<[^>]*$)} [lindex $sgml end] x text rest]} {
+	    set sgml [lreplace $sgml end end $text]
+	    # Mats: unmatched stuff means that it is chopped off. Cache it for next round.
+	    set state(leftover) $rest
+	}
+
+	## Patch from bug report #596959, Marshall Rose
+	# This patch was for use when the caller of this function used lrange
+	# 5 -end on thresult. This is no longer the case [PT]
+	#if {[string compare [lindex $sgml 4] ""]} {
+	#    set sgml [linsert $sgml 0 {} {} {} {} {}]
+	#}
+
+    } else {
+
+	# Performance note (Tcl 8.0):
+	#	In this case, no conversion to list object is performed
+
+	# Mats: This fails if not -final and $sgml is chopped off right in a tag.	
+	regsub -all $elemExpr $sgml $elemSub sgml
+	set sgml "{} {} {} \{$sgml\}"
+    }
+
+    return $sgml
+
+}
+
+# sgml::parseEvent --
+#
+#	Produces an event stream for a XML/HTML document,
+#	given the Tcl list format returned by tokenise.
+#
+#	This procedure checks that the document is well-formed,
+#	and throws an error if the document is found to be not
+#	well formed.  Warnings are passed via the -warningcommand script.
+#
+#	The procedure only check for well-formedness,
+#	no DTD is required.  However, facilities are provided for entity expansion.
+#
+# Arguments:
+#	sgml		Instance data, as a Tcl list.
+#	args		option/value pairs
+#
+# Valid Options:
+#	-final			Indicates end of document data
+#	-validate		Boolean to enable validation
+#	-baseuri		URL for resolving relative URLs
+#	-elementstartcommand	Called when an element starts
+#	-elementendcommand	Called when an element ends
+#	-characterdatacommand	Called when character data occurs
+#	-entityreferencecommand	Called when an entity reference occurs
+#	-processinginstructioncommand	Called when a PI occurs
+#	-externalentitycommand	Called for an external entity reference
+#
+#	-xmldeclcommand		Called when the XML declaration occurs
+#	-doctypecommand		Called when the document type declaration occurs
+#	-commentcommand		Called when a comment occurs
+#	-entitydeclcommand	Called when a parsed entity is declared
+#	-unparsedentitydeclcommand	Called when an unparsed external entity is declared
+#	-parameterentitydeclcommand	Called when a parameter entity is declared
+#	-notationdeclcommand	Called when a notation is declared
+#	-elementdeclcommand	Called when an element is declared
+#	-attlistdeclcommand	Called when an attribute list is declared
+#	-paramentityparsing	Boolean to enable/disable parameter entity substitution
+#	-defaultexpandinternalentities	Boolean to enable/disable expansion of entities declared in internal DTD subset
+#
+#	-startdoctypedeclcommand	Called when the Doc Type declaration starts (see also -doctypecommand)
+#	-enddoctypedeclcommand	Called when the Doc Type declaration ends (see also -doctypecommand)
+#
+#	-errorcommand		Script to evaluate for a fatal error
+#	-warningcommand		Script to evaluate for a reportable warning
+#	-statevariable		global state variable
+#	-normalize		whether to normalize names
+#	-reportempty		whether to include an indication of empty elements
+#	-ignorewhitespace	whether to automatically strip whitespace
+#
+# Results:
+#	The various callback scripts are invoked.
+#	Returns empty string.
+#
+# BUGS:
+#	If command options are set to empty string then they should not be invoked.
+
+proc sgml::parseEvent {sgml args} {
+    variable Wsp
+    variable noWsp
+    variable Nmtoken
+    variable Name
+    variable ParseEventNum
+    variable StdOptions
+
+    array set options [array get StdOptions]
+    catch {array set options $args}
+
+    # Mats:
+    # If the data is not final then there must be a variable to persistently store the parse state.
+    if {!$options(-final) && ![info exists options(-statevariable)]} {
+	return -code error {option "-statevariable" required if not final}
+    }
+    
+    foreach {opt value} [array get options *command] {
+	if {[string compare $opt "-externalentitycommand"] && ![string length $value]} {
+	    set options($opt) [namespace current]::noop
+	}
+    }
+
+    if {![info exists options(-statevariable)]} {
+	set options(-statevariable) [namespace current]::ParseEvent[incr ParseEventNum]
+    }
+    if {![info exists options(entities)]} {
+	set options(entities) [namespace current]::Entities$ParseEventNum
+	array set $options(entities) [array get [namespace current]::EntityPredef]
+    }
+    if {![info exists options(extentities)]} {
+	set options(extentities) [namespace current]::ExtEntities$ParseEventNum
+    }
+    if {![info exists options(parameterentities)]} {
+	set options(parameterentities) [namespace current]::ParamEntities$ParseEventNum
+    }
+    if {![info exists options(externalparameterentities)]} {
+	set options(externalparameterentities) [namespace current]::ExtParamEntities$ParseEventNum
+    }
+    if {![info exists options(elementdecls)]} {
+	set options(elementdecls) [namespace current]::ElementDecls$ParseEventNum
+    }
+    if {![info exists options(attlistdecls)]} {
+	set options(attlistdecls) [namespace current]::AttListDecls$ParseEventNum
+    }
+    if {![info exists options(notationdecls)]} {
+	set options(notationdecls) [namespace current]::NotationDecls$ParseEventNum
+    }
+    if {![info exists options(namespaces)]} {
+	set options(namespaces) [namespace current]::Namespaces$ParseEventNum
+    }
+
+    # For backward-compatibility
+    catch {set options(-baseuri) $options(-baseurl)}
+
+    # Choose an external entity resolver
+
+    if {![string length $options(-externalentitycommand)]} {
+	if {$options(-validate)} {
+	    set options(-externalentitycommand) [namespace code ResolveEntity]
+	} else {
+	    set options(-externalentitycommand) [namespace code noop]
+	}
+    }
+
+    upvar #0 $options(-statevariable) state
+    upvar #0 $options(entities) entities
+
+    # Mats:
+    # The problem is that the state is not maintained when -final 0 !
+    # I've switched back to an older version here. 
+    
+    if {![info exists state(line)]} {
+	# Initialise the state variable
+	array set state {
+	    mode normal
+	    haveXMLDecl 0
+	    haveDocElement 0
+	    inDTD 0
+	    context {}
+	    stack {}
+	    line 0
+	    defaultNS {}
+	    defaultNSURI {}
+	}
+    }
+
+    foreach {tag close param text} $sgml {
+
+	# Keep track of lines in the input
+	incr state(line) [regsub -all \n $param {} discard]
+	incr state(line) [regsub -all \n $text {} discard]
+
+	# If the current mode is cdata or comment then we must undo what the
+	# regsub has done to reconstitute the data
+
+	set empty {}
+	switch $state(mode) {
+	    comment {
+		# This had "[string length $param] && " as a guard -
+		# can't remember why :-(
+		if {[regexp ([cl ^-]*)--\$ $tag discard comm1]} {
+		    # end of comment (in tag)
+		    set tag {}
+		    set close {}
+		    set state(mode) normal
+		    DeProtect1 $options(-commentcommand) $state(commentdata)<$comm1
+		    unset state(commentdata)
+		} elseif {[regexp ([cl ^-]*)--\$ $param discard comm1]} {
+		    # end of comment (in attributes)
+		    DeProtect1 $options(-commentcommand) $state(commentdata)<$close$tag>$comm1
+		    unset state(commentdata)
+		    set tag {}
+		    set param {}
+		    set close {}
+		    set state(mode) normal
+		} elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm1 text]} {
+		    # end of comment (in text)
+		    DeProtect1 $options(-commentcommand) $state(commentdata)<$close$tag$param>$comm1
+		    unset state(commentdata)
+		    set tag {}
+		    set param {}
+		    set close {}
+		    set state(mode) normal
+		} else {
+		    # comment continues
+		    append state(commentdata) <$close$tag$param>$text
+		    continue
+		}
+	    }
+	    cdata {
+		if {[string length $param] && [regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $tag discard cdata1]} {
+		    # end of CDATA (in tag)
+		    PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$cdata1]
+		    set text [subst -novariable -nocommand $text]
+		    set tag {}
+		    unset state(cdata)
+		    set state(mode) normal
+		} elseif {[regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $param discard cdata1]} {
+		    # end of CDATA (in attributes)
+		    PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$tag$cdata1]
+		    set text [subst -novariable -nocommand $text]
+		    set tag {}
+		    set param {}
+		    unset state(cdata)
+		    set state(mode) normal
+		} elseif {[regexp (.*)\]\][cl $Wsp]*>(.*) $text discard cdata1 text]} {
+		    # end of CDATA (in text)
+		    PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$tag$param>$cdata1]
+		    set text [subst -novariable -nocommand $text]
+		    set tag {}
+		    set param {}
+		    set close {}
+		    unset state(cdata)
+		    set state(mode) normal
+		} else {
+		    # CDATA continues
+		    append state(cdata) [subst -nocommand -novariable <$close$tag$param>$text]
+		    continue
+		}
+	    }
+	    continue {
+		# We're skipping elements looking for the close tag
+		switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close {
+		    0,* {
+			continue
+		    }
+		    *,0, {
+			if {![string compare $tag $state(continue:tag)]} {
+			    set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]
+			    if {![string length $empty]} {
+				incr state(continue:level)
+			    }
+			}
+			continue
+		    }
+		    *,0,/ {
+			if {![string compare $tag $state(continue:tag)]} {
+			    incr state(continue:level) -1
+			}
+			if {!$state(continue:level)} {
+			    unset state(continue:tag)
+			    unset state(continue:level)
+			    set state(mode) {}
+			}
+		    }
+		    default {
+			continue
+		    }
+		}
+	    }
+	    default {
+		# The trailing slash on empty elements can't be automatically separated out
+		# in the RE, so we must do it here.
+		regexp (.*)(/)[cl $Wsp]*$ $param discard param empty
+	    }
+	}
+
+	# default: normal mode
+
+	# Bug: if the attribute list has a right angle bracket then the empty
+	# element marker will not be seen
+
+	set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]
+
+	switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close,$empty {
+
+	    0,0,, {
+		# Ignore empty tag - dealt with non-normal mode above
+	    }
+	    *,0,, {
+
+		# Start tag for an element.
+
+		# Check if the internal DTD entity is in an attribute value
+		regsub -all &xml:intdtd\; $param \[$options(-internaldtd)\] param
+
+		set code [catch {ParseEvent:ElementOpen $tag $param [array get options]} msg]
+		set state(haveDocElement) 1
+		switch $code {
+		    0 {# OK}
+		    3 {
+			# break
+			return {}
+		    }
+		    4 {
+			# continue
+			# Remember this tag and look for its close
+			set state(continue:tag) $tag
+			set state(continue:level) 1
+			set state(mode) continue
+			continue
+		    }
+		    default {
+			return -code $code -errorinfo $::errorInfo $msg
+		    }
+		}
+
+	    }
+
+	    *,0,/, {
+
+		# End tag for an element.
+
+		set code [catch {ParseEvent:ElementClose $tag [array get options]} msg]
+		switch $code {
+		    0 {# OK}
+		    3 {
+			# break
+			return {}
+		    }
+		    4 {
+			# continue
+			# skip sibling nodes
+			set state(continue:tag) [lindex $state(stack) end]
+			set state(continue:level) 1
+			set state(mode) continue
+			continue
+		    }
+		    default {
+			return -code $code -errorinfo $::errorInfo $msg
+		    }
+		}
+
+	    }
+
+	    *,0,,/ {
+
+		# Empty element
+
+		# The trailing slash sneaks through into the param variable
+		regsub -all /[cl $::sgml::Wsp]*\$ $param {} param
+
+		set code [catch {ParseEvent:ElementOpen $tag $param [array get options] -empty 1} msg]
+		set state(haveDocElement) 1
+		switch $code {
+		    0 {# OK}
+		    3 {
+			# break
+			return {}
+		    }
+		    4 {
+			# continue
+			# Pretty useless since it closes straightaway
+		    }
+		    default {
+			return -code $code -errorinfo $::errorInfo $msg
+		    }
+		}
+		set code [catch {ParseEvent:ElementClose $tag [array get options] -empty 1} msg]
+		switch $code {
+		    0 {# OK}
+		    3 {
+			# break
+			return {}
+		    }
+		    4 {
+			# continue
+			# skip sibling nodes
+			set state(continue:tag) [lindex $state(stack) end]
+			set state(continue:level) 1
+			set state(mode) continue
+			continue
+		    }
+		    default {
+			return -code $code -errorinfo $::errorInfo $msg
+		    }
+		}
+
+	    }
+
+	    *,1,* {
+		# Processing instructions or XML declaration
+		switch -glob -- $tag {
+
+		    {\?xml} {
+			# XML Declaration
+			if {$state(haveXMLDecl)} {
+			    uplevel #0 $options(-errorcommand) [list illegalcharacter "unexpected characters \"<$tag\" around line $state(line)"]
+			} elseif {![regexp {\?$} $param]} {
+			    uplevel #0 $options(-errorcommand) [list missingcharacters "XML Declaration missing characters \"?>\" around line $state(line)"]
+			} else {
+
+			    # We can do the parsing in one step with Tcl 8.1 RE's
+			    # This has the benefit of performing better WF checking
+
+			    set adv_re [format {^[%s]*version[%s]*=[%s]*("|')(-+|[a-zA-Z0-9_.:]+)\1([%s]+encoding[%s]*=[%s]*("|')([A-Za-z][-A-Za-z0-9._]*)\4)?([%s]*standalone[%s]*=[%s]*("|')(yes|no)\7)?[%s]*\?$} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp]
+
+			    if {[catch {regexp $adv_re $param discard delimiter version discard delimiter encoding discard delimiter standalone} matches]} {
+				# Otherwise we must fallback to 8.0.
+				# This won't detect certain well-formedness errors
+
+				# Get the version number
+				if {[regexp [format {[%s]*version[%s]*=[%s]*"(-+|[a-zA-Z0-9_.:]+)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard version] || [regexp [format {[%s]*version[%s]*=[%s]*'(-+|[a-zA-Z0-9_.:]+)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard version]} {
+				    if {[string compare $version "1.0"]} {
+					# Should we support future versions?
+					# At least 1.X?
+					uplevel #0 $options(-errorcommand) [list versionincompatibility "document XML version \"$version\" is incompatible with XML version 1.0"]
+				    }
+				} else {
+				    uplevel #0 $options(-errorcommand) [list missingversion "XML Declaration missing version information around line $state(line)"]
+				}
+
+				# Get the encoding declaration
+				set encoding {}
+				regexp [format {[%s]*encoding[%s]*=[%s]*"([A-Za-z]([A-Za-z0-9._]|-)*)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard encoding
+				regexp [format {[%s]*encoding[%s]*=[%s]*'([A-Za-z]([A-Za-z0-9._]|-)*)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard encoding
+
+				# Get the standalone declaration
+				set standalone {}
+				regexp [format {[%s]*standalone[%s]*=[%s]*"(yes|no)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard standalone
+				regexp [format {[%s]*standalone[%s]*=[%s]*'(yes|no)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard standalone
+
+				# Invoke the callback
+				uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone]
+
+			    } elseif {$matches == 0} {
+				uplevel #0 $options(-errorcommand) [list illformeddeclaration "XML Declaration not well-formed around line $state(line)"]
+			    } else {
+
+				# Invoke the callback
+				uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone]
+
+			    }
+
+			}
+
+		    }
+
+		    {\?*} {
+			# Processing instruction
+			set tag [string range $tag 1 end]
+			if {[regsub {\?$} $tag {} tag]} {
+			    if {[string length [string trim $param]]} {
+				uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$param\" in processing instruction around line $state(line)"]
+			    }
+			} elseif {![regexp ^$Name\$ $tag]} {
+			    uplevel #0 $options(-errorcommand) [list illegalcharacter "illegal character in processing instruction target \"$tag\""]
+			} elseif {[regexp {[xX][mM][lL]} $tag]} {
+			    uplevel #0 $options(-errorcommand) [list illegalcharacters "characters \"xml\" not permitted in processing instruction target \"$tag\""]
+			} elseif {![regsub {\?$} $param {} param]} {
+			    uplevel #0 $options(-errorcommand) [list missingquestion "PI: expected '?' character around line $state(line)"]
+			}
+			set code [catch {uplevel #0 $options(-processinginstructioncommand) [list $tag [string trimleft $param]]} msg]
+			switch $code {
+			    0 {# OK}
+			    3 {
+				# break
+				return {}
+			    }
+			    4 {
+				# continue
+				# skip sibling nodes
+				set state(continue:tag) [lindex $state(stack) end]
+				set state(continue:level) 1
+				set state(mode) continue
+				continue
+			    }
+			    default {
+				return -code $code -errorinfo $::errorInfo $msg
+			    }
+			}
+		    }
+
+		    !DOCTYPE {
+			# External entity reference
+			# This should move into xml.tcl
+			# Parse the params supplied.  Looking for Name, ExternalID and MarkupDecl
+			set matched [regexp ^[cl $Wsp]*($Name)[cl $Wsp]*(.*) $param x state(doc_name) param]
+			set state(doc_name) [Normalize $state(doc_name) $options(-normalize)]
+			set externalID {}
+			set pubidlit {}
+			set systemlit {}
+			set externalID {}
+			if {[regexp -nocase ^[cl $Wsp]*(SYSTEM|PUBLIC)(.*) $param x id param]} {
+			    switch [string toupper $id] {
+				SYSTEM {
+				    if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
+					set externalID [list SYSTEM $systemlit] ;# "
+				    } else {
+					uplevel #0 $options(-errorcommand) {syntaxerror {syntax error: SYSTEM identifier not followed by literal}}
+				    }
+				}
+				PUBLIC {
+				    if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x pubidlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x pubidlit param]} {
+					if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
+					    set externalID [list PUBLIC $pubidlit $systemlit]
+					} else {
+					    uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: PUBLIC identifier not followed by system literal around line $state(line)"]
+					}
+				    } else {
+					uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: PUBLIC identifier not followed by literal around line $state(line)"]
+				    }
+				}
+			    }
+			    if {[regexp -nocase ^[cl $Wsp]+NDATA[cl $Wsp]+($Name)(.*) $param x notation param]} {
+				lappend externalID $notation
+			    }
+			}
+
+			set state(inDTD) 1
+
+			ParseEvent:DocTypeDecl [array get options] $state(doc_name) $pubidlit $systemlit $options(-internaldtd)
+
+			set state(inDTD) 0
+
+		    }
+
+		    !--* {
+
+			# Start of a comment
+			# See if it ends in the same tag, otherwise change the
+			# parsing mode
+
+			regexp {!--(.*)} $tag discard comm1
+			if {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $comm1 discard comm1_1]} {
+			    # processed comment (end in tag)
+			    uplevel #0 $options(-commentcommand) [list $comm1_1]
+			} elseif {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $param discard comm2]} {
+			    # processed comment (end in attributes)
+			    uplevel #0 $options(-commentcommand) [list $comm1$comm2]
+			} elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm2 text]} {
+			    # processed comment (end in text)
+			    uplevel #0 $options(-commentcommand) [list $comm1$param$empty>$comm2]
+			} else {
+			    # start of comment
+			    set state(mode) comment
+			    set state(commentdata) "$comm1$param$empty>$text"
+			    continue
+			}
+		    }
+
+		    {!\[CDATA\[*} {
+
+			regexp {!\[CDATA\[(.*)} $tag discard cdata1
+			if {[regexp {(.*)]]$} $cdata1 discard cdata2]} {
+			    # processed CDATA (end in tag)
+			    PCDATA [array get options] [subst -novariable -nocommand $cdata2]
+			    set text [subst -novariable -nocommand $text]
+			} elseif {[regexp {(.*)]]$} $param discard cdata2]} {
+			    # processed CDATA (end in attribute)
+			    # Backslashes in param are quoted at this stage
+			    PCDATA [array get options] $cdata1[subst -novariable -nocommand $cdata2]
+			    set text [subst -novariable -nocommand $text]
+			} elseif {[regexp {(.*)]]>(.*)} $text discard cdata2 text]} {
+			    # processed CDATA (end in text)
+			    # Backslashes in param and text are quoted at this stage
+			    PCDATA [array get options] $cdata1[subst -novariable -nocommand $param]$empty>[subst -novariable -nocommand $cdata2]
+			    set text [subst -novariable -nocommand $text]
+			} else {
+			    # start CDATA
+			    set state(cdata) "$cdata1$param>$text"
+			    set state(mode) cdata
+			    continue
+			}
+
+		    }
+
+		    !ELEMENT -
+		    !ATTLIST -
+		    !ENTITY -
+		    !NOTATION {
+			uplevel #0 $options(-errorcommand) [list illegaldeclaration "[string range $tag 1 end] declaration not expected in document instance around line $state(line)"]
+		    }
+
+		    default {
+			uplevel #0 $options(-errorcommand) [list unknowninstruction "unknown processing instruction \"<$tag>\" around line $state(line)"]
+		    }
+		}
+	    }
+	    *,1,* -
+	    *,0,/,/ {
+		# Syntax error
+	    	uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: closed/empty tag: tag $tag param $param empty $empty close $close around line $state(line)"]
+	    }
+	}
+	
+	# Mats: we could have been reset from any of the callbacks!
+	if {![info exists state(haveDocElement)]} {
+	    return {}
+	}
+
+	# Process character data
+	if {$state(haveDocElement) && [llength $state(stack)]} {
+
+	    # Check if the internal DTD entity is in the text
+	    regsub -all &xml:intdtd\; $text \[$options(-internaldtd)\] text
+
+	    # Look for entity references
+	    if {([array size entities] || \
+		    [string length $options(-entityreferencecommand)]) && \
+		    $options(-defaultexpandinternalentities) && \
+		    [regexp {&[^;]+;} $text]} {
+
+		# protect Tcl specials
+		# NB. braces and backslashes may already be protected
+		regsub -all {\\({|}|\\)} $text {\1} text
+		regsub -all {([][$\\{}])} $text {\\\1} text
+
+		# Mark entity references
+		regsub -all {&([^;]+);} $text [format {%s; %s {\1} ; %s %s} \}\} [namespace code [list Entity [array get options] $options(-entityreferencecommand) [namespace code [list PCDATA [array get options]]] $options(entities)]] [namespace code [list DeProtect [namespace code [list PCDATA [array get options]]]]] \{\{] text
+		set text "uplevel #0 [namespace code [list DeProtect1 [namespace code [list PCDATA [array get options]]]]] {{$text}}"
+		eval $text
+	    } else {
+
+		# Restore protected special characters
+		regsub -all {\\([][{}\\])} $text {\1} text
+		PCDATA [array get options] $text
+	    }
+	} elseif {[string length [string trim $text]]} {
+	    uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\" in document prolog around line $state(line)"]
+	}
+
+    }
+
+    # If this is the end of the document, close all open containers
+    if {$options(-final) && [llength $state(stack)]} {
+	eval $options(-errorcommand) [list unclosedelement "element [lindex $state(stack) end] remains unclosed around line $state(line)"]
+    }
+
+    return {}
+}
+
+# sgml::DeProtect --
+#
+#	Invoke given command after removing protecting backslashes
+#	from given text.
+#
+# Arguments:
+#	cmd	Command to invoke
+#	text	Text to deprotect
+#
+# Results:
+#	Depends on command
+
+proc sgml::DeProtect1 {cmd text} {
+    if {[string compare {} $text]} {
+	regsub -all {\\([]$[{}\\])} $text {\1} text
+	uplevel #0 $cmd [list $text]
+    }
+}
+proc sgml::DeProtect {cmd text} {
+    set text [lindex $text 0]
+    if {[string compare {} $text]} {
+	regsub -all {\\([]$[{}\\])} $text {\1} text
+	uplevel #0 $cmd [list $text]
+    }
+}
+
+# sgml::ParserDelete --
+#
+#	Free all memory associated with parser
+#
+# Arguments:
+#	var	global state array
+#
+# Results:
+#	Variables unset
+
+proc sgml::ParserDelete var {
+    upvar #0 $var state
+
+    if {![info exists state]} {
+	return -code error "unknown parser"
+    }
+
+    catch {unset $state(entities)}
+    catch {unset $state(parameterentities)}
+    catch {unset $state(elementdecls)}
+    catch {unset $state(attlistdecls)}
+    catch {unset $state(notationdecls)}
+    catch {unset $state(namespaces)}
+
+    unset state
+
+    return {}
+}
+
+# sgml::ParseEvent:ElementOpen --
+#
+#	Start of an element.
+#
+# Arguments:
+#	tag	Element name
+#	attr	Attribute list
+#	opts	Options
+#	args	further configuration options
+#
+# Options:
+#	-empty boolean
+#		indicates whether the element was an empty element
+#
+# Results:
+#	Modify state and invoke callback
+
+proc sgml::ParseEvent:ElementOpen {tag attr opts args} {
+    variable Name
+    variable Wsp
+
+    array set options $opts
+    upvar #0 $options(-statevariable) state
+    array set cfg {-empty 0}
+    array set cfg $args
+    set handleEmpty 0
+
+    if {$options(-normalize)} {
+	set tag [string toupper $tag]
+    }
+
+    # Update state
+    lappend state(stack) $tag
+
+    # Parse attribute list into a key-value representation
+    if {[string compare $options(-parseattributelistcommand) {}]} {
+	if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $opts $attr]} attr]} {
+	    if {[string compare [lindex $attr 0] "unterminated attribute value"]} {
+		uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
+		set attr {}
+	    } else {
+
+		# It is most likely that a ">" character was in an attribute value.
+		# This manifests itself by ">" appearing in the element's text.
+		# In this case the callback should return a three element list;
+		# the message "unterminated attribute value", the attribute list it
+		# did manage to parse and the remainder of the attribute list.
+
+		foreach {msg attlist brokenattr} $attr break
+
+		upvar text elemText
+		if {[string first > $elemText] >= 0} {
+
+		    # Now piece the attribute list back together
+		    regexp [cl $Wsp]*($Name)[cl $Wsp]*=[cl $Wsp]*("|')(.*) $brokenattr discard attname delimiter attvalue
+		    regexp (.*)>([cl ^>]*)\$ $elemText discard remattlist elemText
+		    regexp ([cl ^$delimiter]*)${delimiter}(.*) $remattlist discard remattvalue remattlist
+
+		    # Gotcha: watch out for empty element syntax
+		    if {[string match */ [string trimright $remattlist]]} {
+			set remattlist [string range $remattlist 0 end-1]
+			set handleEmpty 1
+			set cfg(-empty) 1
+		    }
+
+		    append attvalue >$remattvalue
+		    lappend attlist $attname $attvalue
+
+		    # Complete parsing the attribute list
+		    if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $options(-statevariable) $remattlist]} attr]} {
+			uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
+			set attr {}
+			set attlist {}
+		    } else {
+			eval lappend attlist $attr
+		    }
+
+		    set attr $attlist
+
+		} else {
+		    uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
+		    set attr {}
+		}
+	    }
+	}
+    }
+
+    set empty {}
+    if {$cfg(-empty) && $options(-reportempty)} {
+	set empty {-empty 1}
+    }
+
+    # Check for namespace declarations
+    upvar #0 $options(namespaces) namespaces
+    set nsdecls {}
+    if {[llength $attr]} {
+	array set attrlist $attr
+	foreach {attrName attrValue} [array get attrlist xmlns*] {
+	    unset attrlist($attrName)
+	    set colon [set prefix {}]
+	    if {[regexp {^xmlns(:(.+))?$} $attrName discard colon prefix]} {
+		switch -glob [string length $colon],[string length $prefix] {
+		    0,0 {
+			# default NS declaration
+			lappend state(defaultNSURI) $attrValue
+			lappend state(defaultNS) [llength $state(stack)]
+			lappend nsdecls $attrValue {}
+		    }
+		    0,* {
+			# Huh?
+		    }
+		    *,0 {
+			# Error
+			uplevel #0 $state(-warningcommand) "no prefix specified for namespace URI \"$attrValue\" in element \"$tag\""
+		    }
+		    default {
+			set namespaces($prefix,[llength $state(stack)]) $attrValue
+			lappend nsdecls $attrValue $prefix
+		    }
+		}
+	    }
+	}
+	if {[llength $nsdecls]} {
+	    set nsdecls [list -namespacedecls $nsdecls]
+	}
+	set attr [array get attrlist]
+    }
+
+    # Check whether this element has an expanded name
+    set ns {}
+    if {[regexp {([^:]+):(.*)$} $tag discard prefix tag]} {
+	set nsspec [lsort -dictionary -decreasing [array names namespaces $prefix,*]]
+	if {[llength $nsspec]} {
+	    set nsuri $namespaces([lindex $nsspec 0])
+	    set ns [list -namespace $nsuri]
+	} else {
+	    uplevel #0 $options(-errorcommand) [list namespaceundeclared "no namespace declared for prefix \"$prefix\" in element $tag"]
+	}
+    } elseif {[llength $state(defaultNSURI)]} {
+	set ns [list -namespace [lindex $state(defaultNSURI) end]]
+    }
+
+    # Invoke callback
+    set code [catch {uplevel #0 $options(-elementstartcommand) [list $tag $attr] $empty $ns $nsdecls} msg]
+
+    # Sometimes empty elements must be handled here (see above)
+    if {$code == 0 && $handleEmpty} {
+	ParseEvent:ElementClose $tag $opts -empty 1
+    }
+
+    return -code $code -errorinfo $::errorInfo $msg
+}
+
+# sgml::ParseEvent:ElementClose --
+#
+#	End of an element.
+#
+# Arguments:
+#	tag	Element name
+#	opts	Options
+#	args	further configuration options
+#
+# Options:
+#	-empty boolean
+#		indicates whether the element as an empty element
+#
+# Results:
+#	Modify state and invoke callback
+
+proc sgml::ParseEvent:ElementClose {tag opts args} {
+    array set options $opts
+    upvar #0 $options(-statevariable) state
+    array set cfg {-empty 0}
+    array set cfg $args
+
+    # WF check
+    if {[string compare $tag [lindex $state(stack) end]]} {
+	uplevel #0 $options(-errorcommand) [list illegalendtag "end tag \"$tag\" does not match open element \"[lindex $state(stack) end]\" around line $state(line)"]
+	return
+    }
+
+    # Check whether this element has an expanded name
+    upvar #0 $options(namespaces) namespaces
+    set ns {}
+    if {[regexp {([^:]+):(.*)$} $tag discard prefix tag]} {
+	set nsuri $namespaces([lindex [lsort -dictionary -decreasing [array names namespaces $prefix,*]] 0])
+	set ns [list -namespace $nsuri]
+    } elseif {[llength $state(defaultNSURI)]} {
+	set ns [list -namespace [lindex $state(defaultNSURI) end]]
+    }
+
+    # Pop namespace stacks, if any
+    if {[llength $state(defaultNS)]} {
+	if {[llength $state(stack)] == [lindex $state(defaultNS) end]} {
+	    set state(defaultNS) [lreplace $state(defaultNS) end end]
+	}
+    }
+    foreach nsspec [array names namespaces *,[llength $state(stack)]] {
+	unset namespaces($nsspec)
+    }
+
+    # Update state
+    set state(stack) [lreplace $state(stack) end end]
+
+    set empty {}
+    if {$cfg(-empty) && $options(-reportempty)} {
+	set empty {-empty 1}
+    }
+
+    # Invoke callback
+    # Mats: Shall be same as sgml::ParseEvent:ElementOpen to handle exceptions in callback.
+    set code [catch {uplevel #0 $options(-elementendcommand) [list $tag] $empty $ns} msg]
+    return -code $code -errorinfo $::errorInfo $msg
+}
+
+# sgml::PCDATA --
+#
+#	Process PCDATA before passing to application
+#
+# Arguments:
+#	opts	options
+#	pcdata	Character data to be processed
+#
+# Results:
+#	Checks that characters are legal,
+#	checks -ignorewhitespace setting.
+
+proc sgml::PCDATA {opts pcdata} {
+    array set options $opts
+
+    if {$options(-ignorewhitespace) && \
+	    ![string length [string trim $pcdata]]} {
+	return {}
+    }
+
+    if {![regexp ^[cl $::sgml::Char]*\$ $pcdata]} {
+	upvar \#0 $options(-statevariable) state
+	uplevel \#0 $options(-errorcommand) [list illegalcharacters "illegal, non-Unicode characters found in text \"$pcdata\" around line $state(line)"]
+    }
+
+    uplevel \#0 $options(-characterdatacommand) [list $pcdata]
+}
+
+# sgml::Normalize --
+#
+#	Perform name normalization if required
+#
+# Arguments:
+#	name	name to normalize
+#	req	normalization required
+#
+# Results:
+#	Name returned as upper-case if normalization required
+
+proc sgml::Normalize {name req} {
+    if {$req} {
+	return [string toupper $name]
+    } else {
+	return $name
+    }
+}
+
+# sgml::Entity --
+#
+#	Resolve XML entity references (syntax: &xxx;).
+#
+# Arguments:
+#	opts		options
+#	entityrefcmd	application callback for entity references
+#	pcdatacmd	application callback for character data
+#	entities	name of array containing entity definitions.
+#	ref		entity reference (the "xxx" bit)
+#
+# Results:
+#	Returns substitution text for given entity.
+
+proc sgml::Entity {opts entityrefcmd pcdatacmd entities ref} {
+    array set options $opts
+    upvar #0 $options(-statevariable) state
+
+    if {![string length $entities]} {
+	set entities [namespace current]::EntityPredef
+    }
+
+    switch -glob -- $ref {
+	%* {
+	    # Parameter entity - not recognised outside of a DTD
+	}
+	#x* {
+	    # Character entity - hex
+	    if {[catch {format %c [scan [string range $ref 2 end] %x tmp; set tmp]} char]} {
+		return -code error "malformed character entity \"$ref\""
+	    }
+	    uplevel #0 $pcdatacmd [list $char]
+
+	    return {}
+
+	}
+	#* {
+	    # Character entity - decimal
+	    if {[catch {format %c [scan [string range $ref 1 end] %d tmp; set tmp]} char]} {
+		return -code error "malformed character entity \"$ref\""
+	    }
+	    uplevel #0 $pcdatacmd [list $char]
+
+	    return {}
+
+	}
+	default {
+	    # General entity
+	    upvar #0 $entities map
+	    if {[info exists map($ref)]} {
+
+		if {![regexp {<|&} $map($ref)]} {
+
+		    # Simple text replacement - optimise
+		    uplevel #0 $pcdatacmd [list $map($ref)]
+
+		    return {}
+
+		}
+
+		# Otherwise an additional round of parsing is required.
+		# This only applies to XML, since HTML doesn't have general entities
+
+		# Must parse the replacement text for start & end tags, etc
+		# This text must be self-contained: balanced closing tags, and so on
+
+		set tokenised [tokenise $map($ref) $::xml::tokExpr $::xml::substExpr]
+		set options(-final) 0
+		eval parseEvent [list $tokenised] [array get options]
+
+		return {}
+
+	    } elseif {[string compare $entityrefcmd "::sgml::noop"]} {
+
+		set result [uplevel #0 $entityrefcmd [list $ref]]
+
+		if {[string length $result]} {
+		    uplevel #0 $pcdatacmd [list $result]
+		}
+
+		return {}
+
+	    } else {
+
+		# Reconstitute entity reference
+
+		uplevel #0 $options(-errorcommand) [list illegalentity "undefined entity reference \"$ref\""]
+
+		return {}
+
+	    }
+	}
+    }
+
+    # If all else fails leave the entity reference untouched
+    uplevel #0 $pcdatacmd [list &$ref\;]
+
+    return {}
+}
+
+####################################
+#
+# DTD parser for SGML (XML).
+#
+# This DTD actually only handles XML DTDs.  Other language's
+# DTD's, such as HTML, must be written in terms of a XML DTD.
+#
+####################################
+
+# sgml::ParseEvent:DocTypeDecl --
+#
+#	Entry point for DTD parsing
+#
+# Arguments:
+#	opts	configuration options
+#	docEl	document element name
+#	pubId	public identifier
+#	sysId	system identifier (a URI)
+#	intSSet	internal DTD subset
+
+proc sgml::ParseEvent:DocTypeDecl {opts docEl pubId sysId intSSet} {
+    array set options {}
+    array set options $opts
+
+    set code [catch {uplevel #0 $options(-doctypecommand) [list $docEl $pubId $sysId $intSSet]} err]
+    switch $code {
+	3 {
+	    # break
+	    return {}
+	}
+	0 -
+	4 {
+	    # continue
+	}
+	default {
+	    return -code $code $err
+	}
+    }
+
+    # Otherwise we'll parse the DTD and report it piecemeal
+
+    # The internal DTD subset is processed first (XML 2.8)
+    # During this stage, parameter entities are only allowed
+    # between markup declarations
+
+    ParseDTD:Internal [array get options] $intSSet
+
+    # The external DTD subset is processed last (XML 2.8)
+    # During this stage, parameter entities may occur anywhere
+
+    # We must resolve the external identifier to obtain the
+    # DTD data.  The application may supply its own resolver.
+
+    if {[string length $pubId] || [string length $sysId]} {
+	uplevel #0 $options(-externalentitycommand) [list $options(-cmd) $options(-baseuri) $sysId $pubId]
+    }
+
+    return {}
+}
+
+# sgml::ParseDTD:Internal --
+#
+#	Parse the internal DTD subset.
+#
+#	Parameter entities are only allowed between markup declarations.
+#
+# Arguments:
+#	opts	configuration options
+#	dtd	DTD data
+#
+# Results:
+#	Markup declarations parsed may cause callback invocation
+
+proc sgml::ParseDTD:Internal {opts dtd} {
+    variable MarkupDeclExpr
+    variable MarkupDeclSub
+
+    array set options {}
+    array set options $opts
+
+    upvar #0 $options(-statevariable) state
+    upvar #0 $options(parameterentities) PEnts
+    upvar #0 $options(externalparameterentities) ExtPEnts
+
+    # Bug 583947: remove comments before further processing
+    regsub -all {<!--.*?-->} $dtd {} dtd
+
+    # Tokenize the DTD
+
+    # Protect Tcl special characters
+    regsub -all {([{}\\])} $dtd {\\\1} dtd
+
+    regsub -all $MarkupDeclExpr $dtd $MarkupDeclSub dtd
+
+    # Entities may have angle brackets in their replacement
+    # text, which breaks the RE processing.  So, we must
+    # use a similar technique to processing doc instances
+    # to rebuild the declarations from the pieces
+
+    set mode {} ;# normal
+    set delimiter {}
+    set name {}
+    set param {}
+
+    set state(inInternalDTD) 1
+
+    # Process the tokens
+    foreach {decl value text} [lrange "{} {} \{$dtd\}" 3 end] {
+
+	# Keep track of line numbers
+	incr state(line) [regsub -all \n $text {} discard]
+
+	ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param
+
+	ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode replText text param
+
+	# There may be parameter entity references between markup decls
+
+	if {[regexp {%.*;} $text]} {
+
+	    # Protect Tcl special characters
+	    regsub -all {([{}\\])} $text {\\\1} text
+
+	    regsub -all %($::sgml::Name)\; $text "\} {\\1} \{" text
+
+	    set PElist "\{$text\}"
+	    set PElist [lreplace $PElist end end]
+	    foreach {text entref} $PElist {
+		if {[string length [string trim $text]]} {
+		    uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text in internal DTD subset around line $state(line)"]
+		}
+
+		# Expand parameter entity and recursively parse
+		# BUG: no checks yet for recursive entity references
+
+		if {[info exists PEnts($entref)]} {
+		    set externalParser [$options(-cmd) entityparser]
+		    $externalParser parse $PEnts($entref) -dtdsubset internal
+		} elseif {[info exists ExtPEnts($entref)]} {
+		    set externalParser [$options(-cmd) entityparser]
+		    $externalParser parse $ExtPEnts($entref) -dtdsubset external
+		    #$externalParser free
+		} else {
+		    uplevel #0 $options(-errorcommand) [list illegalreference "reference to undeclared parameter entity \"$entref\""]
+		}
+	    }
+
+	}
+
+    }
+
+    return {}
+}
+
+# sgml::ParseDTD:EntityMode --
+#
+#	Perform special processing for various parser modes
+#
+# Arguments:
+#	opts	configuration options
+#	modeVar	pass-by-reference mode variable
+#	replTextVar	pass-by-ref
+#	declVar	pass-by-ref
+#	valueVar	pass-by-ref
+#	textVar	pass-by-ref
+#	delimiter	delimiter currently in force
+#	name
+#	param
+#
+# Results:
+#	Depends on current mode
+
+proc sgml::ParseDTD:EntityMode {opts modeVar replTextVar declVar valueVar textVar delimiter name param} {
+    upvar 1 $modeVar mode
+    upvar 1 $replTextVar replText
+    upvar 1 $declVar decl
+    upvar 1 $valueVar value
+    upvar 1 $textVar text
+    array set options $opts
+
+    switch $mode {
+	{} {
+	    # Pass through to normal processing section
+	}
+	entity {
+	    # Look for closing delimiter
+	    if {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $decl discard val1 remainder]} {
+		append replText <$val1
+		DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
+		set decl /
+		set text $remainder\ $value>$text
+		set value {}
+		set mode {}
+	    } elseif {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $value discard val2 remainder]} {
+		append replText <$decl\ $val2
+		DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
+		set decl /
+		set text $remainder>$text
+		set value {}
+		set mode {}
+	    } elseif {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $text discard val3 remainder]} {
+		append replText <$decl\ $value>$val3
+		DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
+		set decl /
+		set text $remainder
+		set value {}
+		set mode {}
+	    } else {
+
+		# Remain in entity mode
+		append replText <$decl\ $value>$text
+		return -code continue
+
+	    }
+	}
+
+	ignore {
+	    upvar #0 $options(-statevariable) state
+
+	    if {[regexp {]](.*)$} $decl discard remainder]} {
+		set state(condSections) [lreplace $state(condSections) end end]
+		set decl $remainder
+		set mode {}
+	    } elseif {[regexp {]](.*)$} $value discard remainder]} {
+		set state(condSections) [lreplace $state(condSections) end end]
+		regexp <[cl $::sgml::Wsp]*($::sgml::Name)(.*) $remainder discard decl value
+		set mode {}
+	    } elseif {[regexp {]]>(.*)$} $text discard remainder]} {
+		set state(condSections) [lreplace $state(condSections) end end]
+		set decl /
+		set value {}
+		set text $remainder
+		#regexp <[cl $::sgml::Wsp]*($::sgml::Name)([cl ^>]*)>(.*) $remainder discard decl value text
+		set mode {}
+	    } else {
+		set decl /
+	    }
+
+	}
+
+	comment {
+	    # Look for closing comment delimiter
+
+	    upvar #0 $options(-statevariable) state
+
+	    if {[regexp (.*?)--(.*)\$ $decl discard data1 remainder]} {
+	    } elseif {[regexp (.*?)--(.*)\$ $value discard data1 remainder]} {
+	    } elseif {[regexp (.*?)--(.*)\$ $text discard data1 remainder]} {
+	    } else {
+		# comment continues
+		append state(commentdata) <$decl\ $value>$text
+		set decl /
+		set value {}
+		set text {}
+	    }
+	}
+
+    }
+
+    return {}
+}
+
+# sgml::ParseDTD:ProcessMarkupDecl --
+#
+#	Process a single markup declaration
+#
+# Arguments:
+#	opts	configuration options
+#	declVar	pass-by-ref
+#	valueVar	pass-by-ref
+#	delimiterVar	pass-by-ref for current delimiter in force
+#	nameVar	pass-by-ref
+#	modeVar	pass-by-ref for current parser mode
+#	replTextVar	pass-by-ref
+#	textVar	pass-by-ref
+#	paramVar	pass-by-ref
+#
+# Results:
+#	Depends on markup declaration.  May change parser mode
+
+proc sgml::ParseDTD:ProcessMarkupDecl {opts declVar valueVar delimiterVar nameVar modeVar replTextVar textVar paramVar} {
+    upvar 1 $modeVar mode
+    upvar 1 $replTextVar replText
+    upvar 1 $textVar text
+    upvar 1 $declVar decl
+    upvar 1 $valueVar value
+    upvar 1 $nameVar name
+    upvar 1 $delimiterVar delimiter
+    upvar 1 $paramVar param
+
+    variable declExpr
+    variable ExternalEntityExpr
+
+    array set options $opts
+    upvar #0 $options(-statevariable) state
+
+    switch -glob -- $decl {
+
+	/ {
+	    # continuation from entity processing
+	}
+
+	!ELEMENT {
+	    # Element declaration
+	    if {[regexp $declExpr $value discard tag cmodel]} {
+		DTD:ELEMENT [array get options] $tag $cmodel
+	    } else {
+		uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed element declaration around line $state(line)"]
+	    }
+	}
+
+	!ATTLIST {
+	    # Attribute list declaration
+	    variable declExpr
+	    if {[regexp $declExpr $value discard tag attdefns]} {
+		if {[catch {DTD:ATTLIST [array get options] $tag $attdefns} err]} {
+		    #puts stderr "Stack trace: $::errorInfo\n***\n"
+		    # Atttribute parsing has bugs at the moment
+		    #return -code error "$err around line $state(line)"
+		    return {}
+		}
+	    } else {
+		uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed attribute list declaration around line $state(line)"]
+	    }
+	}
+
+	!ENTITY {
+	    # Entity declaration
+	    variable EntityExpr
+
+	    if {[regexp $EntityExpr $value discard param name value]} {
+
+		# Entity replacement text may have a '>' character.
+		# In this case, the real delimiter will be in the following
+		# text.  This is complicated by the possibility of there
+		# being several '<','>' pairs in the replacement text.
+		# At this point, we are searching for the matching quote delimiter.
+
+		if {[regexp $ExternalEntityExpr $value]} {
+		    DTD:ENTITY [array get options] $name [string trim $param] $value
+		} elseif {[regexp ("|')(.*?)\\1(.*) $value discard delimiter replText value]} {
+
+		    if {[string length [string trim $value]]} {
+			uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"]
+		    } else {
+			DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
+		    }
+		} elseif {[regexp ("|')(.*) $value discard delimiter replText]} {
+		    append replText >$text
+		    set text {}
+		    set mode entity
+		} else {
+		    uplevel #0 $options(-errorcommand) [list illegaldeclaration "no delimiter for entity declaration around line $state(line)"]
+		}
+
+	    } else {
+		uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"]
+	    }
+	}
+
+	!NOTATION {
+	    # Notation declaration
+	    if {[regexp $declExpr param discard tag notation]} {
+		DTD:ENTITY [array get options] $tag $notation
+	    } else {
+		uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"]
+	    }
+	}
+
+	!--* {
+	    # Start of a comment
+
+	    if {[regexp !--(.*?)--\$ $decl discard data]} {
+		if {[string length [string trim $value]]} {
+		    uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$value\""]
+		}
+		uplevel #0 $options(-commentcommand) [list $data]
+		set decl /
+		set value {}
+	    } elseif {[regexp -- ^(.*?)--\$ $value discard data2]} {
+		regexp !--(.*)\$ $decl discard data1
+		uplevel #0 $options(-commentcommand) [list $data1\ $data2]
+		set decl /
+		set value {}
+	    } elseif {[regexp (.*?)-->(.*)\$ $text discard data3 remainder]} {
+		regexp !--(.*)\$ $decl discard data1
+		uplevel #0 $options(-commentcommand) [list $data1\ $value>$data3]
+		set decl /
+		set value {}
+		set text $remainder
+	    } else {
+		regexp !--(.*)\$ $decl discard data1
+		set state(commentdata) $data1\ $value>$text
+		set decl /
+		set value {}
+		set text {}
+		set mode comment
+	    }
+	}
+
+	!*INCLUDE* -
+	!*IGNORE* {
+	    if {$state(inInternalDTD)} {
+		uplevel #0 $options(-errorcommand) [list illegalsection "conditional section not permitted in internal DTD subset around line $state(line)"]
+	    }
+
+	    if {[regexp {^!\[INCLUDE\[(.*)} $decl discard remainder]} {
+		# Push conditional section stack, popped by ]]> sequence
+
+		if {[regexp {(.*?)]]$} $remainder discard r2]} {
+		    # section closed immediately
+		    if {[string length [string trim $r2]]} {
+			uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
+		    }
+		} elseif {[regexp {(.*?)]](.*)} $value discard r2 r3]} {
+		    # section closed immediately
+		    if {[string length [string trim $r2]]} {
+			uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
+		    }
+		    if {[string length [string trim $r3]]} {
+			uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r3\" in conditional section"]
+		    }
+		} else {
+
+		    lappend state(condSections) INCLUDE
+
+		    set parser [$options(-cmd) entityparser]
+		    $parser parse $remainder\ $value> -dtdsubset external
+		    #$parser free
+
+		    if {[regexp {(.*?)]]>(.*)} $text discard t1 t2]} {
+			if {[string length [string trim $t1]]} {
+			    uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""]
+			}
+			if {![llength $state(condSections)]} {
+			    uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
+			}
+			set state(condSections) [lreplace $state(condSections) end end]
+			set text $t2
+		    }
+
+		}
+	    } elseif {[regexp {^!\[IGNORE\[(.*)} $decl discard remainder]} {
+		# Set ignore mode.  Still need a stack
+		set mode ignore
+
+		if {[regexp {(.*?)]]$} $remainder discard r2]} {
+		    # section closed immediately
+		    if {[string length [string trim $r2]]} {
+			uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
+		    }
+		} elseif {[regexp {(.*?)]](.*)} $value discard r2 r3]} {
+		    # section closed immediately
+		    if {[string length [string trim $r2]]} {
+			uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
+		    }
+		    if {[string length [string trim $r3]]} {
+			uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r3\" in conditional section"]
+		    }
+		} else {
+		    
+		    lappend state(condSections) IGNORE
+
+		    if {[regexp {(.*?)]]>(.*)} $text discard t1 t2]} {
+			if {[string length [string trim $t1]]} {
+			    uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""]
+			}
+			if {![llength $state(condSections)]} {
+			    uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
+			}
+			set state(condSections) [lreplace $state(condSections) end end]
+			set text $t2
+		    }
+
+		}
+	    } else {
+		uplevel #0 $options(-errorcommand) [list illegaldeclaration "illegal markup declaration \"$decl\" around line $state(line)"]
+	    }
+
+	}
+
+	default {
+	    if {[regexp {^\?(.*)} $decl discard target]} {
+		# Processing instruction
+	    } else {
+		uplevel #0 $options(-errorcommand) [list illegaldeclaration "illegal markup declaration \"$decl\""]
+	    }
+	}
+    }
+
+    return {}
+}
+
+# sgml::ParseDTD:External --
+#
+#	Parse the external DTD subset.
+#
+#	Parameter entities are allowed anywhere.
+#
+# Arguments:
+#	opts	configuration options
+#	dtd	DTD data
+#
+# Results:
+#	Markup declarations parsed may cause callback invocation
+
+proc sgml::ParseDTD:External {opts dtd} {
+    variable MarkupDeclExpr
+    variable MarkupDeclSub
+    variable declExpr
+
+    array set options $opts
+    upvar #0 $options(parameterentities) PEnts
+    upvar #0 $options(externalparameterentities) ExtPEnts
+    upvar #0 $options(-statevariable) state
+
+    # As with the internal DTD subset, watch out for
+    # entities with angle brackets
+    set mode {} ;# normal
+    set delimiter {}
+    set name {}
+    set param {}
+
+    set oldState 0
+    catch {set oldState $state(inInternalDTD)}
+    set state(inInternalDTD) 0
+
+    # Initialise conditional section stack
+    if {![info exists state(condSections)]} {
+	set state(condSections) {}
+    }
+    set startCondSectionDepth [llength $state(condSections)]
+
+    while {[string length $dtd]} {
+	set progress 0
+	set PEref {}
+	if {![string compare $mode "ignore"]} {
+	    set progress 1
+	    if {[regexp {]]>(.*)} $dtd discard dtd]} {
+		set remainder {}
+		set mode {} ;# normal
+		set state(condSections) [lreplace $state(condSections) end end]
+		continue
+	    } else {
+		uplevel #0 $options(-errorcommand) [list missingdelimiter "IGNORE conditional section closing delimiter not found"]
+	    }
+	} elseif {[regexp ^(.*?)%($::sgml::Name)\;(.*)\$ $dtd discard data PEref remainder]} {
+	    set progress 1
+	} else {
+	    set data $dtd
+	    set dtd {}
+	    set remainder {}
+	}
+
+	# Tokenize the DTD (so far)
+
+	# Protect Tcl special characters
+	regsub -all {([{}\\])} $data {\\\1} dataP
+
+	set n [regsub -all $MarkupDeclExpr $dataP $MarkupDeclSub dataP]
+
+	if {$n} {
+	    set progress 1
+	    # All but the last markup declaration should have no text
+	    set dataP [lrange "{} {} \{$dataP\}" 3 end]
+	    if {[llength $dataP] > 3} {
+		foreach {decl value text} [lrange $dataP 0 [expr [llength $dataP] - 4]] {
+		    ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param
+		    ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode repltextVar text param
+
+		    if {[string length [string trim $text]]} {
+			# check for conditional section close
+			if {[regexp {]]>(.*)$} $text discard text]} {
+			    if {[string length [string trim $text]]} {
+				uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\""]
+			    }
+			    if {![llength $state(condSections)]} {
+				uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
+			    }
+			    set state(condSections) [lreplace $state(condSections) end end]
+			    if {![string compare $mode "ignore"]} {
+				set mode {} ;# normal
+			    }
+			} else {
+			    uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\""]
+			}
+		    }
+		}
+	    }
+	    # Do the last declaration
+	    foreach {decl value text} [lrange $dataP [expr [llength $dataP] - 3] end] {
+		ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param
+		ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode repltextVar text param
+	    }
+	}
+
+	# Now expand the PE reference, if any
+	switch -glob $mode,[string length $PEref],$n {
+	    ignore,0,* {
+		set dtd $text
+	    }
+	    ignore,*,* {
+		set dtd $text$remainder
+	    }
+	    *,0,0 {
+		set dtd $data
+	    }
+	    *,0,* {
+		set dtd $text
+	    }
+	    *,*,0 {
+		if {[catch {append data $PEnts($PEref)}]} {
+		    if {[info exists ExtPEnts($PEref)]} {
+			set externalParser [$options(-cmd) entityparser]
+			$externalParser parse $ExtPEnts($PEref) -dtdsubset external
+			#$externalParser free
+		    } else {
+			uplevel #0 $options(-errorcommand) [list entityundeclared "parameter entity \"$PEref\" not declared"]
+		    }
+		}
+		set dtd $data$remainder
+	    }
+	    default {
+		if {[catch {append text $PEnts($PEref)}]} {
+		    if {[info exists ExtPEnts($PEref)]} {
+			set externalParser [$options(-cmd) entityparser]
+			$externalParser parse $ExtPEnts($PEref) -dtdsubset external
+			#$externalParser free
+		    } else {
+			uplevel #0 $options(-errorcommand) [list entityundeclared "parameter entity \"$PEref\" not declared"]
+		    }
+		}
+		set dtd $text$remainder
+	    }
+	}
+
+	# Check whether a conditional section has been terminated
+	if {[regexp {^(.*?)]]>(.*)$} $dtd discard t1 t2]} {
+	    if {![regexp <.*> $t1]} {
+		if {[string length [string trim $t1]]} {
+		    uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""]
+		}
+		if {![llength $state(condSections)]} {
+		    uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
+		}
+		set state(condSections) [lreplace $state(condSections) end end]
+		if {![string compare $mode "ignore"]} {
+		    set mode {} ;# normal
+		}
+		set dtd $t2
+		set progress 1
+	    }
+	}
+
+	if {!$progress} {
+	    # No parameter entity references were found and 
+	    # the text does not contain a well-formed markup declaration
+	    # Avoid going into an infinite loop
+	    upvar #0 $options(-errorcommand) [list syntaxerror "external entity does not contain well-formed markup declaration"]
+	    break
+	}
+    }
+
+    set state(inInternalDTD) $oldState
+
+    # Check that conditional sections have been closed properly
+    if {[llength $state(condSections)] > $startCondSectionDepth} {
+	uplevel #0 $options(-errorcommand) [list syntaxerror "[lindex $state(condSections) end] conditional section not closed"]
+    }
+    if {[llength $state(condSections)] < $startCondSectionDepth} {
+	uplevel #0 $options(-errorcommand) [list syntaxerror "too many conditional section closures"]
+    }
+
+    return {}
+}
+
+# Procedures for handling the various declarative elements in a DTD.
+# New elements may be added by creating a procedure of the form
+# parse:DTD:_element_
+
+# For each of these procedures, the various regular expressions they use
+# are created outside of the proc to avoid overhead at runtime
+
+# sgml::DTD:ELEMENT --
+#
+#	<!ELEMENT ...> defines an element.
+#
+#	The content model for the element is stored in the contentmodel array,
+#	indexed by the element name.  The content model is parsed into the
+#	following list form:
+#
+#		{}	Content model is EMPTY.
+#			Indicated by an empty list.
+#		*	Content model is ANY.
+#			Indicated by an asterix.
+#		{ELEMENT ...}
+#			Content model is element-only.
+#		{MIXED {element1 element2 ...}}
+#			Content model is mixed (PCDATA and elements).
+#			The second element of the list contains the 
+#			elements that may occur.  #PCDATA is assumed 
+#			(ie. the list is normalised).
+#
+# Arguments:
+#	opts	configuration options
+#	name	element GI
+#	modspec	unparsed content model specification
+
+proc sgml::DTD:ELEMENT {opts name modspec} {
+    variable Wsp
+    array set options $opts
+
+    upvar #0 $options(elementdecls) elements
+
+    if {$options(-validate) && [info exists elements($name)]} {
+	eval $options(-errorcommand) [list elementdeclared "element \"$name\" already declared"]
+    } else {
+	switch -- $modspec {
+	    EMPTY {
+	    	set elements($name) {}
+		uplevel #0 $options(-elementdeclcommand) $name {{}}
+	    }
+	    ANY {
+	    	set elements($name) *
+		uplevel #0 $options(-elementdeclcommand) $name *
+	    }
+	    default {
+		# Don't parse the content model for now,
+		# just pass the model to the application
+		if {0 && [regexp [format {^\([%s]*#PCDATA[%s]*(\|([^)]+))?[%s]*\)*[%s]*$} $Wsp $Wsp $Wsp $Wsp] discard discard mtoks]} {
+		    set cm($name) [list MIXED [split $mtoks |]]
+		} elseif {0} {
+		    if {[catch {CModelParse $state(state) $value} result]} {
+			eval $options(-errorcommand) [list element? $result]
+		    } else {
+			set cm($id) [list ELEMENT $result]
+		    }
+		} else {
+		    set elements($name) $modspec
+		    uplevel #0 $options(-elementdeclcommand) $name [list $modspec]
+		}
+	    }
+	}
+    }
+}
+
+# sgml::CModelParse --
+#
+#	Parse an element content model (non-mixed).
+#	A syntax tree is constructed.
+#	A transition table is built next.
+#
+#	This is going to need alot of work!
+#
+# Arguments:
+#	state	state array variable
+#	value	the content model data
+#
+# Results:
+#	A Tcl list representing the content model.
+
+proc sgml::CModelParse {state value} {
+    upvar #0 $state var
+
+    # First build syntax tree
+    set syntaxTree [CModelMakeSyntaxTree $state $value]
+
+    # Build transition table
+    set transitionTable [CModelMakeTransitionTable $state $syntaxTree]
+
+    return [list $syntaxTree $transitionTable]
+}
+
+# sgml::CModelMakeSyntaxTree --
+#
+#	Construct a syntax tree for the regular expression.
+#
+#	Syntax tree is represented as a Tcl list:
+#	rep {:choice|:seq {{rep list1} {rep list2} ...}}
+#	where:	rep is repetition character, *, + or ?. {} for no repetition
+#		listN is nested expression or Name
+#
+# Arguments:
+#	spec	Element specification
+#
+# Results:
+#	Syntax tree for element spec as nested Tcl list.
+#
+#	Examples:
+#	(memo)
+#		{} {:seq {{} memo}}
+#	(front, body, back?)
+#		{} {:seq {{} front} {{} body} {? back}}
+#	(head, (p | list | note)*, div2*)
+#		{} {:seq {{} head} {* {:choice {{} p} {{} list} {{} note}}} {* div2}}
+#	(p | a | ul)+
+#		+ {:choice {{} p} {{} a} {{} ul}}
+
+proc sgml::CModelMakeSyntaxTree {state spec} {
+    upvar #0 $state var
+    variable Wsp
+    variable name
+
+    # Translate the spec into a Tcl list.
+
+    # None of the Tcl special characters are allowed in a content model spec.
+    if {[regexp {\$|\[|\]|\{|\}} $spec]} {
+	return -code error "illegal characters in specification"
+    }
+
+    regsub -all [format {(%s)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $name $Wsp $Wsp] $spec [format {%sCModelSTname %s {\1} {\2} {\3}} \n $state] spec
+    regsub -all {\(} $spec "\nCModelSTopenParen $state " spec
+    regsub -all [format {\)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $Wsp $Wsp] $spec [format {%sCModelSTcloseParen %s {\1} {\2}} \n $state] spec
+
+    array set var {stack {} state start}
+    eval $spec
+
+    # Peel off the outer seq, its redundant
+    return [lindex [lindex $var(stack) 1] 0]
+}
+
+# sgml::CModelSTname --
+#
+#	Processes a name in a content model spec.
+#
+# Arguments:
+#	state	state array variable
+#	name	name specified
+#	rep	repetition operator
+#	cs	choice or sequence delimiter
+#
+# Results:
+#	See CModelSTcp.
+
+proc sgml::CModelSTname {state name rep cs args} {
+    if {[llength $args]} {
+	return -code error "syntax error in specification: \"$args\""
+    }
+
+    CModelSTcp $state $name $rep $cs
+}
+
+# sgml::CModelSTcp --
+#
+#	Process a content particle.
+#
+# Arguments:
+#	state	state array variable
+#	name	name specified
+#	rep	repetition operator
+#	cs	choice or sequence delimiter
+#
+# Results:
+#	The content particle is added to the current group.
+
+proc sgml::CModelSTcp {state cp rep cs} {
+    upvar #0 $state var
+
+    switch -glob -- [lindex $var(state) end]=$cs {
+	start= {
+	    set var(state) [lreplace $var(state) end end end]
+	    # Add (dummy) grouping, either choice or sequence will do
+	    CModelSTcsSet $state ,
+	    CModelSTcpAdd $state $cp $rep
+	}
+	:choice= -
+	:seq= {
+	    set var(state) [lreplace $var(state) end end end]
+	    CModelSTcpAdd $state $cp $rep
+	}
+	start=| -
+	start=, {
+	    set var(state) [lreplace $var(state) end end [expr {$cs == "," ? ":seq" : ":choice"}]]
+	    CModelSTcsSet $state $cs
+	    CModelSTcpAdd $state $cp $rep
+	}
+	:choice=| -
+	:seq=, {
+	    CModelSTcpAdd $state $cp $rep
+	}
+	:choice=, -
+	:seq=| {
+	    return -code error "syntax error in specification: incorrect delimiter after \"$cp\", should be \"[expr {$cs == "," ? "|" : ","}]\""
+	}
+	end=* {
+	    return -code error "syntax error in specification: no delimiter before \"$cp\""
+	}
+	default {
+	    return -code error "syntax error"
+	}
+    }
+    
+}
+
+# sgml::CModelSTcsSet --
+#
+#	Start a choice or sequence on the stack.
+#
+# Arguments:
+#	state	state array
+#	cs	choice oir sequence
+#
+# Results:
+#	state is modified: end element of state is appended.
+
+proc sgml::CModelSTcsSet {state cs} {
+    upvar #0 $state var
+
+    set cs [expr {$cs == "," ? ":seq" : ":choice"}]
+
+    if {[llength $var(stack)]} {
+	set var(stack) [lreplace $var(stack) end end $cs]
+    } else {
+	set var(stack) [list $cs {}]
+    }
+}
+
+# sgml::CModelSTcpAdd --
+#
+#	Append a content particle to the top of the stack.
+#
+# Arguments:
+#	state	state array
+#	cp	content particle
+#	rep	repetition
+#
+# Results:
+#	state is modified: end element of state is appended.
+
+proc sgml::CModelSTcpAdd {state cp rep} {
+    upvar #0 $state var
+
+    if {[llength $var(stack)]} {
+	set top [lindex $var(stack) end]
+    	lappend top [list $rep $cp]
+	set var(stack) [lreplace $var(stack) end end $top]
+    } else {
+	set var(stack) [list $rep $cp]
+    }
+}
+
+# sgml::CModelSTopenParen --
+#
+#	Processes a '(' in a content model spec.
+#
+# Arguments:
+#	state	state array
+#
+# Results:
+#	Pushes stack in state array.
+
+proc sgml::CModelSTopenParen {state args} {
+    upvar #0 $state var
+
+    if {[llength $args]} {
+	return -code error "syntax error in specification: \"$args\""
+    }
+
+    lappend var(state) start
+    lappend var(stack) [list {} {}]
+}
+
+# sgml::CModelSTcloseParen --
+#
+#	Processes a ')' in a content model spec.
+#
+# Arguments:
+#	state	state array
+#	rep	repetition
+#	cs	choice or sequence delimiter
+#
+# Results:
+#	Stack is popped, and former top of stack is appended to previous element.
+
+proc sgml::CModelSTcloseParen {state rep cs args} {
+    upvar #0 $state var
+
+    if {[llength $args]} {
+	return -code error "syntax error in specification: \"$args\""
+    }
+
+    set cp [lindex $var(stack) end]
+    set var(stack) [lreplace $var(stack) end end]
+    set var(state) [lreplace $var(state) end end]
+    CModelSTcp $state $cp $rep $cs
+}
+
+# sgml::CModelMakeTransitionTable --
+#
+#	Given a content model's syntax tree, constructs
+#	the transition table for the regular expression.
+#
+#	See "Compilers, Principles, Techniques, and Tools",
+#	Aho, Sethi and Ullman.  Section 3.9, algorithm 3.5.
+#
+# Arguments:
+#	state	state array variable
+#	st	syntax tree
+#
+# Results:
+#	The transition table is returned, as a key/value Tcl list.
+
+proc sgml::CModelMakeTransitionTable {state st} {
+    upvar #0 $state var
+
+    # Construct nullable, firstpos and lastpos functions
+    array set var {number 0}
+    foreach {nullable firstpos lastpos} [	\
+	TraverseDepth1st $state $st {
+	    # Evaluated for leaf nodes
+	    # Compute nullable(n)
+	    # Compute firstpos(n)
+	    # Compute lastpos(n)
+	    set nullable [nullable leaf $rep $name]
+	    set firstpos [list {} $var(number)]
+	    set lastpos [list {} $var(number)]
+	    set var(pos:$var(number)) $name
+	} {
+	    # Evaluated for nonterminal nodes
+	    # Compute nullable, firstpos, lastpos
+	    set firstpos [firstpos $cs $firstpos $nullable]
+	    set lastpos  [lastpos  $cs $lastpos  $nullable]
+	    set nullable [nullable nonterm $rep $cs $nullable]
+	}	\
+    ] break
+
+    set accepting [incr var(number)]
+    set var(pos:$accepting) #
+
+    # var(pos:N) maps from position to symbol.
+    # Construct reverse map for convenience.
+    # NB. A symbol may appear in more than one position.
+    # var is about to be reset, so use different arrays.
+
+    foreach {pos symbol} [array get var pos:*] {
+	set pos [lindex [split $pos :] 1]
+	set pos2symbol($pos) $symbol
+	lappend sym2pos($symbol) $pos
+    }
+
+    # Construct the followpos functions
+    catch {unset var}
+    followpos $state $st $firstpos $lastpos
+
+    # Construct transition table
+    # Dstates is [union $marked $unmarked]
+    set unmarked [list [lindex $firstpos 1]]
+    while {[llength $unmarked]} {
+	set T [lindex $unmarked 0]
+	lappend marked $T
+	set unmarked [lrange $unmarked 1 end]
+
+	# Find which input symbols occur in T
+	set symbols {}
+	foreach pos $T {
+	    if {$pos != $accepting && [lsearch $symbols $pos2symbol($pos)] < 0} {
+		lappend symbols $pos2symbol($pos)
+	    }
+	}
+	foreach a $symbols {
+	    set U {}
+	    foreach pos $sym2pos($a) {
+		if {[lsearch $T $pos] >= 0} {
+		    # add followpos($pos)
+	    	    if {$var($pos) == {}} {
+	    	    	lappend U $accepting
+	    	    } else {
+	    	    	eval lappend U $var($pos)
+	    	    }
+		}
+	    }
+	    set U [makeSet $U]
+	    if {[llength $U] && [lsearch $marked $U] < 0 && [lsearch $unmarked $U] < 0} {
+		lappend unmarked $U
+	    }
+	    set Dtran($T,$a) $U
+	}
+	
+    }
+
+    return [list [array get Dtran] [array get sym2pos] $accepting]
+}
+
+# sgml::followpos --
+#
+#	Compute the followpos function, using the already computed
+#	firstpos and lastpos.
+#
+# Arguments:
+#	state		array variable to store followpos functions
+#	st		syntax tree
+#	firstpos	firstpos functions for the syntax tree
+#	lastpos		lastpos functions
+#
+# Results:
+#	followpos functions for each leaf node, in name/value format
+
+proc sgml::followpos {state st firstpos lastpos} {
+    upvar #0 $state var
+
+    switch -- [lindex [lindex $st 1] 0] {
+	:seq {
+	    for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
+	    	followpos $state [lindex [lindex $st 1] $i]			\
+			[lindex [lindex $firstpos 0] [expr $i - 1]]	\
+			[lindex [lindex $lastpos 0] [expr $i - 1]]
+	    	foreach pos [lindex [lindex [lindex $lastpos 0] [expr $i - 1]] 1] {
+		    eval lappend var($pos) [lindex [lindex [lindex $firstpos 0] $i] 1]
+		    set var($pos) [makeSet $var($pos)]
+	    	}
+	    }
+	}
+	:choice {
+	    for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
+		followpos $state [lindex [lindex $st 1] $i]			\
+			[lindex [lindex $firstpos 0] [expr $i - 1]]	\
+			[lindex [lindex $lastpos 0] [expr $i - 1]]
+	    }
+	}
+	default {
+	    # No action at leaf nodes
+	}
+    }
+
+    switch -- [lindex $st 0] {
+	? {
+	    # We having nothing to do here ! Doing the same as
+	    # for * effectively converts this qualifier into the other.
+	}
+	* {
+	    foreach pos [lindex $lastpos 1] {
+		eval lappend var($pos) [lindex $firstpos 1]
+		set var($pos) [makeSet $var($pos)]
+	    }
+	}
+    }
+
+}
+
+# sgml::TraverseDepth1st --
+#
+#	Perform depth-first traversal of a tree.
+#	A new tree is constructed, with each node computed by f.
+#
+# Arguments:
+#	state	state array variable
+#	t	The tree to traverse, a Tcl list
+#	leaf	Evaluated at a leaf node
+#	nonTerm	Evaluated at a nonterminal node
+#
+# Results:
+#	A new tree is returned.
+
+proc sgml::TraverseDepth1st {state t leaf nonTerm} {
+    upvar #0 $state var
+
+    set nullable {}
+    set firstpos {}
+    set lastpos {}
+
+    switch -- [lindex [lindex $t 1] 0] {
+	:seq -
+	:choice {
+	    set rep [lindex $t 0]
+	    set cs [lindex [lindex $t 1] 0]
+
+	    foreach child [lrange [lindex $t 1] 1 end] {
+		foreach {childNullable childFirstpos childLastpos} \
+			[TraverseDepth1st $state $child $leaf $nonTerm] break
+		lappend nullable $childNullable
+		lappend firstpos $childFirstpos
+		lappend lastpos  $childLastpos
+	    }
+
+	    eval $nonTerm
+	}
+	default {
+	    incr var(number)
+	    set rep [lindex [lindex $t 0] 0]
+	    set name [lindex [lindex $t 1] 0]
+	    eval $leaf
+	}
+    }
+
+    return [list $nullable $firstpos $lastpos]
+}
+
+# sgml::firstpos --
+#
+#	Computes the firstpos function for a nonterminal node.
+#
+# Arguments:
+#	cs		node type, choice or sequence
+#	firstpos	firstpos functions for the subtree
+#	nullable	nullable functions for the subtree
+#
+# Results:
+#	firstpos function for this node is returned.
+
+proc sgml::firstpos {cs firstpos nullable} {
+    switch -- $cs {
+	:seq {
+	    set result [lindex [lindex $firstpos 0] 1]
+	    for {set i 0} {$i < [llength $nullable]} {incr i} {
+	    	if {[lindex [lindex $nullable $i] 1]} {
+	    	    eval lappend result [lindex [lindex $firstpos [expr $i + 1]] 1]
+		} else {
+		    break
+		}
+	    }
+	}
+	:choice {
+	    foreach child $firstpos {
+		eval lappend result $child
+	    }
+	}
+    }
+
+    return [list $firstpos [makeSet $result]]
+}
+
+# sgml::lastpos --
+#
+#	Computes the lastpos function for a nonterminal node.
+#	Same as firstpos, only logic is reversed
+#
+# Arguments:
+#	cs		node type, choice or sequence
+#	lastpos		lastpos functions for the subtree
+#	nullable	nullable functions forthe subtree
+#
+# Results:
+#	lastpos function for this node is returned.
+
+proc sgml::lastpos {cs lastpos nullable} {
+    switch -- $cs {
+	:seq {
+	    set result [lindex [lindex $lastpos end] 1]
+	    for {set i [expr [llength $nullable] - 1]} {$i >= 0} {incr i -1} {
+		if {[lindex [lindex $nullable $i] 1]} {
+		    eval lappend result [lindex [lindex $lastpos $i] 1]
+		} else {
+		    break
+		}
+	    }
+	}
+	:choice {
+	    foreach child $lastpos {
+		eval lappend result $child
+	    }
+	}
+    }
+
+    return [list $lastpos [makeSet $result]]
+}
+
+# sgml::makeSet --
+#
+#	Turn a list into a set, ie. remove duplicates.
+#
+# Arguments:
+#	s	a list
+#
+# Results:
+#	A set is returned, which is a list with duplicates removed.
+
+proc sgml::makeSet s {
+    foreach r $s {
+	if {[llength $r]} {
+	    set unique($r) {}
+	}
+    }
+    return [array names unique]
+}
+
+# sgml::nullable --
+#
+#	Compute the nullable function for a node.
+#
+# Arguments:
+#	nodeType	leaf or nonterminal
+#	rep		repetition applying to this node
+#	name		leaf node: symbol for this node, nonterm node: choice or seq node
+#	subtree		nonterm node: nullable functions for the subtree
+#
+# Results:
+#	Returns nullable function for this branch of the tree.
+
+proc sgml::nullable {nodeType rep name {subtree {}}} {
+    switch -glob -- $rep:$nodeType {
+	:leaf -
+	+:leaf {
+	    return [list {} 0]
+	}
+	\\*:leaf -
+	\\?:leaf {
+	    return [list {} 1]
+	}
+	\\*:nonterm -
+	\\?:nonterm {
+	    return [list $subtree 1]
+	}
+	:nonterm -
+	+:nonterm {
+	    switch -- $name {
+		:choice {
+		    set result 0
+		    foreach child $subtree {
+			set result [expr $result || [lindex $child 1]]
+		    }
+		}
+		:seq {
+		    set result 1
+		    foreach child $subtree {
+			set result [expr $result && [lindex $child 1]]
+		    }
+		}
+	    }
+	    return [list $subtree $result]
+	}
+    }
+}
+
+# sgml::DTD:ATTLIST --
+#
+#	<!ATTLIST ...> defines an attribute list.
+#
+# Arguments:
+#	opts	configuration opions
+#	name	Element GI
+#	attspec	unparsed attribute definitions
+#
+# Results:
+#	Attribute list variables are modified.
+
+proc sgml::DTD:ATTLIST {opts name attspec} {
+    variable attlist_exp
+    variable attlist_enum_exp
+    variable attlist_fixed_exp
+
+    array set options $opts
+
+    # Parse the attribute list.  If it were regular, could just use foreach,
+    # but some attributes may have values.
+    regsub -all {([][$\\])} $attspec {\\\1} attspec
+    regsub -all $attlist_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {} \{" attspec
+    regsub -all $attlist_enum_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {} {\\4} \{" attspec
+    regsub -all $attlist_fixed_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {\\4} \{" attspec
+
+    eval "noop \{$attspec\}"
+
+    return {}
+}
+
+# sgml::DTDAttribute --
+#
+#	Parse definition of a single attribute.
+#
+# Arguments:
+#	callback	attribute defn callback
+#	name	element name
+#	var	array variable
+#	att	attribute name
+#	type	type of this attribute
+#	default	default value of the attribute
+#	value	other information
+#	text	other text (should be empty)
+#
+# Results:
+#	Attribute defn added to array, unless it already exists
+
+proc sgml::DTDAttribute args {
+    # BUG: Some problems with parameter passing - deal with it later
+    foreach {callback name var att type default value text} $args break
+
+    upvar #0 $var atts
+
+    if {[string length [string trim $text]]} {
+	return -code error "unexpected text \"$text\" in attribute definition"
+    }
+
+    # What about overridden attribute defns?
+    # A non-validating app may want to know about them
+    # (eg. an editor)
+    if {![info exists atts($name/$att)]} {
+	set atts($name/$att) [list $type $default $value]
+	uplevel #0 $callback [list $name $att $type $default $value]
+    }
+
+    return {}
+}
+
+# sgml::DTD:ENTITY --
+#
+#	<!ENTITY ...> declaration.
+#
+#	Callbacks:
+#	-entitydeclcommand for general entity declaration
+#	-unparsedentitydeclcommand for unparsed external entity declaration
+#	-parameterentitydeclcommand for parameter entity declaration
+#
+# Arguments:
+#	opts	configuration options
+#	name	name of entity being defined
+#	param	whether a parameter entity is being defined
+#	value	unparsed replacement text
+#
+# Results:
+#	Modifies the caller's entities array variable
+
+proc sgml::DTD:ENTITY {opts name param value} {
+
+    array set options $opts
+
+    if {[string compare % $param]} {
+	# Entity declaration - general or external
+	upvar #0 $options(entities) ents
+	upvar #0 $options(extentities) externals
+
+	if {[info exists ents($name)] || [info exists externals($name)]} {
+	    eval $options(-warningcommand) entity [list "entity \"$name\" already declared"]
+	} else {
+	    if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} {
+		return -code error "unable to parse entity declaration due to \"$value\""
+	    }
+	    switch -glob [lindex $value 0],[lindex $value 3] {
+		internal, {
+		    set ents($name) [EntitySubst [array get options] [lindex $value 1]]
+		    uplevel #0 $options(-entitydeclcommand) [list $name $ents($name)]
+		}
+		internal,* {
+		    return -code error "unexpected NDATA declaration"
+		}
+		external, {
+		    set externals($name) [lrange $value 1 2]
+		    uplevel #0 $options(-entitydeclcommand) [eval list $name [lrange $value 1 2]]
+		}
+		external,* {
+		    set externals($name) [lrange $value 1 3]
+		    uplevel #0 $options(-unparsedentitydeclcommand) [eval list $name [lrange $value 1 3]]
+		}
+		default {
+		    return -code error "internal error: unexpected parser state"
+		}
+	    }
+	}
+    } else {
+	# Parameter entity declaration
+	upvar #0 $options(parameterentities) PEnts
+	upvar #0 $options(externalparameterentities) ExtPEnts
+
+	if {[info exists PEnts($name)] || [info exists ExtPEnts($name)]} {
+	    eval $options(-warningcommand) parameterentity [list "parameter entity \"$name\" already declared"]
+	} else {
+	    if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} {
+		return -code error "unable to parse parameter entity declaration due to \"$value\""
+	    }
+	    if {[string length [lindex $value 3]]} {
+		return -code error "NDATA illegal in parameter entity declaration"
+	    }
+	    switch [lindex $value 0] {
+		internal {
+		    # Substitute character references and PEs (XML: 4.5)
+		    set value [EntitySubst [array get options] [lindex $value 1]]
+
+		    set PEnts($name) $value
+		    uplevel #0 $options(-parameterentitydeclcommand) [list $name $value]
+		}
+		external -
+		default {
+		    # Get the replacement text now.
+		    # Could wait until the first reference, but easier
+		    # to just do it now.
+
+		    set token [uri::geturl [uri::resolve $options(-baseuri) [lindex $value 1]]]
+
+		    set ExtPEnts($name) [lindex [array get $token data] 1]
+		    uplevel #0 $options(-parameterentitydeclcommand) [eval list $name [lrange $value 1 2]]
+		}
+	    }
+	}
+    }
+}
+
+# sgml::EntitySubst --
+#
+#	Perform entity substitution on an entity replacement text.
+#	This differs slightly from other substitution procedures,
+#	because only parameter and character entity substitution
+#	is performed, not general entities.
+#	See XML Rec. section 4.5.
+#
+# Arguments:
+#	opts	configuration options
+#	value	Literal entity value
+#
+# Results:
+#	Expanded replacement text
+
+proc sgml::EntitySubst {opts value} {
+    array set options $opts
+
+    # Protect Tcl special characters
+    regsub -all {([{}\\])} $value {\\\1} value
+
+    # Find entity references
+    regsub -all (&#\[0-9\]+|&#x\[0-9a-fA-F\]+|%${::sgml::Name})\; $value "\[EntitySubstValue [list $options(parameterentities)] {\\1}\]" value
+
+    set result [subst $value]
+
+    return $result
+}
+
+# sgml::EntitySubstValue --
+#
+#	Handle a single character or parameter entity substitution
+#
+# Arguments:
+#	PEvar	array variable containing PE declarations
+#	ref	character or parameter entity reference
+#
+# Results:
+#	Replacement text
+
+proc sgml::EntitySubstValue {PEvar ref} {
+    switch -glob -- $ref {
+	&#x* {
+	    scan [string range $ref 3 end] %x hex
+	    return [format %c $hex]
+	}
+	&#* {
+	    return [format %c [string range $ref 2 end]]
+	}
+	%* {
+	    upvar #0 $PEvar PEs
+	    set ref [string range $ref 1 end]
+	    if {[info exists PEs($ref)]} {
+		return $PEs($ref)
+	    } else {
+		return -code error "parameter entity \"$ref\" not declared"
+	    }
+	}
+	default {
+	    return -code error "internal error - unexpected entity reference"
+	}
+    }
+    return {}
+}
+
+# sgml::DTD:NOTATION --
+#
+#	Process notation declaration
+#
+# Arguments:
+#	opts	configuration options
+#	name	notation name
+#	value	unparsed notation spec
+
+proc sgml::DTD:NOTATION {opts name value} {
+    return {}
+
+    variable notation_exp
+    upvar opts state
+
+    if {[regexp $notation_exp $value x scheme data] == 2} {
+    } else {
+	eval $state(-errorcommand) [list notationvalue "notation value \"$value\" incorrectly specified"]
+    }
+}
+
+# sgml::ResolveEntity --
+#
+#	Default entity resolution routine
+#
+# Arguments:
+#	cmd	command of parent parser
+#	base	base URL for relative URLs
+#	sysId	system identifier
+#	pubId	public identifier
+
+proc sgml::ResolveEntity {cmd base sysId pubId} {
+    variable ParseEventNum
+
+    if {[catch {uri::resolve $base $sysId} url]} {
+	return -code error "unable to resolve system identifier \"$sysId\""
+    }
+    if {[catch {uri::geturl $url} token]} {
+	return -code error "unable to retrieve external entity \"$url\" for system identifier \"$sysId\""
+    }
+
+    upvar #0 $token data
+
+    set parser [uplevel #0 $cmd entityparser]
+
+    set body {}
+    catch {set body $data(body)}
+    catch {set body $data(data)}
+    if {[string length $body]} {
+	uplevel #0 $parser parse [list $body] -dtdsubset external
+    }
+    $parser free
+
+    return {}
+}
diff --git a/lib/tclxml3.1/tclparser-8.1.tcl b/lib/tclxml3.1/tclparser-8.1.tcl
new file mode 100644
index 0000000..727727c
--- /dev/null
+++ b/lib/tclxml3.1/tclparser-8.1.tcl
@@ -0,0 +1,612 @@
+# tclparser-8.1.tcl --
+#
+#	This file provides a Tcl implementation of a XML parser.
+#	This file supports Tcl 8.1.
+#
+#	See xml-8.[01].tcl for definitions of character sets and
+#	regular expressions.
+#
+# Copyright (c) 1998-2003 Zveno Pty Ltd
+# http://www.zveno.com/
+# 
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: tclparser-8.1.tcl,v 1.26 2004/08/14 07:41:11 balls Exp $
+
+package require Tcl 8.1
+
+package provide xml::tclparser 3.1
+
+package require xmldefs 3.1
+
+package require sgmlparser 1.0
+
+namespace eval xml::tclparser {
+
+    namespace export create createexternal externalentity parse configure get delete
+
+    # Tokenising expressions
+
+    variable tokExpr $::xml::tokExpr
+    variable substExpr $::xml::substExpr
+
+    # Register this parser class
+
+    ::xml::parserclass create tcl \
+	    -createcommand [namespace code create] \
+	    -createentityparsercommand [namespace code createentityparser] \
+	    -parsecommand [namespace code parse] \
+	    -configurecommand [namespace code configure] \
+	    -deletecommand [namespace code delete] \
+	    -resetcommand [namespace code reset]
+}
+
+# xml::tclparser::create --
+#
+#	Creates XML parser object.
+#
+# Arguments:
+#	name	unique identifier for this instance
+#
+# Results:
+#	The state variable is initialised.
+
+proc xml::tclparser::create name {
+
+    # Initialise state variable
+    upvar \#0 [namespace current]::$name parser
+    array set parser [list -name $name			\
+	-cmd [uplevel 3 namespace current]::$name	\
+	-final 1					\
+	-validate 0					\
+	-statevariable [namespace current]::$name	\
+	-baseuri {}					\
+	internaldtd {}					\
+	entities [namespace current]::Entities$name	\
+	extentities [namespace current]::ExtEntities$name	\
+	parameterentities [namespace current]::PEntities$name	\
+	externalparameterentities [namespace current]::ExtPEntities$name	\
+	elementdecls [namespace current]::ElDecls$name	\
+	attlistdecls [namespace current]::AttlistDecls$name	\
+	notationdecls [namespace current]::NotDecls$name	\
+	depth 0						\
+	leftover {}                                     \
+    ]
+
+    # Initialise entities with predefined set
+    array set [namespace current]::Entities$name [array get ::sgml::EntityPredef]
+
+    return $parser(-cmd)
+}
+
+# xml::tclparser::createentityparser --
+#
+#	Creates XML parser object for an entity.
+#
+# Arguments:
+#	name	name for the new parser
+#	parent	name of parent parser
+#
+# Results:
+#	The state variable is initialised.
+
+proc xml::tclparser::createentityparser {parent name} {
+    upvar #0 [namespace current]::$parent p
+
+    # Initialise state variable
+    upvar \#0 [namespace current]::$name external
+    array set external [array get p]
+
+    regsub $parent $p(-cmd) {} parentns
+
+    array set external [list -name $name		\
+	-cmd $parentns$name				\
+	-statevariable [namespace current]::$name	\
+	internaldtd {}					\
+	line 0						\
+    ]
+    incr external(depth)
+
+    return $external(-cmd)
+}
+
+# xml::tclparser::configure --
+#
+#	Configures a XML parser object.
+#
+# Arguments:
+#	name	unique identifier for this instance
+#	args	option name/value pairs
+#
+# Results:
+#	May change values of config options
+
+proc xml::tclparser::configure {name args} {
+    upvar \#0 [namespace current]::$name parser
+
+    # BUG: very crude, no checks for illegal args
+    # Mats: Should be synced with sgmlparser.tcl
+    set options {-elementstartcommand -elementendcommand \
+      -characterdatacommand -processinginstructioncommand \
+      -externalentitycommand -xmldeclcommand \
+      -doctypecommand -commentcommand \
+      -entitydeclcommand -unparsedentitydeclcommand \
+      -parameterentitydeclcommand -notationdeclcommand \
+      -elementdeclcommand -attlistdeclcommand \
+      -paramentityparsing -defaultexpandinternalentities \
+      -startdoctypedeclcommand -enddoctypedeclcommand \
+      -entityreferencecommand -warningcommand \
+      -defaultcommand -unknownencodingcommand -notstandalonecommand \
+      -startcdatasectioncommand -endcdatasectioncommand \
+      -errorcommand -final \
+      -validate -baseuri -baseurl \
+      -name -cmd -emptyelement \
+      -parseattributelistcommand -parseentitydeclcommand \
+      -normalize -internaldtd -dtdsubset \
+      -reportempty -ignorewhitespace \
+      -reportempty \
+    }
+    set usage [join $options ", "]
+    regsub -all -- - $options {} options
+    set pat ^-([join $options |])$
+    foreach {flag value} $args {
+	if {[regexp $pat $flag]} {
+	    # Validate numbers
+	    if {[info exists parser($flag)] && \
+		    [string is integer -strict $parser($flag)] && \
+		    ![string is integer -strict $value]} {
+		return -code error "Bad value for $flag ($value), must be integer"
+	    }
+	    set parser($flag) $value
+	} else {
+	    return -code error "Unknown option $flag, can be: $usage"
+	}
+    }
+
+    # Backward-compatibility: -baseuri is a synonym for -baseurl
+    catch {set parser(-baseuri) $parser(-baseurl)}
+
+    return {}
+}
+
+# xml::tclparser::parse --
+#
+#	Parses document instance data
+#
+# Arguments:
+#	name	parser object
+#	xml	data
+#	args	configuration options
+#
+# Results:
+#	Callbacks are invoked
+
+proc xml::tclparser::parse {name xml args} {
+
+    array set options $args
+    upvar \#0 [namespace current]::$name parser
+    variable tokExpr
+    variable substExpr
+
+    # Mats:
+    if {[llength $args]} {
+	eval {configure $name} $args
+    }
+
+    set parseOptions [list \
+	    -emptyelement [namespace code ParseEmpty] \
+	    -parseattributelistcommand [namespace code ParseAttrs] \
+	    -parseentitydeclcommand [namespace code ParseEntity] \
+	    -normalize 0]
+    eval lappend parseOptions \
+	    [array get parser -*command] \
+	    [array get parser -reportempty] \
+	    [array get parser -ignorewhitespace] \
+	    [array get parser -name] \
+	    [array get parser -cmd] \
+	    [array get parser -baseuri] \
+	    [array get parser -validate] \
+	    [array get parser -final] \
+	    [array get parser -defaultexpandinternalentities] \
+	    [array get parser entities] \
+	    [array get parser extentities] \
+	    [array get parser parameterentities] \
+	    [array get parser externalparameterentities] \
+	    [array get parser elementdecls] \
+	    [array get parser attlistdecls] \
+	    [array get parser notationdecls]
+
+    # Mats:
+    # If -final 0 we also need to maintain the state with a -statevariable !
+    if {!$parser(-final)} {
+	eval lappend parseOptions [array get parser -statevariable]
+    }
+
+    set dtdsubset no
+    catch {set dtdsubset $options(-dtdsubset)}
+    switch -- $dtdsubset {
+	internal {
+	    # Bypass normal parsing
+	    lappend parseOptions -statevariable $parser(-statevariable)
+	    array set intOptions [array get ::sgml::StdOptions]
+	    array set intOptions $parseOptions
+	    ::sgml::ParseDTD:Internal [array get intOptions] $xml
+	    return {}
+	}
+	external {
+	    # Bypass normal parsing
+	    lappend parseOptions -statevariable $parser(-statevariable)
+	    array set intOptions [array get ::sgml::StdOptions]
+	    array set intOptions $parseOptions
+	    ::sgml::ParseDTD:External [array get intOptions] $xml
+	    return {}
+	}
+	default {
+	    # Pass through to normal processing
+	}
+    }
+
+    lappend tokenOptions  \
+      -internaldtdvariable [namespace current]::${name}(internaldtd)
+    
+    # Mats: If -final 0 we also need to maintain the state with a -statevariable !
+    if {!$parser(-final)} {
+	eval lappend tokenOptions [array get parser -statevariable] \
+	  [array get parser -final]
+    }
+    
+    # Mats:
+    # Why not the first four? Just padding? Lrange undos \n interp.
+    # It is necessary to have the first four as well if chopped off in
+    # middle of pcdata.
+    set tokenised [lrange \
+	    [eval {::sgml::tokenise $xml $tokExpr $substExpr} $tokenOptions] \
+	0 end]
+
+    lappend parseOptions -internaldtd [list $parser(internaldtd)]
+    eval ::sgml::parseEvent [list $tokenised] $parseOptions
+
+    return {}
+}
+
+# xml::tclparser::ParseEmpty --  Tcl 8.1+ version
+#
+#	Used by parser to determine whether an element is empty.
+#	This is usually dead easy in XML, but as always not quite.
+#	Have to watch out for empty element syntax
+#
+# Arguments:
+#	tag	element name
+#	attr	attribute list (raw)
+#	e	End tag delimiter.
+#
+# Results:
+#	Return value of e
+
+proc xml::tclparser::ParseEmpty {tag attr e} {
+    switch -glob [string length $e],[regexp "/[::xml::cl $::xml::Wsp]*$" $attr] {
+	0,0 {
+	    return {}
+	}
+	0,* {
+	    return /
+	}
+	default {
+	    return $e
+	}
+    }
+}
+
+# xml::tclparser::ParseAttrs -- Tcl 8.1+ version
+#
+#	Parse element attributes.
+#
+# There are two forms for name-value pairs:
+#
+#	name="value"
+#	name='value'
+#
+# Arguments:
+#	opts	parser options
+#	attrs	attribute string given in a tag
+#
+# Results:
+#	Returns a Tcl list representing the name-value pairs in the 
+#	attribute string
+#
+#	A ">" occurring in the attribute list causes problems when parsing
+#	the XML.  This manifests itself by an unterminated attribute value
+#	and a ">" appearing the element text.
+#	In this case return a three element list;
+#	the message "unterminated attribute value", the attribute list it
+#	did manage to parse and the remainder of the attribute list.
+
+proc xml::tclparser::ParseAttrs {opts attrs} {
+
+    set result {}
+
+    while {[string length [string trim $attrs]]} {
+	if {[regexp [::sgml::cl $::xml::Wsp]*($::xml::Name)[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')([::sgml::cl ^<]*?)\\2(.*) $attrs discard attrName delimiter value attrs]} {
+	    lappend result $attrName [NormalizeAttValue $opts $value]
+	} elseif {[regexp [::sgml::cl $::xml::Wsp]*$::xml::Name[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')[::sgml::cl ^<]*\$ $attrs]} {
+	    return -code error [list {unterminated attribute value} $result $attrs]
+	} else {
+	    return -code error "invalid attribute list"
+	}
+    }
+
+    return $result
+}
+
+# xml::tclparser::NormalizeAttValue --
+#
+#	Perform attribute value normalisation.  This involves:
+#	. character references are appended to the value
+#	. entity references are recursively processed and replacement value appended
+#	. whitespace characters cause a space to be appended
+#	. other characters appended as-is
+#
+# Arguments:
+#	opts	parser options
+#	value	unparsed attribute value
+#
+# Results:
+#	Normalised value returned.
+
+proc xml::tclparser::NormalizeAttValue {opts value} {
+
+    # sgmlparser already has backslashes protected
+    # Protect Tcl specials
+    regsub -all {([][$])} $value {\\\1} value
+
+    # Deal with white space
+    regsub -all "\[$::xml::Wsp\]" $value { } value
+
+    # Find entity refs
+    regsub -all {&([^;]+);} $value {[NormalizeAttValue:DeRef $opts {\1}]} value
+
+    return [subst $value]
+}
+
+# xml::tclparser::NormalizeAttValue:DeRef --
+#
+#	Handler to normalize attribute values
+#
+# Arguments:
+#	opts	parser options
+#	ref	entity reference
+#
+# Results:
+#	Returns character
+
+proc xml::tclparser::NormalizeAttValue:DeRef {opts ref} {
+
+    switch -glob -- $ref {
+	#x* {
+	    scan [string range $ref 2 end] %x value
+	    set char [format %c $value]
+	    # Check that the char is legal for XML
+	    if {[regexp [format {^[%s]$} $::xml::Char] $char]} {
+		return $char
+	    } else {
+		return -code error "illegal character"
+	    }
+	}
+	#* {
+	    scan [string range $ref 1 end] %d value
+	    set char [format %c $value]
+	    # Check that the char is legal for XML
+	    if {[regexp [format {^[%s]$} $::xml::Char] $char]} {
+		return $char
+	    } else {
+		return -code error "illegal character"
+	    }
+	}
+	lt -
+	gt -
+	amp -
+	quot -
+	apos {
+	    array set map {lt < gt > amp & quot \" apos '}
+	    return $map($ref)
+	}
+	default {
+	    # A general entity.  Must resolve to a text value - no element structure.
+
+	    array set options $opts
+	    upvar #0 $options(entities) map
+
+	    if {[info exists map($ref)]} {
+
+		if {[regexp < $map($ref)]} {
+		    return -code error "illegal character \"<\" in attribute value"
+		}
+
+		if {![regexp & $map($ref)]} {
+		    # Simple text replacement
+		    return $map($ref)
+		}
+
+		# There are entity references in the replacement text.
+		# Can't use child entity parser since must catch element structures
+
+		return [NormalizeAttValue $opts $map($ref)]
+
+	    } elseif {[string compare $options(-entityreferencecommand) "::sgml::noop"]} {
+
+		set result [uplevel #0 $options(-entityreferencecommand) [list $ref]]
+
+		return $result
+
+	    } else {
+		return -code error "unable to resolve entity reference \"$ref\""
+	    }
+	}
+    }
+}
+
+# xml::tclparser::ParseEntity --
+#
+#	Parse general entity declaration
+#
+# Arguments:
+#	data	text to parse
+#
+# Results:
+#	Tcl list containing entity declaration
+
+proc xml::tclparser::ParseEntity data {
+    set data [string trim $data]
+    if {[regexp $::sgml::ExternalEntityExpr $data discard type delimiter1 id1 discard delimiter2 id2 optNDATA ndata]} {
+	switch $type {
+	    PUBLIC {
+		return [list external $id2 $id1 $ndata]
+	    }
+	    SYSTEM {
+		return [list external $id1 {} $ndata]
+	    }
+	}
+    } elseif {[regexp {^("|')(.*?)\1$} $data discard delimiter value]} {
+	return [list internal $value]
+    } else {
+	return -code error "badly formed entity declaration"
+    }
+}
+
+# xml::tclparser::delete --
+#
+#	Destroy parser data
+#
+# Arguments:
+#	name	parser object
+#
+# Results:
+#	Parser data structure destroyed
+
+proc xml::tclparser::delete name {
+    upvar \#0 [namespace current]::$name parser
+    catch {::sgml::ParserDelete $parser(-statevariable)}
+    catch {unset parser}
+    return {}
+}
+
+# xml::tclparser::get --
+#
+#	Retrieve additional information from the parser
+#
+# Arguments:
+#	name	parser object
+#	method	info to retrieve
+#	args	additional arguments for method
+#
+# Results:
+#	Depends on method
+
+proc xml::tclparser::get {name method args} {
+    upvar #0 [namespace current]::$name parser
+
+    switch -- $method {
+
+	elementdecl {
+	    switch [llength $args] {
+
+		0 {
+		    # Return all element declarations
+		    upvar #0 $parser(elementdecls) elements
+		    return [array get elements]
+		}
+
+		1 {
+		    # Return specific element declaration
+		    upvar #0 $parser(elementdecls) elements
+		    if {[info exists elements([lindex $args 0])]} {
+			return [array get elements [lindex $args 0]]
+		    } else {
+			return -code error "element \"[lindex $args 0]\" not declared"
+		    }
+		}
+
+		default {
+		    return -code error "wrong number of arguments: should be \"elementdecl ?element?\""
+		}
+	    }
+	}
+
+	attlist {
+	    if {[llength $args] != 1} {
+		return -code error "wrong number of arguments: should be \"get attlist element\""
+	    }
+
+	    upvar #0 $parser(attlistdecls)
+
+	    return {}
+	}
+
+	entitydecl {
+	}
+
+	parameterentitydecl {
+	}
+
+	notationdecl {
+	}
+
+	default {
+	    return -code error "unknown method \"$method\""
+	}
+    }
+
+    return {}
+}
+
+# xml::tclparser::ExternalEntity --
+#
+#	Resolve and parse external entity
+#
+# Arguments:
+#	name	parser object
+#	base	base URL
+#	sys	system identifier
+#	pub	public identifier
+#
+# Results:
+#	External entity is fetched and parsed
+
+proc xml::tclparser::ExternalEntity {name base sys pub} {
+}
+
+# xml::tclparser:: --
+#
+#	Reset a parser instance, ready to parse another document
+#
+# Arguments:
+#	name	parser object
+#
+# Results:
+#	Variables unset
+
+proc xml::tclparser::reset {name} {
+    upvar \#0 [namespace current]::$name parser
+
+    # Has this parser object been properly initialised?
+    if {![info exists parser] || \
+	    ![info exists parser(-name)]} {
+	return [create $name]
+    }
+
+    array set parser {
+	-final 1
+	depth 0
+	leftover {}
+    }
+
+    foreach var {Entities ExtEntities PEntities ExtPEntities ElDecls AttlistDecls NotDecls} {
+	catch {unset [namespace current]::${var}$name}
+    }
+
+    # Initialise entities with predefined set
+    array set [namespace current]::Entities$name [array get ::sgml::EntityPredef]
+
+    return {}
+}
diff --git a/lib/tclxml3.1/xml-8.1.tcl b/lib/tclxml3.1/xml-8.1.tcl
new file mode 100644
index 0000000..501c12a
--- /dev/null
+++ b/lib/tclxml3.1/xml-8.1.tcl
@@ -0,0 +1,133 @@
+# xml.tcl --
+#
+#	This file provides generic XML services for all implementations.
+#	This file supports Tcl 8.1 regular expressions.
+#
+#	See tclparser.tcl for the Tcl implementation of a XML parser.
+#
+# Copyright (c) 1998-2004 Zveno Pty Ltd
+# http://www.zveno.com/
+# 
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: xml-8.1.tcl,v 1.16 2004/08/14 07:41:11 balls Exp $
+
+package require Tcl 8.1
+
+package provide xmldefs 3.1
+
+package require sgml 1.8
+
+namespace eval xml {
+
+    namespace export qnamesplit
+
+    # Convenience routine
+    proc cl x {
+	return "\[$x\]"
+    }
+
+    # Define various regular expressions
+
+    # Characters
+    variable Char $::sgml::Char
+
+    # white space
+    variable Wsp " \t\r\n"
+    variable allWsp [cl $Wsp]*
+    variable noWsp [cl ^$Wsp]
+
+    # Various XML names and tokens
+
+    variable NameChar $::sgml::NameChar
+    variable Name $::sgml::Name
+    variable Names $::sgml::Names
+    variable Nmtoken $::sgml::Nmtoken
+    variable Nmtokens $::sgml::Nmtokens
+
+    # XML Namespaces names
+
+    # NCName ::= Name - ':'
+    variable NCName $::sgml::Name
+    regsub -all : $NCName {} NCName
+    variable QName (${NCName}:)?$NCName		;# (Prefix ':')? LocalPart
+
+    # The definition of the Namespace URI for XML Namespaces themselves.
+    # The prefix 'xml' is automatically bound to this URI.
+    variable xmlnsNS http://www.w3.org/XML/1998/namespace
+
+    # table of predefined entities
+
+    variable EntityPredef
+    array set EntityPredef {
+	lt <   gt >   amp &   quot \"   apos '
+    }
+
+    # Expressions for pulling things apart
+    variable tokExpr <(/?)([::xml::cl ^$::xml::Wsp>/]+)([::xml::cl $::xml::Wsp]*[::xml::cl ^>]*)>
+    variable substExpr "\}\n{\\2} {\\1} {\\3} \{"
+
+}
+
+###
+###	Exported procedures
+###
+
+# xml::qnamesplit --
+#
+#	Split a QName into its constituent parts:
+#	the XML Namespace prefix and the Local-name
+#
+# Arguments:
+#	qname	XML Qualified Name (see XML Namespaces [6])
+#
+# Results:
+#	Returns prefix and local-name as a Tcl list.
+#	Error condition returned if the prefix or local-name
+#	are not valid NCNames (XML Name)
+
+proc xml::qnamesplit qname {
+    variable NCName
+    variable Name
+
+    set prefix {}
+    set localname $qname
+    if {[regexp : $qname]} {
+	if {![regexp ^($NCName)?:($NCName)\$ $qname discard prefix localname]} {
+	    return -code error "name \"$qname\" is not a valid QName"
+	}
+    } elseif {![regexp ^$Name\$ $qname]} {
+	return -code error "name \"$qname\" is not a valid Name"
+    }
+
+    return [list $prefix $localname]
+}
+
+###
+###	General utility procedures
+###
+
+# xml::noop --
+#
+# A do-nothing proc
+
+proc xml::noop args {}
+
+### Following procedures are based on html_library
+
+# xml::zapWhite --
+#
+#	Convert multiple white space into a single space.
+#
+# Arguments:
+#	data	plain text
+#
+# Results:
+#	As above
+
+proc xml::zapWhite data {
+    regsub -all "\[ \t\r\n\]+" $data { } data
+    return $data
+}
+
diff --git a/lib/tclxml3.1/xml__tcl.tcl b/lib/tclxml3.1/xml__tcl.tcl
new file mode 100644
index 0000000..ef9948b
--- /dev/null
+++ b/lib/tclxml3.1/xml__tcl.tcl
@@ -0,0 +1,270 @@
+# xml__tcl.tcl --
+#
+#	This file provides a Tcl implementation of the parser
+#	class support found in ../tclxml.c.  It is only used
+#	when the C implementation is not installed (for some reason).
+#
+# Copyright (c) 2000-2004 Zveno Pty Ltd
+# http://www.zveno.com/
+# 
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: xml__tcl.tcl,v 1.15 2004/08/14 07:41:11 balls Exp $
+
+package provide xml::tcl 3.1
+
+namespace eval xml {
+    namespace export configure parser parserclass
+
+    # Parser implementation classes
+    variable classes
+    array set classes {}
+
+    # Default parser class
+    variable default {}
+
+    # Counter for generating unique names
+    variable counter 0
+}
+
+# xml::configure --
+#
+#	Configure the xml package
+#
+# Arguments:
+#	None
+#
+# Results:
+#	None (not yet implemented)
+
+proc xml::configure args {}
+
+# xml::parserclass --
+#
+#	Implements the xml::parserclass command for managing
+#	parser implementations.
+#
+# Arguments:
+#	method	subcommand
+#	args	method arguments
+#
+# Results:
+#	Depends on method
+
+proc xml::parserclass {method args} {
+    variable classes
+    variable default
+
+    switch -- $method {
+
+	create {
+	    if {[llength $args] < 1} {
+		return -code error "wrong number of arguments, should be xml::parserclass create name ?args?"
+	    }
+
+	    set name [lindex $args 0]
+	    if {[llength [lrange $args 1 end]] % 2} {
+		return -code error "missing value for option \"[lindex $args end]\""
+	    }
+	    array set classes [list $name [list \
+		    -createcommand [namespace current]::noop \
+		    -createentityparsercommand [namespace current]::noop \
+		    -parsecommand [namespace current]::noop \
+		    -configurecommand [namespace current]::noop \
+		    -getcommand [namespace current]::noop \
+		    -deletecommand [namespace current]::noop \
+	    ]]
+	    # BUG: we're not checking that the arguments are kosher
+	    set classes($name) [lrange $args 1 end]
+	    set default $name
+	}
+
+	destroy {
+	    if {[llength $args] < 1} {
+		return -code error "wrong number of arguments, should be xml::parserclass destroy name"
+	    }
+
+	    if {[info exists classes([lindex $args 0])]} {
+		unset classes([lindex $args 0])
+	    } else {
+		return -code error "no such parser class \"[lindex $args 0]\""
+	    }
+	}
+
+	info {
+	    if {[llength $args] < 1} {
+		return -code error "wrong number of arguments, should be xml::parserclass info method"
+	    }
+
+	    switch -- [lindex $args 0] {
+		names {
+		    return [array names classes]
+		}
+		default {
+		    return $default 
+		}
+	    }
+	}
+
+	default {
+	    return -code error "unknown method \"$method\""
+	}
+    }
+
+    return {}
+}
+
+# xml::parser --
+#
+#	Create a parser object instance
+#
+# Arguments:
+#	args	optional name, configuration options
+#
+# Results:
+#	Returns object name.  Parser instance created.
+
+proc xml::parser args {
+    variable classes
+    variable default
+
+    if {[llength $args] < 1} {
+	# Create unique name, no options
+	set parserName [FindUniqueName]
+    } else {
+	if {[string index [lindex $args 0] 0] == "-"} {
+	    # Create unique name, have options
+	    set parserName [FindUniqueName]
+	} else {
+	    # Given name, optional options
+	    set parserName [lindex $args 0]
+	    set args [lrange $args 1 end]
+	}
+    }
+
+    array set options [list \
+	-parser $default
+    ]
+    array set options $args
+
+    if {![info exists classes($options(-parser))]} {
+	return -code error "no such parser class \"$options(-parser)\""
+    }
+
+    # Now create the parser instance command and data structure
+    # The command must be created in the caller's namespace
+    uplevel 1 [list proc $parserName {method args} "eval [namespace current]::ParserCmd [list $parserName] \[list \$method\] \$args"]
+    upvar #0 [namespace current]::$parserName data
+    array set data [list class $options(-parser)]
+
+    array set classinfo $classes($options(-parser))
+    if {[string compare $classinfo(-createcommand) ""]} {
+	eval $classinfo(-createcommand) [list $parserName]
+    }
+    if {[string compare $classinfo(-configurecommand) ""] && \
+	    [llength $args]} {
+	eval $classinfo(-configurecommand) [list $parserName] $args
+    }
+
+    return $parserName
+}
+
+# xml::FindUniqueName --
+#
+#	Generate unique object name
+#
+# Arguments:
+#	None
+#
+# Results:
+#	Returns string.
+
+proc xml::FindUniqueName {} {
+    variable counter
+    return xmlparser[incr counter]
+}
+
+# xml::ParserCmd --
+#
+#	Implements parser object command
+#
+# Arguments:
+#	name	object reference
+#	method	subcommand
+#	args	method arguments
+#
+# Results:
+#	Depends on method
+
+proc xml::ParserCmd {name method args} {
+    variable classes
+    upvar #0 [namespace current]::$name data
+
+    array set classinfo $classes($data(class))
+
+    switch -- $method {
+
+	configure {
+	    # BUG: We're not checking for legal options
+	    array set data $args
+	    eval $classinfo(-configurecommand) [list $name] $args
+	    return {}
+	}
+
+	cget {
+	    return $data([lindex $args 0])
+	}
+
+	entityparser {
+	    set new [FindUniqueName]
+
+	    upvar #0 [namespace current]::$name parent
+	    upvar #0 [namespace current]::$new data
+	    array set data [array get parent]
+
+	    uplevel 1 [list proc $new {method args} "eval [namespace current]::ParserCmd [list $new] \[list \$method\] \$args"]
+
+	    return [eval $classinfo(-createentityparsercommand) [list $name $new] $args]
+	}
+
+	free {
+	    eval $classinfo(-deletecommand) [list $name]
+	    unset data
+	    uplevel 1 [list rename $name {}]
+	}
+
+	get {
+	    eval $classinfo(-getcommand) [list $name] $args
+	}
+
+	parse {
+	    if {[llength $args] < 1} {
+		return -code error "wrong number of arguments, should be $name parse xml ?options?"
+	    }
+	    eval $classinfo(-parsecommand) [list $name] $args
+	}
+
+	reset {
+	    eval $classinfo(-resetcommand) [list $name]
+	}
+
+	default {
+	    return -code error "unknown method"
+	}
+    }
+
+    return {}
+}
+
+# xml::noop --
+#
+#	Do nothing utility proc
+#
+# Arguments:
+#	args	whatever
+#
+# Results:
+#	Nothing happens
+
+proc xml::noop args {}
diff --git a/lib/tclxml3.1/xmldep.tcl b/lib/tclxml3.1/xmldep.tcl
new file mode 100644
index 0000000..7f1c404
--- /dev/null
+++ b/lib/tclxml3.1/xmldep.tcl
@@ -0,0 +1,179 @@
+# xmldep.tcl --
+#
+#	Find the dependencies in an XML document.
+#	Supports external entities and XSL include/import.
+#
+# TODO:
+#	XInclude
+#
+# Copyright (c) 2001-2003 Zveno Pty Ltd
+# http://www.zveno.com/
+#
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: xmldep.tcl,v 1.3 2003/12/09 04:43:15 balls Exp $
+
+package require xml
+
+package provide xml::dep 1.0
+
+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)
+    }
+
+}
+
diff --git a/lib/tclxml3.1/xpath.tcl b/lib/tclxml3.1/xpath.tcl
new file mode 100644
index 0000000..7d248aa
--- /dev/null
+++ b/lib/tclxml3.1/xpath.tcl
@@ -0,0 +1,362 @@
+# xpath.tcl --
+#
+#	Provides an XPath parser for Tcl,
+#	plus various support procedures
+#
+# Copyright (c) 2000-2003 Zveno Pty Ltd
+#
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: xpath.tcl,v 1.8 2003/12/09 04:43:15 balls Exp $
+
+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"
+}
+
diff --git a/lib/tdom/pkgIndex.tcl b/lib/tdom/pkgIndex.tcl
new file mode 100644
index 0000000..5e92b90
--- /dev/null
+++ b/lib/tdom/pkgIndex.tcl
@@ -0,0 +1,6 @@
+# Only relevant on Windows-x86
+if {[string compare $::tcl_platform(platform) "windows"]} { return }
+if {[string compare $::tcl_platform(machine) "intel"]} { return }
+package ifneeded tdom 0.8.3 \
+  "load [list [file join $dir win32-ix86 tdom083.dll]];\
+   source [list [file join $dir tdom.tcl]]"
diff --git a/lib/tdom/tdom.tcl b/lib/tdom/tdom.tcl
new file mode 100644
index 0000000..569a11e
--- /dev/null
+++ b/lib/tdom/tdom.tcl
@@ -0,0 +1,911 @@
+#----------------------------------------------------------------------------
+#   Copyright (c) 1999 Jochen Loewer (loewerj@hotmail.com)
+#----------------------------------------------------------------------------
+#
+#   $Id: tdom.tcl,v 1.19 2005/01/11 15:57:19 rolf Exp $
+#
+#
+#   The higher level functions of tDOM written in plain Tcl.
+#
+#
+#   The contents of this file are subject to the Mozilla Public License
+#   Version 1.1 (the "License"); you may not use this file except in
+#   compliance with the License. You may obtain a copy of the License at
+#   http://www.mozilla.org/MPL/
+#
+#   Software distributed under the License is distributed on an "AS IS"
+#   basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+#   License for the specific language governing rights and limitations
+#   under the License.
+#
+#   The Original Code is tDOM.
+#
+#   The Initial Developer of the Original Code is Jochen Loewer
+#   Portions created by Jochen Loewer are Copyright (C) 1998, 1999
+#   Jochen Loewer. All Rights Reserved.
+#
+#   Contributor(s):
+#       Rolf Ade (rolf@pointsman.de):   'fake' nodelists/live childNodes
+#
+#   written by Jochen Loewer
+#   April, 1999
+#
+#----------------------------------------------------------------------------
+
+package require tdom 
+
+#----------------------------------------------------------------------------
+#   setup namespaces for additional Tcl level methods, etc.
+#
+#----------------------------------------------------------------------------
+namespace eval ::dom {
+    namespace eval  domDoc {
+    }
+    namespace eval  domNode {
+    }
+    namespace eval  DOMImplementation {
+    }
+    namespace eval  xpathFunc {
+    }
+    namespace eval  xpathFuncHelper {
+    }
+}
+
+namespace eval ::tDOM { 
+    variable extRefHandlerDebug 0
+    variable useForeignDTD ""
+
+    namespace export xmlOpenFile xmlReadFile extRefHandler baseURL
+}
+
+#----------------------------------------------------------------------------
+#   hasFeature (DOMImplementation method)
+#
+#
+#   @in  url    the URL, where to get the XML document
+#
+#   @return     document object
+#   @exception  XML parse errors, ...
+#
+#----------------------------------------------------------------------------
+proc ::dom::DOMImplementation::hasFeature { dom feature {version ""} } {
+
+    switch $feature {
+        xml -
+        XML {
+            if {($version == "") || ($version == "1.0")} {
+                return 1
+            }
+        }
+    }
+    return 0
+
+}
+
+#----------------------------------------------------------------------------
+#   load (DOMImplementation method)
+#
+#       requests a XML document via http using the given URL and
+#       builds up a DOM tree in memory returning the document object
+#
+#
+#   @in  url    the URL, where to get the XML document
+#
+#   @return     document object
+#   @exception  XML parse errors, ...
+#
+#----------------------------------------------------------------------------
+proc ::dom::DOMImplementation::load { dom url } {
+
+    error "Sorry, load method not implemented yet!"
+
+}
+
+#----------------------------------------------------------------------------
+#   isa (docDoc method, for [incr tcl] compatibility)
+#
+#
+#   @in  className
+#
+#   @return         1 iff inherits from the given class
+#
+#----------------------------------------------------------------------------
+proc ::dom::domDoc::isa { doc className } {
+
+    if {$className == "domDoc"} {
+        return 1
+    }
+    return 0
+}
+
+#----------------------------------------------------------------------------
+#   info (domDoc method, for [incr tcl] compatibility)
+#
+#
+#   @in  subcommand
+#   @in  args
+#
+#----------------------------------------------------------------------------
+proc ::dom::domDoc::info { doc subcommand args } {
+
+    switch $subcommand {
+        class {
+            return "domDoc"
+        }
+        inherit {
+            return ""
+        }
+        heritage {
+            return "domDoc {}"
+        }
+        default {
+            error "domDoc::info subcommand $subcommand not yet implemented!"
+        }
+    }
+}
+
+#----------------------------------------------------------------------------
+#   importNode (domDoc method)
+#
+#       Document Object Model (Core) Level 2 method
+#
+#
+#   @in  subcommand
+#   @in  args
+#
+#----------------------------------------------------------------------------
+proc ::dom::domDoc::importNode { doc importedNode deep } {
+
+    if {$deep || ($deep == "-deep")} {
+        set node [$importedNode cloneNode -deep]
+    } else {
+        set node [$importedNode cloneNode]
+    }
+    return $node
+}
+
+#----------------------------------------------------------------------------
+#   isa (domNode method, for [incr tcl] compatibility)
+#
+#
+#   @in  className
+#
+#   @return         1 iff inherits from the given class
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::isa { doc className } {
+
+    if {$className == "domNode"} {
+        return 1
+    }
+    return 0
+}
+
+#----------------------------------------------------------------------------
+#   info (domNode method, for [incr tcl] compatibility)
+#
+#
+#   @in  subcommand
+#   @in  args
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::info { doc subcommand args } {
+
+    switch $subcommand {
+        class {
+            return "domNode"
+        }
+        inherit {
+            return ""
+        }
+        heritage {
+            return "domNode {}"
+        }
+        default {
+            error "domNode::info subcommand $subcommand not yet implemented!"
+        }
+    }
+}
+
+#----------------------------------------------------------------------------
+#   isWithin (domNode method)
+#
+#       tests, whether a node object is nested below another tag
+#
+#
+#   @in  tagName  the nodeName of an elment node
+#
+#   @return       1 iff node is nested below a element with nodeName tagName
+#                 0 otherwise
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::isWithin { node tagName } {
+
+    while {[$node parentNode] != ""} {
+        set node [$node parentNode]
+        if {[$node nodeName] == $tagName} {
+            return 1
+        }
+    }
+    return 0
+}
+
+#----------------------------------------------------------------------------
+#   tagName (domNode method)
+#
+#       same a nodeName for element interface
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::tagName { node } {
+
+    if {[$node nodeType] == "ELEMENT_NODE"} {
+        return [$node nodeName]
+    }
+    return -code error "NOT_SUPPORTED_ERR not an element!"
+}
+
+#----------------------------------------------------------------------------
+#   simpleTranslate (domNode method)
+#
+#       applies simple translation rules similar to Cost's simple
+#       translations to a node
+#
+#
+#   @in  output_var
+#   @in  trans_specs
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::simpleTranslate { node output_var trans_specs } {
+
+    upvar $output_var output
+
+    if {[$node nodeType] == "TEXT_NODE"} {
+        append output [cgiQuote [$node nodeValue]]
+        return
+    }
+    set found 0
+
+    foreach {match action} $trans_specs {
+
+        if {[catch {
+            if {!$found && ([$node selectNode self::$match] != "") } {
+              set found 1
+            }
+        } err]} {
+            if {![string match "NodeSet expected for parent axis!" $err]} {
+                error $err
+            }
+        }
+        if {$found && ($action != "-")} {
+            set stop 0
+            foreach {type value} $action {
+                switch $type {
+                    prefix { append output [subst $value] }
+                    tag    { append output <$value>       }
+                    start  { append output [eval $value]  }
+                    stop   { set stop 1                   }
+                }
+            }
+            if {!$stop} {
+                foreach child [$node childNodes] {
+                    simpleTranslate  $child output $trans_specs
+                }
+            }
+            foreach {type value} $action {
+                switch $type {
+                    suffix { append output [subst $value] }
+                    end    { append output [eval $value]  }
+                    tag    { append output </$value>      }
+                }
+            }
+            return
+        }
+    }
+    foreach child [$node childNodes] {
+        simpleTranslate $child output $trans_specs
+    }
+}
+
+#----------------------------------------------------------------------------
+#   a DOM conformant 'live' childNodes
+#
+#   @return   a 'nodelist' object (it is just the normal node)
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::childNodesLive { node } {
+
+    return $node
+}
+
+#----------------------------------------------------------------------------
+#   item method on a 'nodelist' object
+#
+#   @return   a 'nodelist' object (it is just a normal
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::item { nodeListNode index } {
+
+    return [lindex [$nodeListNode childNodes] $index]
+}
+
+#----------------------------------------------------------------------------
+#   length method on a 'nodelist' object
+#
+#   @return   a 'nodelist' object (it is just a normal
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::length { nodeListNode } {
+
+    return [llength [$nodeListNode childNodes]]
+}
+
+#----------------------------------------------------------------------------
+#   appendData on a 'CharacterData' object
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::appendData { node  arg } {
+
+    set type [$node nodeType]
+    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
+        ($type != "COMMENT_NODE")
+    } {
+        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
+    }
+    set oldValue [$node nodeValue]
+    $node nodeValue [append oldValue $arg]
+}
+
+#----------------------------------------------------------------------------
+#   deleteData on a 'CharacterData' object
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::deleteData { node offset count } {
+
+    set type [$node nodeType]
+    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
+        ($type != "COMMENT_NODE")
+    } {
+        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
+    }
+    incr offset -1
+    set before [string range [$node nodeValue] 0 $offset]
+    incr offset
+    incr offset $count
+    set after  [string range [$node nodeValue] $offset end]
+    $node nodeValue [append before $after]
+}
+
+#----------------------------------------------------------------------------
+#   insertData on a 'CharacterData' object
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::insertData { node  offset arg } {
+
+    set type [$node nodeType]
+    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
+        ($type != "COMMENT_NODE")
+    } {
+        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
+    }
+    incr offset -1
+    set before [string range [$node nodeValue] 0 $offset]
+    incr offset
+    set after  [string range [$node nodeValue] $offset end]
+    $node nodeValue [append before $arg $after]
+}
+
+#----------------------------------------------------------------------------
+#   replaceData on a 'CharacterData' object
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::replaceData { node offset count arg } {
+
+    set type [$node nodeType]
+    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
+        ($type != "COMMENT_NODE")
+    } {
+        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
+    }
+    incr offset -1
+    set before [string range [$node nodeValue] 0 $offset]
+    incr offset
+    incr offset $count
+    set after  [string range [$node nodeValue] $offset end]
+    $node nodeValue [append before $arg $after]
+}
+
+#----------------------------------------------------------------------------
+#   substringData on a 'CharacterData' object
+#
+#   @return   part of the node value (text)
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::substringData { node offset count } {
+
+    set type [$node nodeType]
+    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
+        ($type != "COMMENT_NODE")
+    } {
+        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
+    }
+    set endOffset [expr $offset + $count - 1]
+    return [string range [$node nodeValue] $offset $endOffset]
+}
+
+#----------------------------------------------------------------------------
+#   coerce2number
+#
+#----------------------------------------------------------------------------
+proc ::dom::xpathFuncHelper::coerce2number { type value } {
+    switch $type {
+        empty      { return 0 }
+        number -
+        string     { return $value }
+        attrvalues { return [lindex $value 0] }
+        nodes      { return [[lindex $value 0] selectNodes number()] }
+        attrnodes  { return [lindex $value 1] }
+    }
+}
+
+#----------------------------------------------------------------------------
+#   coerce2string
+#
+#----------------------------------------------------------------------------
+proc ::dom::xpathFuncHelper::coerce2string { type value } {
+    switch $type {
+        empty      { return "" }
+        number -
+        string     { return $value }
+        attrvalues { return [lindex $value 0] }
+        nodes      { return [[lindex $value 0] selectNodes string()] }
+        attrnodes  { return [lindex $value 1] }
+    }
+}
+
+#----------------------------------------------------------------------------
+#   function-available
+#
+#----------------------------------------------------------------------------
+proc ::dom::xpathFunc::function-available { ctxNode pos
+                                            nodeListType nodeList args} {
+
+    if {[llength $args] != 2} {
+        error "function-available(): wrong # of args!"
+    }
+    foreach { arg1Typ arg1Value } $args break
+    set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
+    switch $str {
+        boolean -
+        ceiling -
+        concat -
+        contains -
+        count -
+        current -
+        document -
+        element-available -
+        false -
+        floor -
+        format-number -
+        generate-id -
+        id -
+        key -
+        last -
+        lang -
+        local-name -
+        name -
+        namespace-uri -
+        normalize-space -
+        not -
+        number -
+        position -
+        round -
+        starts-with -
+        string -
+        string-length -
+        substring -
+        substring-after -
+        substring-before -
+        sum -
+        translate -
+        true -
+        unparsed-entity-uri {
+            return [list bool true]
+        }
+        default {
+            set TclXpathFuncs [info procs ::dom::xpathFunc::*]
+            if {[lsearch -exact $TclXpathFuncs $str] != -1} {
+                return [list bool true]
+            } else {
+                return [list bool false]
+            }
+        }
+    }
+}
+
+#----------------------------------------------------------------------------
+#   element-available
+#
+#   This is not strictly correct. The XSLT namespace may be bound
+#   to another prefix (and the prefix 'xsl' may be bound to another
+#   namespace). Since the expression context isn't available at the
+#   moment at tcl coded XPath functions, this couldn't be done better
+#   than this "works in the 'normal' cases" version.
+#----------------------------------------------------------------------------
+proc ::dom::xpathFunc::element-available { ctxNode pos
+                                            nodeListType nodeList args} {
+
+    if {[llength $args] != 2} {
+        error "element-available(): wrong # of args!"
+    }
+    foreach { arg1Typ arg1Value } $args break
+    set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
+    switch $str {
+        xsl:stylesheet -
+        xsl:transform -
+        xsl:include -
+        xsl:import -
+        xsl:strip-space -
+        xsl:preserve-space -
+        xsl:template -
+        xsl:apply-templates -
+        xsl:apply-imports -
+        xsl:call-template -
+        xsl:element -
+        xsl:attribute -
+        xsl:attribute-set -
+        xsl:text -
+        xsl:processing-instruction -
+        xsl:comment -
+        xsl:copy -
+        xsl:value-of -
+        xsl:number -
+        xsl:for-each -
+        xsl:if -
+        xsl:choose -
+        xsl:when -
+        xsl:otherwise -
+        xsl:sort -
+        xsl:variable -
+        xsl:param -
+        xsl:copy-of -
+        xsl:with-param -
+        xsl:key -
+        xsl:message -
+        xsl:decimal-format -
+        xsl:namespace-alias -
+        xsl:output -
+        xsl:fallback {
+            return [list bool true]
+        }
+        default {
+            return [list bool false]
+        }
+    }
+}
+
+#----------------------------------------------------------------------------
+#   system-property
+#
+#   This is not strictly correct. The XSLT namespace may be bound
+#   to another prefix (and the prefix 'xsl' may be bound to another
+#   namespace). Since the expression context isn't available at the
+#   moment at tcl coded XPath functions, this couldn't be done better
+#   than this "works in the 'normal' cases" version.
+#----------------------------------------------------------------------------
+proc ::dom::xpathFunc::system-property { ctxNode pos
+                                         nodeListType nodeList args } {
+
+    if {[llength $args] != 2} {
+        error "system-property(): wrong # of args!"
+    }
+    foreach { arg1Typ arg1Value } $args break
+    set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
+    switch $str {
+        xsl:version {
+            return [list number 1.0]
+        }
+        xsl:vendor {
+            return [list string "Jochen Loewer (loewerj@hotmail.com), Rolf Ade (rolf@pointsman.de) et. al."]
+        }
+        xsl:vendor-url {
+            return [list string "http://www.tdom.org"]
+        }
+        default {
+            return [list string ""]
+        }
+    }
+}
+
+#----------------------------------------------------------------------------
+#   IANAEncoding2TclEncoding
+#
+#----------------------------------------------------------------------------
+
+# As of version 8.3.4 tcl supports 
+# cp860 cp861 cp862 cp863 tis-620 cp864 cp865 cp866 gb12345 cp949
+# cp950 cp869 dingbats ksc5601 macCentEuro cp874 macUkraine jis0201
+# gb2312 euc-cn euc-jp iso8859-10 macThai jis0208 iso2022-jp
+# macIceland iso2022 iso8859-13 iso8859-14 jis0212 iso8859-15 cp737
+# iso8859-16 big5 euc-kr macRomania macTurkish gb1988 iso2022-kr
+# macGreek ascii cp437 macRoman iso8859-1 iso8859-2 iso8859-3 ebcdic
+# macCroatian koi8-r iso8859-4 iso8859-5 cp1250 macCyrillic iso8859-6
+# cp1251 koi8-u macDingbats iso8859-7 cp1252 iso8859-8 cp1253
+# iso8859-9 cp1254 cp1255 cp850 cp1256 cp932 identity cp1257 cp852
+# macJapan cp1258 shiftjis utf-8 cp855 cp936 symbol cp775 unicode
+# cp857
+# 
+# Just add more mappings (and mail them to the tDOM mailing list, please).
+
+proc tDOM::IANAEncoding2TclEncoding {IANAName} {
+    
+    # First the most widespread encodings with there
+    # preferred MIME name, to speed lookup in this
+    # usual cases. Later the official names and the
+    # aliases.
+    #
+    # For "official names for character sets that may be
+    # used in the Internet" see 
+    # http://www.iana.org/assignments/character-sets
+    # (that's the source for the encoding names below)
+    # 
+    # Matching is case-insensitive
+
+    switch [string tolower $IANAName] {
+        "us-ascii"    {return ascii}
+        "utf-8"       {return utf-8}
+        "utf-16"      {return unicode; # not sure about this}
+        "iso-8859-1"  {return iso8859-1}
+        "iso-8859-2"  {return iso8859-2}
+        "iso-8859-3"  {return iso8859-3}
+        "iso-8859-4"  {return iso8859-4}
+        "iso-8859-5"  {return iso8859-5}
+        "iso-8859-6"  {return iso8859-6}
+        "iso-8859-7"  {return iso8859-7}
+        "iso-8859-8"  {return iso8859-8}
+        "iso-8859-9"  {return iso8859-9}
+        "iso-8859-10" {return iso8859-10}
+        "iso-8859-13" {return iso8859-13}
+        "iso-8859-14" {return iso8859-14}
+        "iso-8859-15" {return iso8859-15}
+        "iso-8859-16" {return iso8859-16}
+        "iso-2022-kr" {return iso2022-kr}
+        "euc-kr"      {return euc-kr}
+        "iso-2022-jp" {return iso2022-jp}
+        "koi8-r"      {return koi8-r}
+        "shift_jis"   {return shiftjis}
+        "euc-jp"      {return euc-jp}
+        "gb2312"      {return gb2312}
+        "big5"        {return big5}
+        "cp866"       {return cp866}
+        "cp1250"      {return cp1250}
+        "cp1253"      {return cp1253}
+        "cp1254"      {return cp1254}
+        "cp1255"      {return cp1255}
+        "cp1256"      {return cp1256}
+        "cp1257"      {return cp1257}
+
+        "windows-1251" -
+        "cp1251"      {return cp1251}
+
+        "windows-1252" -
+        "cp1252"      {return cp1252}    
+
+        "iso_8859-1:1987" -
+        "iso-ir-100" -
+        "iso_8859-1" -
+        "latin1" -
+        "l1" -
+        "ibm819" -
+        "cp819" -
+        "csisolatin1" {return iso8859-1}
+        
+        "iso_8859-2:1987" -
+        "iso-ir-101" -
+        "iso_8859-2" -
+        "iso-8859-2" -
+        "latin2" -
+        "l2" -
+        "csisolatin2" {return iso8859-2}
+
+        "iso_8859-5:1988" -
+        "iso-ir-144" -
+        "iso_8859-5" -
+        "iso-8859-5" -
+        "cyrillic" -
+        "csisolatincyrillic" {return iso8859-5}
+
+        "ms_kanji" -
+        "csshiftjis"  {return shiftjis}
+        
+        "csiso2022kr" {return iso2022-kr}
+
+        "ibm866" -
+        "csibm866"    {return cp866}
+        
+        default {
+            # There are much more encoding names out there
+            # It's only laziness, that let me stop here.
+            error "Unrecognized encoding name '$IANAName'"
+        }
+    }
+}
+
+#----------------------------------------------------------------------------
+#   xmlOpenFile
+#
+#----------------------------------------------------------------------------
+proc tDOM::xmlOpenFile {filename {encodingString {}}} {
+
+    set fd [open $filename]
+
+    if {$encodingString != {}} {
+        upvar $encodingString encString
+    }
+
+    # The autodetection of the encoding follows
+    # XML Recomendation, Appendix F
+
+    fconfigure $fd -encoding binary
+    if {![binary scan [read $fd 4] "H8" firstBytes]} {
+        # very short (< 4 Bytes) file
+        seek $fd 0 start
+        set encString UTF-8
+        return $fd
+    }
+    
+    # First check for BOM
+    switch [string range $firstBytes 0 3] {
+        "feff" -
+        "fffe" {
+            # feff: UTF-16, big-endian BOM
+            # ffef: UTF-16, little-endian BOM
+            seek $fd 0 start
+            set encString UTF-16            
+            fconfigure $fd -encoding identity
+            return $fd
+        }
+    }
+
+    # If the entity has a XML Declaration, the first four characters
+    # must be "<?xm".
+    switch $firstBytes {
+        "3c3f786d" {
+            # UTF-8, ISO 646, ASCII, some part of ISO 8859, Shift-JIS,
+            # EUC, or any other 7-bit, 8-bit, or mixed-width encoding which 
+            # ensures that the characters of ASCII have their normal positions,
+            # width and values; the actual encoding declaration must be read to
+            # detect which of these applies, but since all of these encodings
+            # use the same bit patterns for the ASCII characters, the encoding
+            # declaration itself be read reliably.
+
+            # First 300 bytes should be enough for a XML Declaration
+            # This is of course not 100 percent bullet-proof.
+            set head [read $fd 296]
+
+            # Try to find the end of the XML Declaration
+            set closeIndex [string first ">" $head]
+            if {$closeIndex == -1} {
+                error "Weird XML data or not XML data at all"
+            }
+
+            seek $fd 0 start
+            set xmlDeclaration [read $fd [expr {$closeIndex + 5}]]
+            # extract the encoding information
+            set pattern {^[^>]+encoding=[\x20\x9\xd\xa]*["']([^ "']+)['"]}
+            # emacs: "
+            if {![regexp $pattern $head - encStr]} {
+                # Probably something like <?xml version="1.0"?>. 
+                # Without encoding declaration this must be UTF-8
+                set encoding utf-8
+                set encString UTF-8
+            } else {
+                set encoding [IANAEncoding2TclEncoding $encStr]
+                set encString $encStr
+            }
+        }
+        "0000003c" -
+        "0000003c" -
+        "3c000000" -
+        "00003c00" {
+            # UCS-4
+            error "UCS-4 not supported"
+        }
+        "003c003f" -
+        "3c003f00" {
+            # UTF-16, big-endian, no BOM
+            # UTF-16, little-endian, no BOM
+            seek $fd 0 start
+            set encoding identity
+            set encString UTF-16
+        }
+        "4c6fa794" {
+            # EBCDIC in some flavor
+            error "EBCDIC not supported"
+        }
+        default {
+            # UTF-8 without an encoding declaration
+            seek $fd 0 start
+            set encoding identity
+            set encString "UTF-8"
+        }
+    }
+    fconfigure $fd -encoding $encoding
+    return $fd
+}
+
+#----------------------------------------------------------------------------
+#   xmlReadFile
+#
+#----------------------------------------------------------------------------
+proc tDOM::xmlReadFile {filename {encodingString {}}} {
+
+    if {$encodingString != {}} {
+        upvar $encodingString encString
+    }
+    
+    set fd [xmlOpenFile $filename encString]
+    set data [read $fd [file size $filename]]
+    close $fd 
+    return $data
+}
+
+#----------------------------------------------------------------------------
+#   extRefHandler
+#   
+#   A very simple external entity resolver, included for convenience.
+#   Depends on the tcllib package uri and resolves only file URLs. 
+#
+#----------------------------------------------------------------------------
+
+if {![catch {package require uri}]} {
+    proc tDOM::extRefHandler {base systemId publicId} {
+        variable extRefHandlerDebug
+        variable useForeignDTD
+
+        if {$extRefHandlerDebug} {
+            puts stderr "tDOM::extRefHandler called with:"
+            puts stderr "\tbase:     '$base'"
+            puts stderr "\tsystemId: '$systemId'"
+            puts stderr "\tpublicId: '$publicId'"
+        }
+        if {$systemId == ""} {
+            if {$useForeignDTD != ""} {
+                set systemId $useForeignDTD
+            } else {
+                error "::tDOM::useForeignDTD does\
+                        not point to the foreign DTD"
+            }
+        }
+        set absolutURI [uri::resolve $base $systemId]
+        array set uriData [uri::split $absolutURI]
+        switch $uriData(scheme) {
+            file {
+                return [list string $absolutURI [xmlReadFile $uriData(path)]]
+            }
+            default {
+                error "can only handle file URI's"
+            }
+        }
+    }
+}
+
+#----------------------------------------------------------------------------
+#   baseURL
+#   
+#   A simple convenience proc which returns an absolute URL for a given
+#   filename.
+#
+#----------------------------------------------------------------------------
+
+proc tDOM::baseURL {path} {
+    switch [file pathtype $path] {
+        "relative" {
+            return "file://[pwd]/$path"
+        }
+        default {
+            return "file://$path"
+        }
+    }
+}
+
+# EOF
diff --git a/lib/tdom/win32-ix86/tdom083.dll b/lib/tdom/win32-ix86/tdom083.dll
new file mode 100644
index 0000000..a7e6fb4
Binary files /dev/null and b/lib/tdom/win32-ix86/tdom083.dll differ
diff --git a/lib/tls/pkgIndex.tcl b/lib/tls/pkgIndex.tcl
new file mode 100644
index 0000000..2d80fc4
--- /dev/null
+++ b/lib/tls/pkgIndex.tcl
@@ -0,0 +1,6 @@
+# We only have a win32-intel binary at the moment
+if {[string compare $::tcl_platform(platform) "windows"]} { return }
+if {[string compare $::tcl_platform(machine) "intel"]} { return }
+if {![package vsatisfies [package provide Tcl] 8.3]} { return }
+package ifneeded tls 1.6 "source \[file join [list $dir] tls.tcl\];\
+    tls::initlib \[file join [list $dir] win32-ix86\] tls16.dll"
diff --git a/lib/tls/tls.tcl b/lib/tls/tls.tcl
new file mode 100644
index 0000000..fa362d2
--- /dev/null
+++ b/lib/tls/tls.tcl
@@ -0,0 +1,250 @@
+#
+# Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com> 
+#
+# $Header: /cvsroot/tls/tls/tls.tcl,v 1.10 2008/03/19 02:34:21 patthoyts Exp $
+#
+namespace eval tls {
+    variable logcmd tclLog
+    variable debug 0
+ 
+    # Default flags passed to tls::import
+    variable defaults {}
+
+    # Maps UID to Server Socket
+    variable srvmap
+    variable srvuid 0
+
+    # Over-ride this if you are using a different socket command
+    variable socketCmd
+    if {![info exists socketCmd]} {
+        set socketCmd [info command ::socket]
+    }
+}
+
+proc tls::initlib {dir dll} {
+    # Package index cd's into the package directory for loading.
+    # Irrelevant to unixoids, but for Windows this enables the OS to find
+    # the dependent DLL's in the CWD, where they may be.
+    set cwd [pwd]
+    catch {cd $dir}
+    set res [catch {uplevel #0 [list load [file join [pwd] $dll]]} err]
+    catch {cd $cwd}
+    if {$res} {
+	namespace eval [namespace parent] {namespace delete tls}
+	return -code $res $err
+    }
+    rename tls::initlib {}
+}
+
+#
+# Backwards compatibility, also used to set the default
+# context options
+#
+proc tls::init {args} {
+    variable defaults
+
+    set defaults $args
+}
+#
+# Helper function - behaves exactly as the native socket command.
+#
+proc tls::socket {args} {
+    variable socketCmd
+    variable defaults
+    set idx [lsearch $args -server]
+    if {$idx != -1} {
+	set server 1
+	set callback [lindex $args [expr {$idx+1}]]
+	set args [lreplace $args $idx [expr {$idx+1}]]
+
+	set usage "wrong # args: should be \"tls::socket -server command ?options? port\""
+	set options "-cadir, -cafile, -certfile, -cipher, -command, -keyfile, -myaddr, -password, -request, -require, -ssl2, -ssl3, or -tls1"
+    } else {
+	set server 0
+
+	set usage "wrong # args: should be \"tls::socket ?options? host port\""
+	set options "-async, -cadir, -cafile, -certfile, -cipher, -command, -keyfile, -myaddr, -myport, -password, -request, -require, -ssl2, -ssl3, or -tls1"
+    }
+    set argc [llength $args]
+    set sopts {}
+    set iopts [concat [list -server $server] $defaults]	;# Import options
+
+    for {set idx 0} {$idx < $argc} {incr idx} {
+	set arg [lindex $args $idx]
+	switch -glob -- $server,$arg {
+	    0,-async	{lappend sopts $arg}
+	    0,-myport	-
+	    *,-myaddr	{lappend sopts $arg [lindex $args [incr idx]]}
+	    *,-cadir	-
+	    *,-cafile	-
+	    *,-certfile	-
+	    *,-cipher	-
+	    *,-command	-
+	    *,-keyfile	-
+	    *,-password	-
+	    *,-request	-
+	    *,-require	-
+	    *,-ssl2	-
+	    *,-ssl3	-
+	    *,-tls1	{lappend iopts $arg [lindex $args [incr idx]]}
+	    -*		{return -code error "bad option \"$arg\": must be one of $options"}
+	    default	{break}
+	}
+    }
+    if {$server} {
+	if {($idx + 1) != $argc} {
+	    return -code error $usage
+	}
+	set uid [incr ::tls::srvuid]
+
+	set port [lindex $args [expr {$argc-1}]]
+	lappend sopts $port
+	#set sopts [linsert $sopts 0 -server $callback]
+	set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]]
+	#set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]]
+    } else {
+	if {($idx + 2) != $argc} {
+	    return -code error $usage
+	}
+	set host [lindex $args [expr {$argc-2}]]
+	set port [lindex $args [expr {$argc-1}]]
+	lappend sopts $host $port
+    }
+    #
+    # Create TCP/IP socket
+    #
+    set chan [eval $socketCmd $sopts]
+    if {!$server && [catch {
+	#
+	# Push SSL layer onto socket
+	#
+	eval [list tls::import] $chan $iopts
+    } err]} {
+	set info ${::errorInfo}
+	catch {close $chan}
+	return -code error -errorinfo $info $err
+    }
+    return $chan
+}
+
+# tls::_accept --
+#
+#   This is the actual accept that TLS sockets use, which then calls
+#   the callback registered by tls::socket.
+#
+# Arguments:
+#   iopts	tls::import opts
+#   callback	server callback to invoke
+#   chan	socket channel to accept/deny
+#   ipaddr	calling IP address
+#   port	calling port
+#
+# Results:
+#   Returns an error if the callback throws one.
+#
+proc tls::_accept { iopts callback chan ipaddr port } {
+    log 2 [list tls::_accept $iopts $callback $chan $ipaddr $port]
+
+    set chan [eval [list tls::import $chan] $iopts]
+
+    lappend callback $chan $ipaddr $port
+    if {[catch {
+	uplevel #0 $callback
+    } err]} {
+	log 1 "tls::_accept error: ${::errorInfo}"
+	close $chan
+	error $err $::errorInfo $::errorCode
+    } else {
+	log 2 "tls::_accept - called \"$callback\" succeeded"
+    }
+}
+#
+# Sample callback for hooking: -
+#
+# error
+# verify
+# info
+#
+proc tls::callback {option args} {
+    variable debug
+
+    #log 2 [concat $option $args]
+
+    switch -- $option {
+	"error"	{
+	    foreach {chan msg} $args break
+
+	    log 0 "TLS/$chan: error: $msg"
+	}
+	"verify"	{
+	    # poor man's lassign
+	    foreach {chan depth cert rc err} $args break
+
+	    array set c $cert
+
+	    if {$rc != "1"} {
+		log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)"
+	    } else {
+		log 2 "TLS/$chan: verify/$depth: $c(subject)"
+	    }
+	    if {$debug > 0} {
+		return 1;	# FORCE OK
+	    } else {
+		return $rc
+	    }
+	}
+	"info"	{
+	    # poor man's lassign
+	    foreach {chan major minor state msg} $args break
+
+	    if {$msg != ""} {
+		append state ": $msg"
+	    }
+	    # For tracing
+	    upvar #0 tls::$chan cb
+	    set cb($major) $minor
+
+	    log 2 "TLS/$chan: $major/$minor: $state"
+	}
+	default	{
+	    return -code error "bad option \"$option\":\
+		    must be one of error, info, or verify"
+	}
+    }
+}
+
+proc tls::xhandshake {chan} {
+    upvar #0 tls::$chan cb
+
+    if {[info exists cb(handshake)] && \
+	$cb(handshake) == "done"} {
+	return 1
+    }
+    while {1} {
+	vwait tls::${chan}(handshake)
+	if {![info exists cb(handshake)]} {
+	    return 0
+	}
+	if {$cb(handshake) == "done"} {
+	    return 1
+	}
+    }
+}
+
+proc tls::password {} {
+    log 0 "TLS/Password: did you forget to set your passwd!"
+    # Return the worlds best kept secret password.
+    return "secret"
+}
+
+proc tls::log {level msg} {
+    variable debug
+    variable logcmd
+
+    if {$level > $debug || $logcmd == ""} {
+	return
+    }
+    set cmd $logcmd
+    lappend cmd $msg
+    uplevel #0 $cmd
+}
diff --git a/lib/tls/win32-ix86/tls16.dll b/lib/tls/win32-ix86/tls16.dll
new file mode 100644
index 0000000..6f4268d
Binary files /dev/null and b/lib/tls/win32-ix86/tls16.dll differ
diff --git a/lib/tooltip/pkgIndex.tcl b/lib/tooltip/pkgIndex.tcl
new file mode 100644
index 0000000..1f40cc2
--- /dev/null
+++ b/lib/tooltip/pkgIndex.tcl
@@ -0,0 +1,4 @@
+# -*- tcl -*-
+
+package ifneeded tooltip  1.4.1 [list source [file join $dir tooltip.tcl]]
+package ifneeded tipstack 1.0 [list source [file join $dir tipstack.tcl]]
diff --git a/lib/tooltip/tipstack.tcl b/lib/tooltip/tipstack.tcl
new file mode 100644
index 0000000..de6069a
--- /dev/null
+++ b/lib/tooltip/tipstack.tcl
@@ -0,0 +1,169 @@
+# tipstack.tcl --
+#
+#	Based on 'tooltip', provides a dynamic stack of tip texts per
+#	widget. This allows dynamic transient changes to the tips, for
+#	example to temporarily replace a standard epxlanation with an
+#	error message.
+#
+# Copyright (c) 2003 ActiveState Corporation.
+#
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: tipstack.tcl,v 1.3 2006/04/04 23:56:36 andreas_kupries Exp $
+#
+
+# ### ######### ###########################
+# Requisites
+
+package require tooltip
+namespace eval ::tipstack {}
+
+# ### ######### ###########################
+# Public API
+#
+## Basic syntax for all commands having a widget reference:
+#
+## tipstack::command .w ...
+## tipstack::command .m -index foo ...
+
+# ### ######### ###########################
+## Push new text for a widget (or menu)
+
+proc ::tipstack::push {args} {
+    if {([llength $args] != 2) && (([llength $args] != 4))} {
+	return -code error "wrong#args: expected w ?-index index? text"
+    }
+
+    # Extract valueable parts.
+
+    set text [lindex $args end]
+    set wref [lrange $args 0 end-1]
+
+    # Remember new data (setup/extend db)
+
+    variable db
+    if {![info exists db($wref)]} {
+	set db($wref) [list $text]
+    } else {
+	lappend db($wref) $text
+    }
+
+    # Forward to standard tooltip package.
+
+    eval [linsert [linsert $wref end $text] 0 tooltip::tooltip]
+    return
+}
+
+# ### ######### ###########################
+## Pop text from stack of tip for widget.
+## ! Keeps the bottom-most entry.
+
+proc ::tipstack::pop {args} {
+    if {([llength $args] != 1) && (([llength $args] != 3))} {
+	return -code error "wrong#args: expected w ?-index index?"
+    }
+    # args == wref (see 'push').
+    set wref $args
+
+    # Pop top information form the database. Except if the
+    # text is the last in the stack. Then we will keep it, it
+    # is the baseline for the widget.
+
+    variable db
+    if {![info exists db($wref)]} {
+	set text ""
+    } else {
+	set data $db($wref)
+
+	if {[llength $data] == 1} {
+	    set text [lindex $data 0]
+	} else {
+	    set data [lrange $data 0 end-1]
+	    set text [lindex $data end]
+
+	    set db($wref) $data
+	}
+    }
+
+    # Forward to standard tooltip package.
+
+    eval [linsert [linsert $wref end $text] 0 tooltip::tooltip]
+    return
+}
+
+# ### ######### ###########################
+## Clears out all data about a widget (or menu).
+
+proc ::tipstack::clear {args} {
+
+    if {([llength $args] != 1) && (([llength $args] != 3))} {
+	return -code error "wrong#args: expected w ?-index index?"
+    }
+    # args == wref (see 'push').
+    set wref $args
+
+    # Remove data about widget.
+
+    variable db
+    catch {unset db($wref)}
+
+    eval [linsert [linsert $wref end ""] 0 tooltip::tooltip]
+    return
+}
+
+# ### ######### ###########################
+## Convenient definition of tooltips for multiple
+## independent widgets. No menus possible
+
+proc ::tipstack::def {defs} {
+    foreach {path text} $defs {
+	push $path $text
+    }
+    return
+}
+
+# ### ######### ###########################
+## Convenient definition of tooltips for multiple
+## widgets in a containing widget. No menus possible.
+## This is for megawidgets.
+
+proc ::tipstack::defsub {base defs} {
+    foreach {subpath text} $defs {
+	push $base$subpath $text
+    }
+    return
+}
+
+# ### ######### ###########################
+## Convenient clearage of tooltips for multiple
+## widgets in a containing widget. No menus possible.
+## This is for megawidgets.
+
+proc ::tipstack::clearsub {base} {
+    variable db
+
+    foreach k [array names db ${base}*] {
+	# Danger. Will fail if 'base' matches a menu reference.
+	clear $k
+    }
+    return
+}
+
+# ### ######### ###########################
+# Internal commands -- None
+
+# ### ######### ###########################
+## Data structures
+
+namespace eval ::tipstack {
+    # Map from widget references to stack of tooltips.
+
+    variable  db
+    array set db {}
+}
+
+# ### ######### ###########################
+# Ready
+
+package provide tipstack 1.0
diff --git a/lib/tooltip/tooltip.tcl b/lib/tooltip/tooltip.tcl
new file mode 100644
index 0000000..dedf3b2
--- /dev/null
+++ b/lib/tooltip/tooltip.tcl
@@ -0,0 +1,414 @@
+# tooltip.tcl --
+#
+#       Balloon help
+#
+# Copyright (c) 1996-2007 Jeffrey Hobbs
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# 
+# RCS: @(#) $Id: tooltip.tcl,v 1.12 2008/03/12 20:41:05 hobbs Exp $
+#
+# Initiated: 28 October 1996
+
+
+package require Tk 8.4
+package provide tooltip 1.4.1
+package require msgcat
+
+#------------------------------------------------------------------------
+# PROCEDURE
+#	tooltip::tooltip
+#
+# DESCRIPTION
+#	Implements a tooltip (balloon help) system
+#
+# ARGUMENTS
+#	tooltip <option> ?arg?
+#
+# clear ?pattern?
+#	Stops the specified widgets (defaults to all) from showing tooltips
+#
+# delay ?millisecs?
+#	Query or set the delay.  The delay is in milliseconds and must
+#	be at least 50.  Returns the delay.
+#
+# disable OR off
+#	Disables all tooltips.
+#
+# enable OR on
+#	Enables tooltips for defined widgets.
+#
+# <widget> ?-index index? ?-item id? ?message?
+#	If -index is specified, then <widget> is assumed to be a menu
+#	and the index represents what index into the menu (either the
+#	numerical index or the label) to associate the tooltip message with.
+#	Tooltips do not appear for disabled menu items.
+#	If message is {}, then the tooltip for that widget is removed.
+#	The widget must exist prior to calling tooltip.  The current
+#	tooltip message for <widget> is returned, if any.
+#
+# RETURNS: varies (see methods above)
+#
+# NAMESPACE & STATE
+#	The namespace tooltip is used.
+#	Control toplevel name via ::tooltip::wname.
+#
+# EXAMPLE USAGE:
+#	tooltip .button "A Button"
+#	tooltip .menu -index "Load" "Loads a file"
+#
+#------------------------------------------------------------------------
+
+namespace eval ::tooltip {
+    namespace export -clear tooltip
+    variable tooltip
+    variable G
+
+    array set G {
+	enabled		1
+	fade		1
+	FADESTEP	0.2
+	FADEID		{}
+	DELAY		500
+	AFTERID		{}
+	LAST		-1
+	TOPLEVEL	.__tooltip__
+    }
+    if {[tk windowingsystem] eq "x11"} {
+	set G(fade) 0 ; # don't fade by default on X11
+    }
+    # The extra ::hide call in <Enter> is necessary to catch moving to
+    # child widgets where the <Leave> event won't be generated
+    bind Tooltip <Enter> [namespace code {
+	#tooltip::hide
+	variable tooltip
+	variable G
+	set G(LAST) -1
+	if {$G(enabled) && [info exists tooltip(%W)]} {
+	    set G(AFTERID) \
+		[after $G(DELAY) [namespace code [list show %W $tooltip(%W) cursor]]]
+	}
+    }]
+
+    bind Menu <<MenuSelect>>	[namespace code { menuMotion %W }]
+    bind Tooltip <Leave>	[namespace code [list hide 1]] ; # fade ok
+    bind Tooltip <Any-KeyPress>	[namespace code hide]
+    bind Tooltip <Any-Button>	[namespace code hide]
+}
+
+proc ::tooltip::tooltip {w args} {
+    variable tooltip
+    variable G
+    switch -- $w {
+	clear	{
+	    if {[llength $args]==0} { set args .* }
+	    clear $args
+	}
+	delay	{
+	    if {[llength $args]} {
+		if {![string is integer -strict $args] || $args<50} {
+		    return -code error "tooltip delay must be an\
+			    integer greater than 50 (delay is in millisecs)"
+		}
+		return [set G(DELAY) $args]
+	    } else {
+		return $G(DELAY)
+	    }
+	}
+	fade	{
+	    if {[llength $args]} {
+		set G(fade) [string is true -strict [lindex $args 0]]
+	    }
+	    return $G(fade)
+	}
+	off - disable	{
+	    set G(enabled) 0
+	    hide
+	}
+	on - enable	{
+	    set G(enabled) 1
+	}
+	default {
+	    set i $w
+	    if {[llength $args]} {
+		set i [uplevel 1 [namespace code "register [list $w] $args"]]
+	    }
+	    set b $G(TOPLEVEL)
+	    if {![winfo exists $b]} {
+		toplevel $b -class Tooltip
+		if {[tk windowingsystem] eq "aqua"} {
+		    ::tk::unsupported::MacWindowStyle style $b help none
+		} else {
+		    wm overrideredirect $b 1
+		}
+		catch {wm attributes $b -topmost 1}
+		# avoid the blink issue with 1 to <1 alpha on Windows
+		catch {wm attributes $b -alpha 0.99}
+		wm positionfrom $b program
+		wm withdraw $b
+		label $b.label -highlightthickness 0 -relief solid -bd 1 \
+			-background lightyellow -fg black
+		pack $b.label -ipadx 1
+	    }
+	    if {[info exists tooltip($i)]} { return $tooltip($i) }
+	}
+    }
+}
+
+proc ::tooltip::register {w args} {
+    variable tooltip
+    set key [lindex $args 0]
+    while {[string match -* $key]} {
+	switch -- $key {
+	    -index	{
+		if {[catch {$w entrycget 1 -label}]} {
+		    return -code error "widget \"$w\" does not seem to be a\
+			    menu, which is required for the -index switch"
+		}
+		set index [lindex $args 1]
+		set args [lreplace $args 0 1]
+	    }
+	    -item	{
+		set namedItem [lindex $args 1]
+		if {[catch {$w find withtag $namedItem} item]} {
+		    return -code error "widget \"$w\" is not a canvas, or item\
+			    \"$namedItem\" does not exist in the canvas"
+		}
+		if {[llength $item] > 1} {
+		    return -code error "item \"$namedItem\" specifies more\
+			    than one item on the canvas"
+		}
+		set args [lreplace $args 0 1]
+	    }
+            -tag {
+                set tag [lindex $args 1]
+                set r [catch {lsearch -exact [$w tag names] $tag} ndx]
+                if {$r || $ndx == -1} {
+                    return -code error "widget \"$w\" is not a text widget or\
+                        \"$tag\" is not a text tag"
+                }
+                set args [lreplace $args 0 1]
+            }
+	    default	{
+		return -code error "unknown option \"$key\":\
+			should be -index or -item"
+	    }
+	}
+	set key [lindex $args 0]
+    }
+    if {[llength $args] != 1} {
+	return -code error "wrong # args: should be \"tooltip widget\
+		?-index index? ?-item item? ?-tag tag? message\""
+    }
+    if {$key eq ""} {
+	clear $w
+    } else {
+	if {![winfo exists $w]} {
+	    return -code error "bad window path name \"$w\""
+	}
+	if {[info exists index]} {
+	    set tooltip($w,$index) $key
+	    return $w,$index
+	} elseif {[info exists item]} {
+	    set tooltip($w,$item) $key
+	    enableCanvas $w $item
+	    return $w,$item
+        } elseif {[info exists tag]} {
+            set tooltip($w,t_$tag) $key
+            enableTag $w $tag
+            return $w,$tag
+	} else {
+	    set tooltip($w) $key
+	    bindtags $w [linsert [bindtags $w] end "Tooltip"]
+	    return $w
+	}
+    }
+}
+
+proc ::tooltip::clear {{pattern .*}} {
+    variable tooltip
+    # cache the current widget at pointer
+    set ptrw [winfo containing [winfo pointerx .] [winfo pointery .]]
+    foreach w [array names tooltip $pattern] {
+	unset tooltip($w)
+	if {[winfo exists $w]} {
+	    set tags [bindtags $w]
+	    if {[set i [lsearch -exact $tags "Tooltip"]] != -1} {
+		bindtags $w [lreplace $tags $i $i]
+	    }
+	    ## We don't remove TooltipMenu because there
+	    ## might be other indices that use it
+
+	    # Withdraw the tooltip if we clear the current contained item
+	    if {$ptrw eq $w} { hide }
+	}
+    }
+}
+
+proc ::tooltip::show {w msg {i {}}} {
+    if {![winfo exists $w]} { return }
+
+    # Use string match to allow that the help will be shown when
+    # the pointer is in any child of the desired widget
+    if {([winfo class $w] ne "Menu")
+	&& ![string match $w* [eval [list winfo containing] \
+				   [winfo pointerxy $w]]]} {
+	return
+    }
+
+    variable G
+
+    after cancel $G(FADEID)
+    set b $G(TOPLEVEL)
+    # Use late-binding msgcat (lazy translation) to support programs
+    # that allow on-the-fly l10n changes
+    $b.label configure -text [::msgcat::mc $msg] -justify left
+    update idletasks
+    set screenw [winfo screenwidth $w]
+    set screenh [winfo screenheight $w]
+    set reqw [winfo reqwidth $b]
+    set reqh [winfo reqheight $b]
+    # When adjusting for being on the screen boundary, check that we are
+    # near the "edge" already, as Tk handles multiple monitors oddly
+    if {$i eq "cursor"} {
+	set y [expr {[winfo pointery $w]+20}]
+	if {($y < $screenh) && ($y+$reqh) > $screenh} {
+	    set y [expr {[winfo pointery $w]-$reqh-5}]
+	}
+    } elseif {$i ne ""} {
+	set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[$w yposition $i]+25}]
+	if {($y < $screenh) && ($y+$reqh) > $screenh} {
+	    # show above if we would be offscreen
+	    set y [expr {[winfo rooty $w]+[$w yposition $i]-$reqh-5}]
+	}
+    } else {
+	set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[winfo height $w]+5}]
+	if {($y < $screenh) && ($y+$reqh) > $screenh} {
+	    # show above if we would be offscreen
+	    set y [expr {[winfo rooty $w]-$reqh-5}]
+	}
+    }
+    if {$i eq "cursor"} {
+	set x [winfo pointerx $w]
+    } else {
+	set x [expr {[winfo rootx $w]+[winfo vrootx $w]+
+		     ([winfo width $w]-$reqw)/2}]
+    }
+    # only readjust when we would appear right on the screen edge
+    if {$x<0 && ($x+$reqw)>0} {
+	set x 0
+    } elseif {($x < $screenw) && ($x+$reqw) > $screenw} {
+	set x [expr {$screenw-$reqw}]
+    }
+    if {[tk windowingsystem] eq "aqua"} {
+	set focus [focus]
+    }
+    # avoid the blink issue with 1 to <1 alpha on Windows, watch half-fading
+    catch {wm attributes $b -alpha 0.99}
+    wm geometry $b +$x+$y
+    wm deiconify $b
+    raise $b
+    if {[tk windowingsystem] eq "aqua" && $focus ne ""} {
+	# Aqua's help window steals focus on display
+	after idle [list focus -force $focus]
+    }
+}
+
+proc ::tooltip::menuMotion {w} {
+    variable G
+
+    if {$G(enabled)} {
+	variable tooltip
+
+        # Menu events come from a funny path, map to the real path.
+        set m [string map {"#" "."} [winfo name $w]]
+	set cur [$w index active]
+
+	# The next two lines (all uses of LAST) are necessary until the
+	# <<MenuSelect>> event is properly coded for Unix/(Windows)?
+	if {$cur == $G(LAST)} return
+	set G(LAST) $cur
+	# a little inlining - this is :hide
+	after cancel $G(AFTERID)
+	catch {wm withdraw $G(TOPLEVEL)}
+	if {[info exists tooltip($m,$cur)] || \
+		(![catch {$w entrycget $cur -label} cur] && \
+		[info exists tooltip($m,$cur)])} {
+	    set G(AFTERID) [after $G(DELAY) \
+		    [namespace code [list show $w $tooltip($m,$cur) cursor]]]
+	}
+    }
+}
+
+proc ::tooltip::hide {{fadeOk 0}} {
+    variable G
+
+    after cancel $G(AFTERID)
+    after cancel $G(FADEID)
+    if {$fadeOk && $G(fade)} {
+	fade $G(TOPLEVEL) $G(FADESTEP)
+    } else {
+	catch {wm withdraw $G(TOPLEVEL)}
+    }
+}
+
+proc ::tooltip::fade {w step} {
+    if {[catch {wm attributes $w -alpha} alpha] || $alpha <= 0.0} {
+        catch { wm withdraw $w }
+        catch { wm attributes $w -alpha 0.99 }
+    } else {
+	variable G
+        wm attributes $w -alpha [expr {$alpha-$step}]
+        set G(FADEID) [after 50 [namespace code [list fade $w $step]]]
+    }
+}
+
+proc ::tooltip::wname {{w {}}} {
+    variable G
+    if {[llength [info level 0]] > 1} {
+	# $w specified
+	if {$w ne $G(TOPLEVEL)} {
+	    hide
+	    destroy $G(TOPLEVEL)
+	    set G(TOPLEVEL) $w
+	}
+    }
+    return $G(TOPLEVEL)
+}
+
+proc ::tooltip::itemTip {w args} {
+    variable tooltip
+    variable G
+
+    set G(LAST) -1
+    set item [$w find withtag current]
+    if {$G(enabled) && [info exists tooltip($w,$item)]} {
+	set G(AFTERID) [after $G(DELAY) \
+		[namespace code [list show $w $tooltip($w,$item) cursor]]]
+    }
+}
+
+proc ::tooltip::enableCanvas {w args} {
+    $w bind all <Enter> +[namespace code [list itemTip $w]]
+    $w bind all <Leave>	+[namespace code [list hide 1]] ; # fade ok
+    $w bind all <Any-KeyPress> +[namespace code hide]
+    $w bind all <Any-Button> +[namespace code hide]
+}
+
+proc ::tooltip::tagTip {w tag} {
+    variable tooltip
+    variable G
+    set G(LAST) -1
+    if {$G(enabled) && [info exists tooltip($w,t_$tag)]} {
+        set G(AFTERID) [after $G(DELAY) \
+            [namespace code [list show $w $tooltip($w,t_$tag) cursor]]]
+    }
+}
+
+proc ::tooltip::enableTag {w tag} {
+    $w tag bind $tag <Enter> +[namespace code [list tagTip $w $tag]]
+    $w tag bind $tag <Leave> +[namespace code [list hide 1]] ; # fade ok
+    $w tag bind $tag <Any-KeyPress> +[namespace code hide]
+    $w tag bind $tag <Any-Button> +[namespace code hide]
+}
diff --git a/lib/udp1.0.9/pkgIndex.tcl b/lib/udp1.0.9/pkgIndex.tcl
new file mode 100644
index 0000000..e15a0ad
--- /dev/null
+++ b/lib/udp1.0.9/pkgIndex.tcl
@@ -0,0 +1,4 @@
+# We only have a win32-intel binary at the moment
+if {[string compare $::tcl_platform(platform) "windows"]} { return }
+if {[string compare $::tcl_platform(machine) "intel"]} { return }
+package ifneeded udp 1.0.9 [list load [file join $dir win32-ix86 udp109.dll]]
diff --git a/lib/udp1.0.9/win32-ix86/udp109.dll b/lib/udp1.0.9/win32-ix86/udp109.dll
new file mode 100644
index 0000000..8cdf176
Binary files /dev/null and b/lib/udp1.0.9/win32-ix86/udp109.dll differ
diff --git a/lib/uri/pkgIndex.tcl b/lib/uri/pkgIndex.tcl
new file mode 100644
index 0000000..c17f1a1
--- /dev/null
+++ b/lib/uri/pkgIndex.tcl
@@ -0,0 +1,6 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+    # FRINK: nocheck
+    return
+}
+package ifneeded uri      1.2.1 [list source [file join $dir uri.tcl]]
+package ifneeded uri::urn 1.0.2 [list source [file join $dir urn-scheme.tcl]]
diff --git a/lib/uri/uri.tcl b/lib/uri/uri.tcl
new file mode 100644
index 0000000..9e0344c
--- /dev/null
+++ b/lib/uri/uri.tcl
@@ -0,0 +1,1034 @@
+# uri.tcl --
+#
+#	URI parsing and fetch
+#
+# Copyright (c) 2000 Zveno Pty Ltd
+# Copyright (c) 2006 Pierre DAVID <Pierre.David@crc.u-strasbg.fr>
+# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Steve Ball, http://www.zveno.com/
+# Derived from urls.tcl by Andreas Kupries
+#
+# TODO:
+#	Handle www-url-encoding details
+#
+# CVS: $Id: uri.tcl,v 1.35 2007/01/11 19:35:23 andreas_kupries Exp $
+
+package require Tcl 8.2
+
+namespace eval ::uri {
+
+    namespace export split join
+    namespace export resolve isrelative
+    namespace export geturl
+    namespace export canonicalize
+    namespace export register
+
+    variable file:counter 0
+
+    # extend these variable in the coming namespaces
+    variable schemes       {}
+    variable schemePattern ""
+    variable url           ""
+    variable url2part
+    array set url2part     {}
+
+    # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    # basic regular expressions used in URL syntax.
+
+    namespace eval basic {
+	variable	loAlpha		{[a-z]}
+	variable	hiAlpha		{[A-Z]}
+	variable	digit		{[0-9]}
+	variable	alpha		{[a-zA-Z]}
+	variable	safe		{[$_.+-]}
+	variable	extra		{[!*'(,)]}
+	# danger in next pattern, order important for []
+	variable	national	{[][|\}\{\^~`]}
+	variable	punctuation	{[<>#%"]}	;#" fake emacs hilit
+	variable	reserved	{[;/?:@&=]}
+	variable	hex		{[0-9A-Fa-f]}
+	variable	alphaDigit	{[A-Za-z0-9]}
+	variable	alphaDigitMinus	{[A-Za-z0-9-]}
+
+	# next is <national | punctuation>
+	variable	unsafe		{[][<>"#%\{\}|\\^~`]} ;#" emacs hilit
+	variable	escape		"%${hex}${hex}"
+
+	#	unreserved	= alpha | digit | safe | extra
+	#	xchar		= unreserved | reserved | escape
+
+	variable	unreserved	{[a-zA-Z0-9$_.+!*'(,)-]}
+	variable	uChar		"(${unreserved}|${escape})"
+	variable	xCharN		{[a-zA-Z0-9$_.+!*'(,);/?:@&=-]}
+	variable	xChar		"(${xCharN}|${escape})"
+	variable	digits		"${digit}+"
+
+	variable	toplabel	\
+		"(${alpha}${alphaDigitMinus}*${alphaDigit}|${alpha})"
+	variable	domainlabel	\
+		"(${alphaDigit}${alphaDigitMinus}*${alphaDigit}|${alphaDigit})"
+
+	variable	hostname	\
+		"((${domainlabel}\\.)*${toplabel})"
+	variable	hostnumber	\
+		"(${digits}\\.${digits}\\.${digits}\\.${digits})"
+
+	variable	host		"(${hostname}|${hostnumber})"
+
+	variable	port		$digits
+	variable	hostOrPort	"${host}(:${port})?"
+
+	variable	usrCharN	{[a-zA-Z0-9$_.+!*'(,);?&=-]}
+	variable	usrChar		"(${usrCharN}|${escape})"
+	variable	user		"${usrChar}*"
+	variable	password	$user
+	variable	login		"(${user}(:${password})?@)?${hostOrPort}"
+    } ;# basic {}
+}
+
+
+# ::uri::register --
+#
+#	Register a scheme (and aliases) in the package. The command
+#	creates a namespace below "::uri" with the same name as the
+#	scheme and executes the script declaring the pattern variables
+#	for this scheme in the new namespace. At last it updates the
+#	uri variables keeping track of overall scheme information.
+#
+#	The script has to declare at least the variable "schemepart",
+#	the pattern for an url of the registered scheme after the
+#	scheme declaration. Not declaring this variable is an error.
+#
+# Arguments:
+#	schemeList	Name of the scheme to register, plus aliases
+#       script		Script declaring the scheme patterns
+#
+# Results:
+#	None.
+
+proc ::uri::register {schemeList script} {
+    variable schemes
+    variable schemePattern
+    variable url
+    variable url2part
+
+    # Check scheme and its aliases for existence.
+    foreach scheme $schemeList {
+	if {[lsearch -exact $schemes $scheme] >= 0} {
+	    return -code error \
+		    "trying to register scheme (\"$scheme\") which is already known"
+	}
+    }
+
+    # Get the main scheme
+    set scheme  [lindex $schemeList 0]
+
+    if {[catch {namespace eval $scheme $script} msg]} {
+	catch {namespace delete $scheme}
+	return -code error \
+	    "error while evaluating scheme script: $msg"
+    }
+
+    if {![info exists ${scheme}::schemepart]} {
+	namespace delete $scheme
+	return -code error \
+	    "Variable \"schemepart\" is missing."
+    }
+
+    # Now we can extend the variables which keep track of the registered schemes.
+
+    eval [linsert $schemeList 0 lappend schemes]
+    set schemePattern	"([::join $schemes |]):"
+
+    foreach s $schemeList {
+	# FRINK: nocheck
+	set url2part($s) "${s}:[set ${scheme}::schemepart]"
+	# FRINK: nocheck
+	append url "(${s}:[set ${scheme}::schemepart])|"
+    }
+    set url [string trimright $url |]
+    return
+}
+
+# ::uri::split --
+#
+#	Splits the given <a url> into its constituents.
+#
+# Arguments:
+#	url	the URL to split
+#
+# Results:
+#	Tcl list containing constituents, suitable for 'array set'.
+
+proc ::uri::split {url {defaultscheme http}} {
+
+    set url [string trim $url]
+    set scheme {}
+
+    # RFC 1738:	scheme = 1*[ lowalpha | digit | "+" | "-" | "." ]
+    regexp -- {^([a-z0-9+.-][a-z0-9+.-]*):} $url dummy scheme
+
+    if {$scheme == {}} {
+	set scheme $defaultscheme
+    }
+
+    # ease maintenance: dynamic dispatch, able to handle all schemes
+    # added in future!
+
+    if {[::info procs Split[string totitle $scheme]] == {}} {
+	error "unknown scheme '$scheme' in '$url'"
+    }
+
+    regsub -- "^${scheme}:" $url {} url
+
+    set       parts(scheme) $scheme
+    array set parts [Split[string totitle $scheme] $url]
+
+    # should decode all encoded characters!
+
+    return [array get parts]
+}
+
+proc ::uri::SplitFtp {url} {
+    # @c Splits the given ftp-<a url> into its constituents.
+    # @a url: The url to split, without! scheme specification.
+    # @r List containing the constituents, suitable for 'array set'.
+
+    # general syntax:
+    # //<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
+    #
+    # additional rules:
+    #
+    # <user>:<password> are optional, detectable by presence of @.
+    # <password> is optional too.
+    #
+    # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
+    #	<cwd1> "/" ..."/" <cwdN> "/" <name> [";type=" <typecode>]
+
+    upvar \#0 [namespace current]::ftp::typepart ftptype
+
+    array set parts {user {} pwd {} host {} port {} path {} type {}}
+
+    # slash off possible type specification
+
+    if {[regexp -indices -- "${ftptype}$" $url dummy ftype]} {
+
+	set from	[lindex $ftype 0]
+	set to		[lindex $ftype 1]
+
+	set parts(type)	[string range   $url $from $to]
+
+	set from	[lindex $dummy 0]
+	set url		[string replace $url $from end]
+    }
+
+    # Handle user, password, host and port
+
+    if {[string match "//*" $url]} {
+	set url [string range $url 2 end]
+
+	array set parts [GetUPHP url]
+    }
+
+    set parts(path) [string trimleft $url /]
+
+    return [array get parts]
+}
+
+proc ::uri::JoinFtp args {
+    array set components {
+	user {} pwd {} host {} port {}
+	path {} type {}
+    }
+    array set components $args
+
+    set userPwd {}
+    if {[string length $components(user)] || [string length $components(pwd)]} {
+	set userPwd $components(user)[expr {[string length $components(pwd)] ? ":$components(pwd)" : {}}]@
+    }
+
+    set port {}
+    if {[string length $components(port)]} {
+	set port :$components(port)
+    }
+
+    set type {}
+    if {[string length $components(type)]} {
+	set type \;type=$components(type)
+    }
+
+    return ftp://${userPwd}$components(host)${port}/[string trimleft $components(path) /]$type
+}
+
+proc ::uri::SplitHttps {url} {
+    return [SplitHttp $url]
+}
+
+proc ::uri::SplitHttp {url} {
+    # @c Splits the given http-<a url> into its constituents.
+    # @a url: The url to split, without! scheme specification.
+    # @r List containing the constituents, suitable for 'array set'.
+
+    # general syntax:
+    # //<host>:<port>/<path>?<searchpart>
+    #
+    #   where <host> and <port> are as described in Section 3.1. If :<port>
+    #   is omitted, the port defaults to 80.  No user name or password is
+    #   allowed.  <path> is an HTTP selector, and <searchpart> is a query
+    #   string. The <path> is optional, as is the <searchpart> and its
+    #   preceding "?". If neither <path> nor <searchpart> is present, the "/"
+    #   may also be omitted.
+    #
+    #   Within the <path> and <searchpart> components, "/", ";", "?" are
+    #   reserved.  The "/" character may be used within HTTP to designate a
+    #   hierarchical structure.
+    #
+    # path == <cwd1> "/" ..."/" <cwdN> "/" <name> ["#" <fragment>]
+
+    upvar #0 [namespace current]::http::search  search
+    upvar #0 [namespace current]::http::segment segment
+
+    array set parts {host {} port {} path {} query {}}
+
+    set searchPattern   "\\?(${search})\$"
+    set fragmentPattern "#(${segment})\$"
+
+    # slash off possible query. the 'search' regexp, while official,
+    # is not good enough. We have apparently lots of urls in the wild
+    # which contain unquoted urls with queries in a query. The RE
+    # finds the embedded query, not the actual one. Using string first
+    # now instead of a RE
+
+    if {[set pos [string first ? $url]] >= 0} {
+	incr pos
+	set parts(query) [string range   $url $pos end]
+	incr pos -1
+	set url          [string replace $url $pos end]
+    }
+
+    # slash off possible fragment
+
+    if {[regexp -indices -- $fragmentPattern $url match fragment]} {
+	set from [lindex $fragment 0]
+	set to   [lindex $fragment 1]
+
+	set parts(fragment) [string range $url $from $to]
+
+	set url [string replace $url [lindex $match 0] end]
+    }
+
+    if {[string match "//*" $url]} {
+	set url [string range $url 2 end]
+
+	array set parts [GetUPHP url]
+    }
+
+    set parts(path) [string trimleft $url /]
+
+    return [array get parts]
+}
+
+proc ::uri::JoinHttp {args} {
+    return [eval [linsert $args 0 ::uri::JoinHttpInner http 80]]
+}
+
+proc ::uri::JoinHttps {args} {
+    return [eval [linsert $args 0 ::uri::JoinHttpInner https 443]]
+}
+
+proc ::uri::JoinHttpInner {scheme defport args} {
+    array set components {host {} path {} query {}}
+    set       components(port) $defport
+    array set components $args
+
+    set port {}
+    if {[string length $components(port)] && $components(port) != $defport} {
+	set port :$components(port)
+    }
+
+    set query {}
+    if {[string length $components(query)]} {
+	set query ?$components(query)
+    }
+
+    regsub -- {^/} $components(path) {} components(path)
+
+    if { [info exists components(fragment)] && $components(fragment) != "" } {
+	set components(fragment) "#$components(fragment)"
+    } else {
+	set components(fragment) ""
+    }
+
+    return $scheme://$components(host)$port/$components(path)$components(fragment)$query
+}
+
+proc ::uri::SplitFile {url} {
+    # @c Splits the given file-<a url> into its constituents.
+    # @a url: The url to split, without! scheme specification.
+    # @r List containing the constituents, suitable for 'array set'.
+
+    upvar #0 [namespace current]::basic::hostname	hostname
+    upvar #0 [namespace current]::basic::hostnumber	hostnumber
+
+    if {[string match "//*" $url]} {
+	set url [string range $url 2 end]
+
+	set hostPattern "^($hostname|$hostnumber)"
+	switch -exact -- $::tcl_platform(platform) {
+	    windows {
+		# Catch drive letter
+		append hostPattern :?
+	    }
+	    default {
+		# Proceed as usual
+	    }
+	}
+
+	if {[regexp -indices -- $hostPattern $url match host]} {
+	    set fh	[lindex $host 0]
+	    set th	[lindex $host 1]
+
+	    set parts(host)	[string range $url $fh $th]
+
+	    set  matchEnd   [lindex $match 1]
+	    incr matchEnd
+
+	    set url	[string range $url $matchEnd end]
+	}
+    }
+
+    set parts(path) $url
+
+    return [array get parts]
+}
+
+proc ::uri::JoinFile args {
+    array set components {
+	host {} port {} path {}
+    }
+    array set components $args
+
+    switch -exact -- $::tcl_platform(platform) {
+	windows {
+	    if {[string length $components(host)]} {
+		return file://$components(host):$components(path)
+	    } else {
+		return file://$components(path)
+	    }
+	}
+	default {
+	    return file://$components(host)$components(path)
+	}
+    }
+}
+
+proc ::uri::SplitMailto {url} {
+    # @c Splits the given mailto-<a url> into its constituents.
+    # @a url: The url to split, without! scheme specification.
+    # @r List containing the constituents, suitable for 'array set'.
+
+    if {[string match "*@*" $url]} {
+	set url [::split $url @]
+	return [list user [lindex $url 0] host [lindex $url 1]]
+    } else {
+	return [list user $url]
+    }
+}
+
+proc ::uri::JoinMailto args {
+    array set components {
+	user {} host {}
+    }
+    array set components $args
+
+    return mailto:$components(user)@$components(host)
+}
+
+proc ::uri::SplitNews {url} {
+    if { [string first @ $url] >= 0 } {
+	return [list message-id $url]
+    } else {
+	return [list newsgroup-name $url]
+    }
+}
+
+proc ::uri::JoinNews args {
+    array set components {
+	message-id {} newsgroup-name {}
+    }
+    array set components $args
+    return news:$components(message-id)$components(newsgroup-name)
+}
+
+proc ::uri::SplitLdaps {url} {
+    ::uri::SplitLdap $url
+}
+
+proc ::uri::SplitLdap {url} {
+    # @c Splits the given Ldap-<a url> into its constituents.
+    # @a url: The url to split, without! scheme specification.
+    # @r List containing the constituents, suitable for 'array set'.
+
+    # general syntax:
+    # //<host>:<port>/<dn>?<attrs>?<scope>?<filter>?<extensions>
+    #
+    #   where <host> and <port> are as described in Section 5 of RFC 1738.
+    #   No user name or password is allowed.
+    #   If omitted, the port defaults to 389 for ldap, 636 for ldaps
+    #   <dn> is the base DN for the search
+    #   <attrs> is a comma separated list of attributes description
+    #   <scope> is either "base", "one" or "sub".
+    #   <filter> is a RFC 2254 filter specification
+    #   <extensions> are documented in RFC 2255
+    #
+
+    array set parts {host {} port {} dn {} attrs {} scope {} filter {} extensions {}}
+
+    #          host        port           dn          attrs       scope               filter     extns
+    set re {//([^:?/]+)(?::([0-9]+))?(?:/([^?]+)(?:\?([^?]*)(?:\?(base|one|sub)?(?:\?([^?]*)(?:\?(.*))?)?)?)?)?}
+
+    if {! [regexp $re $url match parts(host) parts(port) \
+		parts(dn) parts(attrs) parts(scope) parts(filter) \
+		parts(extensions)]} then {
+	return -code error "unable to match URL \"$url\""
+    }
+
+    set parts(attrs) [::split $parts(attrs) ","]
+
+    return [array get parts]
+}
+
+proc ::uri::JoinLdap {args} {
+    return [eval [linsert $args 0 ::uri::JoinLdapInner ldap 389]]
+}
+
+proc ::uri::JoinLdaps {args} {
+    return [eval [linsert $args 0 ::uri::JoinLdapInner ldaps 636]]
+}
+
+proc ::uri::JoinLdapInner {scheme defport args} {
+    array set components {host {} port {} dn {} attrs {} scope {} filter {} extensions {}}
+    set       components(port) $defport
+    array set components $args
+
+    set port {}
+    if {[string length $components(port)] && $components(port) != $defport} {
+	set port :$components(port)
+    }
+
+    set url "$scheme://$components(host)$port"
+
+    set components(attrs) [::join $components(attrs) ","]
+
+    set s ""
+    foreach c {dn attrs scope filter extensions} {
+	if {[string equal $c "dn"]} then {
+	    append s "/"
+	} else {
+	    append s "?"
+	}
+	if {! [string equal $components($c) ""]} then {
+	    append url "${s}$components($c)"
+	    set s ""
+	}
+    }
+
+    return $url
+}
+
+proc ::uri::GetUPHP {urlvar} {
+    # @c Parse user, password host and port out of the url stored in
+    # @c variable <a urlvar>.
+    # @d Side effect: The extracted information is removed from the given url.
+    # @r List containing the extracted information in a format suitable for
+    # @r 'array set'.
+    # @a urlvar: Name of the variable containing the url to parse.
+
+    upvar \#0 [namespace current]::basic::user		user
+    upvar \#0 [namespace current]::basic::password	password
+    upvar \#0 [namespace current]::basic::hostname	hostname
+    upvar \#0 [namespace current]::basic::hostnumber	hostnumber
+    upvar \#0 [namespace current]::basic::port		port
+
+    upvar $urlvar url
+
+    array set parts {user {} pwd {} host {} port {}}
+
+    # syntax
+    # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
+    # "//" already cut off by caller
+
+    set upPattern "^(${user})(:(${password}))?@"
+
+    if {[regexp -indices -- $upPattern $url match theUser c d thePassword]} {
+	set fu	[lindex $theUser 0]
+	set tu	[lindex $theUser 1]
+
+	set fp	[lindex $thePassword 0]
+	set tp	[lindex $thePassword 1]
+
+	set parts(user)	[string range $url $fu $tu]
+	set parts(pwd)	[string range $url $fp $tp]
+
+	set  matchEnd   [lindex $match 1]
+	incr matchEnd
+
+	set url	[string range $url $matchEnd end]
+    }
+
+    set hpPattern "^($hostname|$hostnumber)(:($port))?"
+
+    if {[regexp -indices -- $hpPattern $url match theHost c d e f g h thePort]} {
+	set fh	[lindex $theHost 0]
+	set th	[lindex $theHost 1]
+
+	set fp	[lindex $thePort 0]
+	set tp	[lindex $thePort 1]
+
+	set parts(host)	[string range $url $fh $th]
+	set parts(port)	[string range $url $fp $tp]
+
+	set  matchEnd   [lindex $match 1]
+	incr matchEnd
+
+	set url	[string range $url $matchEnd end]
+    }
+
+    return [array get parts]
+}
+
+proc ::uri::GetHostPort {urlvar} {
+    # @c Parse host and port out of the url stored in variable <a urlvar>.
+    # @d Side effect: The extracted information is removed from the given url.
+    # @r List containing the extracted information in a format suitable for
+    # @r 'array set'.
+    # @a urlvar: Name of the variable containing the url to parse.
+
+    upvar #0 [namespace current]::basic::hostname	hostname
+    upvar #0 [namespace current]::basic::hostnumber	hostnumber
+    upvar #0 [namespace current]::basic::port		port
+
+    upvar $urlvar url
+
+    set pattern "^(${hostname}|${hostnumber})(:(${port}))?"
+
+    if {[regexp -indices -- $pattern $url match host c d e f g h thePort]} {
+	set fromHost	[lindex $host 0]
+	set toHost	[lindex $host 1]
+
+	set fromPort	[lindex $thePort 0]
+	set toPort	[lindex $thePort 1]
+
+	set parts(host)	[string range $url $fromHost $toHost]
+	set parts(port)	[string range $url $fromPort $toPort]
+
+	set  matchEnd   [lindex $match 1]
+	incr matchEnd
+
+	set url [string range $url $matchEnd end]
+    }
+
+    return [array get parts]
+}
+
+# ::uri::resolve --
+#
+#	Resolve an arbitrary URL, given a base URL
+#
+# Arguments:
+#	base	base URL (absolute)
+#	url	arbitrary URL
+#
+# Results:
+#	Returns a URL
+
+proc ::uri::resolve {base url} {
+    if {[string length $url]} {
+	if {[isrelative $url]} {
+
+	    array set baseparts [split $base]
+
+	    switch -- $baseparts(scheme) {
+		http -
+		https -
+		ftp -
+		file {
+		    array set relparts [split $url]
+		    if { [string match /* $url] } {
+			catch { set baseparts(path) $relparts(path) }
+		    } elseif { [string match */ $baseparts(path)] } {
+			set baseparts(path) "$baseparts(path)$relparts(path)"
+		    } else {
+			if { [string length $relparts(path)] > 0 } {
+			    set path [lreplace [::split $baseparts(path) /] end end]
+			    set baseparts(path) "[::join $path /]/$relparts(path)"
+			}
+		    }
+		    catch { set baseparts(query) $relparts(query) }
+		    catch { set baseparts(fragment) $relparts(fragment) }
+            return [eval [linsert [array get baseparts] 0 join]]
+		}
+		default {
+		    return -code error "unable to resolve relative URL \"$url\""
+		}
+	    }
+
+	} else {
+	    return $url
+	}
+    } else {
+	return $base
+    }
+}
+
+# ::uri::isrelative --
+#
+#	Determines whether a URL is absolute or relative
+#
+# Arguments:
+#	url	URL to check
+#
+# Results:
+#	Returns 1 if the URL is relative, 0 otherwise
+
+proc ::uri::isrelative url {
+    return [expr {![regexp -- {^[a-z0-9+-.][a-z0-9+-.]*:} $url]}]
+}
+
+# ::uri::geturl --
+#
+#	Fetch the data from an arbitrary URL.
+#
+#	This package provides a handler for the file:
+#	scheme, since this conflicts with the file command.
+#
+# Arguments:
+#	url	address of data resource
+#	args	configuration options
+#
+# Results:
+#	Depends on scheme
+
+proc ::uri::geturl {url args} {
+    array set urlparts [split $url]
+
+    switch -- $urlparts(scheme) {
+	file {
+        return [eval [linsert $args 0 file_geturl $url]]
+	}
+	default {
+	    # Load a geturl package for the scheme first and only if
+	    # that fails the scheme package itself. This prevents
+	    # cyclic dependencies between packages.
+	    if {[catch {package require $urlparts(scheme)::geturl}]} {
+		package require $urlparts(scheme)
+	    }
+        return [eval [linsert $args 0 $urlparts(scheme)::geturl $url]]
+	}
+    }
+}
+
+# ::uri::file_geturl --
+#
+#	geturl implementation for file: scheme
+#
+# TODO:
+#	This is an initial, basic implementation.
+#	Eventually want to support all options for geturl.
+#
+# Arguments:
+#	url	URL to fetch
+#	args	configuration options
+#
+# Results:
+#	Returns data from file
+
+proc ::uri::file_geturl {url args} {
+    variable file:counter
+
+    set var [namespace current]::file[incr file:counter]
+    upvar #0 $var state
+    array set state {data {}}
+
+    array set parts [split $url]
+
+    set ch [open $parts(path)]
+    # Could determine text/binary from file extension,
+    # except on Macintosh
+    # fconfigure $ch -translation binary
+    set state(data) [read $ch]
+    close $ch
+
+    return $var
+}
+
+# ::uri::join --
+#
+#	Format a URL
+#
+# Arguments:
+#	args	components, key-value format
+#
+# Results:
+#	A URL
+
+proc ::uri::join args {
+    array set components $args
+
+    return [eval [linsert $args 0 Join[string totitle $components(scheme)]]]
+}
+
+# ::uri::canonicalize --
+#
+#	Canonicalize a URL
+#
+# Acknowledgements:
+#	Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# Arguments:
+#	uri	URI (which contains a path component)
+#
+# Results:
+#	The canonical form of the URI
+
+proc ::uri::canonicalize uri {
+
+    # Make uri canonical with respect to dots (path changing commands)
+    #
+    # Remove single dots (.)  => pwd not changing
+    # Remove double dots (..) => gobble previous segment of path
+    #
+    # Fixes for this command:
+    #
+    # * Ignore any url which cannot be split into components by this
+    #   module. Just assume that such urls do not have a path to
+    #   canonicalize.
+    #
+    # * Ignore any url which could be split into components, but does
+    #   not have a path component.
+    #
+    # In the text above 'ignore' means
+    # 'return the url unchanged to the caller'.
+
+    if {[catch {array set u [::uri::split $uri]}]} {
+	return $uri
+    }
+    if {![info exists u(path)]} {
+	return $uri
+    }
+
+    set uri $u(path)
+
+    # Remove leading "./" "../" "/.." (and "/../")
+    regsub -all -- {^(\./)+}    $uri {}  uri
+    regsub -all -- {^/(\.\./)+} $uri {/} uri
+    regsub -all -- {^(\.\./)+}  $uri {}  uri
+
+    # Remove inner /./ and /../
+    while {[regsub -all -- {/\./}         $uri {/} uri]} {}
+    while {[regsub -all -- {/[^/]+/\.\./} $uri {/} uri]} {}
+    while {[regsub -all -- {^[^/]+/\.\./} $uri {}  uri]} {}
+    # Munge trailing /..
+    while {[regsub -all -- {/[^/]+/\.\.} $uri {/} uri]} {}
+    if { $uri == ".." } { set uri "/" }
+
+    set u(path) $uri
+    set uri [eval [linsert [array get u] 0 ::uri::join]]
+
+    return $uri
+}
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+# regular expressions covering various url schemes
+
+# Currently known URL schemes:
+#
+# (RFC 1738)
+# ------------------------------------------------
+# scheme	basic syntax of scheme specific part
+# ------------------------------------------------
+# ftp		//<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
+#
+# http		//<host>:<port>/<path>?<searchpart>
+#
+# gopher	//<host>:<port>/<gophertype><selector>
+#				<gophertype><selector>%09<search>
+#		<gophertype><selector>%09<search>%09<gopher+_string>
+#
+# mailto	<rfc822-addr-spec>
+# news		<newsgroup-name>
+#		<message-id>
+# nntp		//<host>:<port>/<newsgroup-name>/<article-number>
+# telnet	//<user>:<password>@<host>:<port>/
+# wais		//<host>:<port>/<database>
+#		//<host>:<port>/<database>?<search>
+#		//<host>:<port>/<database>/<wtype>/<wpath>
+# file		//<host>/<path>
+# prospero	//<host>:<port>/<hsoname>;<field>=<value>
+# ------------------------------------------------
+#
+# (RFC 2111)
+# ------------------------------------------------
+# scheme	basic syntax of scheme specific part
+# ------------------------------------------------
+# mid	message-id
+#		message-id/content-id
+# cid	content-id
+# ------------------------------------------------
+#
+# (RFC 2255)
+# ------------------------------------------------
+# scheme	basic syntax of scheme specific part
+# ------------------------------------------------
+# ldap		//<host>:<port>/<dn>?<attrs>?<scope>?<filter>?<extensions>
+# ------------------------------------------------
+
+# FTP
+uri::register ftp {
+    variable escape [set [namespace parent [namespace current]]::basic::escape]
+    variable login  [set [namespace parent [namespace current]]::basic::login]
+
+    variable	charN	{[a-zA-Z0-9$_.+!*'(,)?:@&=-]}
+    variable	char	"(${charN}|${escape})"
+    variable	segment	"${char}*"
+    variable	path	"${segment}(/${segment})*"
+
+    variable	type		{[AaDdIi]}
+    variable	typepart	";type=(${type})"
+    variable	schemepart	\
+		    "//${login}(/${path}(${typepart})?)?"
+
+    variable	url		"ftp:${schemepart}"
+}
+
+# FILE
+uri::register file {
+    variable	host [set [namespace parent [namespace current]]::basic::host]
+    variable	path [set [namespace parent [namespace current]]::ftp::path]
+
+    variable	schemepart	"//(${host}|localhost)?/${path}"
+    variable	url		"file:${schemepart}"
+}
+
+# HTTP
+uri::register http {
+    variable	escape \
+        [set [namespace parent [namespace current]]::basic::escape]
+    variable	hostOrPort	\
+        [set [namespace parent [namespace current]]::basic::hostOrPort]
+
+    variable	charN		{[a-zA-Z0-9$_.+!*'(,);:@&=-]}
+    variable	char		"($charN|${escape})"
+    variable	segment		"${char}*"
+
+    variable	path		"${segment}(/${segment})*"
+    variable	search		$segment
+    variable	schemepart	\
+	    "//${hostOrPort}(/${path}(\\?${search})?)?"
+
+    variable	url		"http:${schemepart}"
+}
+
+# GOPHER
+uri::register gopher {
+    variable	xChar \
+        [set [namespace parent [namespace current]]::basic::xChar]
+    variable	hostOrPort \
+        [set [namespace parent [namespace current]]::basic::hostOrPort]
+    variable	search \
+        [set [namespace parent [namespace current]]::http::search]
+
+    variable	type		$xChar
+    variable	selector	"$xChar*"
+    variable	string		$selector
+    variable	schemepart	\
+	    "//${hostOrPort}(/(${type}(${selector}(%09${search}(%09${string})?)?)?)?)?"
+    variable	url		"gopher:${schemepart}"
+}
+
+# MAILTO
+uri::register mailto {
+    variable xChar [set [namespace parent [namespace current]]::basic::xChar]
+    variable host  [set [namespace parent [namespace current]]::basic::host]
+
+    variable schemepart	"$xChar+(@${host})?"
+    variable url	"mailto:${schemepart}"
+}
+
+# NEWS
+uri::register news {
+    variable escape [set [namespace parent [namespace current]]::basic::escape]
+    variable alpha  [set [namespace parent [namespace current]]::basic::alpha]
+    variable host   [set [namespace parent [namespace current]]::basic::host]
+
+    variable	aCharN		{[a-zA-Z0-9$_.+!*'(,);/?:&=-]}
+    variable	aChar		"($aCharN|${escape})"
+    variable	gChar		{[a-zA-Z0-9$_.+-]}
+    variable	newsgroup-name	"${alpha}${gChar}*"
+    variable	message-id	"${aChar}+@${host}"
+    variable	schemepart	"\\*|${newsgroup-name}|${message-id}"
+    variable	url		"news:${schemepart}"
+}
+
+# WAIS
+uri::register wais {
+    variable	uChar \
+        [set [namespace parent [namespace current]]::basic::xChar]
+    variable	hostOrPort \
+        [set [namespace parent [namespace current]]::basic::hostOrPort]
+    variable	search \
+        [set [namespace parent [namespace current]]::http::search]
+
+    variable	db		"${uChar}*"
+    variable	type		"${uChar}*"
+    variable	path		"${uChar}*"
+
+    variable	database	"//${hostOrPort}/${db}"
+    variable	index		"//${hostOrPort}/${db}\\?${search}"
+    variable	doc		"//${hostOrPort}/${db}/${type}/${path}"
+
+    #variable	schemepart	"${doc}|${index}|${database}"
+
+    variable	schemepart \
+	    "//${hostOrPort}/${db}((\\?${search})|(/${type}/${path}))?"
+
+    variable	url		"wais:${schemepart}"
+}
+
+# PROSPERO
+uri::register prospero {
+    variable	escape \
+        [set [namespace parent [namespace current]]::basic::escape]
+    variable	hostOrPort \
+        [set [namespace parent [namespace current]]::basic::hostOrPort]
+    variable	path \
+        [set [namespace parent [namespace current]]::ftp::path]
+
+    variable	charN		{[a-zA-Z0-9$_.+!*'(,)?:@&-]}
+    variable	char		"(${charN}|$escape)"
+
+    variable	fieldname	"${char}*"
+    variable	fieldvalue	"${char}*"
+    variable	fieldspec	";${fieldname}=${fieldvalue}"
+
+    variable	schemepart	"//${hostOrPort}/${path}(${fieldspec})*"
+    variable	url		"prospero:$schemepart"
+}
+
+# LDAP
+uri::register ldap {
+    variable	hostOrPort \
+        [set [namespace parent [namespace current]]::basic::hostOrPort]
+
+    # very crude parsing
+    variable	dn		{[^?]*}
+    variable	attrs		{[^?]*}
+    variable	scope		"base|one|sub"
+    variable	filter		{[^?]*}
+    # extensions are not handled yet
+
+    variable	schemepart	"//${hostOrPort}(/${dn}(\?${attrs}(\?(${scope})(\?${filter})?)?)?)?"
+    variable	url		"ldap:$schemepart"
+}
+
+package provide uri 1.2.1
diff --git a/lib/uri/urn-scheme.tcl b/lib/uri/urn-scheme.tcl
new file mode 100644
index 0000000..0819dde
--- /dev/null
+++ b/lib/uri/urn-scheme.tcl
@@ -0,0 +1,136 @@
+# urn-scheme.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sf.net>
+#
+# extend the uri package to deal with URN (RFC 2141)
+# see http://www.normos.org/ietf/rfc/rfc2141.txt
+#
+# Released under the tcllib license.
+#
+# $Id: urn-scheme.tcl,v 1.11 2005/09/28 04:51:24 andreas_kupries Exp $
+# -------------------------------------------------------------------------
+
+package require uri      1.1.2
+
+namespace eval ::uri {}
+namespace eval ::uri::urn {
+    variable version 1.0.2
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#   Called by uri::split with a url to split into its parts.
+#
+proc ::uri::SplitUrn {uri} {
+    #@c Split the given uri into then URN component parts
+    #@a uri: the URI to split without it's scheme part.
+    #@r List of the component parts suitable for 'array set'
+
+    upvar \#0 [namespace current]::urn::URNpart pattern
+    array set parts {nid {} nss {}}
+    if {[regexp -- ^$pattern $uri -> parts(nid) parts(nss)]} {
+        return [array get parts]
+    } else {
+        error "invalid urn syntax: \"$uri\" could not be parsed"
+    }
+}
+
+
+# -------------------------------------------------------------------------
+
+proc ::uri::JoinUrn args {
+    #@c Join the parts of a URN scheme URI
+    #@a list of nid value nss value
+    #@r a valid string representation for your URI
+    variable urn::NIDpart
+
+    array set parts [list nid {} nss {}]
+    array set parts $args
+    if {! [regexp -- ^$NIDpart$ $parts(nid)]} {
+        error "invalid urn: nid is invalid"
+    }
+    set url "urn:$parts(nid):[urn::quote $parts(nss)]"
+    return $url
+}
+
+# -------------------------------------------------------------------------
+
+# Quote the disallowed characters according to the RFC for URN scheme.
+# ref: RFC2141 sec2.2
+proc ::uri::urn::quote {url} {
+    variable trans
+    
+    set ndx 0
+    set result ""
+    while {[regexp -indices -- "\[^$trans\]" $url r]} {
+        set ndx [lindex $r 0]
+        scan [string index $url $ndx] %c chr
+        set rep %[format %.2X $chr]
+        if {[string match $rep %00]} {
+            error "invalid character: character $chr is not allowed"
+        }
+        
+        incr ndx -1
+        append result [string range $url 0 $ndx] $rep
+        incr ndx 2
+        set url [string range $url $ndx end]
+    }
+    append result $url
+    return $result
+}
+
+# -------------------------------------------------------------------------
+# Perform the reverse of urn::quote.
+
+if { [package vcompare [package provide Tcl] 8.3] < 0 } {
+    # Before Tcl 8.3 we do not have 'regexp -start'. We simulate it by
+    # using 'string range' and adjusting the match results.
+
+    proc ::uri::urn::unquote {url} {
+        set result ""
+        set start 0
+        while {[regexp -indices {%[0-9a-fA-F]{2}} [string range $url $start end] match]} {
+            foreach {first last} $match break
+            incr first $start ; # Make the indices relative to the true string.
+            incr last  $start ; # I.e. undo the effect of the 'string range' on match results.
+            append result [string range $url $start [expr {$first - 1}]]
+            append result [format %c 0x[string range $url [incr first] $last]]
+            set start [incr last]
+        }
+        append result [string range $url $start end]
+        return $result
+    }
+} else {
+    proc ::uri::urn::unquote {url} {
+        set result ""
+        set start 0
+        while {[regexp -start $start -indices {%[0-9a-fA-F]{2}} $url match]} {
+            foreach {first last} $match break
+            append result [string range $url $start [expr {$first - 1}]]
+            append result [format %c 0x[string range $url [incr first] $last]]
+            set start [incr last]
+        }
+        append result [string range $url $start end]
+        return $result
+    }
+}
+
+# -------------------------------------------------------------------------
+
+::uri::register {urn URN} {
+	variable NIDpart {[a-zA-Z0-9][a-zA-Z0-9-]{0,31}}
+        variable esc {%[0-9a-fA-F]{2}}
+        variable trans {a-zA-Z0-9$_.+!*'(,):=@;-}
+        variable NSSpart "($esc|\[$trans\])+"
+        variable URNpart "($NIDpart):($NSSpart)"
+        variable schemepart $URNpart
+	variable url "urn:$NIDpart:$NSSpart"
+}
+
+# -------------------------------------------------------------------------
+
+package provide uri::urn $::uri::urn::version
+
+# -------------------------------------------------------------------------
+# Local Variables:
+#   indent-tabs-mode: nil
+# End:
diff --git a/lib/uuid/pkgIndex.tcl b/lib/uuid/pkgIndex.tcl
new file mode 100644
index 0000000..94f7d14
--- /dev/null
+++ b/lib/uuid/pkgIndex.tcl
@@ -0,0 +1,8 @@
+# pkgIndex.tcl - 
+#
+# uuid package index file
+#
+# $Id: pkgIndex.tcl,v 1.2 2005/09/30 05:36:39 andreas_kupries Exp $
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded uuid 1.0.1 [list source [file join $dir uuid.tcl]]
diff --git a/lib/uuid/uuid.tcl b/lib/uuid/uuid.tcl
new file mode 100644
index 0000000..35a5ca5
--- /dev/null
+++ b/lib/uuid/uuid.tcl
@@ -0,0 +1,216 @@
+# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# UUIDs are 128 bit values that attempt to be unique in time and space.
+#
+# Reference:
+#   http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt
+#
+# uuid: scheme:
+# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html
+#
+# Usage: uuid::uuid generate
+#        uuid::uuid equal $idA $idB
+
+namespace eval uuid {
+    variable version 1.0.1
+    variable accel
+    array set accel {critcl 0}
+
+    namespace export uuid
+
+    variable uid
+    if {![info exists uid]} {
+        set uid 1
+    }
+
+    if {[package vcompare [package provide Tcl] 8.4] < 0} {
+        package require struct::list
+        interp alias {} ::uuid::lset {} ::struct::list::lset
+    }
+
+    proc K {a b} {set a}
+}
+
+# Generates a binary UUID as per the draft spec. We generate a pseudo-random
+# type uuid (type 4). See section 3.4
+#
+proc ::uuid::generate_tcl {} {
+    package require md5 2
+    variable uid
+
+    set tok [md5::MD5Init]
+    md5::MD5Update $tok [clock seconds]; # timestamp
+    md5::MD5Update $tok [clock clicks];  # system incrementing counter
+    md5::MD5Update $tok [incr uid];      # package incrementing counter 
+    md5::MD5Update $tok [info hostname]; # spatial unique id (poor)
+    md5::MD5Update $tok [pid];           # additional entropy
+    md5::MD5Update $tok [array get ::tcl_platform]
+    
+    # More spatial information -- better than hostname.
+    # bug 1150714: opening a server socket may raise a warning messagebox
+    #   with WinXP firewall, using ipconfig will return all IP addresses
+    #   including ipv6 ones if available. ipconfig is OK on win98+
+    if {[string equal $::tcl_platform(platform) "windows"]} {
+        catch {exec ipconfig} config
+        md5::MD5Update $tok $config
+    } else {
+        catch {
+            set s [socket -server void -myaddr [info hostname] 0]
+            K [fconfigure $s -sockname] [close $s]
+        } r
+        md5::MD5Update $tok $r
+    }
+
+    if {[package provide Tk] != {}} {
+        md5::MD5Update $tok [winfo pointerxy .]
+        md5::MD5Update $tok [winfo id .]
+    }
+
+    set r [md5::MD5Final $tok]
+    binary scan $r c* r
+    
+    # 3.4: set uuid versioning fields
+    lset r 8 [expr {([lindex $r 8] & 0x7F) | 0x40}]
+    lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}]
+    
+    return [binary format c* $r]
+}
+
+if {[string equal $tcl_platform(platform) "windows"] 
+        && [package provide critcl] != {}} {
+    namespace eval uuid {
+        critcl::ccode {
+            #define WIN32_LEAN_AND_MEAN
+            #define STRICT
+            #include <windows.h>
+            #include <ole2.h>
+            typedef long (__stdcall *LPFNUUIDCREATE)(UUID *);
+            typedef const unsigned char cu_char;
+        }
+        critcl::cproc generate_c {Tcl_Interp* interp} ok {
+            HRESULT hr = S_OK;
+            int r = TCL_OK;
+            UUID uuid = {0};
+            HMODULE hLib;
+            LPFNUUIDCREATE lpfnUuidCreate = NULL;
+
+            hLib = LoadLibrary(_T("rpcrt4.dll"));
+            if (hLib)
+                lpfnUuidCreate = (LPFNUUIDCREATE)
+                    GetProcAddress(hLib, "UuidCreate");
+            if (lpfnUuidCreate) {
+                Tcl_Obj *obj;
+                lpfnUuidCreate(&uuid);
+                obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid));
+                Tcl_SetObjResult(interp, obj);
+            } else {
+                Tcl_SetResult(interp, "error: failed to create a guid",
+                              TCL_STATIC);
+                r = TCL_ERROR;
+            }
+            return r;
+        }
+    }
+}
+
+# Convert a binary uuid into its string representation.
+#
+proc ::uuid::tostring {uuid} {
+    binary scan $uuid H* s
+    foreach {a b} {0 7 8 11 12 15 16 19 20 end} {
+        append r [string range $s $a $b] -
+    }
+    return [string tolower [string trimright $r -]]
+}
+
+# Convert a string representation of a uuid into its binary format.
+#
+proc ::uuid::fromstring {uuid} {
+    return [binary format H* [string map {- {}} $uuid]]
+}
+
+# Compare two uuids for equality.
+#
+proc ::uuid::equal {left right} {
+    set l [fromstring $left]
+    set r [fromstring $right]
+    return [string equal $l $r]
+}
+
+# Call our generate uuid implementation
+proc ::uuid::generate {} {
+    variable accel
+    if {$accel(critcl)} {
+        return [generate_c]
+    } else {
+        return [generate_tcl]
+    }
+}
+
+# uuid generate -> string rep of a new uuid
+# uuid equal uuid1 uuid2
+#
+proc uuid::uuid {cmd args} {
+    switch -exact -- $cmd {
+        generate {
+            if {[llength $args] != 0} {
+                return -code error "wrong # args:\
+                    should be \"uuid generate\""
+            }
+            return [tostring [generate]]
+        }
+        equal {
+            if {[llength $args] != 2} {
+                return -code error "wrong \# args:\
+                    should be \"uuid equal uuid1 uuid2\""
+            }
+            return [eval [linsert $args 0 equal]]
+        }
+        default {
+            return -code error "bad option \"$cmd\":\
+                must be generate or equal"
+        }
+    }
+}
+
+# -------------------------------------------------------------------------
+
+# LoadAccelerator --
+#
+#	This package can make use of a number of compiled extensions to
+#	accelerate the digest computation. This procedure manages the
+#	use of these extensions within the package. During normal usage
+#	this should not be called, but the test package manipulates the
+#	list of enabled accelerators.
+#
+proc ::uuid::LoadAccelerator {name} {
+    variable accel
+    set r 0
+    switch -exact -- $name {
+        critcl {
+            if {![catch {package require tcllibc}]} {
+                set r [expr {[info command ::uuid::generate_c] != {}}]
+            }
+        }
+        default {
+            return -code error "invalid accelerator package:\
+                must be one of [join [array names accel] {, }]"
+        }
+    }
+    set accel($name) $r
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help.
+namespace eval ::uuid {
+    foreach e {critcl} { if {[LoadAccelerator $e]} { break } }
+}
+
+package provide uuid $::uuid::version
+
+# -------------------------------------------------------------------------
+# Local variables:
+#   mode: tcl
+#   indent-tabs-mode: nil
+# End:
diff --git a/main.tcl b/main.tcl
new file mode 100644
index 0000000..f6e700c
--- /dev/null
+++ b/main.tcl
@@ -0,0 +1,13 @@
+# Starkit setup.
+#
+package require Tcl 8.4
+package require starkit
+if {[starkit::startup] ne "sourced"} {
+    set f [file join $starkit::topdir bin [lindex $argv 0].tcl]
+    if {[file exists $f]} {
+        set argv [lrange $argv 1 end]
+        source $f
+    } else {
+        source [file join $starkit::topdir bin bullfrog.tcl]
+    }
+}
diff --git a/nokit.tcl b/nokit.tcl
new file mode 100644
index 0000000..bf81a24
--- /dev/null
+++ b/nokit.tcl
@@ -0,0 +1,7 @@
+set auto_path [concat [file join [file dirname [info script]] lib] $auto_path]
+if {[lindex $argv 0] eq "irc"} {
+    set argv [lrange $argv 1 end]
+    source [file join [file dirname [info script]] bin irc.tcl]
+} else {
+    source [file join [file dirname [info script]] bin demo.tcl]
+}
diff --git a/tclkit.ico b/tclkit.ico
new file mode 100644
index 0000000..d7850ff
Binary files /dev/null and b/tclkit.ico differ
diff --git a/tclkit.inf b/tclkit.inf
new file mode 100644
index 0000000..46b1867
--- /dev/null
+++ b/tclkit.inf
@@ -0,0 +1,5 @@
+CompanyName "Pat Thoyts"
+LegalCopyright "Copyright (c) 2007-2008 Pat Thoyts"
+FileDescription "Bullfrog multi-user chat"
+ProductName "Bullfrog"
+ProductVersion "0.0.2.0"