package require Tcl 8.5

# Now mount our internal filesystem and add its
# modules directory to the TM search path

package require Tk
package require trofs 0.4
set mountpoint [trofs::mount [info script]]
tcl::tm::path add [file join $mountpoint modules]
foreach p [package names] {
    if {[string equal "" [package provide $p]]} {
	package forget $p
    }
}
#set auto_path [list $::tk_library]
source [file join $mountpoint tkchat.tcl]
#!/bin/sh
#
# Tk front end to the Tcl'ers chat
#
###########################################################
#
# author: Bruce B Hartweg brhartweg@bigfoot.com
# updates: Jeff Hobbs, et al
#
# This program is free to use, modify, extend at will,
# the author(s) provides no warantees, guarantees
# or any responsibility for the use, re-use, abuse
# that may or may not happen. If you somehow sell
# this and make a ton of money - good for you, how
# about sending me some?
############################################################
# \
      exec wish "$0" ${1+"$@"}


if {![info exists env(PATH)]} {
    set env(PATH) .
}

package require Tcl 8.4         ; # core Tcl
package require Tk  8.4		; # core Tk
package require http 2		; # core Tcl
package require msgcat		; # core Tcl
package require textutil	; # tcllib 1.0
package require htmlparse	; # tcllib 1.0
package require log		; # tcllib
package require base64		; # tcllib

catch {
    package require tls     ; # tls (optional)
}

# Deal with 'tile' support.
# We sometimes need to _really_ use the Tk widgets at the moment...
#
if {[llength [info command ::tk::label]] < 1} {
    foreach cmd {label radiobutton entry} {
        rename ::$cmd ::tk::$cmd
    }
    if {![catch {package require tile 0.5}]} {
        if {[namespace exists ::ttk]} {
            namespace import -force ttk::*
        } else {
            namespace import -force tile::*
        }
    }
    foreach cmd {label radiobutton entry} {
        if {[llength [info command ::$cmd]] < 1} {
            interp alias {} ::$cmd {} ::tk::$cmd
        }
    }
}

# Under windows, we can use DDE to open urls
if {$tcl_platform(platform) eq "windows"
    && $tcl_platform(os) ne "Windows CE"} {
    package require dde
}

package forget app-tkchat	;# Workaround until I can convince people
;# that apps are not packages.	:)  DGP
package provide app-tkchat \
    [regexp -inline {\d+(?:\.\d+)?} {$Revision: 1.266 $}]

# Maybe exec a user defined preload script at startup (to set Tk options,
# for example.
# just before showing the logon screen (or not), call 'tkchatrcPostload' so
# you can also tinker with settings when the UI has been built.
proc tkchatrcPostload {} {}
if {[info exists ::env(HOME)] && \
	[file readable [set rctclfile \
			    [file join $::env(HOME) .tkchatrc.tcl]]]} {
    if {[catch {uplevel \#0 source $rctclfile} err]} {
        tk_messageBox -type ok -icon error \
            -title "Error while loading \"$rctclfile\"" \
            -message $err
        log::log error $err
	exit
    }
}

namespace eval ::tkchat {
    variable chatWindowTitle "The Tcler's Chat"

    # Everything will eventually be namespaced
    variable MessageHooks
    array set MessageHooks {}
    variable ChatActivityHooks
    array set ChatActivityHooks {}

    # this is http://mini.net - but that recently had a dns problem
    variable HOST http://mini.net

    variable HEADUrl {http://cvs.sourceforge.net/viewcvs.py/tcllib/tclapps/apps/tkchat/tkchat.tcl?rev=HEAD}
    variable rcsid   {$Id: tkchat.tcl,v 1.266 2005/03/04 03:19:13 patthoyts Exp $}

    variable MSGS
    set MSGS(entered) [list \
			   "%user% has entered the chat!" \
			   "Out of a cloud of smoke, %user% appears!" \
			   "%user% saunters in." \
			   "%user% wanders in." \
			   "%user% checks into the chat." \
			   "%user% is feeling chatty!" \
			   "%user% valt door een gat in het plafond naar binnen." \
			   "%user% wandeld luid schreeuwend binnen." \
			   "%user% \u8FDB\u95E8" \
			   "%user% \u9032\u9580" \
			  ]
    set MSGS(left) [list \
			"%user% has left the chat!" \
			"In a cloud of smoke, %user% disappears!" \
			"%user% exits, stage left!" \
			"%user% doesn't want to talk to you anymore!" \
			"%user% looks at the clock and dashes out the door" \
			"%user% macht wie eine Banane ..." \
			"Ladies and Gentlemen, %user% has left the building!" \
			"%user% zakt door de vloer en is weg." \
			"%user% vertrekt stilletjes." \
		       ]

    # Variables to control the search function.
    variable searchString ""
    variable searchOffset end

    # a variable to support nickname completion
    variable lastCompletion ""

    variable ircOnlineUsers [list]

    # used for dynamically created command aliases (added by JJM 25/Sep/2003)
    variable commandAliases
    array set commandAliases [list names [list] types [list] bodies [list]]

    #NoisyUsers: temporarily hide users who are blabbering
    variable noisyUsers
    variable MessageCounter 0
}

# Tcl8.3 compatibility procs
if {[package vcompare [package provide Tcl] 8.3] == 0} {
    proc ::tkchat::tk_windowingsystem {} {
        if {[string equal $::tcl_platform(platform) "windows"]} {
            return "win32"
        } elseif {[string equal $::tcl_platform(platform) "unix"]} {
            return "x11"
        } else {
            return "dontcare"
        }
    }
} else {
    interp alias {} ::tkchat::tk_windowingsystem {} tk windowingsystem
}

# -------------------------------------------------------------------------

msgcat::mcmset en_gb { Login "Connect" Logout "Disconnect" }
msgcat::mcmset de    {
    Login "Login" Logout "Ausloggen" Yes "Ja" No "Nein"
    "Subscribe request from %s" "Subskriptionsanfrage von %s"
}
msgcat::mcmset fr {
    Login "Se connecter" Logout "Se d\u00e9connecter" Yes "Oui" No "Non"
    "Subscribe request from %s" "Requ\u00eate d'enregistrement de %s"
}

# -------------------------------------------------------------------------

proc ::tkchat::errLog {args} {
    log::logMsg [join $args]
    update idletasks;			# why are we doing this??
}

# trace handler to set the log level whenever Options(LogLevel) is changed
# enable the selected level and above
proc ::tkchat::LogLevelSet {args} {
    global Options
    log::lvSuppressLE emergency 0	  ;# unsuppress all
    log::lvSuppressLE $Options(LogLevel)  ;# suppress all below selected
    log::lvSuppress $Options(LogLevel) 0  ;# unsupress selected
}

#  Pop the nth element off a list. Used in options processing.
proc ::tkchat::Pop {varname {nth 0}} {
    upvar $varname args
    set r [lindex $args $nth]
    set args [lreplace $args $nth $nth]
    return $r
}

# If Proxy Authentication was specified then each HTTP request
# must have an authentication header. This procedure supports
# proxys accepting Basic authentication by builing the header
# required from the users login and password.
#  - PT
proc ::tkchat::buildProxyHeaders {} {
    global Options
    set auth {}
    if { $Options(UseProxy)
	 && [info exists Options(ProxyUsername)]
	 && $Options(ProxyUsername) != {}
     } then {
	if {![info exists Options(ProxyAuth)]} {
	    set Options(ProxyAuth) \
		[list "Proxy-Authorization" \
		     [concat "Basic" \
			  [base64::encode \
			       $Options(ProxyUsername):$Options(ProxyPassword)]]]
	}
	set auth $Options(ProxyAuth)
    }
    return $auth
}

# Retrieve the lastest version of tkchat from the SourceForge CVS.
# This code is (almost) entirely ripped from TkCon. - PT.
proc ::tkchat::Retrieve {} {
    variable HEADUrl
    set rcsVersion {}

    set defExt ""
    if {[string match "windows" $::tcl_platform(platform)]} {
	set defExt ".tcl"
    }

    set file [tk_getSaveFile -title "Save Latest TkChat to ..." \
		  -defaultextension $defExt \
		  -initialdir [file dirname $::argv0] \
		  -initialfile [file tail $::argv0] \
		  -parent . \
		  -filetypes {{"Tcl Files" {.tcl .tk}} {"All Files" {*.*}}}]
    if {[string compare $file ""]} {
	set token [::http::geturl $HEADUrl \
		       -headers [buildProxyHeaders] -timeout 30000]
	::http::wait $token
        if {[string equal [::http::status $token] "ok"] && \
                [::http::ncode $token] == 200} {
            set code [catch {
                set data [::http::data $token]
                if {[string length $data] < 1} {
                    return -code error "Document was empty"
                }
                set fid [open $file w]
                fconfigure $fid -translation binary
                puts -nonewline $fid $data
                close $fid
                regexp -- {Id: tkchat.tcl,v (\d+\.\d+)} $data -> rcsVersion
            } err]
        } else {
            set code 1
            set err [::http::error $token]
            if {[string length $err] < 1} {
                # limit this to 30 lines
                set err [join [lrange [split [http::data $token] "\n"] 0 30] "\n"]
            }
        }

	::http::cleanup $token

	if {$code} {
	    tk_messageBox -type ok -icon error \
		-title "Error retrieving tkchat from CVS" \
		-message $err
	    log::log error $err
	} else {
	    set resource? [tk_messageBox -type yesno -icon info \
			       -title "Retrieved tkchat $rcsVersion" \
			       -message "Successfully retrieved v$rcsVersion.\
		    Do you want to reload from the new version?"]
	    if {${resource?} == "yes"} {
		Debug reload
	    }
	}
    }
}

# Check the HTTP response for redirecting URLs. - PT
proc ::tkchat::checkForRedirection {tok optionName} {
    global Options
    set ncode [::http::ncode $tok]
    if {[expr {$ncode == 302 || $ncode == 301 || $ncode == 307}]} {
	upvar \#0 $tok state
	array set meta $state(meta)
	if {[info exists meta(Location)]} {
	    set Options($optionName) $meta(Location)
	    return 1
	}
    }
    return 0
}

proc ::tkchat::GetHistLogIdx {url} {
    if {[catch {::http::geturl $url -headers [buildProxyHeaders] \
                    -command [list ::tkchat::fetchurldone \
                                  ::tkchat::GotHistLogIdx]} msg]} {
        addSystem "Unable to obtain history from $url: \"$msg\"" end ERROR
    }
}

proc ::tkchat::GotHistLogIdx {tok} {
    global Options
    set loglist {}

    set RE {<A HREF="([0-9\-%d]+\.tcl)">.*\s([0-9]+) bytes}
    foreach line [split [::http::data $tok] \n] {
        # puts "$RE $line"
        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]
    log::log debug "Logs: $loglist"
    after idle [list [namespace origin LoadHistoryFromIndex] $loglist]
    return
}

proc ::tkchat::ParseHistLog {log {reverse 0}} {
    global Options

    set url "$Options(JabberLogs)/$log"
    set retList {}
    set MsgRE {^\s*(?:Mon|Tue|Wed|Thu|Fri|Sat|Sun).+?\[([^\]]+)\]\s+([^:]+):?\s*(.*)$}
    set ircRE {ircbridge: \*\*\* (.+) (.+)$}
    set TimeRE {^(.+?)\s+(.+?)\s+(\d{1,2})\s+(\d\d:\d\d:\d\d)\s+(\d{4})}

    set logTime 0
    # fetch log
    log::log info "History: Fetch log \"$url\""
    set tok [::http::geturl $url \
                   -headers [buildProxyHeaders]]

    errLog "History: status was [::http::status $tok] [::http::code $tok]"
    switch -- [::http::status $tok] {
        ok {
	    # Jabber logs
	    set I [interp create -safe]
	    interp alias $I m {} ::tkjabber::ParseLogMsg
	    if { $reverse } {
		set histTmp $::tkjabber::HistoryLines
		set ::tkjabber::HistoryLines {}
	    }
	    $I eval [::http::data $tok]
	    if { $reverse } {		
		set ::tkjabber::HistoryLines [concat $::tkjabber::HistoryLines $histTmp]
	    }
	    #set retList [tkjabber::LogMsgLines]
	
        }
        reset {
            errLog "History fetch was reset."
        }
        timeout {
            errLog "History fetch timed out"
        }
        error {
            tk_messageBox -message "History fetch error: [::http::error $tok]"
        }
    }
    ::http::cleanup $tok
    return $retList
}

# this called on first logon and after a purge
# so not bothering to backgound it
proc ::tkchat::LoadHistory {} {
    global Options

    # hook in the translation menu initialization (background function)
    if {$Options(UseBabelfish)} {
        babelfishMenu
    }

    set FinalList {}
    if {$Options(HistoryLines) != 0} {
        set url "$Options(JabberLogs)/?pattern=*.tcl"
	GetHistLogIdx $url
    }
}

# Called once we have acquired the log file index.
# logindex is a list of "filename sizeK filename ...."
proc ::tkchat::LoadHistoryFromIndex {logindex} {
    global Options
    set FinalList {}
    set loglist {}
    array set logsize {}

    foreach {name size} $logindex {
        lappend loglist $name
        set logsize($name) $size
    }

    if {$Options(HistoryLines) < 0} {
	if {[llength $loglist] > 0} {
	    # ask user
	    set t [toplevel .histQ -class dialog]
	    wm withdraw $t
	    wm transient $t
	    wm protocol $t WM_DELETE_WINDOW { }
	    wm title $t "Load History From Logs"
	    grid [label $t.lbl \
		    -text "Please select how far back you want to load:"] \
		    -sticky ew -pady 5
	    set i 0
	    variable HistQueryNum [llength $loglist]
	    foreach l $loglist {
		grid [radiobutton $t.rb$i -text "$l ($logsize($l))" \
			-val $i -var ::tkchat::HistQueryNum] \
			-sticky w -padx 15 -pady 0
		incr i
	    }
	    grid [radiobutton $t.rb$i -text "None" \
		    -val $i -var ::tkchat::HistQueryNum] \
		    -sticky w -padx 15 -pady 0
	    grid [button $t.ok -text Ok -width 8 -command [list destroy $t] \
		    -default active] \
		    -sticky e -padx 5 -pady 10
	    grid columnconfigure $t 0 -weight 1
	    bind $t <Return> [list $t.ok invoke]
	    catch {::tk::PlaceWindow $t widget .}
	    wm deiconify $t
	    tkwait visibility $t
            focus $t.ok
	    grab $t
	    tkwait window $t
	    foreach log [lrange $loglist $HistQueryNum end] {
		if {[catch {ParseHistLog $log} new]} {
		    log::log error "error parsing history: \"$new\""
		} else {
		    set FinalList [concat $FinalList $new]
		}
	    }
	}
    } else {
	# go thru logs in reverse until N lines loaded
	for {set idx [expr {[llength $loglist] - 1}]} {$idx >= 0} {incr idx -1} {
	    # fetch log
	    set log [lindex $loglist $idx]
	    if {[catch {ParseHistLog $log 1} new]} {
                log::log error "error parsing history: \"$new\""
	    } else {
		set FinalList [concat $new $FinalList]
	    }
	    if { [::tkjabber::HistoryLines] >= $Options(HistoryLines) } {
		break
	    }
	}
    }

    # Set a mark for the history insertion point.
    #set pos "[.txt index end] - 1 line"
    .txt config -state normal
    if {[lsearch [.txt mark names] HISTORY] == -1} {
        .txt insert 0.0 \
            "+++++++++++++++++++++ Loading History +++++++++++++++++++++\n"
        .txt mark set HISTORY 0.0
    }

    set Options(FinalList) $FinalList

    .txt config -state disabled
    .txt see end

    ::tkjabber::LoadHistoryLines
}


proc ::tkchat::LoadHistoryLines {} {
    global Options

    set state [.txt cget -state]
    .txt configure -state normal

    log::log debug LoadHistoryLines

    # mask the alerts
    set alerts [array get Options Alert,*]
    foreach {alert value} $alerts { set Options($alert) 0 }

    if {![info exists Options(FinalList)]} {set Options(FinalList) {}}

    set count 0
    foreach {time nick msg} $Options(FinalList) {
        addMessage "" $nick $msg HISTORY $time
        incr count 3
        if {$count > 100} { break }
    }
    #.txt see end
    set Options(FinalList) [lrange $Options(FinalList) $count end]

    # Restore the alerts
    array set Options $alerts

    if {$Options(FinalList) == {}} {
        log::log debug "History loading completed."
        .txt configure -state normal
        .txt delete "HISTORY + 1 char" "HISTORY + 1 line"
        .txt insert "HISTORY + 1 char" \
            "+++++++++++++++++++++ End Of History +++++++++++++++++++++\n"
#        .txt see end
    } else {
        after idle [list after 0 ::tkchat::LoadHistoryLines]
    }

    .txt configure -state $state
}


proc ::tkchat::msgSend {str {user ""}} {

    ::tkjabber::msgSend $str -user $user	
}


proc ::tkchat::logonChat {{retry 0}} {
    global Options
    if {0} {	
        # use when testing only - allows restarts without actually logging in again
        catch {pause off}
        return
    }

    # These package requires should be moved to the top of the script
    # when jabber support matures.
    lappend ::auto_path [file join [file dirname [info script]] lib]
    package require sha1;               # tcllib
    package require jlib;               # jlib
    package require browse;             # jlib
    package require muc;                # jlib	
    #package require jlibhttp;          # jlib

    if {[info exists Options(JabberDebug)] && $Options(JabberDebug)} {
        set jlib::debug 2
    }

    # Logon to the jabber server.
    tkjabber::connect
}

# -------------------------------------------------------------------------
# Error handling for http requests (history etc)

# Display the error message returned when an HTTP request results
# in an authentication error.
# Do NOT clean up this token - that's the callers job.
#
proc ::tkchat::AuthenticationError {token {prefix ""}} {
    log::log error "$prefix error: [http::code $token]"
    variable msgtext ""
    htmlparse::parse \
        -cmd [list ::tkchat::ErrorMessageParse ::tkchat::msgtext] \
        [http::data $token]
    set msgtext [regsub -all -line "\n{1,}" $msgtext "\n"]
    tk_messageBox \
        -title [http::code $token] \
        -icon warning \
        -message $msgtext
    unset msgtext
}

proc ::tkchat::ErrorMessageParse {varname tag end attr text} {
    upvar #0 $varname v
    set tag [string tolower $tag]
    set end [string length $end]
    if {[string equal $tag "hmstart"] && $end == 0} {
        set v ""
    } elseif {[string match "h*" $tag] && $end == 0} {
        append v "\n$text"
    } elseif {[string equal "p" $tag] && $end == 0} {
        append v "\n$text"
    } elseif {[string equal "pre" $tag] && $end == 0} {
        append v "\n$text"
    } elseif {[string equal "a" $tag]} {
        append v "$text"
    }
}

proc ::tkchat::HttpServerError {token {prefix ""}} {
    set msg "$prefix error: [::http::code $token]"
    log::log error $msg
    tk_messageBox -message $msg
}

# -------------------------------------------------------------------------
# Translate the selection using Babelfish.
# -------------------------------------------------------------------------

proc ::tkchat::fetchurldone {cmd tok} {
    errLog "fetchurl: status was [::http::status $tok] [::http::code $tok]"
    switch -- [::http::status $tok] {
	ok - OK - Ok {
            if {[::http::ncode $tok] >= 500} {
                HttpServerError $tok
            } elseif {[::http::ncode $tok] >= 400} {
                AuthenticationError $tok
            } else {
                $cmd $tok
            }
	}
	reset - Reset - RESET {
	    errLog "Reset called during fetch of URL"
	}
	timeout - Timeout - TIMEOUT {
	    errLog "Timeout occurred during fetch of URL"
	}
	error - Error - ERROR {
	    tk_messageBox -message "Fetch URL error: [::http::error $tok]"
	}
    }
    ::http::cleanup $tok
}

proc ::tkchat::translateSel {from to} {
    if {![catch {selection get} msg]} {
        log::log debug "translate: $from $to \"$msg\""
        translate $from $to $msg
    }
}

proc ::tkchat::translate {from to text} {
    set url {http://babelfish.altavista.com/babelfish/tr}
    append op $from _ $to
    set query [http::formatQuery tt urltext urltext $text lp $op]
    set hdrs [buildProxyHeaders]
    lappend hdrs "Accept-Charset" "ISO-8859-1,utf-8"
    set tok [http::geturl $url -query $query -headers $hdrs \
             -command [list ::tkchat::fetchurldone ::tkchat::translateDone]]
}

proc ::tkchat::translateDone {tok} {
    set ::tkchat::translate [http::data $tok]
    set r [regexp {<td.*?class=s><div.*?>(.*)</div>} \
            [::http::data $tok] -> text]
    if {$r} {
        showInfo Translation [string trim $text]
    } else {
        errLog "Translation returned no matching data."
    }
}

proc ::tkchat::babelfishInit {{url http://babelfish.altavista.com/babelfish/}} {
    set tok [http::geturl $url \
             -headers [buildProxyHeaders] \
             -command [list ::tkchat::fetchurldone \
                            ::tkchat::babelfishInitDone]]
}

proc ::tkchat::babelfishInitDone {tok} {
    log::log debug "Babelfish init done."
    set ::tkchat::babelfish [http::data $tok]
    if {[regexp {<select name="lp"[^>]*?>(.*?)</select>} [::http::data $tok] -> r]} {
        .mbar.help.tr delete 0 end
        set lst [split [string trim $r] \n]
        foreach option $lst {
            regexp {<option value="(.*?)"[^>]*>(.*?)</option>} \
                    $option -> value label
            set value [split $value _]
            #log::log debug "option: $label $value"
            .mbar.help.tr add command -label $label \
                    -command [concat [namespace current]::translateSel $value]
            variable babelfishinit
            set babelfishinit 1
        }
    } else {
        log::log debug "babelfish received no data"
    }
}

proc ::tkchat::babelfishMenu {} {
    set menu .mbar.help
    if {![winfo exists ${menu}.tr]} {
        log::log debug "Initializing babelfish translation"
        set tr [menu ${menu}.tr]

        # Add to the Help->Translate menu
        catch {
            set ndx [$menu index "Translate Selection"]
            $menu entryconfigure $ndx -menu $tr
        }

        # Add to the context menu
        catch {
            set ndx [.mbar.mm index "Translate"]
            .mbar.mm entryconfigure $ndx -menu $tr
        }
        ::tkchat::babelfishInit
    }
}

proc ::tkchat::babelfishMenuPost {x y} {
    variable babelfishinit 0
    log::log debug "babelfishmenu post"
    if {![winfo exists .mbar.tr]} {
        babelfishMenu
        tkwait variable babelfishinit
    }
    .mbar.help.tr post $x $y
}

# -------------------------------------------------------------------------

proc tkchat::updateIrcUsers { who what } {
    global Options
    variable ircOnlineUsers
    set userNo [lsearch -exact $ircOnlineUsers $who]

    #Check for rename:
    if { [regexp {([^ ]+) is now known as} $who -> realwho] } {
	updateIrcUsers $realwho leaves
	updateIrcUsers $what joins
	return
    }

    switch $what {
	joins {
	    if { $userNo == -1 } {
		lappend ircOnlineUsers $who
	    }
	}
	leaves {
	    if { $userNo > -1 } {
		set ircOnlineUsers [lreplace $ircOnlineUsers $userNo $userNo]
	    }
	}
	default {
	    log::log debug "Unknown ircbridge user update action '$what'"
	}
    }

}

proc ::tkchat::MsgTo {{user "All Users"}} {
    global Options
    variable MsgToColors

    set windows [list .eMsg .tMsg]
    if {![info exists MsgToColors]} {
        foreach w $windows {
            set MsgToColors($w,normal) [$w cget -bg]
            set MsgToColors($w,whisper) $Options(WhisperIndicatorColor)
        }
    }

    if {$user == "All Users"} {
        set type normal
    } else {
        set type whisper
    }

    foreach w $windows {
        $w configure -bg $MsgToColors($w,$type)
    }

    set Options(MsgTo) $user
}

proc ::tkchat::invClr {clr {grays 0}} {
    # generally this is used to get a color that shows
    # up on a dark BG if it was originally a white BG
    # so even the color is grey & the inv color is also
    # grey that is OK
    set r 0; set g 0; set b 0 ;# default to black
    scan $clr %2x%2x%2x r g b
    set R [expr {(~$r)%256}]
    set G [expr {(~$g)%256}]
    set B [expr {(~$b)%256}]
    # A little extra magic to avoid near shades of grey
    if {$grays && abs($R-$r) < 32 && abs($G-$g) < 32 && abs($B-$b) < 32} {
        set R [expr {($r+128)%256}]
        set G [expr {($g+128)%256}]
        set B [expr {($b+128)%256}]
    }
    return [format "%02x%02x%02x" $R $G $B]
}

proc ::tkchat::getColor {name} {
    global Options
    if {[catch {
	set w $Options(Color,$name,Which)
	set clr $Options(Color,$name,$w)
    } err]} {
	set clr ""
	errLog "bad color name '$name'"
    }
    return $clr
}

proc ::tkchat::fadeColor {color} {
    if {[scan $color "%2x%2x%2x" r g b] == 3} {
	foreach c {r g b} {
	    set $c [expr {255 - int((255-[set $c]) * .5)}]
	}
	set color [format "%02x%02x%02x" $r $g $b]
    }
    return $color
}

namespace eval ::tkchat {
    variable UserClicked 0
    variable RE
    array set RE {
        HelpStart {^<FONT COLOR="(.+?)"><B>\[(.+?)\]</B>(.*)$}
        MultiStart {^<FONT COLOR="(.+?)"><B>(\S+?)</B>:(.*?)$}
        ActionStart {^<FONT COLOR="(.+?)"><B>\*\s+(\S+?)\s+(.+)$}
        SectEnd {^(.*)</FONT>$}
        Color {^<FONT COLOR="(.+?)">(.*?)</FONT>$}
        Message {^<B>(\S+?)</B>:(.+?)$}
        Help {^<B>\[(.+?)\]</B>(.*)$}
        Action {^<B>\*\s+(\S+)\s+(.+)</B>$}
        Traffic {^<B>\s*(\S+)\s+has (entered|left) the chat</B>$}
        System {^<B>(.*)</B>$}
	IrcUsers {^<B>ircbridge</B>: \*\*\* ([^ ]+) (joins|leaves)$}
	IrcUserRename {^<B>ircbridge</B>: \*\*\* ([^ ]+) is now known as ([^ ]+)$}
    }
}

proc ::tkchat::stripStr {str} {
    return $str
}

proc ::tkchat::parseStr {str} {
    global Options
    # get href info return list of str link pairs
    set sList {}
    set HTTPRE {(?x)(https?|ftp)://
	[[:alnum:]]+[^[:space:]]*[^[:space:].,!;&?()\[\]{}<>:'\"]+
    }
    while {[regexp -nocase -- $HTTPRE $str url]} {
	set pre ""
	set post ""
	set pos [string first $url $str]
	if { $pos > 0 } {
	    set pre [string range $str 0 [expr {$pos-1}]]			
	}
	set post [string range $str [expr {$pos+[string length $url]}] end]
	
	if {[string length $pre]} {
	    lappend sList [stripStr $pre] ""
	}
	lappend sList [stripStr $url] $url
	set str $post
    }    	

    if {[string length $str]} {
	lappend sList [stripStr $str] ""
    }
    set out {}
    # Assume any 6 or 7-digit sequence is a SF bug id and make URLs for them
    foreach {str url} $sList {
	if {[string length $url]} {
	    lappend out $str $url
	    continue
	}
	while {[regexp -- {^(.*?)(\m[0-9]{6,7}\M)(.*?)$} \
		    $str -> pre id post]} {
	    if {[string length $pre]} {
		lappend out $pre ""
	    }
	    set url "http://sourceforge.net/support/tracker.php?aid=$id"
	    lappend out $id $url
	    set str $post
	}
	if {[string length $str]} {
	    lappend out $str ""
	}
    }
    return $out
}

proc ::tkchat::checkNick {nick clr} {
    global Options

    set wid [expr {[font measure NAME $nick] + 10}]
    if {$wid > $Options(Offset)} {	
        set Options(Offset) $wid
	
	# Maybe limit the nick column width a bit...
	set max [expr {[font measure NAME [string repeat X 12]]+10}]
	if { $Options(Offset) > $max } {
	    set Options(Offset) $max
	}
	
	# Set tabs appropriate for STAMP visibility
	StampVis
    }
    if {$clr == ""} {
        set clr [getColor $nick]
        if {$clr == ""} {
            set clr [getColor MainFG]
        }
    }
    if {[lsearch -exact $Options(NickList) $nick] < 0} {
        lappend Options(NickList) $nick
        set Options(Color,$nick,Web) $clr
        set Options(Color,$nick,Inv) [::tkchat::invClr $clr]
        set Options(Color,$nick,Mine) $clr
        set Options(Color,$nick,Which) Web
        ::tkchat::NickVisMenu
    }
    if {![info exists Options(Color,$nick,Web)] ||
        [string compare $Options(Color,$nick,Web) $clr]} {
        # new color
        set Options(Color,$nick,Web) $clr
        set Options(Color,$nick,Inv) [::tkchat::invClr $clr]
        if {![info exists Options(Color,$nick,Mine)]} {
            set Options(Color,$nick,Mine) [getColor MainFG]
        }
        set clr [getColor $nick]
        if {$clr == ""} { set clr [getColor MainFG] }
	if {[catch {
	    .txt tag configure NICK-$nick -foreground "#$clr"
	    .txt tag configure NOLOG-$nick -foreground "#[fadeColor $clr]"
	} msg]} then { log::log debug "nickCheck: \"$msg\"" }
    }
}

# Beep and/or deiconify and raise the main window as an idle callback.
# This is done as an idle callback because there might be many requests
# to alert in a row and we want to batch them all together into one
# action.
#
proc ::tkchat::alertWhenIdle {} {
    variable alert_pending
    if {![info exists alert_pending]} {
        set alert_pending 1
        after idle [namespace origin alertCallback]
    }
}
proc ::tkchat::alertCallback {} {
    variable alert_pending
    global Options
    catch {unset alert_pending}
    if {$Options(Alert,RAISE) && [llength [focus -displayof .]]==0} {
	# Only call this if the window doesn't already have focus
        wm deiconify .
        raise .
    }
    if {$Options(Alert,SOUND)} bell
}


# Check to see if an alert is desired for the given message.  Issue
# the alert if so.
#
# As a side effect, record the time of last post for user $nick in
# the global LastPost() array.
#
proc ::tkchat::checkAlert {msgtype nick str} {
    global Options LastPost
    set now [clock seconds]
    set LastPost($nick) $now
    set x Alert,$msgtype
    if {![info exists Options($x)] || !$Options($x)} {
        return
    }
    set alert 0
    if {$Options(Alert,ALL)} {
        set alert 1
    }
    if {!$alert && $Options(Alert,ME)} {
        set myname [string tolower $Options(Username)]
        set txt [string tolower $str]
        if {[string first $myname $txt]>=0} {
            set alert 1
        }
    }
    if {!$alert && $Options(Alert,TOPIC)} {
        if {![info exists LastPost($nick)] || $LastPost($nick)<$now-300} {
            set alert 1
        }
    }
    if {$alert} {
        alertWhenIdle
    }
}

proc ::tkchat::addMessage {clr nick str {mark end} {timestamp 0} {extraOpts ""}} {
    global Options
    variable map
    set w .txt

    array set opts $extraOpts

    if {[string equal $nick "ircbridge"]} {
	if {[regexp {^([^ ]+) says: (.*)$} $str -> truenick msg]} {
	    # Use their true nick, but display bridge users as <$nick>
	    # This allows people registered in both systems to appear
	    # with the right color info.
	    set nick <$truenick>
	    set str  $msg

	    if { [nickIsNoisy $nick] } {
		return
	    }

	    if {[string equal $truenick "ijchain"]
                || [string equal $truenick "ijbridge"]} {
		# ijchain is a Jabber to IRC link.
		if {[regexp {&lt;(.*?)&gt; (.*)$} $str -> truenick msg]} {
		    set nick "<$truenick>"
		    set str $msg
		    if { [regexp {^/me (.+)$} $msg -> action] } {
			addAction $clr "$nick" $action $mark
			return
		    }
		}
	    }
	    #Probably obsolete regexp now ircbridge parses CTCPs:
	    if { [regexp {^ACTION (.+)} $str -> action] } {
		addAction $clr "<$nick>" [string range $action 0 end-1] $mark
		return
	    }
	} elseif {[regexp {^\* ([^ ]+) (.*)$} $str -> truenick msg] } {
	    addAction $clr "<$truenick>" $msg $mark
	    return
	}
    }

    if { [nickIsNoisy $nick] } {
	return
    }

    #for colors, it is better to extract the displayed nick from the one used for
    #tags.
    set displayNick $nick
    regexp {^<(.+)>$} $nick displayNick nick

    checkNick $nick $clr
    checkAlert NORMAL $nick $str
    $w config -state normal
    if {[string equal $nick "clock"] || [string equal $nick "tick"]} {
	$w insert $mark "\t" [list STAMP]
	$w insert $mark "$nick\t" [list NICK NICK-$nick]
        $w insert $mark "[formatClock $str] " [list NICK-$nick MSG]
    } else {
	::tkchat::InsertTimestamp $w $nick $mark $timestamp	
	$w insert $mark "$displayNick\t" [list NICK NICK-$nick]
        foreach {str url} [parseStr $str] {
            foreach cmd [array names ::tkchat::MessageHooks] {
                eval $cmd [list $nick $str $url]
            }
	    if { [info exists opts(nolog)] } {
		set tags [list MSG NOLOG-$nick NOLOG]
	    } else {
		set tags [list MSG NICK-$nick]
	    }
            if {$url != ""} {
                lappend tags URL URL-[incr ::URLID]
                $w tag bind URL-$::URLID <1> [list ::tkchat::gotoURL $url]
            }

	    # Split into lines, so we can insert the proper tabs for
	    # timestamps:
	    set lines [split $str \n]
	    for { set i 0 } { $i < [llength $lines] } { incr i } {
		set line [lindex $lines $i]
		if { $i > 0 } {
		    # The first line has the timestamp, only
		    # subsequent lines need an extra tab char
		    log::log debug "More than one line, add tabs"
		    $w insert $mark "\n" {} "\t" [list STAMP]		
		    set line "\t$line"
		}
		tkchat::Insert $w $line $tags $url $mark
	    }
        }
        # Call chat activity hooks
        foreach cmd [array names ::tkchat::ChatActivityHooks] {
            eval $cmd
        }
    }
    $w insert $mark "\n" [list NICK NICK-$nick]
    $w config -state disabled
if 0 {
puts ##############################
    if {[puts #\t***; format 1] && $Options(AutoScroll) && [puts #######; format 1]} { $w see end }
}
    if {$Options(AutoScroll)} { $w see end }
}

# Provide an indication of the number of messages since the window was last
# in focus.
proc ::tkchat::IncrMessageCounter {} {
    variable chatWindowTitle
    variable MessageCounter
    if {[focus] != {} } {
        ResetMessageCounter
    } else {
        incr MessageCounter
        set title "$MessageCounter - $chatWindowTitle"
        wm title . $title
        wm iconname . $title
    }
}
proc ::tkchat::ResetMessageCounter {} {
    variable MessageCounter
    variable chatWindowTitle
    set MessageCounter 0
    set title $chatWindowTitle
    wm title . $title
    wm iconname . $title
}

proc ::tkchat::InsertTimestamp {w nick {mark end} {seconds 0} {tags ""}} {

    # The nick argument is here, so we can display the local time for
    # each nick.

    if { $seconds == 0 } { set seconds [clock seconds] }

    $w insert $mark "\[[clock format $seconds -format %H:%M]\]\t" \
	[concat [list STAMP] $tags]
}

proc ::tkchat::Insert {w str tags {url ""} {mark end}} {
    global Options
    set str [string map {"\n" "\n\t"} $str]
    # Don't do emoticons on URLs
    if {($url == "") && $Options(emoticons)} {
	variable IMG
	variable IMGre
	set i 0
	foreach match [regexp -inline -all -indices -- $IMGre $str] {
	    foreach {start end} $match {break}
	    set emot [string range $str $start $end]
	    if {[info exists IMG($emot)]} {
		$w insert $mark [string range $str $i [expr {$start-1}]] $tags
                set idx [$w index "$mark -1 char"]
		$w image create $mark -image ::tkchat::img::$IMG($emot)
                foreach tg $tags {
                    $w tag add $tg $idx
                }
	    } else {
		$w insert $mark [string range $str $i $end] $tags
	    }
	    set i [expr {$end+1}]
	}
	if {$i <= [string length $str]} {
	    $w insert $mark [string range $str $i end] $tags
	}
    } else {
	# no emoticons?  perish the thought ...
	$w insert $mark $str $tags
    }
}

proc ::tkchat::Hook {do type cmd} {
    switch -glob -- $type {
	msg - mes* { set var [namespace current]::MessageHooks }
        chat       { set var [namespace current]::ChatActivityHooks }
	default {
	    return -code error "unknown hook type \"$type\": must be\
		    message or chat"
	}
    }
    switch -exact -- $do {
	add	{
            # FRINK: nocheck
            set ${var}($cmd) {}
        }
	remove	{
            # FRINK: nocheck
            catch {unset -- ${var}($cmd)}
        }
	default	{
	    return -code error "unknown hook action \"$type\": must be\
		    add or remove"
	}
    }
}

proc ::tkchat::say { who message args } {
    # I've added a few lines to make this speak new messages via the
    # festival synthesiser. It doesn't do it robustly as yet (you'll need
    # festival installed) but as a quick (1min) hack it's got heaps of
    # cool points...  -- Steve Cassidy
    variable festival
    if {![info exists festival]} {
	set festival [open "|festival --pipe" w]
    }

    log::log debug [string map [list "\"" ""] $message]
    puts $festival "(SayText \"$message\")"
    flush $festival
}

if {0 && [string length [auto_execok festival]]} {
    ## Don't add this by default ...
    ::tkchat::Hook add message ::tkchat::say
}

proc ::tkchat::findExecutable {progname varname} {
    upvar 1 $varname result
    set progs [auto_execok $progname]
    if {[llength $progs]} {
	set result [lindex $progs 0]
    }
    return [llength $progs]
}

proc ::tkchat::gotoURL {url} {
    # this can take a bit
    . config -cursor watch
    .txt config -cursor watch
    update
    if {[regexp -nocase -- {&url=(.*)} $url -> trueUrl]} {
	# this was a redirect - just get final destination
	set url $trueUrl
    } elseif {[regexp -nocase -- {^chat} $url]} {
	# this is a relative url
	set url "$::tkchat::HOST/cgi-bin/$url"
    } else {
	# assume a raw url
    }

    # Set the clipboard value to this url in-case the user needs to paste the
    # url in (some windows systems).
    clipboard clear
    clipboard append $url

    global tcl_platform Options
    # this code from  http://purl.org/mini/tcl/557.html
    switch -- $tcl_platform(platform) {
	"unix" {
	    expr {
                  [info exists Options(BROWSER)]
                  || [findExecutable mozilla	Options(BROWSER)]
                  || [findExecutable mozilla-firefox	Options(BROWSER)]
                  || [findExecutable mozilla-firebird	Options(BROWSER)]
                  || [findExecutable konqueror	Options(BROWSER)]
                  || [findExecutable netscape	Options(BROWSER)]
                  || [findExecutable iexplorer	Options(BROWSER)]
                  || [findExecutable lynx		Options(BROWSER)]
              }
	    # lynx can also output formatted text to a variable
	    # with the -dump option, as a last resort:
	    # set formatted_text [ exec lynx -dump $url ] - PSE
	    #
	    # -remote argument might need formatting as a command
	    # 		Try that first
	    if {[catch {exec $Options(BROWSER) -remote openURL($url) 2> /dev/null &}]} {
	        # Try -remote with raw URL argument 
	        if {[catch {exec $Options(BROWSER) -remote $url 2> /dev/null &}]} {
		    # perhaps browser doesn't understand -remote flag
		    if {[catch {exec $Options(BROWSER) $url &} emsg]} {
		        tk_messageBox -message \
                              "Error displaying $url in browser\n$emsg"
		    }
		}
	    }
	}
	"windows" {
            # DDE uses commas to separate command parts
            set url [string map {, %2c} $url]

            # See if we can use dde and an existing browser.
            set handled 0
            foreach app {Firefox {Mozilla Firebird} Mozilla Netscape IExplore} {
                if {[set srv [dde services $app WWW_OpenURL]] != {}} {
                    if {[catch {dde execute $app WWW_OpenURL $url} msg]} {
                        log::log debug "dde exec $app failed: \"$msg\""
                    } else {
                        set handled 1
                        break
                    }
                }
            }

	    # The windows NT shell treats '&' as a special character. Using
	    # a '^' will escape it. See http://wiki.tcl.tk/557 for more info.
            if {! $handled} {
                if {[string equal $tcl_platform(os) "Windows NT"]} {
                    set url [string map {& ^&} $url]
                }
                if {[catch {eval exec [auto_execok start] [list $url] &} emsg]} {
                    tk_messageBox -message \
                        "Error displaying $url in browser\n$emsg"
                }
            }
	}
	"macintosh" {
	    if {![info exists env(BROWSER)]} {
		set env(BROWSER) "Browse the Internet"
	    }
	    if {[catch {
		AppleScript execute\
                      "tell application \"$env(BROWSER)\"
		open url \"$url\"
		end tell
		"} emsg]
	    } then {
		tk_messageBox -message \
                      "Error displaying $url in browser\n$emsg"
	    }
	}
    }
    . config -cursor {}
    .txt config -cursor left_ptr
}

proc ::tkchat::formatClock {str} {
    global Options
    set out [stripStr $str]
    if {[regexp -- {^[\s:]*(\d+)} $out -> ticks]} {
        set cmd [list clock format $ticks -gmt $Options(TimeGMT)]
        if {![string equal $Options(TimeFormat) ""]} {
            lappend cmd -format $Options(TimeFormat)
        }
        set out [eval $cmd]
    }
    return $out
}

proc ::tkchat::addAction {clr nick str {mark end} {timestamp 0} {extraOpts ""}} {
    global Options
    checkNick $nick $clr
    checkAlert ACTION $nick $str
    array set opts $extraOpts
    .txt config -state normal
    #for colors, it is better to extract the displayed nick from the one used for
    #tags.
    set displayNick $nick
    regexp {^<(.+)>$} $nick displayNick nick
    ::tkchat::InsertTimestamp .txt $nick $mark $timestamp
    .txt insert $mark "   * $displayNick " [list NICK NICK-$nick]
    if {[string equal $nick clock]} {
        .txt insert $mark "[formatClock $str] " [list NICK-$nick ACTION]
    } else {
	foreach {str url} [parseStr $str] {
	    if { [info exists opts(nolog)] } {
		set tags [list MSG NOLOG-$nick ACTION NOLOG]	
	    } else {
		set tags [list MSG NICK-$nick ACTION]
	    }
	    if {$url != ""} {
		lappend tags URL URL-[incr ::URLID]
		.txt tag bind URL-$::URLID <1> [list ::tkchat::gotoURL $url]
	    }
	    tkchat::Insert .txt $str $tags $url $mark
	}
    }
    .txt insert $mark "\n" [list NICK-$nick ACTION]

    # Special handling for single dot action message
    if {[string trim $str] == "." && $Options(Username) != $nick} {
        set inspt [.txt index "$mark - 2 line"]
        set endpt [.txt index "$mark - 1 line"]
        .txt tag add SINGLEDOT $inspt $endpt
        .txt tag raise SINGLEDOT NICK-$nick
    }

    .txt config -state disabled
    if {$Options(AutoScroll)} { .txt see $mark }
}

proc ::tkchat::addSystem {str {mark end} {tags {}}} {
    global Options
    .txt config -state normal
    ::tkchat::InsertTimestamp .txt "" $mark
    .txt insert $mark "\t$str\n" [concat [list MSG SYSTEM] $tags]
    .txt config -state disabled
    if {$Options(AutoScroll)} { .txt see $mark }
}

# Add notification of user entering or leaving. We can hide these notifications
# by setting Options(hideTraffic)
# Always add tehse to text - just tag them so we can elide them at will
# this way, the hide option can affect the past as well as the future
proc ::tkchat::addTraffic {who action {mark end} {timestamp 0} } {
    # Action should be entered or left
    global Options

    variable ::tkchat::MSGS
    .txt config -state normal
    if {[string equal $who$action "ircbridgeentered"]} {
        set msg "$who was erected"
    } elseif {[string equal $who$action "ircbridgeleft"]} {
        set msg "$who fell down"
    } elseif {[info exists MSGS($action)]} {
        set msg [string map -nocase [list %user% $who] \
                       [lindex $MSGS($action) \
                              [expr {int(rand()*[llength $MSGS($action)])}]]]
    } else {
        set msg "$who has $action the chat!!"
    }
    ::tkchat::InsertTimestamp .txt "" $mark $timestamp TRAFFIC
    .txt insert $mark "\t$msg\n" [list MSG SYSTEM TRAFFIC [string toupper $action]]
    .txt config -state disabled
    if {$Options(AutoScroll)} { .txt see $mark }
}

proc ::tkchat::addUnknown {str} {
    global Options
}

proc ::tkchat::showInfo {title str} {
    set t .infobox
    set i 0
    while {[winfo exists $t]} {
	set t .infobox[incr i]
    }
    toplevel $t
    wm title $t $title
    set height [expr {[string length $str] / 75 + 1}]
    if {[set lines [regexp -all -- "\n" $str]] > $height} {
	set height $lines
    }
    text $t.txt -cursor left_ptr -wrap word -height $height -font NAME
    pack $t.txt -expand 1 -fill both
    bind $t.txt <1> { focus %W }
    $t.txt tag configure URL -underline 1
    $t.txt tag bind URL <Enter> [list $t.txt config -cursor hand2]
    $t.txt tag bind URL <Leave> [list $t.txt config -cursor left_ptr]
    foreach {str url} [parseStr $str] {
	if {$url == ""} {
	    $t.txt insert end "$str " INFO
	} else {
	    $t.txt insert end "$str " [list INFO URL URL-[incr ::URLID]]
	    $t.txt tag bind URL-$::URLID <1> [list ::tkchat::gotoURL $url]
	}
    }
    $t.txt insert end "\n"
    $t.txt config -state disabled
    button $t.close -text Close -command [list destroy $t]
    focus $t.close
    pack $t.close -side right
}

proc ::tkchat::doIrcBridgeWhisper { clr name str } {
    variable ircOnlineUsers
    set str [string trim $str]
    set what [lindex [split $str ":"] 0]
    switch -- $what {
	onlineusers {
	    set tmp [string range $str [expr [string first : $str]+1] end]
	    set ircOnlineUsers [split [string trim $tmp] " "]
	    #addSystem "Users on IRC: $ircOnlineUsers"
	}
	default {
	    addAction $clr $name " whispers: $str"
	}
    }
}

proc ::tkchat::didIrcBridgeWhisper { clr name str } {
    variable ircOnlineUsers
    global Options

    set str [string trim $str]
    switch -glob -- $str {
	onlineusers* {
	    #addSystem "Asking ircbridge for online users..."
	}
	default {
	    addAction $clr $Options(Username) \
		" whispered to [string range $name 2 end]: $str"
	}
    }
}

proc ::tkchat::addHelp {clr name str} {
    global Options

    if {[lsearch -exact $Options(NickList) $name] >= 0} {
	if { [string equal $name "ircbridge"] } {
	    doIrcBridgeWhisper $clr $name $str
	} else {
	    # this is an incoming private message
	    addAction $clr $name " whispers: $str"
	}
	return
    }
    if {[string match "->*" $name]} {
	if { [string equal $name "->ircbridge"] } {
	    didIrcBridgeWhisper $clr $name $str
	} else {
	    # an outgoing private message
	    addAction $clr $Options(Username) \
		" whispered to [string range $name 2 end]: $str"
	}
	return
    }


    if {[string equal $name "USERINFO"]} {
        set tag USERINFO
    } elseif {[string equal $name "MEMO"]} {
        set tag MEMO
    } elseif {[string equal $name "WELCOME"]} {
        set tag WELCOME
    } elseif {[string equal $name "IP"]} {
        set tag SYSTEM
    } else {
	set tag HELP
    }

    if {![string equal $tag SYSTEM] && $Options(Popup,$tag)} {
	::tkchat::showInfo $tag $str
    }

    if {$clr != ""} {
	.txt tag configure $tag -foreground "#$clr"
    }
    .txt config -state normal
    .txt insert end "$name\t" [list $tag NICK]
    foreach {str url} [::tkchat::parseStr $str] {
	regsub -all "\n" $str "\n\t" str
	if {[string equal $url ""]} {
	    .txt insert end "$str " [list MSG $tag]
	} else {
	    .txt insert end "$str " [list MSG $tag URL URL-[incr ::URLID]]
	    .txt tag bind URL-$::URLID <1> [list ::tkchat::gotoURL $url]
	}
    }
    .txt insert end "\n" [list $tag NICK]
    .txt config -state disabled
    if {$Options(AutoScroll)} { .txt see end }
}

proc ::tkchat::createFonts {} {
    font create FNT   -family helvetica -size -12 -weight normal -slant roman
    font create ACT   -family helvetica -size -12 -weight normal -slant italic
    font create NOLOG -family helvetica -size -12 -weight normal -slant roman
    font create NAME  -family helvetica -size -12 -weight bold	-slant roman
    font create SYS   -family helvetica -size -12 -weight bold	-slant italic
    font create STAMP -family helvetica -size -12 -weight bold	-slant roman
}

proc ::tkchat::displayUsers {} {
    global Options
    if {[winfo exists .pane]} {
	if {$Options(DisplayUsers)} {
	    .pane add $Options(NamesWin) -sticky news
	} else {
	    .pane forget $Options(NamesWin)
	}
    } else {
	if {$Options(DisplayUsers)} {
	    grid $Options(NamesWin)
	} else {
	    grid remove $Options(NamesWin)
	}
    }
}

proc ::tkchat::findCommonRoot { words } {
    #takes a list of words/nicks and returns the longest string
    #that matches the beginning of all of them.

    set count [llength $words]
    if { $count <= 1 } {
	return $words
    }
    set word [lindex $words 0]
    for { set c 0 } { $c < [string length $word] } {incr c} {
	set partial [string range $word 0 $c]
	if { [lsearch -not -glob $words "$partial*"] > -1 } {
	    return [string range $partial 0 end-1]
	}
    }
    return $word
}

proc ::tkchat::deleteCompletions { } {
    .txt config -state normal
    set range [.txt tag nextrange NICKCOMPLETE 0.0]
    while { [llength $range] > 0 } {
	.txt delete [lindex $range 0] [lindex $range 1]
	set range [.txt tag nextrange NICKCOMPLETE [lindex $range 0]]
    }
    .txt config -state disabled
}

proc ::tkchat::nickComplete {} {
    #Bound to <Key-Tab> in the message entry widgets .eMsg and .tMsg
    #It will do nickname completion a'la bash command completion
    #nicknames are taken from the complete, stored nick list
    #not the users' online one. Which is too unreliable IMO.
    global Options
    variable lastCompletion

    set nicks [list]
    foreach key [array names Options "Visibility,NICK-*"] {
	set nick [string range $key [string length "Visibility,NICK-"] end]
	set nick [string map {< "" > ""} $nick]
	lappend nicks $nick
    }
    set nicks [lsort -dictionary $nicks]

    if {[winfo ismapped .eMsg]} {
	#the entry is on screen
	#This fails to find the correct word when the $cursor != end
	set str [.eMsg get]
	set cursor [.eMsg index insert]
	set partial [string range $str [string wordstart $str $cursor] \
			 [string wordend $str $cursor]]

    } else {
	set partial [.tMsg get "insert-1c wordstart" "insert-1c wordend"]
    }

    set matches [lsearch -all -inline -glob $nicks "$partial*"]

    switch [llength $matches] {
	0 {
	    bell
	    set lastCompletion ""
	    return
	}
	1 {
	    set match "$matches "
	    set lastCompletion ""
	}
	default {
	    set match [findCommonRoot $matches]
	    deleteCompletions
	    if { [llength $lastCompletion] > 0 } {
		if { [clock seconds]-2 > [lindex $lastCompletion 0] } {
		    set lastCompletion ""
		}
		if { [string equal [lindex $lastCompletion 1] $match] && \
			 [string length $match] > 0 } {
		    .txt config -state normal
		    .txt insert end "Completions: $matches\n" [list MSG NICKCOMPLETE]
		    .txt config -state disabled
		    if {$Options(AutoScroll)} { .txt see end }
		    after 5500 {
			if { [llength $::tkchat::lastCompletion] > 0 } {
			    if { [clock seconds]-4 < [lindex $::tkchat::lastCompletion 0] } {
				return
			    }
			}
			::tkchat::deleteCompletions
		    }
		}
	    }
	    set lastCompletion [list [clock seconds] $match]
	    bell
	}
    }

    if {[winfo ismapped .eMsg]} {
	.eMsg delete [string wordstart $str $cursor] \
	    [string wordend $str $cursor]
	.eMsg insert [string wordstart $str $cursor] $match
    } else {
	.tMsg delete "insert-1c wordstart" "insert-1c wordend"
	.tMsg insert insert $match
    }
}

proc ::tkchat::CreateGUI {} {
    global Options
    variable chatWindowTitle
    # Pick an enhanced Tk style.
    set done 0
    if {([string match "as*" $Options(Style)]
         || [string equal $Options(Style) "any"])
	&& ![catch {package require as::style}]} {
	as::style::init
	set done 1
    }
    if {!$done
	&& ([string match "g*" $Options(Style)]
            || [string equal $Options(Style) "any"])
	&& [tk_windowingsystem] == "x11"} {
	gtklook_style_init
    }

    wm title . $chatWindowTitle
    wm withdraw .
    wm protocol . WM_DELETE_WINDOW [namespace origin quit]

    catch {createFonts}

    menu .mbar
    . config -menu .mbar

    .mbar add cascade -label "File" -underline 0 \
	-menu [menu .mbar.file -tearoff 0]
    .mbar add cascade -label "Preferences" \
	-underline 0 -menu [menu .mbar.edit -tearoff 0]
    .mbar add cascade -label "Emoticons" \
	-underline 0 -menu [menu .mbar.emot -tearoff 0]
    .mbar add cascade -label "Visibility" \
	-underline 0 -menu [menu .mbar.vis -tearoff 0]
    .mbar add cascade -label "Alerts" \
	-underline 0 -menu [menu .mbar.alert -tearoff 0]
    .mbar add cascade -label "Debug" -underline 0 \
	-menu [menu .mbar.dbg -tearoff 0]
    .mbar add cascade -label "Help" -underline 0 \
	-menu [menu .mbar.help -tearoff 0]

    ## File Menu
    ##
    set m .mbar.file
    #$m add checkbutton -label "Pause" \
	-variable ::tkchat::pause \
	-underline 0 \
	-command { ::tkchat::pause $::tkchat::pause }
    $m add command -label [msgcat::mc Login] -underline 0 \
	-command [namespace origin logonScreen]
    $m add command -label "Save Options" -underline 0 \
	-command [namespace origin saveRC]
    $m add separator
    $m add command -label "Open Whiteboard" -underline 5 \
	-command [namespace origin whiteboard_open]
    $m add separator
    $m add command -label "Exit" -underline 1 -command [namespace origin quit]

    ## Preferences/Edit Menu
    ##
    set m .mbar.edit
    $m add checkbutton -label "Display Online Users" -underline 0 \
	-variable Options(DisplayUsers) \
	-command ::tkchat::displayUsers
    $m add command -label "Colors ..." -underline 0 \
	-command tkchat::ChangeColors
    $m add command -label "Macros ..." -underline 0 \
	-command tkchat::EditMacros
    $m add command -label "Font" -underline 0 \
	-command "::tkchat::ChooseFont"
    $m add command -label "User details ..." -underline 0 \
	-command tkchat::UserInfoDialog
    $m add command -label "Options ..." -underline 0 \
	-command ::tkchat::EditOptions

    $m add separator

    if {[package provide tile] != {}} {
        if {[llength [info commands ::tile::availableThemes]] > 0} {
            set themes [lsort [tile::availableThemes]]
        } else {
            set themes [lsort [style theme names]]
        }
	$m add cascade -label "Tk themes" -menu [menu $m.themes -tearoff 0]
	foreach theme $themes {
	    $m.themes add radiobutton -label [string totitle $theme] \
		-variable ::Options(Theme) \
		-value $theme \
		-command [list [namespace origin SetTheme] $theme]
	}
	$m add separator
    }

    $m add cascade -label "Max Window Buffer" \
	-menu [menu $m.buffer -tearoff 0] \
	-underline 3
    foreach l {500 1000 1500 2500 5000 10000} {
	$m.buffer add radiobutton -label "$l lines" -val $l \
	    -var Options(MaxLines) -underline 0
    }
    $m add cascade -label "Local Chat Logging" \
	-menu [menu $m.chatLog -tearoff 0] \
	-underline 0
    $m.chatLog add radiobutton -label Disabled -var ::Options(ChatLogOff) \
	-val 1 -command {tkchat::OpenChatLog close} -underline 0
    $m.chatLog add command -label "To File..." \
	-command {tkchat::OpenChatLog open} -underline 0

    $m add cascade -label "Server Chat Logging" \
	-menu [menu $m.chatServLog -tearoff 0] \
	-underline 0
    $m.chatServLog add radiobutton -label "Log my messages, do not log my actions (old style)" -val oldStyle \
	-var Options(ServerLogging) -underline 1
    $m.chatServLog add radiobutton -label "Log my messages and actions" -val all \
	-var Options(ServerLogging) -underline 0
    $m.chatServLog add radiobutton -label "Do not log my messages and actions" -val none \
	-var Options(ServerLogging) -underline 3	

    $m add cascade -label "Loading Server History" \
	-menu [menu $m.hist -tearoff 0] \
	-underline 15
    $m.hist add radiobutton -label "Do NOT load any history" -val 0 \
	-var Options(HistoryLines) -underline 3
    $m.hist add radiobutton -label "Ask me which logs to load" -val -1 \
	-var Options(HistoryLines) -underline 0
    foreach l {50 100 200 500 1000 2500 10000} {
	$m.hist add radiobutton -label "Load at least $l lines" -val $l \
	    -var Options(HistoryLines)
    }

    $m add separator
    $m add checkbutton -label "Enable Whiteboard" -underline 0 \
	-variable Options(EnableWhiteboard)

    ## Emoticon Menu
    ##
    set m .mbar.emot
    $m add command -label "Show Emoticons" \
	-command ::tkchat::ShowSmiles -underline 0
    $m add checkbutton -label "Use Emoticons" \
	-onval 1 -offval 0 -var Options(emoticons) \
	-underline 0
    $m add checkbutton -label "Animate Emoticons" \
	-onval 1 -offval 0 -var Options(AnimEmoticons) \
	-command ::tkchat::DoAnim -underline 0
    $m add cascade -label Insert -underline 0 \
	-menu [menu $m.mnu -title Insert]
    variable IMG
    foreach {i e} [array get IMG] {
	set tmp($e) $i
    }
    foreach {img txt} [array get tmp] {
	$m.mnu add command -image ::tkchat::img::$img -command \
	    ".eMsg insert insert \"$txt \" ; .tMsg insert insert \"$txt \""
    }

    ## Visibility Menu
    ##
    set m .mbar.vis
    foreach {tag text} {
	SYSTEM	 "System"
	TRAFFIC	 "Entry/Exit"
	WELCOME	 "Welcome"
	HELP	 "Help"
	USERINFO "User Info"
	MEMO	 "Memo"	
    } {
	$m add checkbutton -label "Hide $text Messages" \
	    -onval 1 -offval 0 \
	    -var Options(Visibility,$tag) \
	    -command "::tkchat::DoVis $tag" \
	    -underline 5
    }
    $m add checkbutton -label "Hide single dot actions" \
	-onval 1 -offval 0 -var Options(Visibility,SINGLEDOT) \
	-command [list ::tkchat::DoVis SINGLEDOT] -underline 12
    $m add checkbutton -label "Hide Timestamps" \
	-onval 1 -offval 0 -var Options(Visibility,STAMP) \
	-command [list ::tkchat::StampVis] -underline 5
    $m add separator
    $m add command -label "Hide All Users" -command  "::tkchat::NickVis 1"
    $m add command -label "Show All Users" -command  "::tkchat::NickVis 0"
    $m add cascade -label "Hide Users" -menu [menu $m.nicks -tearoff 0]
    ::tkchat::NickVisMenu
    $m add separator
    foreach {tag text} {
	HELP	 "Help"
	USERINFO "User Info"
	WELCOME	 "Welcome"
	MEMO	 "Memo"
    } {
	$m add checkbutton -label "Pop-up $text Messages" \
	    -onval 1 -offval 0 \
	    -var Options(Popup,$tag) \
	    -underline 10
    }

    ## Alert Menu
    ##
    set m .mbar.alert
    foreach {tag text} {
	SOUND	  "Beep on alert"
	RAISE	  "Raise to top on alert"
    } {
	$m add checkbutton -label "$text" \
	    -onval 1 -offval 0 \
	    -var Options(Alert,$tag)
    }
    $m add separator
    foreach {tag text} {
	ALL	  "Alert when any message received"
	ME	  "Alert when username mentioned"
	TOPIC	  "Alert when someone speaks who was quiet"
    } {
	$m add checkbutton -label "$text" \
	    -onval 1 -offval 0 \
	    -var Options(Alert,$tag)
    }
    $m add separator
    foreach {tag text} {
	NORMAL	  "Alert on regular posts"
	ACTION	  "Alert on whispers and \"/me\" posts"
    } {
	$m add checkbutton -label "$text" \
	    -onval 1 -offval 0 \
	    -var Options(Alert,$tag)
    }

    ## Debug Menu
    ##
    set m .mbar.dbg
    $m add comman -label "Reload script" -underline 0 \
	-command [list ::tkchat::Debug reload]
    $m add comman -label "Restart script" -underline 2 \
	-command [list ::tkchat::Debug restart]
    $m add comman -label "Retrieve script" -underline 2 \
	-command [list ::tkchat::Debug retrieve]
    $m add comman -label "Evaluate selection" -underline 1 \
	-command [list ::tkchat::Debug evalSel]
    $m add comman -label "Allow remote control" -underline 0 \
	-command [list ::tkchat::Debug server]
    $m add comman -label "Reload history" -underline 7 \
	-command [list ::tkchat::Debug purge]
    $m add separator
    $m add cascade -label "Error Logging" -underline 0 \
	-menu [menu $m.err -tearoff 0]
    $m.err add cascade -label "Log Level" -underline 0 \
	-menu [menu $m.err.lvl -tearoff 0]
    $m.err add radiobutton -label "To Stderr" -underline 3 \
	-var ::Options(LogStderr) -val 1 \
	-command {tkchat::OpenErrorLog stderr}
    $m.err add command -label "To File..." -underline 3 \
	-command {tkchat::OpenErrorLog pick}
    foreach lvl [lsort -command ::log::lvCompare $::log::levels] {
	$m.err.lvl add radiobutton -label $lvl -val $lvl \
	    -var Options(LogLevel)
    }
    $m add separator
    $m add checkbutton -label "Console" -underline 0 \
	-variable ::tkchat::_console \
	-command [list ::tkchat::Debug console] \
	-state disabled
    set ::tkchat::_console 0
    if {[llength [info commands tkcon]]} {
	$m entryconfig "Console" -state normal \
	    -command {
		if {$::tkchat::_console} { tkcon show } else { tkcon hide }
	    }
    } elseif { $::tcl_platform(platform) ne "unix" &&
	[llength [info commands console]] > 0 } {
	$m entryconfig "Console" -state normal
	console eval {
	    bind .console <Map> {
		consoleinterp eval {
		    set ::tkchat::_console 1
		}
	    }
	    bind .console <Unmap> {
		consoleinterp eval {
		    set ::tkchat::_console 0
		}
	    }
	}
    }

    ## Help Menu
    ##
    set m .mbar.help
    $m add command -label About... -underline 0 -command tkchat::About
    $m add cascade -label "Translate Selection" -underline 0 \
        -command [list [namespace current]::babelfishMenu]

    # main display
    if {[info command ::panedwindow] != {} && $Options(UsePane)} {
	set UsePane 1
	panedwindow .pane -sashpad 4 -sashrelief ridge
	frame .txtframe
    } else {
	set UsePane 0
    }

    text .txt -background "#[getColor MainBG]" \
	-foreground "#[getColor MainFG]" \
	-font FNT -relief sunken -bd 2 -wrap word \
	-yscroll "::tkchat::scroll_set .sbar" \
	-state disabled -cursor left_ptr -height 1
    scrollbar .sbar -command ".txt yview"
    # user display
    text .names -background "#[getColor MainBG]" \
	-foreground "#[getColor MainFG]" \
	-relief sunken -bd 2 -width 8 -font FNT -state disabled \
	-cursor left_ptr -height 1 -wrap word

    # bottom frame for entry
    frame .btm
    button .ml -text ">>" -width 0 -command ::tkchat::showExtra
    entry .eMsg
    bind .eMsg <Return>	  ::tkchat::userPost
    bind .eMsg <KP_Enter> ::tkchat::userPost
    bind .eMsg <Key-Up>	  ::tkchat::entryUp
    bind .eMsg <Key-Down> ::tkchat::entryDown
    bind .eMsg <Key-Tab>  {::tkchat::nickComplete ; break}
    bind .eMsg <Key-Prior> [list .txt yview scroll -1 pages]
    bind .eMsg <Key-Next>  [list .txt yview scroll  1 pages]
    text .tMsg -height 6 -font FNT
    bind .tMsg <Key-Tab> {::tkchat::nickComplete ; break}
    button .post -text "Post" -command ::tkchat::userPost
    #button .refresh -text "Refresh" -command {pause off}
    menubutton .mb -indicator on -pady 4 \
	-menu .mb.mnu -textvar Options(MsgTo) -direction above
    menu .mb.mnu -tearoff 0
    .mb.mnu add command -label "All Users" \
	-command [list ::tkchat::MsgTo "All Users"]
    .txt tag configure MSG -lmargin2 50
    .txt tag configure INFO -lmargin2 50
    .txt tag configure NICK -font NAME
    .txt tag configure ACTION -font ACT
    .txt tag configure NOLOG -font NOLOG
    .txt tag configure SYSTEM -font SYS
    .txt tag configure ERROR -background red
    .txt tag configure ENTERED -foreground $Options(EntryMessageColor)
    .txt tag configure LEFT -foreground $Options(ExitMessageColor)
    .txt tag configure STAMP -font STAMP
    .txt tag configure URL -underline 1
    .txt tag configure SINGLEDOT -font ACT
    .txt tag bind URL <Enter> [list .txt config -cursor hand2]
    .txt tag bind URL <Leave> [list .txt config -cursor {}]
    .names tag config NICK -font NAME
    .names tag config TITLE -font SYS -justify center
    .names tag config URL -underline 1
    .names tag bind URL <Enter> [list .names config -cursor hand2]
    .names tag bind URL <Leave> [list .names config -cursor {}]
    # on windows, a disabled text widget can't get focus
    # but someone might want to copy/paste the text
    bind .txt <1> { focus %W }
    bind .txt <Up>	   {.txt yview scroll  -1 units}
    bind .txt <Down>	   {.txt yview scroll	1 units}
    bind .txt <Button-4>   {.txt yview scroll  -1 units}
    bind .txt <Button-5>   {.txt yview scroll	1 units}
    bind .txt <Button-3>   {::tkchat::babelfishMenuPost
				[winfo pointerx %W] [winfo pointery %W]}
    bind .txt <Shift-Button-3> {::dict.leo.org::askLEOforSelection}

    bind . <FocusIn> [list [namespace origin ResetMessageCounter]]
    if {[lsearch [wm attributes .] -alpha] != -1} {
        bind Tkchat <FocusIn>  [list [namespace origin FocusInHandler] %W]
        bind Tkchat <FocusOut> [list [namespace origin FocusOutHandler] %W]
    }

    # using explicit rows for restart
    set Options(NamesWin) [MakeScrolledWidget .names]
    if {$UsePane} {
	.txt configure -width 10
	.names configure -width 10
	grid .txt .sbar -in .txtframe -sticky news -padx 1 -pady 2
	grid columnconfigure .txtframe 0 -weight 1
	grid rowconfigure .txtframe 0 -weight 1
	.pane add .txtframe -sticky news
	#.pane add .names -sticky news
	.pane add $Options(NamesWin) -sticky news
	grid .pane -sticky news -padx 1 -pady 2
	grid .btm  -sticky news
    } else {
	#grid .txt .sbar .names -sticky news -padx 1 -pady 2
	grid .txt .sbar $Options(NamesWin) -sticky news -padx 1 -pady 2
	grid configure .sbar -sticky ns
	grid .btm	     -sticky news -columnspan 3
    }
    grid .ml .eMsg .post .mb -in .btm -sticky ews -padx 2 -pady 2
    grid configure .eMsg -sticky ew

    grid rowconfigure	 . 0 -weight 1
    grid columnconfigure . 0 -weight 1
    grid columnconfigure .btm 1 -weight 1

    if { $::tcl_platform(os) eq "Windows CE" } {
	wm geometry . 240x300+0+0
    } else {
	wm geometry . $Options(Geometry)
    }
    wm deiconify .

    if {$UsePane} {
	update
	if {[info exists $Options(Pane)] && [llength $Options(Pane)] == 2} {
	    eval [linsert $Options(Pane) 0 .pane sash place 0]
	} else {
	    set w [expr {([winfo width .pane] * 4) / 5}]
	    set coord [.pane sash coord 0]
	    .pane sash place 0 $w [lindex $coord 1]
	}
	set Options(PaneUsersWidth) \
	    [expr {[winfo width .pane] - [lindex [.pane sash coord 0] 0]}]
	bind .pane <Configure> [list [namespace origin PaneConfigure] %W %w]
	bind .pane <Leave> [list [namespace origin PaneLeave] %W]
        PaneConfigure .pane [winfo width .pane];# update the pane immediately.
    }

    # call this to activate the option on whether the users should be shown
    MsgTo "All Users"
    displayUsers
}

proc ::tkchat::SetTheme {theme} {
    global Options
    catch {
        #was: package vsatisfies [package provide tile] 0.4
        if {[llength [info command ::tile::setTheme]] > 0} {
            tile::setTheme $theme
        } else {
            style theme use $theme
        }
	set Options(Theme) $theme
    }
}

# On window resizing, we need to adjust the sash location to keep
# proportions the same for each pane.
proc ::tkchat::PaneConfigure {pane width} {
    global Options

    if {$::Options(DisplayUsers)} {
	if {[info exists Options(PaneUsersWidth)]} {
	    set pos [expr {$width - $Options(PaneUsersWidth)}]
	    $pane sash place 0 $pos 2
	}
    }
}

proc ::tkchat::PaneLeave {pane} {
    global Options
    if {$::Options(DisplayUsers)} {
	set Options(PaneUsersWidth) \
	    [expr {[winfo width .pane] - [lindex [.pane sash coord 0] 0]}]
    }
}

proc ::tkchat::DoVis {tag} {
    .txt tag config $tag -elide $::Options(Visibility,$tag)
}

proc ::tkchat::NickVis {val} {
    foreach t [array names ::Options Visibility,NICK-*] {
	if {$::Options($t) != $val} {
	    set ::Options($t) $val
	    DoVis [lindex [split $t ,] end]
	}
    }
}

proc ::tkchat::StampVis {} {
    global Options
    set tag STAMP

    .txt tag config $tag -elide $::Options(Visibility,$tag)

    set wid $Options(Offset)

    if { $::Options(Visibility,$tag) } {
	# Invisible
	.txt config -tabs [list $wid l]
	.txt tag configure MSG -lmargin2 $wid
    } else {
	# Stamps visible
	set wid_tstamp [expr {[font measure NAME "\[88:88\]"] + 5}]
	.txt config -tabs [list $wid_tstamp l [expr {$wid+$wid_tstamp}] l]
	.txt tag configure MSG -lmargin2 [expr {$wid+$wid_tstamp}]
    }

}

proc ::tkchat::NickVisMenu {} {
    set m .mbar.vis.nicks
    $m delete 0 end
    set cnt 0
    foreach n [lsort -dict $::Options(NickList)] {
	set tag NICK-$n
	$m add checkbutton -label $n \
	    -onval 1 -offval 0 \
	    -var Options(Visibility,$tag) \
	    -command "::tkchat::DoVis $tag"
	if {$cnt >0 && $cnt % 25 == 0} {
	    $m entryconfig end -columnbreak 1
	}
	incr cnt
    }
}

proc ::tkchat::ScrolledWidgetSet {sbar f1 f2} {
    $sbar set $f1 $f2
    if {($f1 == 0) && ($f2 == 1)} {
	grid remove $sbar
    } else {
	grid $sbar
    }
}

proc ::tkchat::MakeScrolledWidget {w args} {
    global Options
    if {[package provide tile] != {}} {
	set sbcmd tscrollbar
    } else {
	set sbcmd scrollbar
    }

    set parent [winfo parent $w]
    for {set n 0} {[winfo exists $parent.f$n]} {incr n} {}
    set f [frame $parent.f$n]
    set vs [$sbcmd $f.vs -orient vertical -command [list $w yview]]
    $w configure -yscrollcommand [list $vs set]
    raise $w $f

    grid configure $w $vs -in $f -sticky news
    grid rowconfigure $f 0 -weight 1
    grid columnconfigure $f 0 -weight 1

    return $f
}

proc ::tkchat::About {} {
    variable rcsid
    global Options

    regexp -- {Id: tkchat.tcl,v (\d+\.\d+)} $rcsid -> rcsVersion

    # don't cache this window - of user reloads on the fly
    # we want to make sure it displays latest greatest info!
    catch {destroy .about}

    set w [toplevel .about -class dialog]
    wm withdraw $w
    wm transient $w .
    wm title $w "About TkChat $rcsVersion"
    button $w.b -text Dismiss -command [list wm withdraw $w]
    text $w.text -height 34 -bd 1 -width 100
    pack $w.b -fill x -side bottom
    pack $w.text -fill both -side left -expand 1
    $w.text tag config center -justify center
    $w.text tag config title -justify center -font {Courier -18 bold}
    $w.text tag config h1 -justify left -font {Sans -12 bold}
    $w.text insert 1.0 "About TkChat v$rcsVersion" title \
	"\n\nCopyright (C) 2001 Bruce B Hartweg <brhartweg@bigfoot.com>" \
	center "\n$rcsid\n\n" center

    $w.text insert end "Commands\n" h1 \
	"/msg <nick> <text>\t\tsend private message to user <nick>\n" {} \
	"/userinfo <nick>\t\tdisplay registered information for user <nick>\n" {} \
        "/afk ?reason?\t\tset your status to away with an optional reason\n" {} \
        "/back ?reason?\t\tindicate that you have returned\n" {} \
        "/away ?reason?\t\tsynonym for /afk\n" {} \
	"/google <text>\t\topen a google query for <text> in web browser\n" {} \
	"/googlefight <word> <word>\tperform a google fight between two words or phrases (in quotes)\n" {} \
	"/tip:<NUM>\t\topen the specified TIP document in web browser\n" {} \
	"/wiki <text>\t\tdo a wiki query with the remainder of the line\n" {} \
	"/bug ?group? ?tracker? id\topen a sourceforge tracker item in browser\n" {} \
	"/noisy ?<nick>? ?<minutes>?\tToggle <nick> noisy for x minutes (default 5)\n" {} \
	"\t\t\tmessages from noisy users are not diplayed.\n" {} \
	"\t\t\tNot specifying a nick will give you a list of noisy users.\n" {} \
	"/see <mark>\t\tgoto named mark or index (eg: bookmark1 end 0.0)\n" {} \
	"/alias <name> <type> <body>\ttype is 'proc' or 'script',\
	  type proc takes exactly one argument.\n\
	  \t\t\te.g: /alias foo script addSystem \"test!\"\n" {} \
	"\t\t\t/alias foo proc thisProc\n" {} \
	"\t\t\tproc thisProc { arguments } { addSystem \$arguments }\n" {} \
	"/unalias <pattern>\t\tremoves one or more aliases.\n\
    \t\t\te.g: /unalias f*\n" {} \
	"Searching\n" h1 \
	"/?<text>\t\t\tsearch the chat buffer for matching text.\
	 Repeating the command will progress\n\t\t\tto the previous match\n" {} \
	"/!\t\t\tclear the previous search result\n" {} \


    $w.text config -state disabled
    catch {::tk::PlaceWindow $w widget .}
    wm deiconify $w
}

proc ::tkchat::parseString { variable_name string separators maximum } {
    # added by JJM 25/Sep/2003
    #
    # this routine makes parsing easier WHILE preserving
    # the "exactness" of the string by NOT treating it as a list...
    # parse string without using list commands... for targeted eval, etc
    #
    # get ahold of an array to put results into
    upvar 1 $variable_name local_array

    # get a list of separators...
    set separator_list [split $separators ""]

    # get length in characters
    set count [string length $string]

    # start at first index (maybe make this variable later?)
    set index 0

    # always start counting in result array from 1 (should this really be
    # zero?)
    set found_index 1

    # how many "matches" did we find?
    # NOTE: this will NOT be more than the parameter maximum, if specified
    set found_count 0

    # current string that needs to be added when next separator is found...
    set found_string ""

    #
    # keep going until the end of the string is reached
    #
    while {$index < $count} {
	#
	# go through string on a character-by-character basis
	#
	set character [string index $string $index]
	#
	# if the character is in the separator list,
	# then we need to add to the array...
	#
	if {[lsearch -exact $separator_list $character] != -1} then {
	    if {$maximum > 0} then {
		# we are limiting the number of "matches" to a certain amount
		# to allow for rather flexible argument parsing for callers...
		# (they can treat the first X arguments as separate, and the
		# rest as one long argument) #
		if {$found_count == ($maximum - 1)} then {
		    # stop adding new after X matches... (last one is taken
		    # care of after loop)
		    set do_add 0
		} else {
		    # we haven't reached the maximum yet
		    set do_add 1
		}
	    } else {
		# there is no maximum
		set do_add 1
	    }
	} else {
	    # we didn't find a separator yet
	    set do_add 0
	}

	if {$do_add != 0} then {
	    #
	    # add string to found array...
	    #
	    set local_array($found_index) $found_string
	    # next index in result array
	    set found_index [expr {$found_index + 1}]
	    # increase count of found arguments
	    set found_count [expr {$found_count + 1}]
	    # reset current string
	    set found_string ""
	} else {
	    #
	    # otherwise, just keep appending to current string
	    #
	    if {$found_string != ""} then {
		# tack on the current character (this is not a separator)
		append found_string $character
	    } else {
		# since no other characters in the current string yet, just set
		# it
		set found_string $character
	    }
	}

	incr index
    }

    #
    # don't forget last one... in case there is one...
    # (this should always happen if the string doesn't end in space...)
    #
    if {$found_string != ""} then {
	# add FINAL string to found array...
	set local_array($found_index) $found_string
	# next index in result array
	set found_index [expr {$found_index + 1}]
	# increase count to FINAL count of found arguments
	set found_count [expr {$found_count + 1}]
	# reset current string
	set found_string ""
    }

    #
    # pass back count always, even if no matches...
    #
    set local_array(count) $found_count

    if {$found_count > 0} then {
	# if we found anything, return non-zero
	set result 1
    } else {
	# otherwise return zero
	set result 0
    }

    return $result
}

proc ::tkchat::processAliasCommand { msg } {
    # added by JJM 25/Sep/2003
    # quickly gimme a list of arguments...
    set msg_list [split $msg " "]

    # extract just the command name...
    set command_name [string range [lindex $msg_list 0] 1 end]

    # process the command...
    switch -exact $command_name {
	"alias" {
	    array set msg_array {}
	    # did we succeed in parsing into the array?
	    if {[parseString msg_array $msg " " 4]} then {
		# did we get exactly 4 arguments?
		if {$msg_array(count) == 4} then {
		    # skip over "/alias" in array...
		    set result [addAlias $msg_array(2) $msg_array(3) $msg_array(4)]
		} else {
		    if {$msg_array(count) == 1} then {
			set result [listAliases]
		    } else {
			addSystem "wrong # args: must be /alias name type body" end ERROR
			set result 0
		    }
		}
	    }
	}
	"unalias" {
	    array set msg_array {}
	    # did we succeed in parsing into the array?
	    if {[parseString msg_array $msg " " 2]} then {
		# did we get exactly 2 arguments?
		if {$msg_array(count) == 2} then {
		    # skip over "/unalias" in array...
		    set result [removeAliases $msg_array(2)]
		} else {
		    addSystem "wrong # args: must be /unalias name" end ERROR
		    set result 0
		}
	    }
	}
	default {
	    addSystem "unknown alias processing directive" end ERROR
	    set result 0
	}
    }

    return $result
}

proc ::tkchat::addAlias { name type body } {
    # added by JJM 25/Sep/2003
    variable commandAliases

    set index [findAlias $name]

    if {$index != -1} then {
	# replace existing alias...
	set commandAliases(types) [lreplace $commandAliases(types) $index $index $type]
	set commandAliases(bodies) [lreplace $commandAliases(bodies) $index $index $body]

	# show that we modified it.
	addSystem "alias \"$name\" modified"
    } else {
	# add new alias...
	lappend commandAliases(names) $name
	lappend commandAliases(types) $type
	lappend commandAliases(bodies) $body

	# show that we added it.
	addSystem "alias \"$name\" added"
    }

    # we always either add or replace, so return success.
    return 1
}

proc ::tkchat::removeAliases { name } {
    # added by JJM 25/Sep/2003
    variable commandAliases

    set result 0; # we haven't removed any yet.
    for {set index [expr {[llength $commandAliases(names)] - 1}]} {$index >= 0} {incr index -1} {
	set alias [lindex $commandAliases(names) $index]

	if {[string match $name $alias]} then {
	    # remove matching command alias...
	    set commandAliases(names) [lreplace $commandAliases(names) $index $index]
	    set commandAliases(types) [lreplace $commandAliases(types) $index $index]
	    set commandAliases(bodies) [lreplace $commandAliases(bodies) $index $index]

	    # show that we removed it.
	    addSystem "alias \"$alias\" matching \"$name\" removed"

	    set result 1; # yes, we matched at least one.
	}
    }

    return $result
}

proc ::tkchat::listAliases {} {
    # added by JJM 25/Sep/2003
    variable commandAliases

    addSystem "there are [llength $commandAliases(names)] aliases defined"

    for {set index 0} {$index < [llength $commandAliases(names)]} {incr index} {
	set name [lindex $commandAliases(names) $index]
	set type [lindex $commandAliases(types) $index]
	set body [lindex $commandAliases(bodies) $index]

	if {$type == "proc"} then {
	    # show the whole thing, it's just a proc name.
	    set str $body
	} else {
	    # only show first 80 characters of the script.
	    set str [string range $body 0 79]
	}

	addSystem "alias $name ($type) = \{$str\}"
    }

    # we always list all aliases...
    return 1
}

proc ::tkchat::findAlias { name } {
    # added by JJM 25/Sep/2003
    variable commandAliases
    # find the alias by name...
    return [lsearch -exact $commandAliases(names) $name]
}

proc ::tkchat::checkAlias { msg } {
    # added by JJM 25/Sep/2003
    variable commandAliases

    set msg_list [split $msg " "]
    set command_name [string range [lindex $msg_list 0] 1 end]

    # try to find the command alias...
    set index [findAlias $command_name]

    if {$index != -1} then {
	# get alias type and body.
	set command_type [lindex $commandAliases(types) $index]
	set command_body [lindex $commandAliases(bodies) $index]

	# set initial error info (none).
	set error 0
	set alias_error ""

	switch -exact $command_type {
	    "proc"  {
		set result 0; # default to "not handled". this MAY be changed by the [catch] below.

		array set msg_array {}
		# did we succeed in parsing into the array?
		if {[parseString msg_array $msg " " 2]} then {
		    # are there no arguments?
		    if {$msg_array(count) == 1} then {
			set msg_array(2) ""
			incr msg_array(count)
		    }

		    # did we get exactly 2 arguments?
		    if {$msg_array(count) == 2} then {
			#
			# NOTE: This proc should return zero to indicate
			# "not handled" and non-zero to indicate "handled".
			#
			set error [catch {set result [expr {[namespace eval [namespace \
										 current] [list $command_body $msg_array(2)]] != 0}]} alias_error]
		    } else {
			addSystem "did not get exactly 2 arguments for alias \"$command_name\" ($command_type)" end ERROR
		    }
		} else {
		    addSystem "could not parse arguments for alias \"$command_name\" ($command_type)" end ERROR
		}
	    }
	    "script" -
	    default  {
		# attempt to eval the command body in this namespace...
		set error [catch {namespace eval [namespace current] $command_body} \
			       alias_error]
		#
		# NOTE: If there is an error, we consider that to be "not handled".
		#
		set result [expr {!$error}]
	    }
	}

	# check for and show errors...
	if {$error} then {
	    addSystem "alias \"$command_name\" ($command_type) error: $alias_error"
	}
    } else {
	set result 0
    }

    return $result
}

proc ::tkchat::userPost {} {
    global Options
    variable UserClicked

    if {[winfo ismapped .eMsg]} {
	set str [.eMsg get]
    } else {
	set str [.tMsg get 1.0 end]
    }
    set msg [string trim $str]
    switch -glob -- $msg {
	"" {
	    # skip
	}
	"/*" {
	    # possible command
	    switch -re -- $msg {
		{^/smiley?s?$} {
		    ShowSmiles
		}
		{^/colou?rs?$} {
		    ChangeColors
		}
		{^/font } {
		    set name [string trim [string range $msg 5 end]]
		    catch {ChangeFont -family $name}
		}
		{^/(font)?size [0-9]+} {
		    regexp -- {[0-9]+} $msg size
		    catch {ChangeFont -size $size}
		}
		{^/macros?$} {
		    EditMacros
		}
		{^/userinfo} {
                    set UserClicked 1
                    msgSend $msg
		}
		{^/\?} {
		    doSearch $msg
		}
		{^/!} {
		    resetSearch
		}
		{^/(urn:)?tip[: ]\d+} {
		    if {[regexp {(?:urn:)?tip[: ](\d+)} $msg -> tip]} {
			gotoURL http://tip.tcl.tk/$tip
		    }
		}
		{^/bug[: ]} {
		    doBug [split $msg ": "]
		}
		{^/wiki[: ]} {
		    set q [http::formatQuery [string range $msg 6 end]]
		    gotoURL http://wiki.tcl.tk/$q
		}
		{^/help} {
		    gotoURL http://wiki.tcl.tk/tkchat
		}
		{^/google\s} {
		    set msg [string range $msg 8 end]
		    log::log debug "Google query \"$msg\""
		    if {[string length $msg] > 0} {
			set    q {http://www.google.com/search}
			append q {?hl=en&ie=UTF-8&oe=UTF-8&btnG=Google+Search}
			append q "&q=$msg"
			gotoURL $q
		    }
		}
		{^/see\s} {
		    .txt see [lindex $msg 1]
		}
		{^/alias\s?}  -
		{^/unalias\s?} {
		    processAliasCommand $msg
		}
		{^/noisy\s?} {
		    noisyUser $msg
		}
		{^/googlefight\s?} {
		    set q {http://www.googlefight.com/cgi-bin/compare.pl}
		    set n 1
		    foreach word [lrange $msg 1 end] {
			append q [expr {($n == 1) ? "?" : "&"}]
			append q q$n=$word
			incr n
		    }
		    if {[string match fr_* [msgcat::mclocale]]} {
			append q &langue=fr
		    } else {
			append q &langue=us
		    }
		    gotoURL $q
		}
		{^/log\s?} {
		    if { [string equal $msg "/log"] } {
			# Set the global logging state
			set Options(ServerLogging) all
			addSystem "Your messages will be logged by the server."
		    } else {
			# Send a single message with logging enabled:
			msgSend [string trim [string range $msg 4 end]]
		    }
		}
		{^/nolog\s?} {
		    if { [string equal $msg "/nolog"] } {
			# Set the global logging state
			set Options(ServerLogging) none
			addSystem "Your messages will not be logged by the server."
		    } else {
			# Send a single message without logging:
			tkjabber::msgSend $msg -attrs [list nolog 1]
		    }
		}	
		{^/nick\s?} {
		    tkjabber::setNick [string range $msg 6 end]
		}
		{^/topic\s?} {
		    tkjabber::setTopic [string range $msg 7 end]
		}
		{^/memo\s?} {
		    if { [regexp {^/memo ([^ ]+) (.+)} $msg -> toNick privMsg] } {
                        tkjabber::send_memo $toNick $privMsg
		    }
		}
		{^/me\s?} {
		    switch $Options(ServerLogging) {
			oldStyle -
			none {
			    tkjabber::msgSend "/nolog$msg" -attrs [list nolog 1]
			}
			default {
			    tkjabber::msgSend $msg
			}			
		    }
		}
		{^/ot\s?} {
		    if { [regexp {^/ot/?me (.+)$} $msg -> action] } {
			tkjabber::msgSend "/nolog/me $action"  -attrs [list nolog 1]
		    } else {
			tkjabber::msgSend "/nolog [string range $msg 4 end]" -attrs [list nolog 1]
		    }
		}
		{^/msg\s} {
		    if { [regexp {^/msg ([^ ]+) (.+)} $msg -> toNick privMsg] } {
			tkjabber::msgSend $privMsg -user $toNick
		    }
		}
                {^/away} -
                {^/afk} {
                    set status ""
                    regexp {^/(?:(?:afk)|(?:away))\s*(.*)$} $msg -> status
                    tkjabber::away $status
                }
                {^/back} {
                    set status [string range $msg 5 end]
                    tkjabber::back $status
                }
		default	 {
		    if {![checkAlias $msg]} then {
			# might be server command - pass it on			
			switch $Options(ServerLogging) {
			    none {
				tkjabber::msgSend "/nolog $msg" -attrs [list nolog 1]
			    }				
			    default {
				tkjabber::msgSend $msg
			    }			
			}
		    }
		}
	    }
	}
	default {
	    # check for user defined macro
	    set words [regexp -all -inline -- {\S+} $msg]
	    set macro [lindex $words 0]
	    if {[info exists Options(Macro,$macro)]} {
		# invoke macro instead of raw string
		# build subst map - build it from higher number
		# down so that %10 matches before %1
		set i [llength $words]
		set map [list %% %]
		while {$i >0} {
		    incr i -1
		    lappend map %$i@ [join [lrange $words $i end]]
		    lappend map %$i [lindex $words $i]
		}
		set msg [string map $map $Options(Macro,$macro)]
	    }
	    if {[string equal $Options(MsgTo) "All Users"]} {
		switch $Options(ServerLogging) {
		    none {
			tkjabber::msgSend "/nolog $msg" -attrs [list nolog 1]
		    }				
		    default {
			tkjabber::msgSend $msg
		    }			
		}
	    } else {
		msgSend $msg $Options(MsgTo)
	    }
	}
    }
    .eMsg delete 0 end
    .tMsg delete 1.0 end

    if {$msg != ""} {
	# add it to a recent history list
	upvar #0 ::tkchat::eHIST hist ::tkchat::eCURR cur
	if {[info exists hist] && [string compare $msg [lindex $hist end]]} {
	    # append new different msg, but constrain to max of 50 last msgs
	    set hist [lrange [lappend hist $msg] end-50 end]
	    # set current event to last
	    set cur [llength $hist]
	} elseif { [info exists hist] } {
	    set cur [llength $hist]
	}
    }
}

proc ::tkchat::entryUp {} {
    # Up arrow event in the message entry
    set w .eMsg
    upvar #0 ::tkchat::eHIST hist ::tkchat::eCURR cur
    if {$cur == 0} return
    if {$cur == [llength $hist]} {
	# at the end of the history, save the current line
	set ::tkchat::curMsg [$w get]
    }
    if {$cur} { incr cur -1 }
    $w delete 0 end
    set str [$w insert 0 [lindex $hist $cur]]
}

proc ::tkchat::entryDown {} {
    # Down arrow event in the message entry
    set w .eMsg
    upvar #0 ::tkchat::eHIST hist ::tkchat::eCURR cur
    if {$cur == [llength $hist]} return
    if {[incr cur] == [llength $hist] && [info exists ::tkchat::curMsg]} {
	# at the end of the history, it is the saved current line
	set msg $::tkchat::curMsg
    } else {
	set msg [lindex $hist $cur]
    }
    $w delete 0 end
    set str [$w insert 0 $msg]
}

proc ::tkchat::hideExtra {} {
    grid remove .tMsg
    grid config .eMsg -in .btm -row 0 -column 1 -sticky ew
    .ml config -text ">>" -command ::tkchat::showExtra
    .eMsg delete 0 end
    .eMsg insert end [string trim [.tMsg get 1.0 end]]
}
proc ::tkchat::showExtra {} {
    global Options
    grid remove .eMsg
    grid config .tMsg -in .btm -row 0 -column 1 -sticky ew
    .ml config -text "<<" -command ::tkchat::hideExtra
    .tMsg delete 1.0 end
    .tMsg insert end [.eMsg get]
}
proc ::tkchat::logonScreen {} {
    global Options LOGON
    tkjabber::disconnect
    if {![winfo exists .logon]} {
	toplevel .logon -class dialog
	wm withdraw .logon
	wm transient .logon .
	wm title .logon "Logon to the Tcl'ers Chat"

        set lf [frame .logon.frame]
	checkbutton .logon.prx -text "Use Proxy" -var Options(UseProxy) \
            -underline 7
	label .logon.lph -text "Proxy host:port" -underline 0
        frame .logon.fpx
	entry .logon.eph -textvar Options(ProxyHost)
	entry .logon.epp -textvar Options(ProxyPort) -width 5
	label .logon.lpan -text "Proxy Auth Username" -underline 11
	label .logon.lpap -text "Proxy Auth Password" -underline 13
	entry .logon.epan -textvar Options(ProxyUsername)
	entry .logon.epap -textvar Options(ProxyPassword) -show {*}
	label .logon.lnm -text "Chat Username" -underline 9
	label .logon.lpw -text "Chat Password" -underline 6
	entry .logon.enm -textvar Options(Username)
	entry .logon.epw -textvar Options(Password) -show *
	checkbutton .logon.rpw -text "Remember Chat Password" \
              -var Options(SavePW) -underline 0
        frame .logon.fjsrv
	label .logon.ljsrv -text "Jabber server:port" -underline 0
	entry .logon.ejsrv -textvar Options(JabberServer)
	entry .logon.ejprt -textvar Options(JabberPort) -width 5
	label .logon.ljres -text "Jabber resource" -underline 3
	entry .logon.ejres -textvar Options(JabberResource)
        label .logon.lconf -text "Jabber conference" -underline 10
        entry .logon.econf -textvar Options(JabberConference)
	#checkbutton .logon.rjabberpoll -text "Use Jabber HTTP Polling" \
        #      -var Options(UseJabberPoll)

        frame .logon.sslopt -borderwidth 0
        radiobutton .logon.nossl -text "No SSL" \
            -var Options(UseJabberSSL) -value no -underline 1 \
            -command ::tkjabber::TwiddlePort
        radiobutton .logon.rjabberssl -text "Jabber SSL" \
            -var Options(UseJabberSSL) -value ssl \
            -command ::tkjabber::TwiddlePort
        radiobutton .logon.rstarttls -text "STARTTLS" \
            -var Options(UseJabberSSL) -value starttls \
            -command ::tkjabber::TwiddlePort
        
	checkbutton .logon.atc -text "Auto-connect" -var Options(AutoConnect) \
            -underline 5
        frame  .logon.f  -border 0
	button .logon.ok -text "Logon" -command "set LOGON 1" -width 8 -underline 0
	button .logon.cn -text "Cancel" -command "set LOGON 0" -width 8 -underline 0
	button .logon.qu -text "Quit" -width 8 -underline 0 \
            -command [namespace origin quit]
        catch {.logon.ok configure -default active}
        pack .logon.qu .logon.cn .logon.ok -in .logon.f -side right

        bind .logon <Alt-x> {.logon.prx invoke}
        bind .logon <Alt-l> {.logon.ok invoke}
        bind .logon <Alt-q> {.logon.qu invoke}
        bind .logon <Alt-c> {.logon.cn invoke}
        bind .logon <Alt-p> {focus .logon.eph}
        bind .logon <Alt-u> {focus .logon.epan}
        bind .logon <Alt-s> {focus .logon.epap}
        bind .logon <Alt-n> {focus .logon.enm}
        bind .logon <Alt-a> {focus .logon.epw}
        bind .logon <Alt-r> {.logon.rpw invoke}
        bind .logon <Alt-t> {.logon.atc invoke}
        bind .logon <Alt-e> {.logon.rjabberssl invoke}
        bind .logon <Alt-j> {focus .logon.ejsrv}
        bind .logon <Alt-b> {focus .logon.ejres}
        bind .logon <Alt-o> {focus .logon.nossl}
        bind .logon <Alt-f> {focus .logon.econf}

	trace variable Options(UseProxy)  w [namespace origin optSet]
	trace variable Options(SavePW)    w [namespace origin optSet]

        pack .logon.ejprt -in .logon.fjsrv -side right -fill y
        pack .logon.ejsrv -in .logon.fjsrv -side right -fill both -expand 1

        pack .logon.epp -in .logon.fpx -side right -fill y
        pack .logon.eph -in .logon.fpx -side right -fill both -expand 1

        pack .logon.nossl .logon.rjabberssl .logon.rstarttls \
            -in .logon.sslopt -side left 

	grid .logon.prx -           -           -in $lf -sticky w -pady 3
        grid  x         .logon.lph  .logon.fpx  -in $lf -sticky w -pady 3
	grid  x         .logon.lpan .logon.epan -in $lf -sticky w -pady 3
	grid  x         .logon.lpap .logon.epap -in $lf -sticky w -pady 3
	grid .logon.lnm .logon.enm  -           -in $lf -sticky ew -pady 5
	grid .logon.lpw .logon.epw  -           -in $lf -sticky ew
	grid x          .logon.rpw  -           -in $lf -sticky w -pady 3
	grid x        .logon.ljsrv .logon.fjsrv -in $lf -sticky w -pady 3
	grid x        .logon.ljres .logon.ejres -in $lf -sticky w -pady 3
	grid x        .logon.lconf .logon.econf -in $lf -sticky w -pady 3
        grid x        .logon.sslopt -           -in $lf -sticky w -pady 3
	grid x        .logon.atc    -           -in $lf -sticky w -pady 3
	grid x        x             .logon.f    -in $lf -sticky e -pady 4

        pack $lf -side top -fill both -expand 1
	wm resizable .logon 0 0
        raise .logon
        bind .logon <Return> [list .logon.ok invoke]
        bind .logon <Escape> [list .logon.cn invoke]
    }

    set have_tls [expr {[package provide tls] != {}}]
    if {! $have_tls} {
        .logon.nossl invoke
        foreach w {.logon.nossl .logon.rjabberssl .logon.rstarttls} {
            $w configure -state disabled
        }
    }

    optSet
    catch {::tk::PlaceWindow .logon widget .}
    wm deiconify .logon
    tkwait visibility .logon
    focus -force .logon.ok
    grab .logon
    vwait LOGON
    grab release .logon
    wm withdraw .logon
    if {$LOGON} {
        if {$Options(UseProxy)} {
            catch {unset Options(ProxyAuth)}
            ::http::config -proxyhost $Options(ProxyHost) \
                -proxyport $Options(ProxyPort)
        }
        # connect
        logonChat
    }
}

proc ::tkchat::optSet {args} {
    global Options

    if {$Options(UseProxy)} {
	set s normal
    } else {
	set s disabled
    }
    foreach w {lph eph epp lpan epan lpap epap} {
	.logon.$w config -state $s
    }
    if {$Options(SavePW)} {
	.logon.atc config -state normal
    } else {
	.logon.atc config -state disabled
	set Options(AutoConnect) 0
    }
}

proc ::tkchat::registerScreen {} {
    global Options

    set ::PasswordCheck ""
    set ::REGISTER ""
    set r .register

    if {![winfo exists $r]} {
	toplevel $r -class dialog
	wm withdraw $r
	wm transient $r .
	wm title $r "Register for the Tcler's Chat"
	
	label $r.
	label $r.lfn -text "Full name" -underline 9
	label $r.lem -text "Email address" -underline 9
	label $r.lnm -text "Chat Username" -underline 9
	label $r.lpw -text "Chat Password" -underline 6
	label $r.lpwc -text "Confirm Password" -underline 6
	entry $r.efn -textvar Options(Fullname)
	entry $r.eem -textvar Options(Email)
	entry $r.enm -textvar Options(Username)
	entry $r.epw -textvar Options(Password) -show *
	entry $r.epwc -textvar ::PasswordCheck -show *
	
	button $r.ok -text "Ok" -command "set ::REGISTER ok" -width 8 -underline 0
	button $r.cn -text "Cancel" -command "set ::REGISTER cancel"  -width 8 -underline 0

        bind $r <Alt-k> {.logon.ok invoke}
        bind $r <Alt-q> {.logon.cn invoke}
        bind $r <Alt-n> {focus .logon.enm}
        bind $r <Alt-a> {focus .logon.epw}

	grid $r.lfn $r.efn - -sticky w -pady 3
	grid $r.lem $r.eem - -sticky w -pady 3
	grid $r.lnm $r.enm - -sticky w -pady 3
	grid $r.lpw $r.epw - -sticky w -pady 3
	grid $r.lpwc $r.epwc - -sticky w -pady 3
	grid $r.ok - $r.cn -pady 10
	wm resizable $r 0 0
        raise $r
        bind $r <Return> [list .logon.ok invoke]
        bind $r <Escape> [list .logon.cn invoke]
    }
    catch {::tk::PlaceWindow $r widget .}
    wm deiconify $r
    tkwait visibility $r
    focus -force $r.efn
    grab $r
    while { 1 } {
	vwait ::REGISTER
	if { $::REGISTER eq "cancel" } {
	    break
	}
	if { $Options(Password) ne $::PasswordCheck } {
	    tk_messageBox -message "The passwords do not match." \
		    -title "Password mismatch" -type ok
	    continue
	}
	break
    }
    grab release $r
    wm withdraw $r
    return [expr { $::REGISTER eq "ok" }]
}


proc ::tkchat::doBug {msg} {
    # msg should be off form: ^/bug[: ]id
    if {[llength $msg] != 2} {
	addSystem "wrong # args: must be /bug id" end ERROR
	return
    }
    set id  [lindex $msg end]
    set url "http://sourceforge.net/support/tracker.php?aid=$id"
    gotoURL $url
}

## ::tkchat::Find - searches in text widget $w for $str and highlights it
## If $str is empty, it just deletes any highlighting
# ARGS: w	- text widget
#	str	- string to search for
#	-case	TCL_BOOLEAN	whether to be case sensitive	DEFAULT: 0
#	-regexp	TCL_BOOLEAN	whether to use $str as pattern	DEFAULT: 0
## Taken from tkcon
##
proc ::tkchat::Find {w str args} {
    $w tag remove found 1.0 end
    set opts  {}
    foreach {key val} $args {
	switch -glob -- $key {
	    -c* { if {[string is true -strict $val]} { set case 1 } }
	    -r* { if {[string is true -strict $val]} { lappend opts -regexp } }
	    default { return -code error "Unknown option $key" }
	}
    }
    if {![info exists case]} { lappend opts -nocase }
    if {[string match {} $str]} return
    $w mark set foundmark 1.0
    while {[string compare {} [set ix [eval $w search $opts -count numc -- \
	    [list $str] foundmark end]]]} {
	$w tag add found $ix ${ix}+${numc}c
	$w mark set foundmark ${ix}+1c
    }
    return
}

# Patch 627521 by Pascal Scheffers:
# Search the chat window. msg should be what the user entered including
# the /? prefix.
# Modified by JH to be less compute-intensive, tighter code
proc ::tkchat::doSearch {msg} {
    variable searchString
    variable searchOffset

    if {[regexp {^/\?(.+)} $msg -> newSearch]} {
	if {$newSearch != "" && ![string equal $newSearch $searchString]} {
	    # new search string differs from the previous, new search!
	    set searchString $newSearch
	    Find .txt $searchString -regexp 1
	    set searchOffset 0
	}
    }

    # do we need to search at all?
    if {$searchString != ""} {
	# we need to query each time since the ranges will change if
	# we are clipping output at the top
	set ranges [.txt tag ranges found]
	set len [llength $ranges]
	if {$len} {
	    if {$searchOffset <= 0 || $searchOffset > $len} {
		# wrap to last (this is also the first seen)
		set searchOffset [expr {$len - 2}]
	    } else {
		incr searchOffset -2
	    }
	    .txt see [lindex $ranges $searchOffset]
	} else {
	    addSystem "Bummer. Could not find '$searchString'"
	}
    }
}

# Clear the search state and move back to the end of input.
proc ::tkchat::resetSearch {} {
    variable searchString ""
    .txt tag remove found 1.0 end
    .txt see end
}

# a couple of little helper funcs
proc ::tkchat::newColor {w idx} {
    set init "#$::DlgData(Color,$idx,Mine)"
    set tmp [tk_chooseColor \
                   -title "Select Override Color" \
                   -initialcolor $init]
    if {$tmp != ""} {
	set ::DlgData(Color,$idx,Mine) [string range $tmp 1 end]
	$w config -fg $tmp -selectcolor $tmp
    }
}
proc ::tkchat::buildRow {f idx disp} {
    global DlgData
    variable buildRow_seq
    if { ![info exists buildRow_seq] } {
	set buildRow_seq 1
    } else {
	incr buildRow_seq
    }
    set seq $buildRow_seq
    ::tk::label $f.nm$seq -text "$disp" -anchor w -font NAME -padx 0 -pady 0
    ::tk::radiobutton $f.def$seq -text "default" \
          -var DlgData(Color,$idx,Which) \
          -val Web -fg "#$DlgData(Color,$idx,Web)" \
          -selectcolor "#$DlgData(Color,$idx,Web)" \
          -indicatoron 0 -padx 0 -pady 0 -font FNT
    ::tk::radiobutton $f.inv$seq -text "inverted" \
          -var DlgData(Color,$idx,Which) \
          -val Inv -fg "#$DlgData(Color,$idx,Inv)" \
          -selectcolor "#$DlgData(Color,$idx,Inv)" \
          -indicatoron 0 -padx 0 -pady 0 -font FNT
    ::tk::radiobutton $f.ovr$seq -text "custom" \
          -var DlgData(Color,$idx,Which) \
          -val Mine -fg "#$DlgData(Color,$idx,Mine)"\
          -selectcolor  "#$DlgData(Color,$idx,Mine)" \
          -indicatoron 0  -padx 0 -pady 0 -font FNT
    button $f.clr$seq -text "..." -padx 0 -pady 0  -font FNT \
          -command [list ::tkchat::newColor $f.ovr$seq $idx]
    grid $f.nm$seq $f.def$seq $f.inv$seq $f.ovr$seq $f.clr$seq \
          -padx 2 -pady 2 -sticky ew
}

proc ::tkchat::EditMacros {} {
    set t .macros
    catch {destroy $t}
    toplevel $t -class Dialog
    wm transient $t .
    wm withdraw $t
    wm title $t "Edit Macros"

    listbox $t.lst -yscroll "$t.scr set" -font FNT -selectmode extended
    scrollbar $t.scr -command "$t.lst yview"
    label $t.lbl1 -text "Macro:" -font NAME
    entry $t.mac -width 10 -font FNT -validate all -vcmd {regexp -- {^\S*$} %P}
    bind $t.mac <Return> "focus $t.txt"
    label $t.lbl2 -text "Text:" -font NAME
    entry $t.txt -width 40 -font FNT
    bind $t.txt <Return> "$t.sav invoke"
    bind $t.lst <Double-1> "::tkchat::MacroSel %W @%x,%y"
    button $t.sav -text Save -command "::tkchat::MacroSave $t"
    button $t.del -text Delete -command "::tkchat::MacroKill $t.lst"
    set    help "Macros are invoked whenever the first word in the posted\n"
    append help "message matches a defined macro name. Instead of the\n"
    append help "original message being sent, the Text from the macro\n"
    append help "definition is sent instead. You can substitue words from\n"
    append help "the post into the replacement text by using placeholders\n"
    append help "like %N. where N is which word to be inserted, where 1 is\n"
    append help "the first word after the macro name (%0 is the macro name itself)\n"
    append help "%N@ will substitute the Nth word to end of all input words.\n"
    append help "To get a litereal % char (if followed by a number) use %%\n"
    append help "Extra words are ignored, and if too few words passed the escape\n"
    append help "sequence will be shown\n"
    append help "\n"
    append help "Example: Macro foo defined as \n"
    append help "             '/me needs to %1 his %2 at the %3 because %4@'\n"
    append help "         User enters \n"
    append help "              'foo wash monkey zoo he is so dirty'\n"
    append help "         Result is everyone else seeing:\n"
    append help "    *user needs to wash his monkey at the zoo because he is so dirty\n"
    append help "\n"
    label $t.hlp -text $help -font FNT -justify left

    grid $t.lst - $t.scr -sticky news
    grid $t.del - - -sticky {} -pady 3
    grid $t.lbl1 $t.mac - -sticky nws
    grid $t.lbl2 $t.txt - -sticky news
    grid $t.sav - - -sticky {} -pady 3
    grid $t.hlp - - -sticky news -padx 10

    grid rowconfigure $t 0 -weight 10
    grid columnconfigure $t 1 -weight 10

    tkchat::MacroList $t.lst
    catch {::tk::PlaceWindow $t widget .}
    wm deiconify $t
}
proc ::tkchat::MacroSave {t} {
    global Options
    set m [string trim [$t.mac get]]
    set s [string trim [$t.txt get]]
    if {[string length $m] > 0 &&
        [string length $s] > 0} {
        set Options(Macro,$m) $s
        ::tkchat::MacroList $t.lst
    }
}
proc ::tkchat::MacroKill { w } {
    global Options
    foreach idx [$w curselection] {
        set m [lindex [split [$w get $idx]] 0]
        catch {unset Options(Macro,$m)}
    }
    tkchat::MacroList $w
}
proc ::tkchat::MacroSel { w idx} {
    global Options
    set m [lindex [split [$w get $idx]] 0]
    if {[info exists Options(Macro,$m)]} {
        [winfo parent $w].mac delete 0 end
        [winfo parent $w].txt delete 0 end
        [winfo parent $w].mac insert end $m
        [winfo parent $w].txt insert end $Options(Macro,$m)
    }
}
proc ::tkchat::MacroList {w} {
    global Options
    $w delete 0 end
    foreach idx [lsort [array names Options Macro,*]] {
        $w insert end [format "%-10s  %s" [string range $idx 6 end] $Options($idx)]
    }
}

proc ::tkchat::ChangeColors {} {
    global Options DlgData

    # clear old data
    catch {unset DlgData}
    # make copy of current settings
    array set DlgData [array get Options Color,*]
    set DlgData(MyColor) $Options(MyColor)

    #Build screen
    set t .opts
    catch {destroy $t}
    toplevel $t -class Dialog
    wm transient $t .
    wm protocol $t WM_DELETE_WINDOW {set ::DlgDone cancel}
    wm withdraw $t
    wm title $t "Color Settings"

    label $t.l1 -text "Posting Color" -font NAME
    label $t.l2 -text "Example Text" -background white \
        -foreground \#$DlgData(MyColor) -font ACT
    button $t.myclr -text "Change..." -font FNT -command {
        set tmp [tk_chooseColor \
                       -title "Select Your User Color" \
                       -initialcolor \#$::DlgData(MyColor)]
        if {$tmp != ""} {
            .opts.l2 config -foreground $tmp
            set ::DlgData(MyColor) [string range $tmp 1 end]
        }
    }

    label $t.l3 -text "Display Color Overrides" -font NAME
    frame $t.f -relief sunken -bd 2 -height 300
    canvas $t.f.cvs -yscrollcommand [list $t.f.scr set] \
          -width 10 -height 300 -highlightthickness 0 -bd 0
    scrollbar $t.f.scr -command [list $t.f.cvs yview]
    pack $t.f.cvs -side left -expand 1 -fill both
    pack $t.f.scr -side left -fill y
    set f [frame $t.f.cvs.frm]
    $t.f.cvs create window 0 0 -anchor nw -window $f
    bind $f <Configure> {
	[winfo parent %W] config -width [expr {%w+5}] -scrollregion [list 0 0 %w %h]
    }
    foreach {key str} {Web "All\nDefault" Inv "All\nInverted" Mine "All\nCustom"} {
        button $f.all$key -text $str -padx 0 -pady 0 -font SYS -command \
              [string map [list %val% $key] {
                  foreach idx [array names DlgData *,Which] {
                      set DlgData($idx) %val%
                  }
              }]
    }
    grid x $f.allWeb $f.allInv $f.allMine x -padx 1 -pady 1
    foreach {idx str} {MainBG Background MainFG Foreground SearchBG Searchbackgr} {
        buildRow $f $idx $str
    }
    grid [label $f.online -text "Online Users" -font SYS] - - -
    foreach nick [lsort -dict $Options(OnLineUsers)] {
        if {[info exists DlgData(Color,$nick,Which)]} {
            buildRow $f $nick $nick
        }
    }
    grid [label $f.offline -text "Offline Users" -font SYS] - - -
    foreach nick [lsort -dict $Options(NickList)] {
        if {[lsearch -exact $Options(OnLineUsers) $nick] < 0} {
            buildRow $f $nick $nick
        }
    }
    frame $t.f2
    button $t.f2.ok -width 8 -text "OK" -command {set DlgDone ok} -font SYS
    button $t.f2.app -width 8 -text "Apply" -command {set DlgDone apply} -font SYS
    button $t.f2.can -width 8 -text "Cancel" -command {set DlgDone cancel} -font SYS
    pack $t.f2.ok $t.f2.app $t.f2.can -side left -expand 1 -fill none

    grid $t.l1  $t.l2 $t.myclr x -padx 1 -pady 3 -sticky {}
    grid $t.l3    -       -    - -padx 1 -pady 3 -sticky ew
    grid $t.f     -       -    - -padx 1 -pady 5 -sticky news
    grid $t.f2    -       -    - -padx 1 -pady 10 -sticky news
    grid rowconfigure $t 2 -weight 1
    grid columnconfigure $t 3 -weight 1
    wm resizable $t 0 1
    catch {::tk::PlaceWindow $t widget .}
    wm deiconify $t
    set working 1
    while {$working} {
	vwait ::DlgDone
	switch -- $::DlgDone {
	    ok {
		set working 0
		set change 1
	    }
	    apply {
		set working 1
		set change 1
	    }
	    cancel {
		set change 0
		set working 0
	    }
	}
	if {$change} {
	    # propagate changes to main data
	    array set Options [array get DlgData]
	    # update colors
            applyColors
	}
    }
    destroy $t
}

proc ::tkchat::applyColors {} {
    global Options
    # update colors
    .txt config -bg "#[getColor MainBG]" -fg "#[getColor MainFG]"
    .names config -bg "#[getColor MainBG]" -fg "#[getColor MainFG]"
    .txt tag configure found -background "#[getColor SearchBG]"
    foreach nk $Options(NickList) {
        set clr [getColor $nk]
        if {$clr == ""} {
            set clr [getColor MainFG]
        }
	if {[catch {
	    .txt tag config NICK-$nk -foreground "#$clr"
	    .txt tag config NOLOG-$nk -foreground "#[fadeColor $clr]"
	} msg]} then { log::log debug "applyColors: \"$msg\"" }
    }
}

# Point the Chat log to a new file.
proc ::tkchat::OpenChatLog {opt} {
    global Options
    switch -exact -- $opt {
        close {
            set Options(ChatLogFile) ""
            set Options(ChatLogOff) 1
            Hook remove message [namespace origin ChatLogHook]
            if {[info exists Options(ChatLogChannel)]} {
                close $Options(ChatLogChannel)
                unset Options(ChatLogChannel)
            }
        }
        open {
            set newFileName [tk_getSaveFile -initialfile $Options(ChatLogFile)]
            if {[string length $newFileName]>0} {
                if {[catch {
                    set f [open $newFileName a]
                    fconfigure $f -buffering line -encoding utf-8
                    set Options(ChatLogFile) $newFileName
                    if {[info exists Options(ChatLogChannel)]} {
                        close $Options(ChatLogChannel)
                    }
                    set Options(ChatLogChannel) $f
                    set Options(ChatLogOff) 0
                    Hook add message [namespace origin ChatLogHook]
                } err]} {
                    # Handle file access problems.
                    log::log error $err
                    bgerror $err
                }
            }
        }
    }
}

proc ::tkchat::ChatLogHook {who str url} {
    global Options
    if {! $Options(ChatLogOff)} {
        set T [clock format [clock seconds] -format "%Y%m%dT%H:%M:%S"]
        puts $Options(ChatLogChannel) "$T: $who\t$str"
    }
}

# Point the Error Log to a new file
proc ::tkchat::OpenErrorLog {opt} {
    global Options
    switch -exact -- $opt {
        stderr {
            set Options(LogFile) {}
            set Options(LogStderr) 1
            if {![string match stderr $Options(errLog)]} {
                close $Options(errLog)
            }
            set Options(errLog) stderr
            log::lvChannelForall $Options(errLog)
        }
        pick {
            set newFileName [tk_getSaveFile -initialfile $Options(LogFile)]
            if {[string length $newFileName]>0} {
                if {[catch {
                    set f [open $newFileName a]
                    fconfigure $f -buffering line
                    set Options(LogFile) $newFileName
                    set oldchannel $Options(errLog)
                    set Options(errLog) $f
                    if {![string match stderr $oldchannel]} {
                        close $oldchannel
                    }
                    set Options(LogStderr) 0
                    log::lvChannelForall $Options(errLog)
                } err]} {
                    # Handle file access problems.
                    set Options(LogFile) {}
                    set Options(LogStderr) 1
                    set Options(errLog) stderr
                    log::lvChannelForall $Options(errLog)
                    log::log error $err
                    bgerror $err
                }
            }
        }
    }
}

proc ::tkchat::quit {} {
    set q "Are you sure you want to quit?"
    set a [tk_messageBox -type yesno -message $q]
    if {[string equal $a "yes"]} {
	::tkchat::saveRC
	exit
    }
}

proc ::tkchat::saveRC {} {
    global Options
    if {[info exists ::env(HOME)]} {
	set rcfile [file join $::env(HOME) .tkchatrc]
        set Options(Geometry) [wm geometry .]
        if {[winfo exists .pane] && $::Options(DisplayUsers)} {
            set Options(Pane) [.pane sash coord 0]
        }
	array set tmp [array get Options]
	set ignore {
            History FetchTimerID OnlineTimerID FinalList NamesWin
            FetchToken OnlineToken OnLineUsers ProxyPassword ProxyAuth
            URL URL2 URLchk URLlogs errLog ChatLogChannel PaneUsersWidth
	    retryFailedCheckPage JabberDebug JabberConnect
        }
	if {!$tmp(SavePW)} {
	    lappend ignore Password
	}
	foreach idx $ignore {
	    catch {unset tmp($idx)}
	}
	set oplist [list]
	foreach option [lsort [array names tmp]] {
	    lappend oplist [list $option $tmp($option)]
	}
	if {![catch {open $rcfile w 0600} fd]} {
            fconfigure $fd -encoding utf-8
	    puts $fd "# Auto-generated file: DO NOT MUCK WITH IT!"
	    puts $fd "array set Options \{"
	    puts $fd [join $oplist "\n"]
	    puts $fd "\}"
	    puts $fd "# Auto-generated file: DO NOT MUCK WITH IT!"
	    close $fd
	}
    }
}

proc ::tkchat::scroll_set {sbar f1 f2} {
    global Options
    $sbar set $f1 $f2
    if {($f1 == 0) && ($f2 == 1)} {
	grid remove $sbar
    } else {
        if {[winfo exists .pane]} {
            grid $sbar -in .txtframe
        } else {
            grid $sbar
        }
    }
#    set Options(AutoScroll) [expr {(1.0 - $f2) < 1.0e-6 }]
    set Options(AutoScroll) [expr {$f2 == 1}]
#    log::log debug "scroll_set: $sbar set $f1 $f2 (AutoScroll:\
#       $Options(AutoScroll))"
}


proc ::tkchat::Debug {cmd args } {
    switch -- $cmd {
	console {
	    if {$::tkchat::_console} {
		console show
	    } else {
		console hide
	    }
	}
	reload {
	    uplevel \#0 [list source $::argv0]
            set msg  "Script has been reloaded!\nDo you want to restart?"
            set a [tk_messageBox -type yesno -message $msg]
            if {[string equal $a yes]} {
                Debug restart
            }
	}
	restart {
	    tkjabber::disconnect
	    saveRC
	    eval destroy [winfo children .]
	    eval font delete [font names]
	    unset ::Options
	    after 2000 [linsert $::argv 0 ::tkchat::Init]
	}
	retrieve {
	    Retrieve
	}
	purge {
	    .txt config -state normal
	    .txt delete 1.0 end
	    set ::Options(History) {}
            .txt config -state normal
            catch {::tkchat::LoadHistory}
	}
        server {
            # Permit remote control using either DDE or the tcllib comm package
            # We'll fix the title bar so people know which instance we are.
            #
            variable ServerID
            if {![info exists ServerID]} {
                if {![catch {package require dde}]} {
                    set ServerID [tk appname]
                    set count 0
                    while {[dde services TclEval $ServerID] != {}} {
                        incr count
                        set ServerID "[tk appname] #$count"
                    }
                    dde servername $ServerID
                    if {$count != 0} {
                        wm title . "[wm title .] #$count"
                    }
                } elseif {![catch {package require comm}]} {
                    set ServerID [comm::comm self]
                    wm title . "[wm title .] $ServerID"
                }
            }
        }
	evalSel {
	    if { [catch {selection get} script] } {
		tk_messageBox -message "Couldn't get selection\n$script"
	    } else {
		if {[info complete $script] } {
		    if { [catch {uplevel \#0 $script} msg] } {
			tk_messageBox -message "pasted script errored\n$msg"
		    }
		} else {
		    tk_messageBox -message "script was not complete"
		}
	    }
	}
    }
}

proc ::tkchat::ChooseFont {} {
    set font [::dkfFontSel::dkf_chooseFont \
	    -initialfont [list $::Options(Font,-family) \
                               $::Options(Font,-size) \
                               {}] \
	    -apply ::tkchat::SetFont]
    if { [string compare {} $font] } {
	SetFont $font
    }
    return
}

proc ::tkchat::SetFont { fontString } {
    foreach { family size } $fontString break
    set ::Options(Font,-family) $family
    set ::Options(Font,-size) $size
    foreach font {FNT ACT NOLOG NAME SYS STAMP} {
	font configure $font -family $family -size $size
    }
    return
}

proc ::tkchat::ChangeFont {opt val} {
    set ::Options(Font,$opt) $val
    foreach font {FNT ACT NOLOG NAME SYS STAMP} {
	font configure $font $opt $val
    }
}

proc ::tkchat::DoAnim {} {
    if {$::Options(AnimEmoticons)} {
        foreach img [image names] {
            set name [lindex [split $img :] end]
            catch {after cancel $::tkchat::img::id($name)}
            anim $img
        }
    } else {
        foreach {nm id} [array get ::tkchat::img::id] {
            after cancel $id
        }
    }
}

proc ::tkchat::anim {image {idx 0}} {
    namespace eval ::tkchat::img {} ; # create img namespace
    set this [lindex [info level 0] 0]
    if {[catch {$image configure -format "GIF -index $idx"}]} {
	if {$idx == 1} {
	    # stop animating, only base image exists
	    return
	}
        set cmd [list ::tkchat::anim $image]
    } else {
        set cmd [list ::tkchat::anim $image [expr {$idx + 1}]]
    }
    catch {after cancel $::tkchat::img::id($image)}
    set ::tkchat::img::id($image) [after $::tkchat::img::delay $cmd]
}

proc ::tkchat::SmileId {{image {}} args} {
    # Here be magic
    variable IMG
    foreach arg $args {	set IMG($arg) $image }
    # Do some checking so that things like 'C:/temp/tcl98/blah' and
    # 'lollipop' don't get smileys inserted
    set ids ""
    foreach arg [array names IMG] {
	if {[string is alnum -strict -failindex i $arg]} {
	    lappend ids "\1$arg\1"
	} elseif {$i > 0} {
	    lappend ids "\2$arg"
	} else {
	    lappend ids "\3$arg"
	}
    }
    set ids [join $ids "\0"]
    # The double-back is needed because when map is converted to a list,
    # it will become a single-back.
    set map {
	| \\| ( \\( ) \\) [ \\[ - \\- . \\. * \\* ? \\?
                                \\ \\\\ ^ \\^ $ \\$ \1 \\y \2 \\m \3 \\Y \0 |
    }
    # If we ever change this to use () capturing, change tkchat::Insert too.
    set ::tkchat::IMGre [string map $map $ids]
}

proc ::tkchat::Smile {} {
    namespace eval ::tkchat::img {} ; # create img namespace
    set ::tkchat::img::delay 400
    SmileId cry ":-(" ":^(" ":("
    image create photo ::tkchat::img::cry -format GIF -data {
        R0lGODlhDwAPANUAAP8AzeEDueQFvcUFp8kKq1AqdFJDkCQhUiIvaQASIQUr
        SAAdMQEjOgBtqABqowJ5uj1ofwCf9QCI0QB/xAB9vwB7vQB3twB1swBzsQBw
        rABhlAGb7QKo/gKU4gKFywWO18DAwAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAACAALAAAAAAPAA8AAAaa
        QJBQiFAoGIehElRAeDqdTwVRWBqenGxkI7EYhgVPlgONSJ6YKgjRyXoSCQo8
        M0GADpNIpANPVPoVDQcMH3oRHxAfGxMVFh4PCwwSG5QdEJRnExMXkU9QHQ8S
        DxgZFRQYCwcYURIORkcKGhUaSQgUXbENDg4asXZMDWelFhcYF7xqIAYOF4zE
                xxrJQk0OGQ0NGlRLQwcL3klKQQA7
    }
    SmileId grrr "8-(" "8^(" "8(" "8-|" "8^|" "8|"
    image create photo ::tkchat::img::grrr -format GIF -data {
        R0lGODlhDwAPANX/AMDAwM/RAMXHALGzAJKUAP//AOvrAOfnAObmAN/fANzc
        ANfYANjYANXVAM7PAM7OAMrKAMDBAMHBAL29ALS1ALW1ALO0ALS0AK6vAK6u
        AKytAKusAKysAKurAKqqAKmpAKOkAKSkAKKjAKChAJiZAJmZAJGSAJKSAJGR
        AI2OAI6NAI6OAI2NAHd3AP///8PDwwAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAPAA8AAAaB
        QIBQCCsWh0hAcfXxfFZHJCxlwjgCDgyKBRtON8VQAlTcpLpKUwV0JsBUIcqp
        a6zb6y37x56HeUpGEAUQRiUeRR8PEQ8TBwYFCg8SD3swKxALHUYTDQgMEFBK
        HBcwLy4vYQEaaFMCJEYiIzAboUQpHBkDFg8QKGdJS01PUUlKdUlBADs=
    }
    SmileId LOL-anim LOL lol
    image create photo ::tkchat::img::LOL-anim -format GIF -data {
        R0lGODlhFQAYAKIFAAAAABhr/+fn5///AP///wAAAAAAAAAAACH/C05FVFND
        QVBFMi4wAwEAAAAh+QQFCgAFACwAAAAAFQAYAAADS1i63P4wykmrvbiAve0e
        INgtgAOEqKicJZm+JcucwyfSce3eoV3jq5fQ1sENeSocrafsaZgcnzR44ziB
        VGFStRuuOA3fzRPNmM+WBAAh+QQFCgAFACwKAAkABwADAAADCAgwrMrjrTYS
        ACH5BAkKAAUALAoACAAHAAQAAAMIOADK/SPKORMAIfkECQoABQAsAAAGABIA
        DgAAAz1YUNwNEDIwllN06ArrzV1Xec82ZqelmBQKLqjJbrBsu+t4468caRYQ
        IQIZgkoVglLZiiA5v8HlaZs+YpwEACH5BAkKAAUALAAABAASABAAAANDWFDc
        /mosSOOEIGcGJO5DKGWjA5KkFG6R2IHqyom067Y1DS9wvsqtnus0G9U0miKA
        gFxeTCuCVNqh7JChipBWUQgzCQAh+QQJCgAFACwAAAIAEgASAAADRVhQ3P5q
        LEjjrA9IDDW4zicymgR+Q5qK6uWhbLlFrVSvpKrfk7zzuZ9O1FsJQUHUEEkD
        EIhOZpNApWooMmiq4tthlC1AAgAh+QQJCgAFACwAAAEAEwATAAADTVhQ3P4M
        jAVrnNZKmt/m3TWBEWBy0oA1puqaysuO3yfHatvm+ez+rx4OCDxRUsQfxEaE
        eXI72mCZIxBOVkklBbB6U9uX0aVJCrdIaCEBACH5BAkKAAUALAAAAQATABMA
        AANJWLrc/jDKBaYDo1qaIfgfpzHfYJohFoolmGGvAqPZWaOyrdP4vJ+ziuqH
        gmlUPmCpU1ARQNAnNPd6WksP4/VpyipdXS9xdEmGEgAh+QQJCgAFACwAAAEA
        EwATAAADTli63P5wgQjBmLRZnOWtQMhtnBIOKBoW1jW66Xmq5qXadvuxad/r
        E5JPNcNsCKIksmW8IJ8AaLImgi5L1KsSa4p6rVxeCGypEEU0kG+VAAAh+QQJ
        CgAFACwAAAEAEwATAAADTli63A0uMjCgjNTeV7fL2gSMGlWF46CqY2F2Crim
        KRtXLI6/1rv+ut4JyKoJAQSSMqm8IZ/JaMg5kjKnrpNyi3lun5iTNSUxbW1l
        36mQAAAh+QQJCgAFACwAAAAAFAAWAAADXlhQ3P4NjAVrnDZLmuHm3TWBoTRg
        D6Cqjoky6imzynzFZ7yY3BZMwMAnF/nJjgPhivJx5WKeCWG5mg6igKk2y72m
        Rtwt9Este1vg8jjFLU9JsNH2/fqmeR3cDF6hOhIAIfkECQoABQAsAAAAABQA
        GAAAA2tYutwOLjYwoJTU3ld3zJqnUFU4AmhIdgs6vC86wloGx91qZYHelzFF
        DxAIVI7FVLBAdN1izZSwR0hZqwGHEVAVALze6oCTqpqVZKuakl6jJyW3qy0f
        P7juqmmGOutZHHFOewxONIR3UgsJAAAh+QQJCgAFACwAAAAAFAAYAAADXli6
        3P4wSgfmA6NahvVWHQSMI5d5IDasJ7iW7sjKlZrFQaYHna0BOZZwwFOVerYX
        7RUjkJ5O3a3QcVoB1xMMeXXKKNrncwAWm8kUrFmNWvS6NJGSxIzIhLCJ+MPn
        JwAAIfkECQoABQAsAAAAABQAGAAAA2tYutwOLjYwoJTU3ld3zJqnUFU4AmhI
        dgs6vC86wloGx91qZYHelzFFDxAIVI7FVLBAdN1izZSwR0hZqwGHEVAVALze
        6oCTqpqVZKuakl6jJyW3qy0fP7juqmmGOutZHHFOewxONIR3UgsJAAAh+QQJ
        CgAFACwAAAAAFAAYAAADYlhQ3P4NjAVrnDZLmuHm3TWBoTRgD6Cqjoky6imz
        ynzFZ7yY3BZMwMAnF/nJjgPhivJx5WKeCWG5mg6igKk2y72mRtwt9Este1vg
        8jjFLU9JsNH2/fqmeR3cDF6hhv6AFgkAACH5BAkKAAUALAAAAAAUABgAAANr
        WLrcDi42MKCU1N5Xd8yap1BVOAJoSHYLOrwvOsJaBsfdamWB3pcxRQ8QCFSO
        xVSwQHTdYs2UsEdIWasBhxFQFQC83uqAk6qalWSrmpJeoyclt6stHz+47qpp
        hjrrWRxxTnsMTjSEd1ILCQAAIfkECQoABQAsAAAAABQAGAAAA15Yutz+MEoH
        5gOjWob1Vh0EjCOXeSA2rCe4lu7IypWaxUGmB52tATmWcMBTlXq2F+0VI5Ce
        Tt2t0HFaAdcTDHl1yija53MAFpvJFKxZjVr0ujSRksSMyISwifjD5ycAACH5
        BAkKAAUALAAAAAAUABgAAANrWLrcDi42MKCU1N5Xd8yap1BVOAJoSHYLOrwv
        OsJaBsfdamWB3pcxRQ8QCFSOxVSwQHTdYs2UsEdIWasBhxFQFQC83uqAk6qa
        lWSrmpJeoyclt6stHz+47qpphjrrWRxxTnsMTjSEd1ILCQAAIfkECQoABQAs
        AAAAABQAGAAAA2JYUNz+DYwFa5w2S5rh5t01gaE0YA+gqo6JMuops8p8xWe8
        mNwWTMDAJxf5yY4D4YryceVinglhuZoOooCpNsu9pkbcLfRLLXtb4PI4xS1P
        SbDR9v36pnkd3AxeoYb+gBYJAAAh+QQJCgAFACwAAAAAFAAYAAADa1i63A4u
        NjCglNTeV3fMmqdQVTgCaEh2Czq8LzrCWgbH3Wplgd6XMUUPEAhUjsVUsEB0
        3WLNlLBHSFmrAYcRUBUAvN7qgJOqmpVkq5qSXqMnJberLR8/uO6qaYY661kc
        cU57DE40hHdSCwkAACH5BAkKAAUALAAAAAAUABgAAANeWLrc/jBKB+YDo1qG
        9VYdBIwjl3kgNqwnuJbuyMqVmsVBpgedrQE5lnDAU5V6thftFSOQnk7drdBx
        WgHXEwx5dcoo2udzABabyRSsWY1a9Lo0kZLEjMiEsIn4w+cnAAAh+QQJCgAF
        ACwAAAAAFAAYAAADa1i63A4uNjCglNTeV3fMmqdQVTgCaEh2Czq8LzrCWgbH
        3Wplgd6XMUUPEAhUjsVUsEB03WLNlLBHSFmrAYcRUBUAvN7qgJOqmpVkq5qS
        XqMnJberLR8/uO6qaYY661kccU57DE40hHdSCwkAACH5BAkKAAUALAAAAAAU
        ABgAAANiWFDc/g2MBWucNkua4ebdNYGhNGAPoKqOiTLqKbPKfMVnvJjcFkzA
        wCcX+cmOA+GK8nHlYp4JYbmaDqKAqTbLvaZG3C30Sy17W+DyOMUtT0mw0fb9
        +qZ5HdwMXqGG/oAWCQAAIfkECQoABQAsAAAAABQAGAAAA2tYutwOLjYwoJTU
        3ld3zJqnUFU4AmhIdgs6vC86wloGx91qZYHelzFFDxAIVI7FVLBAdN1izZSw
        R0hZqwGHEVAVALze6oCTqpqVZKuakl6jJyW3qy0fP7juqmmGOutZHHFOewxO
        NIR3UgsJAAAh+QQJCgAFACwAAAAAFAAYAAADXli63P4wSgfmA6NahvVWHQSM
        I5d5IDasJ7iW7sjKlZrFQaYHna0BOZZwwFOVerYX7RUjkJ5O3a3QcVoB1xMM
        eXXKKNrncwAWm8kUrFmNWvS6NJGSxIzIhLCJ+MPnJwAAIfkECQoABQAsAAAA
        ABQAGAAAA2tYutwOLjYwoJTU3ld3zJqnUFU4AmhIdgs6vC86wloGx91qZYHe
        lzFFDxAIVI7FVLBAdN1izZSwR0hZqwGHEVAVALze6oCTqpqVZKuakl6jJyW3
        qy0fP7juqmmGOutZHHFOewxONIR3UgsJAAAh+QQJCgAFACwAAAAAFAAYAAAD
        YlhQ3P4NjAVrnDZLmuHm3TWBoTRgD6Cqjoky6imzynzFZ7yY3BZMwMAnF/nJ
        jgPhivJx5WKeCWG5mg6igKk2y72mRtwt9Este1vg8jjFLU9JsNH2/fqmeR3c
        DF6hhv6AFgkAACH5BAkKAAUALAAAAAAUABgAAANrWLrcDi42MKCU1N5Xd8ya
        p1BVOAJoSHYLOrwvOsJaBsfdamWB3pcxRQ8QCFSOxVSwQHTdYs2UsEdIWasB
        hxFQFQC83uqAk6qalWSrmpJeoyclt6stHz+47qpphjrrWRxxTnsMTjSEd1IL
        CQAAIfkECQoABQAsAAAAABQAGAAAA15Yutz+MEoH5gOjWob1Vh0EjCOXeSA2
        rCe4lu7IypWaxUGmB52tATmWcMBTlXq2F+0VI5CeTt2t0HFaAdcTDHl1yija
        53MAFpvJFKxZjVr0ujSRksSMyISwifjD5ycAACH5BAUKAAUALAAAAAAUABgA
        AANrWLrcDi42MKCU1N5Xd8yap1BVOAJoSHYLOrwvOsJaBsfdamWB3pcxRQ8Q
        CFSOxVSwQHTdYs2UsEdIWasBhxFQFQC83uqAk6qalWSrmpJeoyclt6stHz+4
        7qpphjrrWRxxTnsMTjSEd1ILCQAAIf4aQ29weXJpZ2h0IKkgMjAwMCBLbGFh
        cyBXaXQAOw==
    }
    SmileId mad ">:(" ">:-(" ">:^("
    image create photo ::tkchat::img::mad -format GIF -data {
        R0lGODlhDwAPALP/AMDAwEpKSjk5Kd7ehP//Y729QoSEKefnKa2tEEpKAISE
        AK2tAL29AO/vAAAAAAAAACH5BAEAAAAALAAAAAAPAA8AAARlEEhZ0EJlalAW
        +9+1IUqyNOiSKMtUMKzCNPAiI5LXKIfhw7TWCyUIHAqHgADFqMwaRYJUybQ8
        fVKCj3l5HrLSQ3WIkg6kKBpOh/IZxEEJ4tNYnBh3Bi4XSnvwI38gIhsUFgh7ExEAOw==
    }
    SmileId oh ":-o" ":^o" ":o" ":-O" ":^O" ":O"
    image create photo ::tkchat::img::oh -format GIF -data {
        R0lGODlhDwAPALMAAAAAABgYGGPG/wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAACH5BAEAAAEALAAAAAAPAA8AAAQyMEgJap04VMH5
        xUAnelM4jgDlmcLWap3bsvIp1vaao+z+9pab6gYsxWQpUG+WKVmSkwgAOw==
    }
    SmileId smile ":-)" ":^)" ":)"
    image create photo ::tkchat::img::smile -format GIF -data {
        R0lGODlhDwAPAJEBAAAAAL+/v///AAAAACH5BAEAAAEALAAAAAAPAA8AAAIu
        jA2Zx5EC4WIgWnnqvQBJLTyhE4khaG5Wqn4tp4ErFnMY+Sll9naUfGpkFL5DAQA7
    }
    SmileId smile-big ":-D" ":^D" ":D"
    image create photo ::tkchat::img::smile-big -format GIF -data {
        R0lGODlhEAAQALMAAAAAAKamAP//AP///wAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAACH5BAEAAAEALAAAAAAQABAAAAQ/MEgJqp04VMF7
        zUAnelPocSZKiWYqANrYyu5Io1a+ve0wAD7gD4fTWYivoHL4iiWFwNaqeFRN
        bdZSjZfR5jIRADs=
    }
    SmileId smile-dork "<:-)" "<:^)" "<:)"
    image create photo ::tkchat::img::smile-dork -format GIF -data {
        R0lGODlhEQAfAKIEAP//AAAAAP///zMzM////wAAAAAAAAAAACH5BAEAAAQA
        LAAAAAARAB8AAANhSLrcPi6uIGMQtLKL9RSdR3ChRmYmCKLSoJbWu1akyja1
        LeVzLPc4WWB4U5wCgOTQQUQmn4CbE0plOYdPbHSSnWq3I6pYaRyLM9fxtaxs
        flFeDCa7ycq9uC6eOW2bmiIeCQA7
    }
    SmileId smile-glasses "8-)" "8^)" "8)"
    image create photo ::tkchat::img::smile-glasses -format GIF -data {
        R0lGODlhFAAQALMAAAAAAAD/ANbWAP//AP///wAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAACH5BAEAAAEALAAAAAAUABAAAARUMMgZgL00Tzu6
        t9rmjV8ICGQKaOc1uivVEjTQATRhx9Wl17jfZUUUBHW33K4iORk5HyivIkCl
        SFPnwIYtyarbIXfLqhp1uPF0Yx56TU7zM5QRryURADs=
    }
    SmileId smile-tongue-anim ":-p" ":^p" ":p"
    image create photo ::tkchat::img::smile-tongue-anim -format GIF -data {
        R0lGODlhDwAPAMQTAAAAADExAGMxAGNjAGNjMZxjAJycAJycMc6cAM7OAM7O
        Mc7OY/8AMf/OAP//AP//Mf//Y///nP///wAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAACH/C05FVFNDQVBFMi4wAwEAAAAh+QQFZAAT
        ACwAAAAADwAPAAAIjQAnCBw4gMCAgQgHHoAQIQIEBQcSClzQ0CGEiwoSKmh4
        8YFHjwgUXoQAAIDHkg8cFBCoYGRJBw5KQmgQkoBHBSlh6kzAk0CABwgCNNCp
        M8CABAEINGgg4OjOAgEQJCAwAUGDAVizZk1gQODRARLCipXwdaCBBGDHHu2K
        0IBWrFwlThhwlqdbuQMJ6JUYEAAh+QQFDAATACwDAAUACQAKAAAIRQAhQAAA
        wIEDgg4UPDDI0EGCAA0aGgwgYEAChgkKBEgwoCODjgEMJBiJgAEDBCNTqhwp
        cmUCAxMGtHw5YILNCQQCELgZEAAh+QQFDAATACwGAAkAAwAFAAAIDAAZCBxI
        UGACBgkCAgAh+QQFDAATACwEAAQACAALAAAIQgAhCHzwYCCAgw4cHATwIKFD
        BwkaPEwYYEAChwkKVBzAoOOAAAYSJOjIAIFIkSRPouwo0sAAAyRdTphJgAGB
        mRMCAgAh+QQFDAATACwGAA0AAwACAAAICQATMEhAoGBAAAAh+QQFDAATACwG
        AAsAAwADAAAICgATMEhAsGCCgAAAIfkEBQwAEwAsBQAJAAUAAwAACAwABwgc
        mKDggAQEAwIAOw==
    }
    SmileId smirk-glasses ";/" ";-/" ";^/" ":/" ":-/" ":^/" "8/" "8-/" "8^/"
    image create photo ::tkchat::img::smirk-glasses -format GIF -data {
        R0lGODlhDwAPANX/AMDAwM/RAKepAJmbAI2PAICCAHp7AGxtAGlqAP//APr7
        APX2APX1AOrqANzdANXVAM7OAMzNAMvMAMnKAMnJAMjIAMfHAMTFAMLDAMDB
        ALu7ALi5ALe4ALa3ALe3ALGxALCwAKurAKqqAKenAKWmAKOkAKSkAKGiAKCg
        AJ6fAJucAJqbAJubAJmaAJGSAI6PAI+PAIiIAIWGAIaGAIGCAIKCAICBAIGB
        AGlpAFNTAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAPAA8AAAaG
        QIBQqCsWh0hAkUZTrWpHpA4hi+lEmZMMpxvquEXUY2PMdZUzF8t0qVxKKsPR
        SK/TD/VRHa9TwYwUCRRGLypFAxkeIQ8JjQ8WHBktSxogOhAMCgsNDhEaNF06
        KQI6IxQSEw4BGClnOjYdBHQfGB0FZ0o3KSckIyQaKTe4RDo0LU6gw1J0SUEAOw==
    }
    SmileId tongue2 ":-P" ":^P" ":P"
    image create photo ::tkchat::img::tongue2 -format GIF -data {
        R0lGODlhDwAPAMT/AMDAwFoAAJQAAK0AAM4QADkQAKUxAFI5EL21ADExKVpa
        Ss7Oa///c/f3Y4SEKe/vSv//SrW1MXNzGK2tEPf3CBgYAGNjAIyMAKWlAM7O
        AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAPAA8AAAWHICCK0WRG
        Ywo4Vpsh7aFOF4YgVIbt2BghGYuGQsRoLoiJCEipVCIQiERjeQEimQwlkVhE
        HZVqpqSlOBQNRmORwGVMZciDQZcT35M4JN2I5t5YGRcZD4UPRBQWFygIGC0S
        Dg4HBwUBFxckTIgEAwIDSSMTQGUEAgIGPSmiWS8GAqkqVyYTKCkhADs=
    }
    SmileId updown "(:" "(^:" "(-:"
    image create photo ::tkchat::img::updown -format GIF -data {
        R0lGODlhDwAPALMAAAAAAFr/zv//AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAACH5BAEAAAEALAAAAAAPAA8AAAQwMEgJap04VMH5
        xUAnelPoWaYAUN5orunoxnK31TOen3YK88CVRkdi4YQl2iejQWUiADs=
    }
    SmileId wink-anim ";-)" ";^)" ";)"
    image create photo ::tkchat::img::wink-anim -format GIF -data {
        R0lGODlhDwAPAPcAAOD0AL/WAKu6AF9oAICMAERKALe3t11oAm57A6y7MaWz
        L+//Y/H/Wer/N+j9M+j4MsfZL7jEMpWiKvD/cfD/SdnoMOz8NODvM73OMBwd
        CfH/e8nbM+7/WyQnDTo9IwAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAACH5BAEAAAYALAAAAAAPAA8AAAinAA0IFNihYMGB
        CA0UvECBQgMIBxF2YKhBw4QFDB5g6DCwQ4WGDRcscMAwAkeFFT6o/LDhgcoK
        FTh22LCggQUMGzhYULmhQYKCDUSKrMigwgYHDyB2cJCRwYIJExg00HhhY4cH
        FzxEaMiApAStVrcm8KAAAoYIXyVskCCzggMFHuLGlQDhJ8EEJCMkSKCgLAS2
        HRVgMAqhcALAEjso0Hs4YkKFBk8ODAgAOw==
    }
    SmileId blush ":-\}" ":^\}" ":8\}" ":\}"
    image create photo ::tkchat::img::blush -format GIF -data {
        R0lGODlhEAAQAMIAAAAAAPiUGPisEPj8APj8+AAAAAAAAAAAACH5BAEAAAQA
        LAAAAAAQABAAAAM9SKrQvpC0QWuLoGq78v4AQ02WF3oDOaKTIHyUmwJCELxb
        fTc6rvUtX+510jhQKRHM2FmOMMhVpHMMTa/XBAA7
    }
    SmileId coffee LP
    image create photo ::tkchat::img::coffee -format GIF -data {
	R0lGODlhEAAQAPECAAAAAH9/f////wAAACH5BAEAAAIALAAAAAAQABAAAAKR
	TJgwoUSJEiVKlKgwYUKJEiVKlChRYcKIEiVKlKgwYUSJEiVKlChRYcKIEiVK
	lChRosKEEiVKlChRokSJEiVKlCgRIECAACVKlCgRIECAAAFKlCgRIECAAAVK
	lCgRIECAAAVKlCgRIECAAAFKlCgRIECAACVKlChRIECAECVKFAgQIECAAAFC
	lCgQIECAACFKBQA7
    }
    SmileId lunch |O| |o| |0|
    image create photo ::tkchat::img::lunch -format GIF -data {
	R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAKRTJgwYcKE
	CRMmRIgwYcKECRMCBIgwYcKECRMCBIgwIUCACBMCBIgQIECAABECBIgQYMKE
	ARECBAgQYcKECQECDAgQYcKECQECDAgQYcKECQECDAgQYcKECQECDAgQYcKE
	CQECDIgQYMKEARECDIgQIECAABECDIgwIUCACBMCDIgwYcKECRMGTJgwYcKE
	CRMmBQA7
    }
    SmileId snooze zz zzz zzZ zZZ ZZZ ZZ
    image create photo ::tkchat::img::snooze -format GIF -data {
	R0lGODlhEAALAPABAAAAAP///yH5BAEAAAEALAAAAAAQAAsAAAJkTJgwYcKE
	AAECTJgwYcKEAAECTJgwYcKECRMCTJgwYcKECQMiTJgQIECECQEmTJgwYUCE
	AREmTJgwIcCEABMmBIgwIMKEAAECTIgQYMKEAAECDJgQIECECRMmBIgwYcKE
	CRMmBQA7
    }
    SmileId beer |_P
    image create photo ::tkchat::img::beer -format GIF -data {
	R0lGODlhEAAQAPECAAAAAP//AP///wAAACH5BAEAAAIALAAAAAAQABAAAAKR
	lChRokSJEiVKhChRokSJECVKhCgQoECAECVKBAgwIMCEACFKRJgwYcKEAAFK
	RBgwYcKEEAVCRJgwYcKEECUCRJgwYcKEECUCRJgwIcKEECUCRIgwYcKEECUC
	RJgwYUKEEAVCRJgwYcKEAAFKRJgwYMKEACFKRJgwYcKEECVKRJgwYcKEECVK
	BAgQIECAECVKBQA7
    }

    SmileId cyclops "O-\]" "O-)" "0-\]" "0-)"
    image create photo ::tkchat::img::cyclops -format GIF -data {
        R0lGODlhDwAPAKEAANnZ2QAAAP//AP///yH5BAEAAAMALAAAAAAPAA8AAAIz
        nB2Zx5MC4WIhWnlqVDagDYSa4I2BKG4jGQLr08HqRUvaumH3dX82h/HVPBTc
        pOFQEA8FADs=
    }

    SmileId donuts "donuts"
    image create photo ::tkchat::img::donuts -format GIF -data {
        R0lGODlhKAAPALIBAAAAAP//AGNjY0JC/0JCQjExMQAAAAAAACH/C05FVFND
        QVBFMi4wAwEAAAAh+QQJCgAGACwAAAAAKAAPAAADfmiq0L0wyklbuPfRKboX
        E4CN2RYNAqGuICSSJGAu6Gq3DBxY+6zUNlZOx+vNgEFV56UbyRjPUyrJYjZL
        hqgESRVYMd+nQ/ubdr1Nq2xN4d4WX7AjS9dA3ErXNcM2fT4ScWAMPgseG0V8
        cwoFjY6NEEEmY2SMAgWXmQUKVCoLCQAh+QQJCgAGACwAAAAAKAAPAAADf2iq
        0L0wyklbuPfRKboXE4CN2RYNAqGuICSSJGAu6Gq3DBxY+6zUNlZOx+vNgEFV
        56UbyRjPUyrJYjZLhqgESRVYMd+nY8INLptWmVoDKQuHMIeaQXETcNlrRpzV
        Lj4fEl9OC34bHhtFe3IKBY6PjhBBJnKGBgUCmJqZClQqCwkAIfkECQoABgAs
        AAAAACgADwAAA3xoqtC9MMpJW7j30Sm6FxOAjdkWDQKhriAkkiRgLuhqtwwc
        WPus1DZWTsfrzYBBVeelG8kYz1MqyWI2S4aoBEkVWDHfp2PCDS6bVpl2O03i
        vuCxWAMpK13XzHzz+UjgYAtiMx4bRXoOTwWLjIsQQSaJawoFApWXlgpUKgsJ
        ACH5BAkKAAYALAAAAAAoAA8AAAN9aKrQvTDKSVu499EpuhcTgI3ZFg0Coa4g
        JJIkYC7oarcMHFj7rNQ2Vk7H682AQVXnpRvJjqkki9ksMZ6nqJQgoGK8T6wE
        mVw2qbK0mKYN4rxfhyG8/rWFC3gsbPp8JHpWc3N1ER4bRRkOGgWNjo0QQSaL
        hQUClpiXClsECwkAIfkECQoABgAsAAAAACgADwAAA35oqtC9MMpJW7j30Sm6
        FxOAjdkWDQKhriAkkiRgLuhqtwwcWPus1DZWTsfrzYBBVeelG8mOqSSL2Swx
        nqeolCCgYrxPrASZXDapYcdYG8R5v2qDTAwhCxfv2GNOV3w+EnlWcj5+HRtF
        GQ4aBY2OjRBBJot9BgUCl5mYClsECwkAIfkECQoABgAsAAAAACgADwAAA31o
        qtC9MMpJW7j30Sm6FxOAjdkWDQKhriAkkiRgLuhqtwwcWPus1DZWTsfrzYBB
        VeelG8lcT1oqyWI2S4soBEkVWDFfreM07Xqb1qh2Ww7ivuAxwyCXdl3XjKMe
        +XwkcGBzDBocHRtFenUFjI2MEEEme2sKBQKWmJcKVCoLCQAh+QQFCgAGACwA
        AAAAKAAPAAADfWiq0L0wyklbuPfRKboXE4CN2RYNAqGuICSSJGAu6Gq3DBxY
        +6zUNlZOx+vNgEFV56UbyRjPUyrJYjZLhqgESRVYMd+nY8INLptWmXY7TeK+
        4HFUAykrXdfMfPP5SOBgLllrER4bRXoODwWMjYwQQSaKhAYFApaYlwpUKgsJ
        ADs=
    }

    SmileId bug "bug #" "bug#"
    image create photo ::tkchat::img::bug -format GIF -data {
        R0lGODlhEAAQAKEAAAAAAP///////////yH5BAEAAAIALAAAAAAQABAAAAIr
        lA94y5kMhYsL2Psg3tGGAHxWg4EgZjwbKlXr6L6sKqfxSsqXneI8BQweCgA7
    }
}

proc ::tkchat::ShowSmiles {} {
    set t .smileys
    if {[winfo exists $t]} {
        wm deiconify $t
        raise $t
    } else {
        variable IMG
        foreach {i e} [array get IMG] {
            lappend tmp($e) $i
        }
        toplevel $t
        catch {::tk::PlaceWindow $t widget .}
        wm title $t "Available Emoticons"
        wm protocol $t WM_DELETE_WINDOW [list wm withdraw $t]
        set txt [text $t.txt -font NAME -tabs {1.5i l 2.0i l} \
                       -height [expr {[llength [image names]] + 5}]]
        if {[string equal [tk windowingsystem] "win32"]} {
            $txt configure -background SystemButtonFace -foreground SystemButtonText
        } else {
            $txt configure -background "#c0c0c0" -foreground black
        }
        set sb [scrollbar $t.sb -command [list $txt yview]]
        $txt configure -yscrollcommand [list $sb set]

        foreach image [lsort [image names]] {
            set name [lindex [split $image :] end]
            $txt insert end "$name\t"
            $txt image create end -image $image
            if {[info exists tmp($name)]} {
                $txt insert end "\t[join $tmp($name) "   "]"
            }
            $txt insert end \n
        }
        $txt configure -state disabled
        grid $txt $sb -sticky news
        grid rowconfigure $t 0 -weight 1
        grid columnconfigure $t 0 -weight 1
        if {[llength [info command ::tk::PlaceWindow]] > 0} {
            tk::PlaceWindow $t widget .
        }
    }
}
proc ::tkchat::Init {args} {
    global Options env
    set ::URLID 0
    # set intial defaults
    set ::tkchat::eCURR 0
    set ::tkchat::eHIST ""
    array set Options {
	UseProxy	0
	ProxyHost	""
	ProxyPort	""
	Username	""
	Password	""
	SavePW		0
	Nickname	""
	UseJabberPoll	0
	UseJabberSSL	no
        JabberServer    all.tclers.tk	
        JabberPort      5222
        JabberConference tcl@tach.tclers.tk
	ServerLogging   all
	MyColor		000000
	FetchTimerID	-1
	OnlineTimerID	-1
	AutoConnect	0
	DisplayUsers	1
	Refresh		30
	NickList	{}
	History		{}
	AutoScroll	0
	Geometry	600x500+0+0
        Pane            {520 2}
        UsePane         1
	Font,-family	Helvetica
	Font,-size	-12
	MaxLines	500
	ChatLogFile	""
	LogFile		""
	LogLevel	notice
	errLog		stderr
	emoticons	1
	hideTraffic	0
	TimeFormat	"At the tone, the time is %H:%M on %A %d %b %Y"
	TimeGMT		0
	HistoryLines	-1
	timeout		30000
	Emoticons	1
	AnimEmoticons	0
        Style           {any}
        Theme           {}
        Transparency    100
        AutoFade        0
        AutoFadeLimit   80
	EnableWhiteboard 1
	Popup,USERINFO	1
	Popup,WELCOME	0
	Popup,MEMO	1
	Popup,HELP	1
	Visibility,USERINFO  1
	Visibility,WELCOME   1
	Visibility,MEMO	     1
	Visibility,HELP	     1
	Visibility,SINGLEDOT 0
	Visibility,STAMP     1
	Alert,SOUND	     0
	Alert,RAISE	     1
	Alert,ALL	     0
	Alert,ME	     1
	Alert,TOPIC	     1
	Alert,NORMAL	     1
	Alert,ACTION	     1
        WhisperIndicatorColor #ffe0e0
        UseBabelfish         0
	JabberResource       tkchat	
    }
    catch {set Options(BROWSER) $env(BROWSER)}

    foreach {name clr} { MainBG FFFFFF MainFG 000000 SearchBG FF8C44} {
	set Options(Color,$name,Web)   $clr
	set Options(Color,$name,Inv)   [invClr $clr]
	set Options(Color,$name,Mine)  $clr
	set Options(Color,$name,Which) Web
    }
    # attach a trace function to the log level
    trace variable Options(LogLevel) w [namespace origin LogLevelSet]
    LogLevelSet

    # load RC file if it exists
    if {[info exists ::env(HOME)] && \
	    [file readable [set rcfile [file join $::env(HOME) .tkchatrc]]]} {
	catch {
            set f [open $rcfile r]
            fconfigure $f -encoding utf-8
            set d [read $f]
            close $f
            eval $d
        }
    }

    # Compatability issues...
    if {[string is integer $Options(UseJabberSSL)]} {
        set Options(UseJabberSSL) [lindex {no ssl} $Options(UseJabberSSL)]
    }

    # Set the 'Hardcoded' Options:
    set Options(JabberLogs) "http://tclers.tk/conferences/tcl"
    array set Options {
	EntryMessageColor    #002500
	ExitMessageColor     #250000
    }

    if { $::tcl_platform(os) eq "Windows CE" } {
	# Disable history loading on wince
	set Options(HistoryLines) 0
    }

    set Options(Offset) 50
    catch {unset Options(FetchToken)}
    catch {unset Options(OnlineToken)}
    set Options(History) {}
    set Options(OnLineUsers) {}

    # Process command line args
    set nologin 0
    while {[string match -* [set option [lindex $args 0]]]} {
        switch -exact -- $option {
            -nologin   { set nologin 1 }
            -style     { set Options(Style) [Pop args 1] }
            -theme     { set Options(Theme) [Pop args 1] }
            -loglevel  { LogLevelSet [Pop args 1] }
            -useragent { set Options(UserAgent) [Pop args 1] }
            -debug     { set Options(JabberDebug) 1 }
            -nick - -nickname { set Options(Nickname) [Pop args 1] }
	    -conference { set Options(JabberConference) [Pop args 1] }
            -connect   { set Options(JabberConnect) [Pop args 1] }
            -jabberserver {
                set j [split [Pop args 1] :]
                if {[llength $j] > 0} {
                    set Options(JabberServer) [lindex $j 0]
                    if {[llength $j] > 1} {
                        set Options(JabberPort) [lindex $j 1]
                    }
                }
            }
            -- { Pop args ; break }
            default {
                return -code error "bad option \"$option\":\
                    must be one of -nologin, -style, -theme,\
                    -loglevel, -useragent or --."
            }
        }
        Pop args
    }

    # Set the useragent string to something a bit more standard.
    if {[info exists Options(UserAgent)]} {
        http::config -useragent $Options(UserAgent)
    } else {
        http::config -useragent "Mozilla/4.0\
            ([string totitle $::tcl_platform(platform)];\
            $::tcl_platform(os)) http/[package provide http]\
            Tcl/[package provide Tcl]"
    }

    # Open the error log to file if specified. Default is stderr.
    if {[string length $Options(LogFile)] > 0} {
	set Options(errLog) [open $Options(LogFile) a]
	fconfigure $Options(errLog) -buffering line
	set Options(LogStderr) 0
    } else {
	set Options(LogStderr) 1
    }
    log::lvChannelForall $Options(errLog)

    # Open the ChatLog file for appending.
    if {[string length $Options(ChatLogFile)] > 0} {
	set Options(ChatLogChannel) [open $Options(ChatLogFile) a]
	fconfigure $Options(ChatLogChannel) -buffering line -encoding utf-8
	set Options(ChatLogOff) 0
    } else {
	set Options(ChatLogOff) 1
    }

    SetTheme $Options(Theme)

    # do this first so we have images available
    Smile
    # build screen
    CreateGUI
    foreach idx [array names Options Visibility,*] {
	set tag [lindex [split $idx ,] end]
	.txt tag config $tag -elide $Options($idx)
    }

    Hook add chat [namespace origin IncrMessageCounter]
    BookmarkInit
    if {[tk_windowingsystem] == "win32"} {
        WinicoInit
    }

    if {$Options(UseProxy)} {
	if {$Options(ProxyHost) != "" && $Options(ProxyPort) != ""} {
	    ::http::config -proxyhost $Options(ProxyHost) \
		-proxyport $Options(ProxyPort)
	} elseif {[info exists ::env(http_proxy)]} {
	    if {[regexp {(?:http://)?([[:alnum:].-]+)(?::(\d+))?} \
                     $::env(http_proxy) -> \
                     Options(ProxyHost) \
                     Options(ProxyPort)]} {
                http::config -proxyhost $Options(ProxyHost) \
                    -proxyport $Options(ProxyPort)
            }
	}
    }

    ChangeFont -family $Options(Font,-family)
    ChangeFont -size $Options(Font,-size)

    applyColors
    createRosterImages

    #call the (possibly) user defined postload proc:
    tkchatrcPostload

    # connect
    if {! $nologin} {
        if {$Options(AutoConnect)} {
            logonChat
        } else {
            logonScreen
        }
    }
}

#############################################################
#
# askLEO
#
# This is a web scraper for English/German
# translation via http://dict.leo.org
#
# Translation is invoked on the current X selection
# (needn't be inside of tkChat) via <Shift-Button3>.
#
# Authors:
#
# 2002 - Reinhard Max	  <Reinhard.Max@gmx.de>
#	 Martin Scherbaum <maddin@scherbaum.org>
#
#############################################################
namespace forget ::dict.leo.org

namespace eval ::dict.leo.org {

    namespace export query askLEO askLEOforSelection

    package require Tk
    package require http
    package require htmlparse

    variable table ""
    variable last  ""
    variable Query ""
    variable td
    variable tdcounter 0
    variable leoURL http://pda.leo.org
}

proc ::dict.leo.org::parse {tag close options body} {
    variable td
    variable table
    variable tdcounter

    switch -- $close$tag {

	/TR - /tr {
	    if {[info exists td(2)] && [info exists td(3)]} {
		lappend table [string trim $td(2)] [string trim $td(3)]
	    }
	    set tdcounter 0
	    array unset td
	}

	td - td { incr tdcounter }

	default {
	    set item [htmlparse::mapEscapes $body]
	    if {[string length $item]} {
		append td($tdcounter) $item
	    }
	}
    }
}

proc ::dict.leo.org::query {query} {
    variable table
    variable leoURL
    set query [::http::formatQuery search $query]
    set tok [::http::geturl $leoURL -query $query]
    foreach line [split [::http::data $tok] "\n"] {
	if {[string match "*ENGLISCH*DEUTSCH*" $line]} break
    }
    ::http::cleanup $tok
    set table ""
    ::htmlparse::parse -cmd ::dict.leo.org::parse $line
	return $table
}

proc ::dict.leo.org::max {a b} {expr {$a > $b ? $a : $b}}

proc ::dict.leo.org::askLEOforSelection {} {
    if {![catch {selection get} query]} {
	askLEO $query
    }
}

proc ::dict.leo.org::askLEO {{query {}}} {

    variable w
    variable last
    variable Query
    set query [string trim $query]
    if {$query != ""} {set Query $query}
    if {$Query != $last} {
	$w.bot.text configure -state normal
	$w.bot.text delete 1.0 end
	$w.bot.text configure -state disabled
	if {$Query != ""} {
	    $w.bot.text configure -cursor watch
	    update
	    set table [dict.leo.org::query $Query]
	    set max 0
	    foreach c $table {set max [max $max [string length $c]]}
	    $w.bot.text configure -state normal
	    if {$max} {
		set sep [string repeat = $max]
		set table [linsert $table 0 " English" " Deutsch" $sep $sep]
		foreach {c1 c2} $table {
		    $w.bot.text insert end \
			[format "%-*s  %-*s\n" $max $c1 $max $c2]
		}
	    } else {
		$w.bot.text insert end {No matches}
	    }
	    $w.bot.text configure -state disabled
	    if {![winfo ismapped $w]} {wm deiconify $w} else {raise $w}
	    $w.bot.text configure -cursor ""
	}
    }
    set last $Query
}

proc ::dict.leo.org::init {} {
    variable w .leo
    variable LEOlogo
    catch {destroy $w}
    toplevel $w
    wm withdraw $w
    bind $w <Double-Button-3> [list wm withdraw $w]
    wm protocol $w WM_DELETE_WINDOW [list wm withdraw $w]
    frame $w.main
    frame  $w.top
    entry  $w.top.ent -bg white -textvariable [namespace current]::Query
    button $w.top.but -text "ask LEO" -command [namespace code askLEO]
    bind   $w.top.ent <Return> [list $w.top.but invoke]

    pack $w.top.ent -expand yes -fill x -side left
    pack $w.top.but -expand no -fill none -side left
    pack $w.top	    -fill x -in $w.main

    frame $w.bot
    scrollbar $w.bot.scry -command [list $w.bot.text yview]
    scrollbar $w.bot.scrx -orient horizontal -command [list $w.bot.text xview]
    text $w.bot.text -wrap no -font fixed -state disabled \
	-yscrollcommand [list $w.bot.scry set] -xscrollcommand [list $w.bot.scrx set]
    grid $w.bot.text -row 0 -column 0 -sticky nsew
    grid $w.bot.scry -row 0 -column 1 -sticky ns
    grid $w.bot.scrx -row 1 -column 0 -sticky ew
    grid rowconfigure $w.bot 0 -weight 1
    grid columnconfigure $w.bot 0 -weight 1
    bind $w.bot.text <Button-2> [namespace code askLEOforSelection]
    #pack $w.bot.text -expand yes -fill both -side right
    pack $w.bot -expand yes -fill both -in $w.main

    pack $w.main -expand yes -fill both
    focus $w.top.ent
    wm title $w "askLEO"

    if {$::tcl_platform(platform) != "windows"} {
	image create photo LEOlogo -data $LEOlogo
	toplevel $w.icon -bg ""
	pack [label $w.icon.l -image LEOlogo]
	wm iconwindow $w $w.icon
    }
}

set ::dict.leo.org::LEOlogo {
    R0lGODlhKAAoAPQUAAAAAAAAMwAzAAAzMzMAADMAM2YAADMz/8wAM/8AM8zMAMzMM8z/AMz/
    M//MAP/MM///AP//M///7v///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    ACH5BAEBABQALAAAAAAoACgAAAX+IEVRFEVRFEVR1AEAFEVRFEVRFEUZAEWBFEVRFEVRFEVR
    FEVRFEVR1DEhAEBRFAVSFEVRBgAAAEVRFEVRFEVRFEVRFEVRB3gcyHEAFEVRFEVRFAAAAAAA
    FEVRFEVRIEVRFEVR1HEcE3IcE0BRFEVRlAEAAACAAABQFEVRFEVRFEVRx3EcyIQcBwIAFAVS
    FEUZAAAAAAAAAEBRFEVRFEVRCHIcBzhNxzEhE0BRFEUZRgIAAAAAAAAAAEVRIEVRxzEhxzEh
    xzEhyAEAFEVRhpEkCQCAAAAAAAAAAEVRx3FME3JMCDJNx3EAAAVSlGEkSZIkCQAAAAAAAABQ
    x3Ecx4T+HBOITNNxHNMEAJRhJEmSJEmSJAAAAAAAAOBxHMdxTBMyAQUwIRMCFABQGEmSJEmS
    gEmSJAAAAACATNOEIMiETIXzAAiCFA4AFg4QPEkCFEmSJEmSAABAIQiCTNM0TRMIOAExBYTy
    OE7jOAVQAA6QJEmSJEkCUCB1HMd0IMiEBM5ABI4TAYHjBITzAAUUgEmSJEmSJAlFHdM0Icg0
    HUTgPEDkAI8DRs7jDE7gPMCTJEmSJAlFUcdxIMg0IQcYOIATOYETEM7jBIDjRMDzPEmSJElC
    USBFIQhyTAhyEE7kOM4DTFPgCNMUOMHzgM/zPEmSUBRFUQeCHBNyBM7jPMr+4wTUBAIPME2E
    4wTP8zzP8yQURVEUdRzThBAO+AiP4zgRUACFExBB4AzE8zzP8zwURVEgRVHUMSFH4ASO80CP
    4wCFAz0AAT3A84DP8zzPQ1EURVEURSHIARTQoziP4jxOBCqP4zwOQBXU8zzPQ1EURVEURVHI
    QVEA+ACR4zxA5DiP8zCP8wAPQFHPQ1EURVEgRVEURVEUVQCO80CPEziP4ziPEzmPE4AUAVAU
    RVEURVEURVEUFTiR8yjA4zgBADqN4yjO40BOQFEURVEURVEURVEURREA+DhO4DgP5DxO4DyR
    owRO4AQURVEURVEgRVEURVGBEwGPMzgPFAAB5AT+BFAAkeOAEUFRFEVRFEVRFEVRhPM4DvQ4
    QOA4jgM+jhMAheM8ABAQFEVRFEVRFEVRVAA4D+gEzuM4QVBAj/NAgfM40OMUFEVRFEVRIEVR
    FEVRgQMETuA4keNAgRM5TuBAi/OAAEVRFEVRFEVRFEVRhBNATuQEwOM8jgMGQAA4AREQAUVR
    FEVRFEVRFEVRVEA8Dhg4jhMBBfA4zuNEzuNAAUVRFEVRFEVRIEVRFEVRARQ4zuM4D+QETuQ4
    geM8DkCBFEVRFEVRFEVRFEVRBFA4zgM9gPMoTgACAeEEQEBQFEVRFEVRFEVRFEVRVOBAD+hE
    CvA4DxA5jvNAjwMFFEXiURRFURRFUSBFURRFEQ/wKM7jOJETOM4DPYDzOE5AgRRFURRFURRF
    URRFUUBAAU7gPJDyOM4DOovzAE7gRABFURRFURRFURRFUVQBUAXoRIDzAM4DBY4TOJHjBE5B
    URRFURRFUSBFURRFURRFBU7hBM4DBY4zEI7zAFQAgBRFURRFURRFURRFURRFUURAAYUDBcQD
    AhQVOBFAURRFURRFURRFURRFURRFURRIARQlPABFARRFUQFBURRFURRFURRFUSBFURRFURRF
    URRFUQVFURRFURRFURRFgRRFURRFURQVAgA7
}

::dict.leo.org::init

#######################################################################
#
# dkf's font selection dialog
#
#######################################################################

namespace eval ::dkfFontSel {

    # Local procedure names (ones that it is a bad idea to refer to
    # outside this namespace/file) are prepended with an apostrophe
    # character.  There are no externally useful variables.

    # First some library stuff that is normally in another namespace

    # Simple (nay, brain-dead) option parser.  Given the list of
    # arguments in arglist and the list of legal options in optlist,
    # parse the options to convert into array values (which are stored
    # in the caller's array named in optarray.  Does not handle errors
    # spectacularly well, and can be replaced by something that does a
    # better job without me feeling to fussed about it!
    proc 'parse_opts {arglist optlist optarray} {
	upvar $optarray options
	set options(foo) {}
	unset options(foo)
	set callername [lindex [info level -1] 0]
	if {[llength $arglist]&1} {
	    return -code error \
		    "Must be an even number of arguments to $callername"
	}
	array set options $arglist
	foreach key [array names options] {
	    if {![string match -?* $key]} {
		return -code error "All parameter keys must start\
			with \"-\", but \"$key\" doesn't"
	    }
	    if {[lsearch -exact $optlist $key] < 0} {
		return -code error "Bad parameter \"$key\""
	    }
	}
    }

    # Capitalise the given word.  Assumes the first capitalisable
    # letter is the first character in the argument.
    proc 'capitalise {word} {
	set cUpper [string toupper [string index $word 0]]
	set cLower [string tolower [string range $word 1 end]]
	return ${cUpper}${cLower}
    }

    # The classic functional operation.  Replaces each element of the
    # input list with the result of running the supplied script on
    # that element.
    proc 'map {script list} {
	set newlist {}
	foreach item $list {
	    lappend newlist [uplevel 1 $script [list $item]]
	}
	return $newlist
    }

    # ----------------------------------------------------------------------
    # Now we start in earnest
    namespace export dkf_chooseFont

    variable Family Helvetica
    variable Size   12
    variable Done   0
    variable Win    {}

    array set Style {
	bold 0
	italic 0
	underline 0
	overstrike 0
    }

    # Get the gap spacing for the frameboxes.  Use a user-specified
    # default if there is one (that is a valid integer) and fall back
    # to measuring/guessing otherwise.
    proc 'get_gap {w} {
	set gap [option get $w lineGap LineGap]
	if {[catch {incr gap 0}]} {
	    # Some cunning font measuring!
	    ::tk::label $w._testing
	    set font [$w._testing cget -font]
	    set gap [expr {[font metrics $font -linespace]/2+1}]
	    destroy $w._testing
	}
	return $gap
    }


    # Build the user interface (except for the apply button, which is
    # handled by the 'configure_apply procedure...
    proc 'make_UI {w} {
	# Framed regions.  Do this with grid and labels, as that seems
	# to be the most effective technique in practise!
	frame $w.border1 -class DKFChooseFontFrame
	frame $w.border2 -class DKFChooseFontFrame
	frame $w.border3 -class DKFChooseFontFrame
	frame $w.border4 -class DKFChooseFontFrame
	set gap ['get_gap $w]
	grid $w.border1 -row 0 -column 0 -rowspan 4 -columnspan 4 \
		-padx $gap -pady $gap -sticky nsew
	grid $w.border2 -row 0 -column 4 -rowspan 4 -columnspan 3 \
		-padx $gap -pady $gap -sticky nsew
	grid $w.border3 -row 4 -column 0 -rowspan 3 -columnspan 9 \
		-padx $gap -pady $gap -sticky nsew
	grid $w.border4 -row 7 -column 0 -rowspan 3 -columnspan 9 \
		-padx $gap -pady $gap -sticky nsew
	incr gap $gap
	foreach col {0 3 4 6 8} {
	    grid columnconfigure $w $col -minsize $gap
	}
	foreach row {0 3 4 6 7 9} {
	    grid rowconfigure    $w $row -minsize $gap
	}
	grid columnconfigure $w 1 -weight 1
	grid rowconfigure    $w 1 -weight 1
	grid rowconfigure    $w 8 -weight 1


	# Labels for the framed boxes & focus accelerators for their contents
	foreach {subname row col focusWin} {
	    Family 0 1 .family
	    Style  0 5 .style.sBold
	    Size   4 1 .size.b8
	    Sample 7 1 .sample.text
	} {
	    set l [label $w.lbl$subname]
	    grid $l -row $row -column $col -sticky w
	    set accel ['get_accel $l]
	    if {[string length $accel]} {
		bind $w <$accel> [list focus $w$focusWin]
	    }
	}


	# Font families
	frame $w.familyBox
	listbox $w.family -exportsel 0 -selectmode browse \
		-xscrollcommand [list $w.familyX set] \
		-yscrollcommand [list $w.familyY set]
	scrollbar $w.familyX -command [list $w.family xview]
	scrollbar $w.familyY -command [list $w.family yview]
	foreach family ['list_families] {
	    $w.family insert end ['map 'capitalise $family]
	}
	grid $w.familyBox -row 1 -column 1 -rowspan 1 -columnspan 2 \
		-sticky nsew
	grid columnconfigure $w.familyBox 0 -weight 1
	grid rowconfigure    $w.familyBox 0 -weight 1
	grid $w.family  $w.familyY -sticky nsew -in $w.familyBox
	grid $w.familyX            -sticky nsew -in $w.familyBox
	bind $w.family <1> [namespace code {'change_family %W [%W nearest %y]}]
	bindtags $w.family [concat [bindtags $w.family] key$w.family]
	bind key$w.family <Key> [namespace code {'change_family %W active %A}]


	# Font styles.
	frame $w.style
	grid $w.style -row 1 -column 5 -sticky news
	grid columnconfigure $w.style 0 -weight 1
	foreach {fontstyle lcstyle row next prev} {
	    Bold      bold       0 Italic    {}
	    Italic    italic     1 Underline Bold
	    Underline underline  2 Strikeout Italic
	    Strikeout overstrike 3 {}        Underline
	} {
	    set b $w.style.s$fontstyle
	    checkbutton $b -variable [namespace current]::Style($lcstyle) \
		    -command [namespace code 'set_font]
	    grid $b -sticky nsew -row $row
	    grid rowconfigure $w.style $row -weight 1
	    if {[string length $next]} {
		bind $b <Down> [list focus $w.style.s$next]
	    }
	    if {[string length $prev]} {
		bind $b <Up> [list focus $w.style.s$prev]
	    }
	    bind $b <Tab>       "[list focus $w.size.b8];break"
	    bind $b <Shift-Tab> "[list focus $w.family ];break"
	    set accel ['get_accel $b]
	    if {[string length $accel]} {
		bind $w <$accel> "focus $b; $b invoke"
	    }
	    bind $b <Return> "$b invoke; break"
	}


	# Size adjustment.  Common sizes with radio buttons, and an
	# entry for everything else.
	frame $w.size
	grid $w.size -row 5 -column 1 -rowspan 1 -columnspan 7 -sticky nsew
	foreach {size row col u d l r} {
	    8  0 0  {} 10 {} 12
	    10 1 0   8 {} {} 14
	    12 0 1  {} 14  8 18
	    14 1 1  12 {} 10 24
	    18 0 2  {} 24 12 {}
	    24 1 2  18 {} 14 {}
	} {
	    set b $w.size.b$size
	    radiobutton $b -variable [namespace current]::Size -value $size \
		    -command [namespace code 'set_font]
	    grid $b -row $row -column $col -sticky ew
	    #grid columnconfigure $w.size $col -weight 1
	    if {[string length $u]} {bind $b <Up>    [list focus $w.size.b$u]}
	    if {[string length $d]} {bind $b <Down>  [list focus $w.size.b$d]}
	    if {[string length $l]} {bind $b <Left>  [list focus $w.size.b$l]}
	    if {[string length $r]} {bind $b <Right> [list focus $w.size.b$r]}
	    bind $b <Tab>       "[list focus $w.size.entry ];break"
	    bind $b <Shift-Tab> "[list focus $w.style.sBold];break"
	    set accel ['get_accel $b]
	    if {[string length $accel]} {
		bind $w <$accel> "focus $b; $b invoke"
	    }
	    bind $b <Return> "$b invoke; break"
	}
	entry $w.size.entry -textvariable [namespace current]::Size
	grid $w.size.entry -row 0 -column 3 -rowspan 2 -sticky ew
	grid columnconfigure $w.size 3 -weight 1
	bind $w.size.entry <Return> \
		[namespace code {'set_font;break}]


	# Sample text.  Note that this is editable
	frame $w.sample
	grid $w.sample -row 8 -column 1 -columnspan 7 -sticky nsew
	grid propagate $w.sample 0
        ::tk::entry $w.sample.text
        catch {
            $w.sample.text configure -background [$w.sample cget -background]
        }
	$w.sample.text insert 0 [option get $w.sample.text text Text]
	grid $w.sample.text


	# OK, Cancel and (partially) Apply.  See also 'configure_apply
	frame $w.butnframe
	grid $w.butnframe -row 0 -column 7 -rowspan 4 -columnspan 2 \
		-sticky nsew -pady $gap
	foreach {but code} {
	    ok  0
	    can 1
	} {
	    button $w.butnframe.$but -command \
		    [namespace code [list set Done $code]]
	    pack $w.butnframe.$but -side top -fill x -padx [expr {$gap/2}] \
		    -pady [expr {$gap/2}]
	}
	button $w.butnframe.apl
	bind $w.butnframe.ok <Down> [list focus $w.butnframe.can]
	bind $w.butnframe.can <Up> [list focus $w.butnframe.ok]
    }


    # Convenience proc to get the accelerator for a particular window
    # if the user has given one.  Makes it simpler to get this right
    # everywhere it is needed...
    proc 'get_accel {w} {
	option get $w accelerator Accelerator
    }


    # Called when changing the family.  Sets the family to either be
    # the first family whose name starts with the given character (if
    # char is non-empty and not special) or to be the name of the
    # family at the given index of the listbox.
    proc 'change_family {w index {char {}}} {
	variable Family
	if {[string length $char] && ![regexp {[]*?\\[]} $char]} {
	    set idx [lsearch -glob ['list_families] $char*]
	    if {$idx >= 0} {
		set index $idx
		$w activate $idx
		$w selection clear 0 end
		$w selection anchor $idx
		$w selection set $idx
		$w see $idx
	    }
	}
	set Family [$w get $index]
	##DEBUG
	#wm title [winfo toplevel $w] $Family
	'set_font
    }


    # The apply button runs this script when pressed.
    proc 'do_apply {w script} {
	'set_font
	set font [$w.sample.text cget -font]
	uplevel #0 $script [list $font]
    }


    # Based on whether the supplied script is empty or not, install an
    # apply button into the dialog.  This is not part of 'make_UI
    # since it happens at a different stage of initialisation.
    proc 'configure_apply {w script} {
	set b $w.butnframe.apl
	set binding [list $b invoke]
	if {[string length $script]} {
	    # There is a script, so map the button
	    array set packinfo [pack info $w.butnframe.ok]
	    $b configure -command [namespace code [list 'do_apply $w $script]]
	    pack $b -side top -fill x -padx $packinfo(-padx) \
		    -pady $packinfo(-pady)

	    bind $w.butnframe.can <Down> [list focus $w.butnframe.apl]
	    bind $w.butnframe.apl <Up>   [list focus $w.butnframe.can]

	    # Set up accelerator.  Tricky since we want to force a
	    # systematic match with the underline
	    set uline [$b cget -underline]
	    if {$uline>=0} {
		set uchar [string index [$b cget -text] $uline]
		set uchar [string tolower $uchar]
		bind $w <Meta-$uchar> $binding
	    }

	} else {
	    # No script => no button
	    set manager [winfo manager $b]
	    if {[string length $manager]} {
		$manager forget $b

		# Now we must remove the accelerator!  This is tricky
		# since we don't actually know what it is officially
		# bound to...
		foreach bindseq [bind $w] {
		    if {![string compare [bind $w $bindseq] $binding]} {
			bind $w $bindseq {}
			break
		    }
		}

	    }
	}
    }


    # Set the font on the editor window based on the information in
    # the namespace variables.  Returns a 1 if the operation was a
    # failure and 0 if it iwas a success.
    proc 'set_font {} {
	variable Family
	variable Style
	variable Size
	variable Win

	set styles {}
	foreach style {italic bold underline overstrike} {
	    if {$Style($style)} {
		lappend styles $style
	    }
	}
	if {[catch {
	    expr {$Size+0}
	    if {[llength $styles]} {
		$Win configure -font [list $Family $Size $styles]
	    } else {
		$Win configure -font [list $Family $Size]
	    }
	} s]} {
	    bgerror $s
	    return 1
	}
	return 0
    }


    # Get a sorted lower-case list of all the font families defined on
    # the system.  A canonicalisation of [font families]
    proc 'list_families {} {
	lsort [string tolower [font families]]
    }

    # ----------------------------------------------------------------------

    proc dkf_chooseFont {args} {
	variable Family
	variable Style
	variable Size
	variable Done
	variable Win

	array set options {
	    -parent {}
	    -title {Select a font}
	    -initialfont {}
	    -apply {}
	}
	'parse_opts $args [array names options] options
	switch -exact -- $options(-parent) {
	    . - {} {
		set parent .
		set w .__dkf_chooseFont
	    }
	    default {
		set parent $options(-parent)
		set w $options(-parent).__dkf_chooseFont
	    }
	}
	catch {destroy $w}

	toplevel $w -class DKFChooseFont
	wm title $w $options(-title)
	wm transient $w $parent
	wm iconname $w ChooseFont
	wm group $w $parent
	wm protocol $w WM_DELETE_WINDOW {#}

	if {![string length $options(-initialfont)]} {
	    set options(-initialfont) [option get $w initialFont InitialFont]
	}

	set Win $w.sample.text
	'make_UI $w
	bind $w <Return>  [namespace code {set Done 0}]
	bind $w <Escape>  [namespace code {set Done 1}]
	bind $w <Destroy> [namespace code {set Done 1}]
	focus $w.butnframe.ok

	'configure_apply $w $options(-apply)

	foreach style {italic bold underline overstrike} {
	    set Style($style) 0
	}
	foreach {family size styles} $options(-initialfont) {break}
	set Family $family
	set familyIndex [lsearch -exact ['list_families] \
		[string tolower $family]]
	if {$familyIndex<0} {
	    wm withdraw $w
	    tk_messageBox -type ok -icon warning -title "Bad Font Family" \
		    -message "Font family \"$family\" is unknown.  Guessing..."
	    set family [font actual $options(-initialfont) -family]
	    set familyIndex [lsearch -exact ['list_families] \
		    [string tolower $family]]
	    if {$familyIndex<0} {
		return -code error "unknown font family fallback \"$family\""
	    }
	    wm deiconify $w
	}
	$w.family selection set $familyIndex
	$w.family see $familyIndex
	set Size $size
	foreach style $styles {set Style($style) 1}

	'set_font

	wm withdraw $w
	update idletasks
	if {$options(-parent)==""} {
	    set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
	    set y [expr {([winfo screenheigh $w]-[winfo reqheigh $w])/2}]
	} else {
	    set pw $options(-parent)
	    set x [expr {[winfo x $pw]+
                         ([winfo width $pw]-[winfo reqwidth $w])/2}]
	    set y [expr {[winfo y $pw]+
                         ([winfo heigh $pw]-[winfo reqheigh $w])/2}]
	}
	wm geometry $w +$x+$y
	update idletasks
	wm deiconify $w
	tkwait visibility $w
	vwait [namespace current]::Done
	if {$Done} {
	    destroy $w
	    return ""
	}
	if {['set_font]} {
	    destroy $w
	    return ""
	}
	set font [$Win cget -font]
	destroy $w
	return $font
    }

    # ----------------------------------------------------------------------
    # I normally load these from a file, but I inline them here for portability
    foreach {pattern value} {
	*DKFChooseFont.DKFChooseFontFrame.borderWidth	2
	*DKFChooseFont.DKFChooseFontFrame.relief	ridge


	*DKFChooseFont.lblFamily.text	       Family
	*DKFChooseFont.lblFamily.underline     0
	*DKFChooseFont.lblFamily.accelerator   Control-f

	*DKFChooseFont.lblStyle.text	       Style
	*DKFChooseFont.lblStyle.underline      2
	*DKFChooseFont.lblStyle.accelerator    Control-y

	*DKFChooseFont.lblSize.text	       Size
	*DKFChooseFont.lblSize.underline       2
	*DKFChooseFont.lblSize.accelerator     Control-z

	*DKFChooseFont.lblSample.text	       Sample


	*DKFChooseFont.style.Checkbutton.anchor		w

	*DKFChooseFont.style.sBold.text	       Bold
	*DKFChooseFont.style.sBold.underline   0
	*DKFChooseFont.style.sBold.accelerator Control-b

	*DKFChooseFont.style.sItalic.text      Italic
	*DKFChooseFont.style.sItalic.underline   0
	*DKFChooseFont.style.sItalic.accelerator Control-i

	*DKFChooseFont.style.sUnderline.text   Underline
	*DKFChooseFont.style.sUnderline.underline   0
	*DKFChooseFont.style.sUnderline.accelerator Control-u

	*DKFChooseFont.style.sStrikeout.text   Overstrike
	*DKFChooseFont.style.sStrikeout.underline   0
	*DKFChooseFont.style.sStrikeout.accelerator Control-o


	*DKFChooseFont.Label.padX	       1m
	*DKFChooseFont.Label.padY	       1

	*DKFChooseFont.family.height	       1
	*DKFChooseFont.family.width	       24
	*DKFChooseFont.familyX.orient	       horizontal
	*DKFChooseFont.Scrollbar.takeFocus     0

	*DKFChooseFont.size.b8.text	       8
	*DKFChooseFont.size.b10.text	       10
	*DKFChooseFont.size.b12.text	       12
	*DKFChooseFont.size.b14.text	       14
	*DKFChooseFont.size.b18.text	       18
	*DKFChooseFont.size.b24.text	       24
	*DKFChooseFont.size.Radiobutton.anchor w
	*DKFChooseFont.size.Entry.background   white

	*DKFChooseFont.sample.text.text	       ABCabcXYZxyz123
	*DKFChooseFont.sample.text.takeFocus   0
	*DKFChooseFont.sample.text.highlightThickness 0
	*DKFChooseFont.sample.text.borderWidth 0
	*DKFChooseFont.sample.text.relief      flat
	*DKFChooseFont.sample.text.width       0
	*DKFChooseFont.sample.text.cursor      {}
	*DKFChooseFont.sample.height	       40
	*DKFChooseFont.sample.width	       40

	*DKFChooseFont.butnframe.ok.default    active
	*DKFChooseFont.butnframe.ok.text       OK
	*DKFChooseFont.butnframe.can.default   normal
	*DKFChooseFont.butnframe.can.text      Cancel
	*DKFChooseFont.butnframe.apl.default   normal
	*DKFChooseFont.butnframe.apl.text      Apply
	*DKFChooseFont.butnframe.apl.underline 0
    } {
	option add $pattern $value startupFile
    }
    switch $tcl_platform(platform) {
	windows {
	    option add *DKFChooseFont.initialFont {Arial 12 bold} startupFile
	}
	default {
	    foreach {pattern value} {
		*DKFChooseFont*Button.BorderWidth      1
		*DKFChooseFont*Checkbutton.BorderWidth 1
		*DKFChooseFont*Entry.BorderWidth       1
		*DKFChooseFont*Label.BorderWidth       1
		*DKFChooseFont*Listbox.BorderWidth     1
		*DKFChooseFont*Menu.BorderWidth	       1
		*DKFChooseFont*Menubutton.BorderWidth  1
		*DKFChooseFont*Message.BorderWidth     1
		*DKFChooseFont*Radiobutton.BorderWidth 1
		*DKFChooseFont*Scale.BorderWidth       1
		*DKFChooseFont*Scrollbar.BorderWidth   1
		*DKFChooseFont*Text.BorderWidth	       1
		*DKFChooseFont.Scrollbar.width         10
		*DKFChooseFont.initialFont             {Helvetica 12 bold}
	    } {
		option add $pattern $value startupFile
	    }
	}
    }

}
namespace import -force ::dkfFontSel::dkf_chooseFont

# -------------------------------------------------------------------------
# Tracing variables
# -------------------------------------------------------------------------
#trace add variable ::tkchat::UserClicked write ::tkchat::traceVar

proc ::tkchat::traceVar {varname -> action} {
    if {[catch {
        if {[string compare $action write] == 0} {
            upvar $varname v
            if {[catch {lindex [info level -1] 0} proc]} {
                set proc <unknown>
            }
            ::log::log debug "TRACE: $varname set to $v in $proc"
        }
    } msg]} { log::log warning "TRACE ERROR: $msg" }
}

# -------------------------------------------------------------------------
proc ::tkchat::UserInfoFetch {jid} {
    if {[catch {
        $::tkjabber::jabber vcard_get $jid \
            [list [namespace current]::UserInfoFetchDone $jid]
    } msg]} {
        log::log notice "error in vcard_get: $msg"
    }
}

proc ::tkchat::UserInfoFetchDone {jid jlib type xmllist} {
    log::log debug "UserInfoFetchDone jid=$jid type=$type '$xmllist'"

    set uivar [namespace current]::ui_$jid
    upvar #0 $uivar UI
    set ::xmllist $xmllist
    if {[catch {
	switch $type {
	    result {
	        after cancel $UI(after)
		UserInfoParse $jid $xmllist
	    }
	    error {
	        after cancel $UI(after)
		set errType [lindex $xmllist 0]
		set errMsg [lindex $xmllist 1]
		switch $errType {
		    item-not-found {
			# The UserInfoDialog will take care of displaying
			# the not found message.
		    }
		    default {
			addSystem "error while getting userinfo: $errType '$errMsg'"		
		    }
		}
		# Not really a timeout, but this makes the dialog code continue
		# and use the right if branches
		set UI(timeout) 1
	    }
	    default {
	        after cancel $UI(after)
		log::log debug "eek, unknown type $type!"
		# Not really a timeout, but this makes the dialog code continue
		# and use the right if branches
		set UI(timeout) 1
	    }
	}
    } err]} { log::log error "ERROR UserInfoFetchDone: $err" }
}

proc ::tkchat::UserInfoParse {jid xmllist {prefix {}}} {
    variable ui_$jid
    upvar #0 [namespace current]::ui_$jid ui
    foreach child [wrapper::getchildren $xmllist] {
        set tag $prefix
        append tag [wrapper::gettag $child]
        set data [wrapper::getcdata $child]
        set kids [wrapper::getchildren $child]
        if {[llength $kids] > 0} {
            UserInfoParse $jid $child "${tag}_"
        } else {
            set ui($tag) $data
        }
    }
}

proc ::tkchat::UserInfoSend {jid} {
    variable ui_$jid
    set xmllist [wrapper::createtag vCard -attrlist {xmlns vcard-temp}]
    foreach {tag value} [array get ui_$jid] {
        set tags [split $tag _]
        set tag [lindex $tags end]
        set item [wrapper::createtag $tag -chdata $value]
        set xmllist [UserInfoAppendChild $xmllist [lrange $tags 0 end-1] $item]
        set xmllist [lreplace $xmllist 2 2 0]
    }

    $tkjabber::jabber send_iq set $xmllist \
        -command [namespace current]::UserInfoSent
}

proc ::tkchat::UserInfoSent {type args} {
    if {![string equal $type "result"]} {
        tk_messageBox -icon error -title [string totitle $type] \
            -message $args
    }
}

proc ::tkchat::UserInfoAppendChild {xmllist tags child} {
    if {[llength $tags] > 0} {
        set tag [lindex $tags 0]
        set tags [lrange $tags 1 end]
        set kids [wrapper::getchildren $xmllist]
        set new {}
        set found 0
        foreach kid $kids {
            if {[string equal [wrapper::gettag $kid] $tag]} {
                set found 1
                lappend new [UserInfoAppendChild $kid $tags $child]
            } else {
                lappend new $kid
            }
        }
        if {!$found} {
            set kid [wrapper::createtag $tag -attrlist {xmlns vcard-temp}]
            lappend new [UserInfoAppendChild $kid $tags $child]
        }
        set xmllist [wrapper::setchildlist $xmllist $new]
        set xmllist [lreplace $xmllist 2 2 0]
    } else {
        set kids [wrapper::getchildren $xmllist]
        lappend kids $child
        set xmllist [wrapper::setchildlist $xmllist $kids]
        set xmllist [lreplace $xmllist 2 2 0]
    }
    return $xmllist
}

proc ::tkchat::UserInfoDialog {{jid {}}} {
    variable UserInfo
    variable UserInfoBtn
    variable UserInfoWin

    if {$jid == {}} {
        set jid [::tkjabber::jid !resource $::tkjabber::myId]
    }

    set uivar [namespace current]::ui_$jid
    variable $uivar
    upvar #0 $uivar UI
    if {![info exists UI]} {
        set UI(after) [after 5000 [list array set $uivar {timeout 1}]]
	#addSystem "Requesting user info for $jid..."
        UserInfoFetch $jid
        tkwait variable $uivar
        after cancel $UI(after)
        unset UI(after)
    } else {
	if { [info exists UI(id)] } {
	    raise .$UI(id)	
	} else {
	    addSystem "Still waiting for a vcard from the server..."
	    # Reentry during timeout period.
	}
	return	
    }
    if {[info exists UI(timeout)] && ![string equal [::tkjabber::jid !resource $jid] \
             [::tkjabber::jid !resource $::tkjabber::myId]]} {
	# Not available, and not the users own vcard.
        log::log debug "cleanup as no UI"
        unset $uivar
        addSystem "No info available for $jid"
        return
    }

    if {![info exists UserInfoWin]} {set UserInfoWin 0}

    set id userinfo[incr UserInfoWin]
    set UI(id) $id

    set [namespace current]::$id -1
    set dlg [toplevel .$id -class Dialog]
    wm title $dlg "User info for $jid"
    set f [frame $dlg.f -bd 0]

    # country Country city City age Age
    # photo_url "Picture URL" icq_uin "ICQ uin"
    foreach {key text} {FN "Real name" EMAIL_USERID Email URL "Homepage URL" \
                            ADR_LOCALITY "City"  ADR_CTRY "Country" \
                            PHOTO_EXTVAL "Photo URL" BDAY "Birthday"} {
        set l [label $f.l$key -text $text -anchor nw]
        set e [entry $f.e$key \
                   -textvariable [set uivar]($key) \
                   -bd 1 -background white]
        grid configure $l $e -sticky news -padx 1 -pady 1
    }
    set l [label $f.lstuff -text "Anything else" -anchor nw]
    set e [frame $f.estuff -bd 0]
    set et [text $e.text -height 6 -bd 1 -background white]
    set es [scrollbar $e.scroll -bd 1 -command [list $et yview]]
    $et configure -yscrollcommand [list $es set]
    catch {$et insert 0.0 $UI(DESC)}
    grid configure $et $es -sticky news
    grid rowconfigure $e 0 -weight 1
    grid columnconfigure $e 0 -weight 1

    grid configure $l $e -sticky news -padx 1 -pady 1
    grid columnconfigure $f 1 -weight 1
    grid rowconfigure $f 8 -weight 1

    set btns [frame $dlg.buttons -bd 1]
    button $btns.ok -text Save -width 10 -state disabled \
        -command [list set [namespace current]::$id 1]
    button $btns.cancel -text Close -width 10 \
        -command [list set [namespace current]::$id 0]
    pack $btns.cancel $btns.ok -side right

    pack $btns -fill x -side bottom
    pack $f -fill both -expand 1 -side top

    if {[string equal [::tkjabber::jid !resource $jid] \
             [::tkjabber::jid !resource $::tkjabber::myId]]} {
        $btns.ok configure -state normal
    }

    bind .$id <Key-Escape> [list set [namespace current]::$id 0]

    set UserInfoBtn -1

    tkwait variable [namespace current]::$id

    if {[set [namespace current]::$id] == 1} {
        set UI(DESC) [$et get 0.0 end]
        UserInfoSend $jid
    }
    destroy $dlg
    unset [namespace current]::$id
    unset UI
}

# -------------------------------------------------------------------------

# Windows taskbar support.
# At some point I want to support multiple icons for nochat/chat/alert.
#
proc ::tkchat::WinicoInit {} {
    if {![catch {
        package require Winico
    }]} {
        variable TaskbarIcon
        set icofile [file join [file dirname [info script]] tkchat.ico]
        if {[file exists $icofile]} {
            set TaskbarIcon [winico createfrom $icofile]
            winico taskbar add $TaskbarIcon \
                -pos 0 \
                -text [wm title .] \
                -callback [list [namespace origin WinicoCallback] %m %i]
            bind . <Destroy> [namespace origin WinicoCleanup]
            Hook add chat [namespace origin WinicoChatHook]
        }
    }
}

proc ::tkchat::WinicoCleanup {} {
    variable TaskbarIcon
    winico taskbar delete $TaskbarIcon
}

proc ::tkchat::WinicoCallback {msg icn} {
    switch -exact -- $msg {
        WM_LBUTTONDOWN {
            if {[wm state .] == "withdrawn"} {
                wm deiconify .
                ResetMessageCounter
                WinicoChatHook
            } else {
                wm withdraw .
            }
        }
    }
}

proc ::tkchat::WinicoChatHook {} {
    variable MessageCounter
    variable TaskbarIcon
    if {$MessageCounter > 0} {
        winico taskbar modify $TaskbarIcon \
            -pos 2 \
            -text "$MessageCounter - Tcl'ers chat"
    } else {
        winico taskbar modify $TaskbarIcon \
            -pos 0 \
            -text "Tcl'ers chat"
    }
}

# -------------------------------------------------------------------------

proc ::tkchat::BookmarkInit {} {
    # FIX ME: need to make a better image :)
    image create photo ::tkchat::img::bookmark -format GIF \
        -data {R0lGODlhEAAQAMIAANnZ2QAAAAD//////wlnuglnuglnuglnuiH5BAEAAAMA
            LAAAAAAQABAAAAMpOLrc/jDIKV8QOOPQrv6c4n2gSJLheG7mmqXu28bhoKLd
            WjMUBf3AXwIAOw==}

    menu .mbar.mm -tearoff 0
    .mbar.mm add command -label "Set Bookmark" -accelerator Ctrl-F2 \
        -command ::tkchat::BookmarkAdd
    .mbar.mm add command -label "Prev Bookmark" -accelerator Shift-F2 \
        -command ::tkchat::BookmarkNext
    .mbar.mm add command -label "Next Bookmark" -accelerator F2 \
        -command ::tkchat::BookmarkPrev
    .mbar.mm add command -label "Clear Bookmarks" \
        -command ::tkchat::BookmarkClear
    .mbar.mm add command -label "Google Selection" -accelerator Ctrl-G \
        -command ::tkchat::GoogleSelection


    .mbar.mm add cascade -label "Translate" -command ::tkchat::babelfishMenu

    .mbar.mm add command -label "Cancel"

    bind .txt <Button-1> {focus %W ; %W mark set insert @%x,%y}
    bind .txt <Button-3> {
        %W mark set AddBookmark "@%x,%y linestart"
        .mbar.mm post %X %Y
        %W mark unset AddBookmark
    }
    bind . <F2> ::tkchat::BookmarkNext
    bind . <Shift-F2> ::tkchat::BookmarkPrev
    bind . <Control-F2> ::tkchat::BookmarkAdd
    bind . <Control-G> ::tkchat::GoogleSelection
    bind . <Control-g> ::tkchat::GoogleSelection

}

proc ::tkchat::BookmarkAdd {} {
    variable bookmark
    if {![info exists bookmark(id)]} {set bookmark(id) 0}
    if {[catch {.txt index AddBookmark}]} {
        set x [expr {[winfo pointerx .txt] - [winfo rootx .txt]}]
        set y [expr {[winfo pointery .txt] - [winfo rooty .txt]}]
        .txt mark set AddBookmark "@$x,$y linestart"
    }
    .txt configure -state normal
    .txt image create AddBookmark -image ::tkchat::img::bookmark
    .txt mark set bookmark[incr bookmark(id)] AddBookmark
    .txt mark unset AddBookmark
    .txt configure -state disabled
}

proc ::tkchat::BookmarkNext {} {
    variable bookmark
    if {![info exists bookmark(last)]} {set bookmark(last) 0.0}
    if {$bookmark(last) == "end" || [catch {.txt index $bookmark(last)}]} {
        set bookmark(last) 0.0
    }
    while {$bookmark(last) != {}} {
        set bookmark(last) [.txt mark next $bookmark(last)]
        if {[string match "bookmark*" $bookmark(last)]} {
            break
        }
    }
    if {$bookmark(last) == {}} {
        set bookmark(last) end
    }
    .txt see $bookmark(last)
    return $bookmark(last)
}

proc ::tkchat::BookmarkPrev {} {
    variable bookmark
    if {![info exists bookmark(last)]} {set bookmark(last) end}
    if {$bookmark(last) == "0.0" || [catch {.txt index $bookmark(last)}]} {
        set bookmark(last) end
    }
    while {$bookmark(last) != {}} {
        set bookmark(last) [.txt mark previous $bookmark(last)]
        if {[string match "bookmark*" $bookmark(last)]} {
            break
        }
    }
    if {$bookmark(last) == {}} {
        set bookmark(last) 0.0
    }
    .txt see $bookmark(last)
    return $bookmark(last)
}

proc ::tkchat::BookmarkClear {} {
    set mark 0.0
    while {[set mark [.txt mark next $mark]] != {}} {
        if {[string match "bookmark*" $mark]} {
            set remove $mark
            set mark "[.txt index $mark] + 1 char"
            BookmarkRemove $remove
        }
    }
}

proc ::tkchat::BookmarkRemove {mark} {
    if {[lsearch [.txt mark names] $mark] != -1} {
        .txt configure -state normal
        .txt delete "$mark - 1 char"
        .txt mark unset $mark
        .txt configure -state disabled
    }
}

proc ::tkchat::GoogleSelection {} {
    set sel [.txt tag ranges sel]
    set t [.txt get [lindex $sel 0] [lindex $sel 1]]
    gotoURL http://www.google.com/search?ie=UTF-8&oe=UTF-8&[::http::formatQuery q $t]
}

# -------------------------------------------------------------------------

# NoisyUsers

proc ::tkchat::noisyUser { msg } {
    variable noisyUsers

    #Assign msg elements to cmd, nick and time:
    foreach {cmd nick time} [lrange [split $msg " "] 0 2] {}

    if { [string equal $nick ""] } {
	set cnt 0
	foreach {nick time} [array get noisyUsers] {
	    incr cnt
	    if { $time < [clock seconds] } {
		addSystem "$nick is no longer noisy (timeout expired)"
		unset noisyUsers($nick)
	    } else {
		addSystem "$nick is noisy until [clock format $time -format %H:%M:%S]"
	    }
	}
	if { $cnt == 0 } {
	    addSystem "You don't consider anyone noisy right now"
	}
	return
    }

    if { [info exists noisyUsers($nick)] } {
	if { [string is integer -strict $time] } {
	    switch $time {
		-1 -
		0 {
		    unset noisyUsers($nick)
		    addSystem "$nick is no longer considered noisy."
		}
		default {
		    set noisyUsers($nick) [expr {[clock seconds] + 60*$time}]
		    if { $time > 1 } {
			addSystem "$nick is considered noisy for $time minutes."
		    } else {
			addSystem "$nick is considered noisy for $time minute."
		    }
		}
	    }
	} else {
	    #No time given, remove from noisyUsers
	    unset noisyUsers($nick)
	    addSystem "$nick is no longer considered noisy."
	}
    } else {
	if { ![string is integer -strict $time] } {
	    set time 5
	}
	switch $time {
	    -1 -
	    0 {
		addSystem "$nick not considered noisy at this time."
	    }
	    default {
		set noisyUsers($nick) [expr {[clock seconds] + 60*$time}]
		if { $time > 1 } {
		    addSystem "$nick is considered noisy for $time minutes."
		} else {
		    addSystem "$nick is considered noisy for $time minute."
		}
	    }
	}
    }
}

proc ::tkchat::nickIsNoisy { nick } {
    variable noisyUsers

    if { [info exists noisyUsers($nick)] } {
	if { [clock seconds] < $noisyUsers($nick) } {
	    return 1
	} else {
	    addSystem "$nick is no longer considered noisy (timeout expired)."
	    unset noisyUsers($nick)
	    return 0
	}
    }
    return 0
}

# -------------------------------------------------------------------------

# Tk 8.5a2+ can now do a global transparency on supported platforms (Win2K
# and WinXP.
# n must be from 1 to 100.
#
proc ::tkchat::SetAlpha {n} {
    global Options
    if {[lsearch [wm attributes .] -alpha] != -1} {
        if {$n < 1} {set n 1}
        if {$n > 100} {set n 100}
        set Options(Transparency) $n
        wm attributes . -alpha [expr {$n / 100.0}]
        # Work around a but when transitioning from opaque to
        # any transparent value the toplevel becomes topmost.
        #if {[winfo exists .options]} {raise .options}
    }
}

proc ::tkchat::FadeAlpha {} {
    global Options
    if {$Options(AutoFade)} {
        variable FadeId
        set alpha [wm attributes . -alpha]
        if {($alpha * 100) > $Options(AutoFadeLimit)} {
            wm attributes . -alpha [expr {$alpha - 0.01}]
            set FadeId [after 200 [namespace origin FadeAlpha]]
        }
    }
}

proc ::tkchat::FadeCancel {} {
    global Options
    if {$Options(AutoFade) == 0} {
        set n [expr {$Options(Transparency) / 100.0}]
        after idle [list wm attributes . -alpha $n]
    } else {
        variable FadeId
        catch {after cancel $FadeId}
        catch {unset FadeId}
        catch {wm attributes . -alpha 0.999}
    }
}

proc ::tkchat::FocusInHandler {w args} {
    FadeCancel
}
proc ::tkchat::FocusOutHandler {w args} {
    if {[string length [focus]] == 0} {
        after idle [namespace origin FadeAlpha]
    }
}

proc ::tkchat::EditOptions {} {
    global Options
    variable EditOptions
    array set EditOptions {Result -1}
    if {[info exists Options(BROWSER)]} {
        set EditOptions(BROWSER) $Options(BROWSER)
    } else {
        set EditOptions(BROWSER) {}
    }

    set EditOptions(Style)         $Options(Style)
    set EditOptions(AutoFade)      $Options(AutoFade)
    set EditOptions(AutoFadeLimit) $Options(AutoFadeLimit)
    set EditOptions(Transparency)  $Options(Transparency)

    if {[winfo exists .options]} {destroy .options}
    set dlg [toplevel .options -class dialog]
    wm withdraw $dlg
    wm title $dlg "Tkchat Options"

    if {[package vcompare [package provide Tcl] 8.3] == 0} {
        set bf [frame $dlg.bf]
    } else {
        set bf [labelframe $dlg.bf -text "Preferred browser" -padx 1 -pady 1]
    }
    message $bf.m -justify left -width 320 \
        -text "Provide the command used to launch your web browser. For\
        instance /opt/bin/mozilla or xterm -e links. The URL to\
        be opened will be appended to the command string and for\
        mozilla-type browsers we will call the -remote option to\
        try to use a previously existing browser."
    entry $bf.e -textvariable ::tkchat::EditOptions(BROWSER)
    button $bf.b -text "..."  -command {
        if {[set file [tk_getOpenFile]] != {}} {
            set ::tkchat::EditOptions(BROWSER) $file
        }
    }

    grid $bf.m - -sticky news
    grid $bf.e $bf.b -sticky news
    grid rowconfigure $bf 0 -weight 1
    grid columnconfigure $bf 0 -weight 1

    if {[package vcompare [package provide Tcl] 8.3] == 0} {
        set sf [frame $dlg.sf]
        set gf [frame $dlg.gf]
    } else {
        set sf [labelframe $dlg.sf -text "Tk style" -padx 1 -pady 1]
        set gf [labelframe $dlg.gf -text "Gimmiks"  -padx 1 -pady 1]
    }
    message $sf.m -justify left -width 320 \
        -text "The Tk style selection available here will apply when you \
           next restart tkchat."
    radiobutton $sf.as -text "ActiveState" -underline 0 \
        -variable ::tkchat::EditOptions(Style) -value as_style
    radiobutton $sf.gtk -text "GTK look" -underline 0 \
        -variable ::tkchat::EditOptions(Style) -value gtklook
    radiobutton $sf.any -text "Any" -underline 1 \
        -variable ::tkchat::EditOptions(Style) -value any
    radiobutton $sf.def -text "Tk default" -underline 0 \
        -variable ::tkchat::EditOptions(Style) -value tk

    if {[catch {package require as::style}]} {
        $sf.as configure -state disabled
    }

    bind $dlg <Alt-a> [list $sf.as invoke]
    bind $dlg <Alt-g> [list $sf.gtk invoke]
    bind $dlg <Alt-n> [list $sf.any invoke]
    bind $dlg <Alt-t> [list $sf.def invoke]

    grid $sf.m - - - -sticky news
    grid $sf.as $sf.gtk $sf.any $sf.def -sticky news
    grid rowconfigure $bf 0 -weight 1
    grid columnconfigure $bf 0 -weight 1

    # Gimmicks section.
    set gimmicks 0
    if {[lsearch [wm attributes .] -alpha] != -1} {
        set gimmicks 1
        set scale scale
        if {[info command tscale] != {}} {
            set scale tscale
        }
        checkbutton $gf.fade -text "When not active, fade to " -underline 2 \
            -variable ::tkchat::EditOptions(AutoFade)
        spinbox $gf.fadelimit -from 1 -to 100 -width 4 \
            -textvariable ::tkchat::EditOptions(AutoFadeLimit)
        label $gf.pct -text "%"
        label $gf.alabel -text Transparency
        $scale $gf.alpha -from 1 -to 100 -orient horizontal
        $gf.alpha set $EditOptions(Transparency)
        #[expr {int([wm attributes . -alpha] * 100)}]
        $gf.alpha configure -command [namespace origin SetAlpha]

        bind $dlg <Alt-h> [list $gf.face invoke]
        bind $dlg <Alt-r> [list focus $gf.alpha]

        grid $gf.fade   - $gf.fadelimit $gf.pct x -sticky w
        grid $gf.alabel $gf.alpha - - - -sticky we
        grid configure $gf.alabel -pady {20 0} -sticky w
        grid columnconfigure $gf 4 -weight 1
    }

    button $dlg.ok -text OK -underline 0 -default active \
        -command [list set ::tkchat::EditOptions(Result) 1]
    button $dlg.cancel -text Cancel -underline 0 \
        -command [list set ::tkchat::EditOptions(Result) 0]

    grid $bf - -sticky news -padx 2 -pady 2
    grid $sf - -sticky news -padx 2 -pady 2
    if {$gimmicks} {
        grid $gf - -sticky news -padx 2 -pady 2
    }
    grid $dlg.ok $dlg.cancel -sticky e
    grid rowconfigure $dlg 0 -weight 1
    grid columnconfigure $dlg 0 -weight 1

    bind $dlg <Return> [list $dlg.ok invoke]
    bind $dlg <Escape> [list $dlg.cancel invoke]
    bind $dlg <Alt-o>  [list focus $dlg.ok]
    bind $dlg <Alt-c>  [list focus $dlg.cancel]
    focus $bf.e

    wm resizable $dlg 0 0
    catch {::tk::PlaceWindow $dlg widget .}
    wm deiconify $dlg

    tkwait variable ::tkchat::EditOptions(Result)

    if {$EditOptions(Result) == 1} {
        set Options(BROWSER) $EditOptions(BROWSER)
        foreach property {Style AutoFade AutoFadeLimit} {
            if {![string equal $Options($property) $EditOptions($property)]} {
                set Options($property) $EditOptions($property)
            }
        }
    } else {
        # This one is the reverse of the other dialog properties. In this case
        # the Options copy is the one always updated and the EditOptions value
        # is the backup.
        set Options(Transparency) $EditOptions(Transparency)
    }

    destroy $dlg
    unset EditOptions
}

# -------------------------------------------------------------------------

# Try and adjust the Tk style.
# If we can find the ActiveState look&feel package then lets use that
# otherwise we have something that was modified from the Gtklook page
# of the wiki: http://mini.net/tcl/gtklook
#

proc gtklook_style_init {} {
    set defaultColor #dcdad5
    set activeFG     #ffffff
    set activeBG     #4a6984
    set troughColor  #bdb6ad

    font create GtkLookFont \
        -family Helvetica -size 12 -weight normal
    font create GtkLookDialogFont \
        -family Helvetica -size 16 -weight bold -slant italic

    option add *background $defaultColor widgetDefault
    option add *borderWidth 1 widgetDefault
    option add *highlightThickness 0 widgetDefault
    option add *troughColor $troughColor widgetDefault
    option add *activeBorderWidth 1 widgetDefault
    option add *selectBorderWidth 1 widgetDefault
    option add *font GtkLookFont widgetDefault

    option add *Button.highlightThickness 1 widgetDefault
    option add *Checkbutton.highlightThickness 1 widgetDefault
    option add *Radiobutton.highlightThickness 1 widgetDefault

    option add *Listbox.background white widgetDefault
    option add *Listbox.selectBorderWidth 0 widgetDefault
    option add *Listbox.selectForeground $activeFG widgetDefault
    option add *Listbox.selectBackground $activeBG widgetDefault

    option add *Entry.background white
    option add *Entry.foreground black
    option add *Entry.selectBorderWidth 0
    option add *Entry.selectForeground $activeFG
    option add *Entry.selectBackground $activeBG

    option add *Text.background white
    option add *Text.selectBorderWidth 0
    option add *Text.selectForeground $activeFG
    option add *Text.selectBackground $troughColor

    option add *Menu.activeBackground $activeBG
    option add *Menu.activeForeground $activeFG
    option add *Menu.activeBorderWidth 0
    option add *Menu.highlightThickness 1
    option add *Menu.borderWidth 2

    option add *Menubutton.activeBackground $activeBG
    option add *Menubutton.activeForeground $activeFG
    option add *Menubutton.activeBorderWidth 0
    option add *Menubutton.highlightThickness 0
    option add *Menubutton.borderWidth 0

    option add *Labelframe.borderWidth 2
    option add *Frame.borderWidth 2

    option add *Dialog.msg.font GtkLookDialogFont
}
# -------------------------------------------------------------------------
# Whiteboard

proc tkchat::whiteboard_eval { wbitem color } {

    if { ![winfo exists .wb]  } {
        if { !$::Options(EnableWhiteboard) } {
            return
        }
	whiteboard_open
    }

    set ::wbentry $wbitem

    catch {
        interp eval .wbinterp $::wbentry
    }
}

proc tkchat::whiteboard_transmit {w id} {
    set attrs [list xmlns urn:tkchat:whiteboard color $::Options(MyColor)]

    set wbitem ".wb.c create line [string map {.0 {}} [$w coords $id]]"

    set xlist [list [wrapper::createtag x -attrlist $attrs -chdata $wbitem]]

    $tkjabber::jabber send_message $tkjabber::conference -type groupchat -xlist $xlist

    .wb.e selection range 0 end
}

proc tkchat::whiteboard_clear { } {
    set attrs [list xmlns urn:tkchat:whiteboard color $::Options(MyColor)]

    set wbitem ".wb.c delete all"

    set xlist [list [wrapper::createtag x -attrlist $attrs -chdata $wbitem]]

    $tkjabber::jabber send_message $tkjabber::conference -type groupchat -xlist $xlist

    .wb.e selection range 0 end

}

proc tkchat::whiteboard_open {} {

    if { ![winfo exists .wb] } {
	set wb [toplevel .wb]

	entry $wb.e -textvar ::wbentry -bg white -width 80
	bind $wb.e <Return> {interp eval .wbinterp $::wbentry}
	set white_board [canvas $wb.c -bg white -width 350 -height 300]
	button $wb.bclear -text "clear" -command ::tkchat::whiteboard_clear
	bind $wb.c <1> {set entry ""; set id [%W create line %x %y %x %y]}
	bind $wb.c <B1-Motion> {%W coords $id [concat [%W coords $id] %x %y]}
	bind $wb.c <ButtonRelease-1> {::tkchat::whiteboard_transmit %W $id}
	grid $wb.e $wb.bclear -sticky new
	grid $wb.c - -sticky new
	#pack $wb.e $wb.c -fill both -expand 1
	
	catch {
	    interp create -safe .wbinterp
	    interp alias .wbinterp .wb.c {} .wb.c
	}
    } else {
	focus .wb	
    }
}


# -------------------------------------------------------------------------
# Jabber handling

namespace eval tkjabber {
    proc Variable {args} {
	if {[llength $args] % 2} {
	    variable [lindex $args end]
	    set args [lrange $args 0 end-1]
	}
	foreach {var val} $args {
	    variable $var
	    if {![info exists $var]} {
		set $var $val
	    }
	}
    }
    Variable jabber ; if {![info exists jabber]} {set jabber ""}
    Variable topic
    Variable jhttp ""
    Variable muc
    Variable nickTries 0 ;# The number of times I tried to solve a nick conflict
    Variable baseNick "" ;# used when trying to solve a nick conflict.
    Variable grabNick "" ;# grab this nick when it becomes available.

    Variable ignoreNextNick ""
    # If the next entry is by this nick, don't display it (for nick changes.)

    Variable roster ""
    Variable browser ""
    Variable socket ""
    Variable conn
    Variable myId ""
    Variable RunRegistration 0
    Variable reconnect 0 ;# set to 1 after a succesful connect.
    # retrytime in seconds, distributed so not everyone tries at the same time.
    Variable connectionRetryTime [expr {int(5+rand()*5.0)}]
    Variable reconnectTimer {}

    Variable HistoryLines {}
    Variable HaveHistory 0
    Variable LastMessage 0 ;# used for reconnects when asking for conference history.

    Variable conference

    Variable muc_jid_map ;# array with conference-id to user-jid map.
    Variable users ;#
    Variable user_alias
    Variable Away 0

    # Provides a map of nicks to full jids (works because the chat is
    # not anonymous. Used for the /memo function.
    variable members; if {![info exists members]} {array set members {}}
}

# Login:
proc tkjabber::connect { } {
    variable jhttp
    variable jabber
    variable roster
    variable browser
    variable socket
    variable conn
    variable reconnect
    variable conference
    variable reconnectTimer
    variable have_tls

    global Options

    if { $reconnectTimer ne "" } {
	after cancel $reconnectTimer
	set reconnectTimer ""
    }

    set conference $Options(JabberConference)

    if {$Options(UseProxy) && [string length $Options(ProxyHost)] > 0} {
	set keepalive_seconds 30
    } else {
	set keepalive_seconds 90
    }

    if { !$reconnect } {
	if { $roster eq "" } {
	    set roster [roster::roster [namespace current]::RosterCB]
	}	
	set jabber [jlib::new $roster [namespace current]::ClientCB  \
			-iqcommand          [namespace current]::IqCB  \
			-messagecommand     [namespace current]::MsgCB \
			-presencecommand    [namespace current]::PresCB \
			-keepalivesecs	    $keepalive_seconds]
	
	set browser [browse::new $jabber -command [namespace current]::BrowseCB]
        
        # override the jabberlib version info query
        jlib::iq_register $jabber get jabber:iq:version \
            [namespace origin on_iq_version] 40
    }

    if { $Options(UseJabberPoll) } {
	set socket [jlib::http::new $jabber "http://scheffers.net:5280/http-poll" \
		    -usekeys 1 \
		    -command [namespace current]::httpCB]
	openStream
	
    } else {
        set have_tls [expr {[package provide tls] != {}}]
	if { [catch {
	    if {$Options(UseProxy) && [string length $Options(ProxyHost)] > 0} {
		set socket [ProxyConnect $Options(ProxyHost) $Options(ProxyPort) \
				$Options(JabberServer) $Options(JabberPort)]
	    } elseif {$have_tls && $Options(UseJabberSSL) eq "ssl"} {
		set socket [tls::socket $Options(JabberServer) $Options(JabberPort)]
	    } else {
		if {$Options(JabberPort) == 5223} {incr Options(JabberPort) -1}
                if {[info exists Options(JabberConnect)]
                    && $Options(JabberConnect) ne ""} {
                    foreach {srv prt} [split $Options(JabberConnect) :] break
                    if {$prt eq ""} {set prt $Options(JabberPort)}
                    set socket [socket $srv $prt]
                } else {
                    set socket [socket $Options(JabberServer) $Options(JabberPort)]
                }
	    }
	} res] } {
	    # Connection failed.
	    tkchat::addSystem "Connecting failed: $res" end ERROR
	    if { $reconnect } {
		scheduleReconnect
	    }
	} else {
            #fconfigure $socket -encoding utf-8
	    $jabber setsockettransport $socket
	    openStream
	}
    }

    # The next thing which will/should happen is the a call to ConnectProc by
    # jabberlib.
    if {[winfo exists .mbar.file]} {
        .mbar.file entryconfigure 0 -label [msgcat::mc Logout]
    }
}

proc tkjabber::disconnect { } {

    variable jhttp
    variable jabber
    variable roster
    variable browser
    variable socket
    variable conn
    variable reconnect
    variable reconnectTimer

    global Options

    set reconnect 0
    if { $reconnectTimer ne "" } {
	after cancel $reconnectTimer
	set reconnectTimer ""
    }

    if { $socket eq "" } {
	return
    }

    cleanup
    tkchat::addSystem "Disconnected from jabber server."
}

proc tkjabber::cleanup {} {
    variable jabber
    variable muc
    variable conference
    variable socket

    if { [catch {
	$muc exit $conference
    }] } {
	log::log error "Cleanup: $::errorInfo"
    }

    if { [catch {$jabber closestream}] } {
	log::log error "Closestream: $::errorInfo"
    }

    #catch {close $socket}
    catch {jlib::resetsocket $jabber}
    set socket ""
    if {[winfo exists .mbar.file]} {
        .mbar.file entryconfigure 0 -label [msgcat::mc Login]
    }
}

proc tkjabber::openStream {} {
    variable socket
    variable jabber
    global Options
    log::log debug "OPENSTREAM to $Options(JabberServer) on $socket"

    $jabber openstream $Options(JabberServer) \
        -cmd [namespace current]::ConnectProc \
        -socket $socket \
        -version 1.0
}

proc tkjabber::ConnectProc {jlibName args} {
    global Options
    variable conn
    variable jabber
    variable have_tls

    log::log debug "ConnectProc args '$args'"

    array set conn $args
    tkchat::addSystem "Connected to $conn(from), sending credentials."
    update idletasks

    # Now send authentication details:
    if {$have_tls && $Options(UseJabberSSL) eq "starttls"} {
        jlib::starttls $jabber [namespace origin OnStartTlsFinish]
    } else {
        SendAuth
    }
}

proc tkjabber::OnStartTlsFinish {jlib type args} {
    log::log debug "starttls: $jlib $type $args"
    SendAuth
}

proc tkjabber::SendAuth { } {
    # This proc is called by ConnectProc after openstream succeeded.

    global Options
    variable jabber
    variable myId
    variable socket

    fconfigure $socket -encoding utf-8; # this is quite important.

    set user $Options(Username)
    set pass $Options(Password)
    set ress $Options(JabberResource)

    if {[info command jlib::havesasl] ne "" && [jlib::havesasl]} {
        jlib::auth_sasl $jabber $user $ress $pass \
            [namespace origin OnSaslFinish]
    } else {
        SendAuthOld
    }
}

proc ::tkjabber::OnSaslFinish {jlib type args} {
    log::log debug "OnSaslFinish $type $args"
    if {$type eq "error"} {
        # try using the non-sasl login
        SendAuthOld
    } else {
        update idletasks
        log::log debug "Calling login callback..."
        LoginCB $jlib $type $args
    }
}

proc tkjabber::SendAuthOld {} {
    global Options
    variable conn
    variable jabber
    variable myId

    set user $Options(Username)
    set pass $Options(Password)
    set ress $Options(JabberResource)

    set myId [$jabber send_auth $user $ress \
                  [namespace origin LoginCB] \
                  -digest [sha1::sha1 $conn(id)$pass]]
    log::log debug "SendAuth: Logging in as $myId"

    update idletasks
    # The next callback is the LoginCB
}


# Jabber callback procs - this is where we get messages from.

# The roster stuff...
proc tkjabber::RosterCB {rostName what {jid {}} args} {
    log::log debug "--roster-> what=$what, jid=$jid, args='$args'"
    variable conference
    variable members
    variable grabNick
    variable ignoreNextNick

    switch -- $what {
	presence {
	    array set p $args
	    set action ""
            set newnick ""
	    # online/away/offline, etc.
	    set status [list online]
	    if { [info exists p(-show)] } { set status [list $p(-show)] }
	    if { [info exists p(-status)] } { lappend status $p(-status) }
	    switch -- $p(-type) {
		available {
		    set action entered

                    # Add the user's nick into a nick/jid map
                    if {[info exists p(-x)]} {
                        foreach child $p(-x) {
                            set ns [wrapper::getattribute $child xmlns]
                            if {[string equal $ns \
                                     "http://jabber.org/protocol/muc#user"]} {
                                set item [wrapper::getchildswithtag $child item]
                                if {[llength $item] > 0} {
                                    set usrjid [wrapper::getattribute \
                                                    [lindex $item 0] jid]
                                    set members($p(-resource),jid) $usrjid
                                    set members($p(-resource),status) $status
                                }
                                break
                            }
                        }
                    }
		}
		unavailable {
                    set nickchange 0
                    set action left
                    set status offline

                    if {[info exists p(-x)]} {
                        # Check for nickname change
                        foreach child $p(-x) {
                            set ns [wrapper::getattribute $child xmlns]
                            if {[string equal $ns \
                                     "http://jabber.org/protocol/muc#user"]} {
                                set status_elem [wrapper::getchildswithtag $child status]
                                if { [llength $status_elem]==0 } {
                                    # Not a nickname change.
                                    continue
                                }
                                set status_code [wrapper::getattribute [lindex $status_elem 0] code]
                                if { $status_code eq "303" } {
                                    # nickname change!
                                    set item [wrapper::getchildswithtag $child item]
                                    if {[llength $item] > 0} {
                                        set nickchange 1
                                        set action nickchange
                                        set newnick [wrapper::getattribute \
                                                        [lindex $item 0] nick]
                                        break
                                    }
                                }
                            }
                        }
                    }
                    if {[info exists members($p(-resource),jid)]} {
                        unset members($p(-resource),jid)
                    }
                    if {[info exists members($p(-resource),status)]} {
                        unset members($p(-resource),status)
                    }
		    # Do we want to be this nick?
		    if { $grabNick ne "" && $p(-resource) eq $grabNick } {
			after idle [list tkjabber::setNick $grabNick]
			set grabNick ""
		    }

		}
	    }

	    if { $jid ne $conference } {
		set tstatus [string map {
		    dnd "do not disturb"
		    xa "away (idle)"
		    chat "I want to chat"
		    away "away"
		} [lindex $status 0]]
                set m "$jid has $action ($tstatus)"
                if {[llength $status] > 1} {append m ": [lindex $status 1]"}
		tkchat::addSystem $m
		return
	    }
	
	    # Much more interesting info available in array ...

            if { $action eq "nickchange" } {
                tkchat::addSystem "In a fit of schizophrenia, $p(-resource) would like to be known as $newnick."
                set ignoreNextNick $newnick
            } else {
                if { !($action eq "entered" && $ignoreNextNick eq $p(-resource)) } {
                    # if not the ignore nick:
                    tkchat::addTraffic $p(-resource) $action
                }
                # Always reset ignoreNextNick!
                set ignoreNextNick ""
            }
	    tkchat::updateJabberNames
	}
	default {
	    tkchat::addSystem "--roster-> what=$what, jid=$jid, args='$args'"
	}
    }
}

# Browse stuff...
proc tkjabber::BrowseCB {browseName type jid xmllist args} {
    tkchat::addSystem "--browse-> browseName=$browseName type=$type, jid=$jid, xmllist='$xmllist', args='$args'"
}
proc tkjabber::BrowseErrorCB {browseName what jid errlist} {
    tkchat::addSystem "--browse-(error)-> what=$what, jid=$jid, errlist='$errlist'"
}

# The jabberlib stuff...
proc tkjabber::ClientCB {jlibName cmd args} {

    log::log debug "ClientCB: jlibName=$jlibName, cmd=$cmd, args='$args'"
    switch -- $cmd {
	connect {
	    tkchat::addSystem "Connection to Jabber Server Established"	
	}
	disconnect {
	    cleanup
	    scheduleReconnect
	}
	networkerror {
            array set x {-body ""}
	    array set x $args
	    tkchat::addSystem "Network error $x(-body)"
	    cleanup
	    scheduleReconnect
	}
	streamerror {
            array set x {-errormsg ""}
	    array set x $args
	    set type [lindex $x(-errormsg) 0]
	    set message [lindex $x(-errormsg) 1]
	    switch -- $type {
		conflict {
		    tkchat::addSystem $message		
		}
		default {
		    tkchat::addSystem "ClientCB: $cmd ; args='$args'"		
		}
	    }
	    disconnect
	}
	default {
	    tkchat::addSystem "ClientCB: jlibName=$jlibName, cmd=$cmd, args='$args'"
	}
    }
    update idletasks
}

proc tkjabber::IqCB {jlibName type args} {
    # These callbacks don't work. You should register an iq handler instead
    # - see the setup for on_iq_version.
    log::log debug "|| MyIqCB > type=$type, args=$args"
}

proc tkjabber::MsgCB {jlibName type args} {
    variable conference
    variable muc
    variable topic
    variable LastMessage

    set LastMessage [clock seconds]

    log::log debug "|| MsgCB > type=$type, args=$args"

    set color ""
    set ts 0

    array set m $args
    if { [info exists m(-x)] } {
	foreach x $m(-x) {
	    switch [wrapper::getattribute $x xmlns] {
		"jabber:x:delay" {
		    set ts [clock scan [wrapper::getattribute $x stamp] -gmt 1]
		    if { $ts eq "" } {
			set ts 0
		    }
		}
		"urn:tkchat:chat" {
		    array set tkchatAttr [wrapper::getattrlist $x]		
		    set color [wrapper::getattribute $x color]
		}
		"urn:tkchat:whiteboard" {		
		    tkchat::whiteboard_eval [wrapper::getcdata $x] [wrapper::getattribute $x color]
		    return
		}
		"urn:tkchat:changenick" {
		    # Request for nick handover.
		    tkchat::addSystem "$m(-from) has requested your nickname."
		    transferNick $m(-from)
		    return
		}
	    }		
	}
    }	

    switch -- $type {
	chat {
	    set from $m(-from)
            if { [regexp {([^/]+)/(.+)} $m(-from) -> conf name] } {
		if { $conf eq $conference } {
		    tkchat::addAction "" $name " whispers: $m(-body)" end $ts
		} else {
		    tkchat::addAction "" $from " whispers: $m(-body)" end $ts
		}
	    } else {
		tkchat::addAction "" $from " whispers: $m(-body)" end $ts
	    }
	}
	groupchat {
	    set from $m(-from)
            regexp {([^/]+)/(.+)} $m(-from) -> conf from
	    set msg ""
	    if { [info exists m(-subject)] } {
		# changing topic.
		set topic $m(-subject)
		set ::tkchat::chatWindowTitle "The Tcler's Chat - $topic"
		wm title . $::tkchat::chatWindowTitle
           	if { [info exists m(-body)] } {
		    if { $from eq $conference } {
			tkchat::addSystem $m(-body)
		    } else {
			tkchat::addAction $color $from " changed the topic to: $m(-subject)\n ... $m(-body)" end $ts
		    }
	    	} else {
		    tkchat::addAction $color $from " changed the topic to: $m(-subject)" end $ts
		}		
	    } else {		
		if { [info exists m(-body)] > 0 } {
		    set opts {}
		    if { [string match "ijchain*" $from] } {
			set pos [string first " " $m(-body)]
			set from [string trim [string range $m(-body) 0 $pos]]
			incr pos
			set m(-body) [string range $m(-body) $pos end]
			if { $from eq "***" && [regexp {([^ ]+) (leaves|joins)} $m(-body) -> who action] } {
			    set action [string map {joins entered leaves left} $action]
			    tkchat::addTraffic <$who> $action end $ts
			    return
			}
			if { $from eq "<azbridge>" } {
			    set pos [string first " " $m(-body)]
			    set from "[string trim [string range $m(-body) 0 $pos]]"
			    incr pos
			    set m(-body) [string range $m(-body) $pos end]
			}
			if { $from eq "*" && [regexp {([^ ]+) (entered|left)} $m(-body) -> who action] } {
			    set action [string map {joins entered leaves left} $action]
			    # Double <> to show webchat users.
			    tkchat::addTraffic <<$who>> $action end $ts
			    return
			}		
			if { $from eq "*" } {
			    set pos [string first " " $m(-body)]
			    set from "<[string trim [string range $m(-body) 0 $pos]]>"
			    incr pos
			    set m(-body) "/me [string range $m(-body) $pos end]"				
			} 			
	    	    }
		    if { [string match "/nolog*" $m(-body)] } {
			set m(-body) [string trim [string range $m(-body) 6 end]]
			lappend opts nolog 1
		    } elseif { [info exists tkchatAttr(nolog)] && $tkchatAttr(nolog) } {
			lappend opts nolog 1
		    }
		    if { [string range $m(-body) 0 3] eq "/me " } {
			tkchat::addAction $color $from [string range $m(-body) 4 end] end $ts $opts
		    } else {		
			tkchat::addMessage $color $from $m(-body) end $ts $opts
		    }
		} else {
		    #tkchat::addSystem "Got a message I do not understand from $from:\n$args"
		}
	    }
	}
	normal {
	    set conf ""
	    set from $m(-from)
            regexp {([^/]+)/(.+)} $m(-from) -> conf from
	    if { $conf ne $conference } {
		set from $m(-from)
	    }	
	    set msg ""
	    if { [info exists m(-subject)] } {
		lappend msg "Subject: $m(-subject)"
	    }
	    if { [info exists m(-body)] } {
		lappend msg "$m(-body)"
	    }
	    if { [llength $msg] > 0 } {
		tkchat::addAction "" $from " whispers: [join $msg \n]" 		
	    } else {
		tkchat::addSystem "Got a message I do not understand from $from:\n$args"
	    }	
	    #tkchat::addMessage ""  "Subject: $m(-subject)\n$m(-body)" end $ts
	}
	error {
	    if { [info exists m(-error)] } {
		switch -- [lindex $m(-error) 0] {
		    405 {
			if { [catch {
			    $muc exit $conference
			}] } {
			    log::log debug "MUC EXIT: $::errorInfo"
			}
			tkchat::addSystem "$m(-from): [lindex $m(-error) 1]. Trying to get in again..."
			$::tkjabber::muc enter $::tkjabber::conference $::Options(Nickname) -command [namespace current]::MucEnterCB
		    }
		    default {
			tkchat::addSystem  "MsgCB (error) args='$args'"
		    }
		}
	    }	
	}
	#get {
	    if { [info exists m(-query)] } {
		log::log debug "Jabber query\n$args"
		array set iq $m(-query)		
	    } else {
		tkchat::addSystem "|| MsgCB > type=$type, args=$args"
	    }
	}
	default {
	    tkchat::addSystem "|| MsgCB > type=$type, args=$args"
	}
    }
}

proc tkjabber::PresCB {jlibName type args} {
    log::log debug "|| PresCB > type=$type, args=$args"
    array set a {-from {} -to {} -status {}}
    array set a $args
    switch -exact -- $type {
        probe {
            # We do not need to reply.
        }
        subscribe {
            after idle [list [namespace origin SubscriptionRequest] \
                            $a(-from) $a(-status)]
        }
        default {
            tkchat::addSystem "Received $type presence message from $a(-from)."
        }
    }
}

proc tkjabber::httpCB { status message } {
    log::log debug "jabber-http $status : $message"
}

proc tkjabber::RegisterCB {jlibName type theQuery} {
    log::log debug "RegisterCB: type=$type, theQuery='$theQuery'"
    switch -- $type {
	result {
	    tkchat::addSystem "Registered."
	    update idletasks
	    SendAuth
	}
	default {
	    tkchat::addSystem "MyRegisterProc: type=$type, theQuery='$theQuery'"
	}
    }
}

proc tkjabber::LoginCB {jlibname type theQuery} {
    # After SendAuth, this is the next Callback.
    variable jabber
    variable roster
    variable conference
    variable muc
    variable baseNick
    variable nickTries

    global Options
    log::log debug "LoginCB: type=$type, theQuery='$theQuery'"

    #set conference tcl@conference.kroc.tk
    switch -- $type {
	error {
	    if { [lindex $theQuery 0] eq "not-authorized" || \
		$theQuery eq "{} {}" } {
		if { ![tkchat::registerScreen] } {
		    return
		}
		
		$jabber register_set $Options(Username) $Options(Password) [namespace current]::RegisterCB  \
		  -name $Options(Fullname) -email $Options(Email)
		
		tkchat::addSystem "Registering username."
		update idletasks
		# the next step is in RegisterCB
	    } else {
		tkchat::addSystem "LoginCB: type=$type, theQuery='$theQuery'"
	    }
		
	}
	result {
	    tkchat::addSystem "Logged in."
            #after 20000 [list jlib::schedule_keepalive $jlibname]
	    set tkjabber::reconnect 1
	    set tkjabber::connectionRetryTime [expr {int(5+rand()*5.0)}]
	    $jabber send_presence -type available
	    set muc [jlib::muc::new $jabber]
	    if { $::Options(Nickname) eq "" } {
		set ::Options(Nickname) $::Options(Username)
	    }
	    set baseNick $::Options(Nickname)
	    set nickTries 0
	    $muc enter $conference $::Options(Nickname) -command [namespace current]::MucEnterCB
	    # We are logged in. Now any of the callbacks can be called,
	    # Likely ones are MsgCB, MucEnterCB, RosterCB for normal traffic.
	}
	default {
	    tkchat::addSystem "LoginCB: type=$type, theQuery='$theQuery'"
	}
    }
    return


    $jabber conference get_enter $conference [namespace current]::GenericIQProc
    set subelements [list [wrapper::createtag {nick} -chdata tkchat]]
    $jabber conference set_enter $conference $subelements [namespace current]::GenericIQProc

    tkchat::addSystem "MyLoginProc: type=$type, theQuery='$theQuery'"
}
proc tkjabber::SearchGetProc {jlibName type theQuery} {
    tkchat::addSystem "MySearchGetProc: type=$type, theQuery='$theQuery'"
}
proc tkjabber::SearchSetProc {jlibName type theQuery} {
    tkchat::addSystem "MySearchSetProc: type=$type, theQuery='$theQuery'"
}
proc tkjabber::RosterResultProc {jlibName what} {
    tkchat::addSystem  "MyRosterResultProc: what=$what"
}
proc tkjabber::VCardSetProc {jlibName type theQuery} {
    tkchat::addSystem  "VCardSetProc: type=$type, theQuery='$theQuery'"
}
proc tkjabber::VCardGetProc {jlibName type theQuery} {
    tkchat::addSystem  "VCardGetProc: type=$type, theQuery='$theQuery'"
}
proc tkjabber::GenericIQProc {jlibName type theQuery} {
    tkchat::addSystem  "GenericIQProc: type=$type, theQuery='$theQuery'"
}
proc tkjabber::MucEnterCB {mucName type args} {
    variable conference
    variable muc
    variable nickTries
    variable baseNick

    log::log debug "MucEnter: type=$type, args='$args'"
    switch -- $type {
	error {
	    array set m $args
	    if { [info exists m(-error)] } {
		switch -- [lindex $m(-error) 0] {
		    401 {
			tkchat::addSystem "This conference is password protected."
		    }
		    403 {
			tkchat::addSystem "You have been banned from this conference."
		    }
		    404 {
			tkchat::addSystem "This room does not exist."
		    }
		    405 {
			tkchat::addSystem "The maximum number of users has been reached for this room."
		    }
		    407 {
			tkchat::addSystem "You must be a member to enter this conference."
		    }		
		    409 {
			# Nick conflict. Try again?
			if { $nickTries > 5 } {
    			    tkchat::addSystem  "Unable to solve nick conflict, try setting one with /nick <nickname> and then trying again"
			}
			if { $nickTries < 2 } {
			    append ::Options(Nickname) _
			} else {
			    set ::Options(Nickname) $baseNick$nickTries			
			}
			$muc enter $conference $::Options(Nickname) -command [namespace current]::MucEnterCB
		    }
		    default {
			tkchat::addSystem  "MucEnter: type=$type, args='$args'"
		    }
		}
	    }
	}
	available {
	    #tkchat::addSystem  "MucEnter: type=$type, args='$args'"
	    #only load history for tclers chat when it is not loaded already.
	    if {$conference eq "tcl@tach.tclers.tk" \
                    &&  !$tkjabber::HaveHistory } {
                # Force history loading to the background
		after 10 [list tkchat::LoadHistory]
	    }
	}
	default {
	    tkchat::addSystem  "MucEnter: type=$type, args='$args'"
	}
    }

}

proc ::tkjabber::userinfo {nick} {
    variable jabber
    variable conference
    variable roster

    if {[string match "/userinfo *" $nick]} {
        set nick [string range $nick 10 end]
    }
    if { [string first @ $nick] == -1 } {
	# No @ in the nick, assume someone from the conference:
	
	# Try to get the real jid for the user from the conference roster.	
	set x [$roster getx $conference/$nick muc#user]
	set item [wrapper::getchildswithtag $x item]
	if {[llength $item] > 0} {
	    set jid [wrapper::getattribute \
			    [lindex $item 0] jid]
	    # vcard requests must be made without the resource part:
	    regexp {([^/]+)/(.+)} $jid -> jid res
	} else {
	    # Not online, perhaps...
	    # Default to the current server
	    set jid $nick@$::Options(JabberServer)
	}		
	::tkchat::UserInfoDialog $jid
    } else {
	# A full jid was specified. Use that.
	::tkchat::UserInfoDialog $nick
    }

}

proc tkjabber::msgSend { msg args } {
    variable jabber
    variable roster
    variable conference
    variable Away
    set users {}

    array set opts {
	-user {}
	-xlist {}
	-attrs {}
    }

    if { [string match "/userinfo *" $msg] } {
        after idle [list [namespace current]::userinfo $msg]
	return
    }

    if {$Away} {back ""}

    # Trim the nolog prefix - it's already an extended attribute.
    regexp {^/nolog\s?(.*)$} $msg -> msg

    if { [llength $args] > 0 } {
	array set opts $args
    }

    set user $opts(-user)

    if { $user eq "" } {
	set user $conference
	set type groupchat
    } else {
	# lookup the real nick
	set found 0
	set type chat
        foreach person [$::tkjabber::muc participants $::tkjabber::conference] {
	    regexp {([^/])/(.+)} $person -> conf name
	    if { $name eq $user } {
		set user $person
		set found 1
		::tkchat::addAction "" $::Options(Username) \
		    " whispered to $name: $msg"		
		break
	    }
	}
	if {!$found } {	
	    log::log debug "Seaching roster. '$roster' [$roster getname $user] / [$roster getrosteritem $user/tkabber]"
	
	    foreach presence [$roster getpresence $user] {
		array set pres $presence
		if { $pres(-resource) ne {} && $pres(-type) eq "available" } {
		    log::log debug "Roster user: $user/$pres(-resource)"
	    	    lappend users $user/$pres(-resource)
    		    incr found
		    ::tkchat::addAction "" $::Options(Username) \
		        " whispered to $user/$pres(-resource): $msg"		
		}
		unset pres
	    }
	
	}
	if { !$found } {	
	    ::tkchat::addSystem "Unknown nick name '$user'"
	    return
	}
    }
    if { [llength $users] == 0 } {
	set users $user
    }

    # Example usage
    #set x [wrapper::createtag x -attrlist {xmlns urn:tkchat:chat} \
    #    -subtags [list [wrapper::createtag color \
    #                        -attrlist {attr1 val1 attr2 val2} \
    #                        -chdata $::Options(MyColor)]]]

    set attrs [concat $opts(-attrs) \
                   [list xmlns urn:tkchat:chat color $::Options(MyColor)]]

    set xlist [concat [list [wrapper::createtag x -attrlist $attrs]] \
                   $opts(-xlist)]
    log::log debug "send_message $msg $xlist"
    foreach user $users {
	$jabber send_message $user -body $msg -type $type -xlist $xlist
    }
    #-xlist [wrapper::createtag x -attrlist {xmlns http://tcl.tk/tkchat foo bar}]

}

# tkjabber::jid --
#
#       A helper function for splitting out parts of Jabber IDs.
#
proc ::tkjabber::jid {part jid} {
    log::log debug "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
}

# Send a Jabber message to the full jid of a user. Accept either a full
# JID or lookup a chatroom nick in the members array. Such messages
# are held for the user if the user is not currently available.
proc ::tkjabber::send_memo {to msg {subject Memo}} {
    variable myId
    variable jabber
    variable members

    if {[string first @ $to] == -1} {
        if {[info exists members($to,jid)]} {
            set to $members($to,jid)
        } else {
            tkchat::addSystem "Cannot find a JID for '$to'."
            return
        }
    }

    set k {}
    lappend k [list subject {} 0 $subject {}]
    lappend k [list body {} 0 $msg {}]
    set a [list xmlns jabber:client type normal from $myId to $to]
    set m [list message $a 0 "" $k]
    $jabber send $m
    tkchat::addSystem "Memo send to $to."
}

proc ::tkchat::updateJabberNames { } {
    global Options
    variable ::tkjabber::members

    set scrollcmd [.names cget -yscrollcommand]
    .names configure -yscrollcommand {}

    # Delete all URL-* tags to prevent a huge memory leak
    foreach tagname [.names tag names] {
        if {[string match URL-* $tagname]} {
	    .names tag delete $tagname
	}
    }

    set i 0
    .names config -state normal
    .names delete 1.0 end
    .mb.mnu delete 0 end
    .mb.mnu add command -label "All Users" \
	-command [list ::tkchat::MsgTo "All Users"]
    set Options(OnLineUsers) {}
    foreach person [lsort -dictionary [$::tkjabber::muc participants $::tkjabber::conference]] {

        if {![regexp {([^/])/(.+)} $person -> conf name]} {
            log::log debug "updateJabberNames: regexp failed on '$person'"
            continue
        }

        set status [list online];# FIX ME
        if {[info exists members($name,status)]} {
            set status $members($name,status)
        }
	
	lappend Options(OnLineUsers) $name
	# NOTE : the URL's don't work because of the & in them
	# doesn't work well when we exec the call to browsers
	# and if we follow spec and escape them with %26 then
	# the cgi script on the other end pukes so we will
	# just do an inline /userinfo when they are clicked
        switch -exact -- [lindex $status 0] {
            online {
                .names image create end -image ::tkchat::roster::online
            }
            chat {
                .names image create end -image ::tkchat::roster::chat
            }
            dnd {
                .names image create end -image ::tkchat::roster::dnd
            }
            away - xa {
                .names image create end -image ::tkchat::roster::away
            }
        }
	.names insert end "$name" [list NICK URL URL-[incr ::URLID]] "\n"
	.names tag bind URL-$::URLID <1> \
	    "set ::tkchat::UserClicked 1;\
               [list ::tkchat::msgSend "/userinfo $name"]"
	incr i
	.mb.mnu add command -label $name \
	    -command [list ::tkchat::MsgTo $name]
    }

    .names insert 1.0 "$i Users Online\n\n" TITLE
    .names configure -yscrollcommand $scrollcmd
    .names config -state disabled
}

proc ::tkchat::createRosterImages {} {
    image create photo ::tkchat::roster::chat -data {
        R0lGODlhDgAKAMIAAAAAAP//gICAgP///4CAQACA/wBAgH9/fyH5BAEKAAcA
        LAAAAAAOAAoAAAMseAesy22FKda4F0hq8dDARFSA9ymAoEIsWhSG4czL+8a0
        a+M5YMOy3o9HSwAAOw==
    }
    image create photo ::tkchat::roster::online -data {
        R0lGODlhDgAKAMIAAAAAAP//gICAgICAQACA/wBAgP///////yH5BAEKAAcA
        LAAAAAAOAAoAAAMkeAes/itIAR+QgVZ1w9DbIozhQhBFEQLnmW5s+1axq9It
        ekMJADs=
    }
    image create photo ::tkchat::roster::away -data {
        R0lGODlhDgAKAMIAAAAAAP//gICAgP///4CAQACA/wBAgP///yH5BAEKAAcA
        LAAAAAAOAAoAAAMzeAesy8CBQMUaeMRFgwCZpnEB8WXguAhsymARUBSGkcKa
        PNN2GO+8R2MBrDmOupnxqEgAADs=
    }
    image create photo ::tkchat::roster::dnd -data {
        R0lGODlhDgAKAOMAAAAAAP//gICAgP8AAICAQP///wCA/wBAgP//////////
        /////////////////////yH5BAEKAAgALAAAAAAOAAoAAAQ5ECFA5aTAgsDF
        HOCQTVwgAGGYbQFxDkVciBIg3Kg8r4ZxHKiUCNDr/YIgXvF3qUyKvoNlSlxK
        p5IIADs=
    }
}


proc ::tkjabber::setNick { newnick } {
    variable muc
    variable conference
    variable roster
    variable jabber
    variable grabNick

    if {[lsearch -exact $::Options(OnLineUsers) $newnick] > -1 } {
	# Perhaps it is my own nick, in another window?
	set x [$roster getx $conference/$newnick muc#user]
	set item [wrapper::getchildswithtag $x item]
	set otherjid ""
	if {[llength $item] > 0} {
	    set otherjid [wrapper::getattribute \
			    [lindex $item 0] jid]	
	}
	regexp {([^/]+)/(.+)} [$jabber myjid] -> myjid myres
	
	if { [regexp {([^/]+)/(.+)} $otherjid -> ojid ores] } {
	    if { $ojid eq $myjid && $ores ne $myres } {
		# Yes, it is my JID, different resource.
		# Send a rename request:
	        set attrs [list xmlns urn:tkchat:changenick]
	        set xlist [list [wrapper::createtag x -attrlist $attrs]]

		$tkjabber::jabber send_message $otherjid -type chat -xlist $xlist
		tkchat::addSystem "This nick is owned by another you, requested transfer..."
		set grabNick $newnick
		return
	    }
	}	
	tkchat::addSystem "The nickname '$newnick' is already in use."
	return
    }

    # There is a race condition here. new nick could enter between the check
    # and the setnick call...
    set ::Options(Nickname) $newnick
    $muc setnick $conference $newnick
}

proc ::tkjabber::transferNick { reqfrom } {
    variable muc
    variable conference
    variable roster
    variable jabber

    regexp {([^/]+)/(.+)} $reqfrom -> ojid ores
	
    regexp {([^/]+)/(.+)} [$jabber myjid] -> myjid myres
	
    if { $ojid ne $myjid } {
	# No, it is not a request from an alter ego.
	# Denied.
	log::log debug "Denied nick transfer request from $reqfrom"
	return
    }

    # It is a valid request. Do the transfer.
    set postfix $::Options(JabberResource)
    if { [string match "tkchat*" $postfix] } {
	set postfix [string range $postfix 6 end]
	if { $postfix eq "" } {
	    set postfix "Away"
	}
    }
    set newnick $::Options(Nickname)$postfix
    if {[lsearch -exact $::Options(OnLineUsers) $newnick] > -1 } {
	tkchat::addSystem "Got a nick transfer request, but $newnick is already in use."
	return
    }

    # Set my nick name to newnick.
    set ::Options(Nickname) $newnick
    $muc setnick $conference $newnick

    # The other party does not need to be notified - it should be in nickgrab mode.

}


proc ::tkjabber::setTopic { newtopic } {

    variable conference
    variable jabber

    $jabber send_message $conference -subject $newtopic -type groupchat

}

proc ::tkjabber::ParseLogMsg { when nick msg {opts ""} args } {
    variable HistoryLines
    variable HaveHistory
    set HaveHistory 1
    set time [clock scan ${when} -gmt 1]
    lappend HistoryLines [list $time $nick $msg]
    if { [llength $args] > 0 } {
	log::log warning "Log incorrect log format."
    }
    log::log debug "[clock format $time] $nick :: $msg"
}

proc ::tkjabber::HistoryLines { } {
    variable HistoryLines
    return [llength $HistoryLines]
}

proc ::tkjabber::LoadHistoryLines {} {
    global Options
    variable HistoryLines

    set state [.txt cget -state]
    .txt configure -state normal

    log::log debug tkjabber-LoadHistoryLines

    # mask the alerts
    set alerts [array get Options Alert,*]
    foreach {alert value} $alerts { set Options($alert) 0 }

    if {![info exists Options(FinalList)]} {set Options(FinalList) {}}

    set count 0
    foreach entry $HistoryLines {
	set time [lindex $entry 0]
	set nick [lindex $entry 1]
	set msg [lindex $entry 2]
	
	if { [string match "ijchain*" $nick] } {
	    set pos [string first " " $msg]
	    set nick [string trim [string range $msg 0 $pos]]
	    incr pos
	    set msg [string range $msg $pos end]
	    if { $nick eq "<azbridge>" } {
		set pos [string first " " $msg]
		set nick "[string trim [string range $msg 0 $pos]]"
		incr pos
		set msg [string range $msg $pos end]
	    }
	    if { $nick eq "*" } {
		set pos [string first " " $msg]
		set nick "<[string trim [string range $msg 0 $pos]]>"
		incr pos
		set msg "/me [string range $msg $pos end]"				
	    }
	}
	
	if { [string equal $nick ""] && [string match "* has left" $msg] } {
	    tkchat::addTraffic [lindex [split $msg] 0] left HISTORY $time
	} elseif {[string equal $nick ""] && [string match "* has become available" $msg] } {
	    tkchat::addTraffic [lindex [split $msg] 0] entered HISTORY $time
	} elseif { [string match "/me *" $msg] } {
	    tkchat::addAction "" $nick [string range $msg 4 end] HISTORY $time
	} else {
            tkchat::addMessage "" $nick $msg HISTORY $time
	}
        incr count
        if {$count > 35 } { break }
    }
    .txt see end
    set HistoryLines [lrange $HistoryLines $count end]

    # Restore the alerts
    array set Options $alerts

    if {$HistoryLines == {}} {
        log::log debug "History loading completed."
        .txt configure -state normal
        .txt delete "HISTORY + 1 char" "HISTORY + 1 line"
        .txt insert "HISTORY + 1 char" \
            "+++++++++++++++++++++ End Of History +++++++++++++++++++++\n"
    } else {
        after idle [list after 0 ::tkjabber::LoadHistoryLines]
    }

    .txt configure -state $state
}

proc ::tkjabber::TwiddlePort {} {
    global Options
    if {$Options(UseJabberSSL) eq "ssl" && $Options(JabberPort) == 5222} {
        incr Options(JabberPort)
    } elseif {$Options(UseJabberSSL) ne "ssl" && $Options(JabberPort) == 5223} {
        incr Options(JabberPort) -1
    }
}

proc ::tkjabber::scheduleReconnect {} {
    variable reconnectTimer
    variable connectionRetryTime

    if { $reconnectTimer ne "" } {
	log::log debug "Already trying to reconnect..."
	return
    }

    tkchat::addSystem "Will try to reconnect in $connectionRetryTime seconds."
    set reconnectTimer [after [expr {$connectionRetryTime*1000}] tkjabber::connect]

    set connectionRetryTime [expr { int ($connectionRetryTime * 1.5) } ]
    # Max out at 3 minutes
    if { $connectionRetryTime > 180 } {
	set connectionRetryTime 180
    }
}


# Respond to subscriptin requests
proc tkjabber::SubscriptionRequest {from status} {
    variable subs_uid
    if {![info exists subs_uid]} { set subs_uid 0 }
    set jid [jid !resource $from]
    set ttl [msgcat::mc "Subscribe request from %s" $jid]
    set msg [msgcat::mc "Do you want to let %s add you to their roster?" $jid]
    set status [string trim $status]
    set wid dlg[incr subs_uid]
    set dlg [toplevel .$wid -class Dialog]
    wm title $dlg $ttl
    set f [frame $dlg.f -borderwidth 0]
    set lt [label $f.lt -text "$ttl" -anchor w]
    set ls [label $f.ls -text " \"$status\"" -anchor w]
    set lm [label $f.lm -text "$msg" -anchor w]
    set fb [frame $f.fb -borderwidth 0]
    set yes [button $fb.yes -text [msgcat::mc "Yes"] -default active \
                 -command [list set [namespace current]::$wid subscribed]]
    set no  [button $fb.no -text [msgcat::mc "No"] -default normal \
                 -command [list set [namespace current]::$wid unsubscribed]]
    bind $dlg <Return>     [list $yes invoke]
    bind $dlg <Key-Escape> [list $no  invoke]
    pack $no $yes -side right
    pack $lt $ls $lm $fb -side top -fill x -expand 1
    pack $f -side top -fill both -expand 1
    set [namespace current]::$wid waiting
    tkwait variable [namespace current]::$wid
    destroy $dlg
    set response [set [namespace current]::$wid]
    $tkjabber::jabber send_presence -type $response \
        -from [$tkjabber::jabber myjid] \
        -to $jid
    unset [namespace current]::$wid
    return
}

proc tkjabber::away {status} {
    variable Away
    variable conference
    set Away 1
    set jid $conference/[$tkjabber::muc mynick $conference]
    $tkjabber::jabber send_presence -type available \
        -from $jid -to $conference -show away -status $status
}

proc tkjabber::back {status} {
    variable Away
    variable conference
    set Away 0
    set jid $conference/[$tkjabber::muc mynick $conference]
    $tkjabber::jabber send_presence -type available \
        -from $jid -to $conference -show online -status $status
}

# -------------------------------------------------------------------------

proc tkjabber::on_iq_version {token from subiq args} {
    global tcl_platform
    
    array set a {-id {}}
    array set a $args
    set opts {}
    if {$a(-id) ne {}} { lappend opts -id $a(-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 "Tkchat"]  \
      [wrapper::createtag version -chdata [package provide app-tkchat]]  \
      [wrapper::createtag os      -chdata $os] ]
    set xmllist [wrapper::createtag query -subtags $subtags  \
      -attrlist {xmlns jabber:iq:version}]
    eval {jlib::send_iq $token "result" [list $xmllist]} $opts

    # Tell jlib's iq-handler that we handled the event.
    return 1
}

# -------------------------------------------------------------------------

proc tkjabber::ProxyConnect {proxyserver proxyport jabberserver jabberport} {
    global Options
    variable have_tls

    set sock [socket $proxyserver $proxyport]
    fconfigure $sock -blocking 0 -buffering line -translation crlf

    set proxyauth [join [::tkchat::buildProxyHeaders] {: }]
    puts $sock "CONNECT $jabberserver:$jabberport HTTP/1.1"
    puts $sock "Host: $jabberserver"
    puts $sock "User-Agent: [http::config -useragent]"
    puts $sock "Proxy-Connection: keep-alive"
    puts $sock "Connection: keep-alive"
    if {[string length $proxyauth] > 0} {
        puts $sock "$proxyauth"
    }
    puts $sock ""

    fileevent $sock readable {set proxy_readable ""}
    global proxy_readable
    vwait proxy_readable
    fileevent $sock readable {}

    set block [read $sock]
    set result [lindex [split $block \n] 0]
    set code [lindex [split $result { }] 1]
    fconfigure $sock -blocking 1 -translation binary -buffering none

    if {$code >= 200 && $code < 300} {
        if {$have_tls && $Options(UseJabberSSL) eq "ssl"} {
            tls::import $sock
        }
    } else {
        error "proxy connect failed: $block"
    }
    return $sock
}

# -------------------------------------------------------------------------
# Windows CE specific code.

if { $tcl_platform(os) eq "Windows CE" && ![info exists ::tkchat::wince_fixes]} {
    set ::tkchat::wince_fixes 1
    # Work around for socket problem with sockets. ("select 10022")
    # Not quite there yet...
    proc tkchat::WinCE_Accept {channel peer port} {
	log::log debug "WinCE work around accepted connection $channel $peer $port"
    }
    if { [catch {
	socket -server ::tkchat::WinCE_Accept 12345
        set ::tkchat::wince_clientchan [socket 127.0.0.1 12345]
    }] } {
	log::log debug "Error during WinCE fix init: $::errorInfo"
    }
}

# -------------------------------------------------------------------------

if {![info exists ::URLID]} {
    eval [linsert $argv 0 ::tkchat::Init]
}
package require Tcl 8.5
package require trofs 0.4

		source [file join [trofs::mount [info script]] textutil.tcl]
	

namespace eval ::textutil {

    namespace eval adjust {

        variable here [file dirname [info script]]
        variable StrRepeat [ namespace parent ]::strRepeat
        variable Justify  left
        variable Length   72
        variable FullLine 0
        variable StrictLength 0
        variable Hyphenate    0
        variable HyphPatterns

        namespace export adjust indent undent

        # This will be redefined later. We need it just to let
        # a chance for the next import subcommand to work
        #
        proc adjust { text args } { }
        proc indent { text args } { }
        proc undent { text args } { }
    }

    namespace import -force adjust::adjust adjust::indent adjust::undent
    namespace export adjust indent undent

}

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

proc ::textutil::adjust::adjust { text args } {

    if { [ string length [ string trim $text ] ] == 0 } then {
        return ""
    }

    Configure $args
    Adjust text newtext

    return $newtext
}

proc ::textutil::adjust::Configure { args } {
  variable Justify         left
  variable Length    72
  variable FullLine  0
  variable StrictLength 0
  variable Hyphenate    0
  variable HyphPatterns;                       # hyphenation patterns (TeX)

    set args [ lindex $args 0 ]
    foreach { option value } $args {
      switch -exact -- $option {
        -full {
          if { ![ string is boolean -strict $value ] } then {
            error "expected boolean but got \"$value\""
          }
          set FullLine [ string is true $value ]
        }
        -hyphenate {
          # the word exceeding the length of line is tried to be
          # hyphenated; if a word cannot be hyphenated to fit into
          # the line processing stops! The length of the line should
          # be set to a reasonable value!

          if { ![ string is boolean -strict $value ] } then {
            error "expected boolean but got \"$value\""
          }
          set Hyphenate [string is true $value]
          if { $Hyphenate && ![info exists HyphPatterns(_LOADED_)]} {
            error "hyphenation patterns not loaded!"
          }
        }
        -justify {
          set lovalue [ string tolower $value ]
          switch -exact -- $lovalue {
            left -
            right -
            center -
            plain {
              set Justify $lovalue
            }
            default {
              error "bad value \"$value\": should be center, left, plain or right"
            }
          }
        }
        -length {
          if { ![ string is integer $value ] } then {
            error "expected positive integer but got \"$value\""
          }
          if { $value < 1 } then {
            error "expected positive integer but got \"$value\""
          }
          set Length $value
        }
        -strictlength {
          # the word exceeding the length of line is moved to the
          # next line without hyphenation; words longer than given
          # line length are cut into smaller pieces

          if { ![ string is boolean -strict $value ] } then {
            error "expected boolean but got \"$value\""
          }
          set StrictLength [ string is true $value ]
        }
        default {
          error "bad option \"$option\": must be -full, -hyphenate, \
          -justify, -length, or -strictlength"
        }
      }
    }

    return ""
}

# ::textutil::adjust::Adjust
#
# History:
#      rewritten on 2004-04-13 for bugfix tcllib-bugs-882402 (jhv)

proc ::textutil::adjust::Adjust { varOrigName varNewName } {
  variable Length
  variable FullLine
  variable StrictLength
  variable Hyphenate

  upvar $varOrigName orig
  upvar $varNewName  text

  set pos 0;                                   # Cursor after writing
  set line ""
  set text ""


  if {!$FullLine} {
    regsub -all -- "(\n)|(\t)"     $orig   " "  orig
    regsub -all -- " +"            $orig  " "   orig
    regsub -all -- "(^ *)|( *\$)"  $orig  ""    orig
  }

  set words [split $orig];
  set numWords [llength $words];
  set numline 0;

  for {set cnt 0} {$cnt < $numWords} {incr cnt} {

    set w [lindex $words $cnt];
    set wLen [string length $w];

    # the word $w doesn't fit into the present line
    # case #1: we try to hyphenate

    if {$Hyphenate && ($pos+$wLen >= $Length)} {
      # Hyphenation instructions
      set w2 [textutil::adjust::Hyphenation $w];

      set iMax [llength $w2];
      if {$iMax == 1 && [string length $w] > $Length} {
        # word cannot be hyphenated and exceeds linesize

        error "Word \"$w2\" can\'t be hyphenated\
        and exceeds linesize $Length!"
      } else {
        # hyphenating of $w was successfull, but we have to look
        # that every sylable would fit into the line

        foreach x $w2 {
          if {[string length $x] >= $Length} {
            error "Word \"$w\" can\'t be hyphenated\
            to fit into linesize $Length!"
          }
        }
      }

      for {set i 0; set w3 ""} {$i < $iMax} {incr i} {
        set syl [lindex $w2 $i];
        if {($pos+[string length " $w3$syl-"]) > $Length} {break}
        append w3 $syl;
      }
      for {set w4 ""} {$i < $iMax} {incr i} {
        set syl [lindex $w2 $i];
        append w4 $syl;
      }

      if {[string length $w3] && [string length $w4]} {
        # hyphenation was successfull: redefine
        # list of words w => {"$w3-" "$w4"}

        set x [lreplace $words $cnt $cnt "$w4"];
        set words [linsert $x $cnt "$w3-"];
        set w [lindex $words $cnt];
        set wLen [string length $w];
        incr numWords;
      }
    }

    # the word $w doesn't fit into the present line
    # case #2: we try to cut the word into pieces

    if {$StrictLength && ([string length $w] > $Length)} {
      # cut word into two pieces
      set w2 $w;

      set over [expr $pos+2+$wLen-$Length];
      set w3 [string range $w2 0 $Length]
      set w4 [string range $w2 [expr $Length+1] end];

      set x [lreplace $words $cnt $cnt $w4];
      set words [linsert $x $cnt $w3 ];
      set w [lindex $words $cnt];
      set wLen [string length $w];
      incr numWords;
    } else {
      ;
    }

    # continuing with the normal procedure

    if {($pos+$wLen < $Length)} {
      # append word to current line

      if {$pos} {append line " "; incr pos}
      append line $w;
      incr pos $wLen;
    } else {
      # line full => write buffer and  begin a new line

      if [string length $text] {append text "\n"}
      append text [Justification $line [incr numline]];
      set line $w;
      set pos $wLen;
    }
  }

  # write buffer and return!

  if [string length $text] {append text "\n"}
  append text [Justification $line end];
  return $text
}

# ::textutil::adjust::Justification
#
# justify a given line
#
# Parameters:
#      line    text for justification
#      index   index for line in text
#
# Returns:
#      the justified line
#
# Remarks:
#      Only lines with size not exceeding the max. linesize provided
#      for text formatting are justified!!!

proc ::textutil::adjust::Justification { line index } {
  variable Justify
  variable Length
  variable FullLine
  variable StrRepeat

  set len [string length $line];               # length of current line

  if { $Length <= $len } then {
    # the length of current line ($len) is equal as or greater than
    # the value provided for text formatting ($Length) => to avoid
    # inifinite loops we leave $line unchanged and return!

    return $line;
  }

  # Special case:
  # for the last line, and if the justification is set to 'plain'
  # the real justification is 'left' if the length of the line
  # is less than 90% (rounded) of the max length allowed. This is
  # to avoid expansion of this line when it is too small: without
  # it, the added spaces will 'unbeautify' the result.
  #

  set justify $Justify;
  if { ( "$index" == "end" ) && \
       ( "$Justify" == "plain" ) && \
       ( $len < round($Length * 0.90) ) } then {
         set justify left;
  }

  # For a left justification, nothing to do, but to
  # add some spaces at the end of the line if requested

  if { "$justify" == "left" } then {
    set jus ""
    if { $FullLine } then {
      set jus [ $StrRepeat " " [ expr { $Length - $len } ] ]
    }
    return "${line}${jus}";
  }

  # For a right justification, just add enough spaces
  # at the beginning of the line

  if { "$justify" == "right" } then {
    set jus [ $StrRepeat " " [ expr { $Length - $len } ] ]
    return "${jus}${line}";
  }

  # For a center justification, add half of the needed spaces
  # at the beginning of the line, and the rest at the end
  # only if needed.

  if { "$justify" == "center" } then {
    set mr [ expr { ( $Length - $len ) / 2 } ]
    set ml [ expr { $Length - $len - $mr } ]
    set jusl [ $StrRepeat " " $ml ]
    set jusr [ $StrRepeat " " $mr ]
    if { $FullLine } then {
      return "${jusl}${line}${jusr}"
    } else {
      return "${jusl}${line}"
    }
  }

  # For a plain justification, it's a little bit complex:
  #
  # if some spaces are missing, then
  #
  # 1) sort the list of words in the current line by decreasing size
  # 2) foreach word, add one space before it, except if it's the
  #    first word, until enough spaces are added
  # 3) rebuild the line

  if { "$justify" == "plain" } then {
    set miss [ expr { $Length - [ string length $line ] } ]

    # Bugfix tcllib-bugs-860753 (jhv)

    set words [split $line];
    set numWords [llength $words];

    if {$numWords < 2} {
      # current line consists of less than two words - we can't
      # insert blanks to achieve a plain justification => leave
      # $line unchanged and return!

      return $line;
    }

    for {set i 0; set totalLen 0} {$i < $numWords} {incr i} {
      set w($i) [lindex $words $i];
      if {$i > 0} {set w($i) " $w($i)"};
      set wLen($i) [string length $w($i)];
      set totalLen [expr $totalLen+$wLen($i)];
    }

    set miss [expr {$Length - $totalLen}];

    # len walks through all lengths of words of the line under
    # consideration

    for {set len 1} {$miss > 0} {incr len} {
      for {set i 1} {($i < $numWords) && ($miss > 0)} {incr i} {
        if {$wLen($i) == $len} {
          set w($i) " $w($i)";
          incr wLen($i);
          incr miss -1;
        }
      }
    }

    set line "";
    for {set i 0} {$i < $numWords} {incr i} {
      set line "$line$w($i)";
    }

    # End of bugfix

    return "${line}"
  }

  error "Illegal justification key \"$justify\""
}

proc ::textutil::adjust::SortList { list dir index } {

    if { [ catch { lsort -integer -$dir -index $index $list } sl ] != 0 } then {
        error "$sl"
    }

    return $sl
}

# Hyphenation utilities based on Knuth's algorithm
#
# Copyright (C) 2001-2003 by Dr.Johannes-Heinrich Vogeler (jhv)
# These procedures may be used as part of the tcllib

# textutil::adjust::Hyphenation
#
#      Hyphenate a string using Knuth's algorithm
#
# Parameters:
#      str     string to be hyphenated
#
# Returns:
#      the hyphenated string

proc ::textutil::adjust::Hyphenation { str } {

  # if there are manual set hyphenation marks e.g. "Recht\-schrei\-bung"
  # use these for hyphenation and return

  if [regexp {[^\\-]*[\\-][.]*} $str] {
    regsub -all {(\\)(-)} $str {-} tmp;
    return [split $tmp -];
  }

  # Don't hyphenate very short words! Minimum length for hyphenation
  # is set to 3 characters!

  if { [string length $str] < 4 } then { return $str }

  # otherwise follow Knuth's algorithm

  variable HyphPatterns;                       # hyphenation patterns (TeX)

  set w ".[string tolower $str].";             # transform to lower case
  set wLen [string length $w];                 # and add delimiters

  # Initialize hyphenation weights

  set s {}
  for {set i 0} {$i < $wLen} {incr i} {
    lappend s 0;
  }

  for {set i 0} {$i < $wLen} {incr i} {
    set kmax [expr $wLen-$i];
    for {set k 1} {$k < $kmax} {incr k} {
      set sw [string range $w $i [expr $i+$k]];
      if [info exists HyphPatterns($sw)] {
        set hw $HyphPatterns($sw);
        set hwLen [string length $hw];
        for {set l1 0; set l2 0} {$l1 < $hwLen} {incr l1} {
          set c [string index $hw $l1];
          if [string is digit $c] {
            set sPos [expr $i+$l2];
            if {$c > [lindex $s $sPos]} {
              set s [lreplace $s $sPos $sPos $c];
            }
          } else {
            incr l2;
          }
        }
      }
    }
  }

  # Replace all even hyphenation weigths by zero

  for {set i 0} {$i < [llength $s]} {incr i} {
    set c [lindex $s $i];
    if ![expr $c%2] { set s [lreplace $s $i $i 0] }
  }

  # Don't start with a hyphen! Take also care of words enclosed in quotes
  # or that someone has forgotten to put a blank between a punctuation
  # character and the following word etc.

  for {set i 1} {$i < [expr $wLen-1]} {incr i} {
    set c [string range $w $i end]
    if [regexp {^[:alpha:][.]*} $c] {
      for {set k 1} {$k < [expr $i+1]} {incr k} {
        set s [lreplace $s $k $k 0];
      }
      break
    }
  }

  # Don't separate the last character of a word with a hyphen

  set max [expr [llength $s]-2];
  if {$max} {set s [lreplace $s $max end 0]}

  # return the syllabels of the hyphenated word as a list!

  set ret "";
  set w ".$str.";
  for {set i 1} {$i < [expr $wLen-1]} {incr i} {
    if [lindex $s $i] { append ret - }
    append ret [string index $w $i];
  }
  return [split $ret -];
}

# textutil::adjust::listPredefined
#
#      Return the names of the hyphenation files coming with the package.
#
# Parameters:
#      None.
#
# Result:
#       List of filenames (without directory)

proc ::textutil::adjust::listPredefined {} {
    variable here
    return [glob -type f -directory $here -tails *.tex]
}

# textutil::adjust::getPredefined
#
#      Retrieve the full path for a predefined hyphenation file
#       coming with the package.
#
# Parameters:
#      name     Name of the predefined file.
#
# Results:
#       Full path to the file, or an error if it doesn't
#       exist or is matching the pattern *.tex.

proc ::textutil::adjust::getPredefined {name} {
    variable here

    if {![string match *.tex $name]} {
        return -code error \
                "Illegal hyphenation file \"$name\""
    }
    set path [file join $here $name]
    if {![file exists $path]} {
        return -code error \
                "Unknown hyphenation file \"$path\""
    }
    return $path
}

# textutil::adjust::readPatterns
#
#      Read hyphenation patterns from a file and store them in an array
#
# Parameters:
#      filNam  name of the file containing the patterns

proc ::textutil::adjust::readPatterns { filNam } {

  variable HyphPatterns;                       # hyphenation patterns (TeX)

  # HyphPatterns(_LOADED_) is used as flag for having loaded
  # hyphenation patterns from the respective file (TeX format)

  if [info exists HyphPatterns(_LOADED_)] {
    unset HyphPatterns(_LOADED_);
  }

  # the array xlat provides translation from TeX encoded characters
  # to those of the ISO-8859-1 character set

  set xlat(\"s) \337;                          # 223 := sharp s
  set xlat(\`a) \340;                          # 224 := a, grave
  set xlat(\'a) \341;                          # 225 := a, acute
  set xlat(\^a) \342;                          # 226 := a, circumflex
  set xlat(\"a) \344;                          # 228 := a, diaeresis
  set xlat(\`e) \350;                          # 232 := e, grave
  set xlat(\'e) \351;                          # 233 := e, acute
  set xlat(\^e) \352;                          # 234 := e, circumflex
  set xlat(\`i) \354;                          # 236 := i, grave
  set xlat(\'i) \355;                          # 237 := i, acute
  set xlat(\^i) \356;                          # 238 := i, circumflex
  set xlat(\~n) \361;                          # 241 := n, tilde
  set xlat(\`o) \362;                          # 242 := o, grave
  set xlat(\'o) \363;                          # 243 := o, acute
  set xlat(\^o) \364;                          # 244 := o, circumflex
  set xlat(\"o) \366;                          # 246 := o, diaeresis
  set xlat(\`u) \371;                          # 249 := u, grave
  set xlat(\'u) \372;                          # 250 := u, acute
  set xlat(\^u) \373;                          # 251 := u, circumflex
  set xlat(\"u) \374;                          # 252 := u, diaeresis

  set fd [open $filNam RDONLY];
  set status 0;

  while {[gets $fd line] >= 0} {

    switch -exact $status {
      PATTERNS {
        if [regexp {^\}[.]*} $line] {
          # End of patterns encountered: set status
          # and ignore that line
          set status 0;
          continue;
        } else {
          # This seems to be pattern definition line; to process it
          # we have first to do some editing
          #
          # 1) eat comments in a pattern definition line
          # 2) eat braces and coded linefeeds

          set z [string first "%" $line];
          if {$z > 0} { set line [string range $line 0 [expr $z-1]] }

          regsub -all {(\\n|\{|\})} $line {} tmp;
          set line $tmp;

          # Now $line should consist only of hyphenation patterns
          # separated by white space

          # Translate TeX encoded characters to ISO-8859-1 characters
          # using the array xlat defined above

          foreach x [array names xlat] {
            regsub -all {$x} $line $xlat($x) tmp;
            set line $tmp;
          }

          # split the line and create a lookup array for
          # the repective hyphenation patterns

          foreach item [split $line] {
            if [string length $item] {
              if ![string match {\\} $item] {
                # create index for hyphenation patterns

                set var $item;
                regsub -all {[0-9]} $var {} idx;
                # store hyphenation patterns as elements of an array

                set HyphPatterns($idx) $item;
              }
            }
          }
        }
      }
      EXCEPTIONS {
        if [regexp {^\}[.]*} $line] {
          # End of patterns encountered: set status
          # and ignore that line
          set status 0;
          continue;
        } else {
          # to be done in the future
        }
      }
      default {
        if [regexp {^\\endinput[.]*} $line] {
          # end of data encountered, stop processing and
          # ignore all the following text ..
          break;
        } elseif [regexp {^\\patterns[.]*} $line] {
          # begin of patterns encountered: set status
          # and ignore that line
          set status PATTERNS;
          continue;
        } elseif [regexp {^\\hyphenation[.]*} $line] {
          # some particular cases to be treated separately
          set status EXCEPTIONS
          continue;
        } else {
          set status 0;
        }
      }
    }                  ;# switch
  }

  close $fd;
  set HyphPatterns(_LOADED_) 1;

  return;
}

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

# @c The specified <a text>block is indented
# @c by <a prefix>ing each line. The first
# @c <a hang> lines ares skipped.
#
# @a text:   The paragraph to indent.
# @a prefix: The string to use as prefix for each line
# @a prefix: of <a text> with.
# @a skip:   The number of lines at the beginning to leave untouched.
#
# @r Basically <a text>, but indented a certain amount.
#
# @i indent
# @n This procedure is not checked by the testsuite.

proc ::textutil::adjust::indent {text prefix {skip 0}} {
    set text [string trim $text]

    set res [list]
    foreach line [split $text \n] {
        if {[string compare "" [string trim $line]] == 0} {
            lappend res {}
        } elseif {$skip <= 0} {
            lappend res $prefix[string trimright $line]
        } else {
            lappend res [string trimright $line]
        }
        if {$skip > 0} {incr skip -1}
    }
    return [join $res \n]
}

# Undent the block of text: Compute LCP (restricted to whitespace!)
# and remove that from each line. Note that this preverses the
# shaping of the paragraph (i.e. hanging indent are _not_ flattened)
# We ignore empty lines !!

proc ::textutil::adjust::undent {text} {

    if {$text == {}} {return {}}

    set lines [split $text \n]
    set ne [list]
    foreach l $lines {
        if {[string length [string trim $l]] == 0} continue
        lappend ne $l
    }
    set lcp [::textutil::longestCommonPrefixList $ne]

    if {[string length $lcp] == 0} {return $text}

    regexp {^([         ]*)} $lcp -> lcp

    if {[string length $lcp] == 0} {return $text}

    set len [string length $lcp]

    set res [list]
    foreach l $lines {
        if {[string length [string trim $l]] == 0} {
            lappend res {}
        } else {
            lappend res [string range $l $len end]
        }
    }
    return [join $res \n]
}
#---------------------------------------------------------------------
# TITLE:
#	expander.tcl
#
# AUTHOR:
#	Will Duquette
#
# DESCRIPTION:
#
# An expander is an object that takes as input text with embedded
# Tcl code and returns text with the embedded code expanded.  The
# text can be provided all at once or incrementally.
#
# See  expander.[e]html for usage info.
# Also expander.n
#
# LICENSE:
#       Copyright (C) 2001 by William H. Duquette.  See expander_license.txt,
#       distributed with this file, for license information.
#
# CHANGE LOG:
#
#       10/31/01: V0.9 code is complete.
#       11/23/01: Added "evalcmd"; V1.0 code is complete.

# Provide the package.

# Create the package's namespace.

namespace eval ::textutil {
    namespace eval expander {
	# All indices are prefixed by "$exp-".
	#
	# lb		    The left bracket sequence
	# rb		    The right bracket sequence
	# errmode	    How to handle macro errors: 
	#		    nothing, macro, error, fail.
        # evalcmd           The evaluation command.
	# textcmd           The plain text processing command.
	# level		    The context level
	# output-$level     The accumulated text at this context level.
	# name-$level       The tag name of this context level
	# data-$level-$var  A variable of this context level     
	
	variable Info
    
	# In methods, the current object:
	variable This ""
	
	# Export public commands
	namespace export expander
    }

    #namespace import expander::*
    namespace export expander

    proc expander {name} {uplevel ::textutil::expander::expander [list $name]}
}

#---------------------------------------------------------------------
# FUNCTION:
# 	expander name
#
# INPUTS:
#	name		A proc name for the new object.  If not
#                       fully-qualified, it is assumed to be relative
#                       to the caller's namespace.
#
# RETURNS:
#	nothing
#
# DESCRIPTION:
#	Creates a new expander object.

proc ::textutil::expander::expander {name} {
    variable Info

    # FIRST, qualify the name.
    if {![string match "::*" $name]} {
        # Get caller's namespace; append :: if not global namespace.
        set ns [uplevel 1 namespace current]
        if {"::" != $ns} {
            append ns "::"
        }
        
        set name "$ns$name"
    }

    # NEXT, Check the name
    if {"" != [info command $name]} {
        return -code error "command name \"$name\" already exists"
    }

    # NEXT, Create the object.
    proc $name {method args} [format {
        if {[catch {::textutil::expander::Methods %s $method $args} result]} {
            return -code error $result
        } else {
            return $result
        }
    } $name]

    # NEXT, Initialize the object
    Op_reset $name
    
    return $name
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Methods name method argList
#
# INPUTS:
#	name		The object's fully qualified procedure name.
#			This argument is provided by the object command
#			itself.
#	method		The method to call.
#	argList		Arguments for the specific method.
#
# RETURNS:
#	Depends on the method
#
# DESCRIPTION:
#	Handles all method dispatch for a expander object.
#       The expander's object command merely passes its arguments to
#	this function, which dispatches the arguments to the
#	appropriate method procedure.  If the method raises an error,
#	the method procedure's name in the error message is replaced
#	by the object and method names.

proc ::textutil::expander::Methods {name method argList} {
    variable Info
    variable This

    switch -exact -- $method {
        expand -
        lb -
        rb -
        setbrackets -
        errmode -
        evalcmd -
	textcmd -
        cpush -
	ctopandclear -
        cis -
        cname -
        cset -
        cget -
        cvar -
        cpop -
        cappend -
	where -
        reset {
            # FIRST, execute the method, first setting This to the object
            # name; then, after the method has been called, restore the
            # old object name.
            set oldThis $This
            set This $name

            set retval [catch "Op_$method $name $argList" result]

            set This $oldThis

            # NEXT, handle the result based on the retval.
            if {$retval} {
                regsub -- "Op_$method" $result "$name $method" result
                return -code error $result
            } else {
                return $result
            }
        }
        default {
            return -code error "\"$name $method\" is not defined"
        }
    }
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Get key
#
# INPUTS:
#	key		A key into the Info array, excluding the
#	                object name.  E.g., "lb"
#
# RETURNS:
#	The value from the array
#
# DESCRIPTION:
#	Gets the value of an entry from Info for This.

proc ::textutil::expander::Get {key} {
    variable Info
    variable This

    return $Info($This-$key)
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Set key value
#
# INPUTS:
#	key		A key into the Info array, excluding the
#	                object name.  E.g., "lb"
#
#	value		A Tcl value
#
# RETURNS:
#	The value
#
# DESCRIPTION:
#	Sets the value of an entry in Info for This.

proc ::textutil::expander::Set {key value} {
    variable Info
    variable This

    return [set Info($This-$key) $value]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Var key
#
# INPUTS:
#	key		A key into the Info array, excluding the
#	                object name.  E.g., "lb"
#
# RETURNS:
#	The full variable name, suitable for setting or lappending

proc ::textutil::expander::Var {key} {
    variable Info
    variable This

    return ::textutil::expander::Info($This-$key)
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Contains list value
#
# INPUTS:
#       list		any list
#	value		any value
#
# RETURNS:
#	TRUE if the list contains the value, and false otherwise.

proc ::textutil::expander::Contains {list value} {
    if {[lsearch -exact $list $value] == -1} {
        return 0
    } else {
        return 1
    }
}


#---------------------------------------------------------------------
# FUNCTION:
# 	Op_lb ?newbracket?
#
# INPUTS:
#	newbracket		If given, the new bracket token.
#
# RETURNS:
#	The current left bracket
#
# DESCRIPTION:
#	Returns the current left bracket token.

proc ::textutil::expander::Op_lb {name {newbracket ""}} {
    if {[string length $newbracket] != 0} {
        Set lb $newbracket
    }
    return [Get lb]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_rb ?newbracket?
#
# INPUTS:
#	newbracket		If given, the new bracket token.
#
# RETURNS:
#	The current left bracket
#
# DESCRIPTION:
#	Returns the current left bracket token.

proc ::textutil::expander::Op_rb {name {newbracket ""}} {
    if {[string length $newbracket] != 0} {
        Set rb $newbracket
    }
    return [Get rb]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_setbrackets lbrack rbrack
#
# INPUTS:
#	lbrack		The new left bracket
#	rbrack		The new right bracket
#
# RETURNS:
#	nothing
#
# DESCRIPTION:
#	Sets the brackets as a pair.

proc ::textutil::expander::Op_setbrackets {name lbrack rbrack} {
    Set lb $lbrack
    Set rb $rbrack
    return
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_errmode ?newErrmode?
#
# INPUTS:
#	newErrmode		If given, the new error mode.
#
# RETURNS:
#	The current error mode
#
# DESCRIPTION:
#	Returns the current error mode.

proc ::textutil::expander::Op_errmode {name {newErrmode ""}} {
    if {[string length $newErrmode] != 0} {
        if {![Contains "macro nothing error fail" $newErrmode]} {
            error "$name errmode: Invalid error mode: $newErrmode"
        }

        Set errmode $newErrmode
    }
    return [Get errmode]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_evalcmd ?newEvalCmd?
#
# INPUTS:
#	newEvalCmd		If given, the new eval command.
#
# RETURNS:
#	The current eval command
#
# DESCRIPTION:
#	Returns the current eval command.  This is the command used to
#	evaluate macros; it defaults to "uplevel #0".

proc ::textutil::expander::Op_evalcmd {name {newEvalCmd ""}} {
    if {[string length $newEvalCmd] != 0} {
        Set evalcmd $newEvalCmd
    }
    return [Get evalcmd]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_textcmd ?newTextCmd?
#
# INPUTS:
#	newTextCmd		If given, the new text command.
#
# RETURNS:
#	The current text command
#
# DESCRIPTION:
#	Returns the current text command.  This is the command used to
#	process plain text. It defaults to {}, meaning identity.

proc ::textutil::expander::Op_textcmd {name args} {
    switch -exact [llength $args] {
	0 {}
	1 {Set textcmd [lindex $args 0]}
	default {
	    return -code error "wrong#args for textcmd: name ?newTextcmd?"
	}
    }
    return [Get textcmd]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_reset
#
# INPUTS:
#	none
#
# RETURNS:
#	nothing
#
# DESCRIPTION:
#	Resets all object values, as though it were brand new.

proc ::textutil::expander::Op_reset {name} {
    variable Info 

    if {[info exists Info($name-lb)]} {
        foreach elt [array names Info "$name-*"] {
            unset Info($elt)
        }
    }

    set Info($name-lb) "\["
    set Info($name-rb) "\]"
    set Info($name-errmode) "fail"
    set Info($name-evalcmd) "uplevel #0"
    set Info($name-textcmd) ""
    set Info($name-level) 0
    set Info($name-output-0) ""
    set Info($name-name-0) ":0"

    return
}

#-------------------------------------------------------------------------
# Context: Every expansion takes place in its own context; however, 
# a macro can push a new context, causing the text it returns and all
# subsequent text to be saved separately.  Later, a matching macro can
# pop the context, acquiring all text saved since the first command,
# and use that in its own output.

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_cpush cname
#
# INPUTS:
#	cname		The context name
#
# RETURNS:
#	nothing
#
# DESCRIPTION:
#       Pushes an empty macro context onto the stack.  All expanded text
#       will be added to this context until it is popped.

proc ::textutil::expander::Op_cpush {name cname} {
    # FRINK: nocheck
    incr [Var level]
    # FRINK: nocheck
    set [Var output-[Get level]] {}
    # FRINK: nocheck
    set [Var name-[Get level]] $cname
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_cis cname
#
# INPUTS:
#	cname		A context name
#
# RETURNS:
#	true or false
#
# DESCRIPTION:
#       Returns true if the current context has the specified name, and
#	false otherwise.

proc ::textutil::expander::Op_cis {name cname} {
    return [expr {[string compare $cname [Op_cname $name]] == 0}]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_cname
#
# INPUTS:
#	none
#
# RETURNS:
#	The context name
#
# DESCRIPTION:
#       Returns the name of the current context.

proc ::textutil::expander::Op_cname {name} {
    return [Get name-[Get level]]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_cset varname value
#
# INPUTS:
#	varname		The name of a context variable
#	value		The new value for the context variable
#
# RETURNS:
#	The value
#
# DESCRIPTION:
#       Sets a variable in the current context.

proc ::textutil::expander::Op_cset {name varname value} {
    Set data-[Get level]-$varname $value
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_cget varname
#
# INPUTS:
#	varname		The name of a context variable
#
# RETURNS:
#	The value
#
# DESCRIPTION:
#       Returns the value of a context variable.  It's an error if
#	the variable doesn't exist.

proc ::textutil::expander::Op_cget {name varname} {
    if {![info exists [Var data-[Get level]-$varname]]} {
        error "$name cget: $varname doesn't exist in this context ([Get level])"
    }
    return [Get data-[Get level]-$varname]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_cvar varname
#
# INPUTS:
#	varname		The name of a context variable
#
# RETURNS:
#	The index to the variable
#
# DESCRIPTION:
#       Returns the index to a context variable, for use with set, 
#	lappend, etc.

proc ::textutil::expander::Op_cvar {name varname} {
    if {![info exists [Var data-[Get level]-$varname]]} {
        error "$name cvar: $varname doesn't exist in this context"
    }

    return [Var data-[Get level]-$varname]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_cpop cname
#
# INPUTS:
#	cname		The expected context name.
#
# RETURNS:
#	The accumulated output in this context
#
# DESCRIPTION:
#       Returns the accumulated output for the current context, first
#	popping the context from the stack.  The expected context name
#	must match the real name, or an error occurs.

proc ::textutil::expander::Op_cpop {name cname} {
    variable Info

    if {[Get level] == 0} {
        error "$name cpop underflow on '$cname'"
    }

    if {[string compare [Op_cname $name] $cname] != 0} {
        error "$name cpop context mismatch: expected [Op_cname $name], got $cname"
    }

    set result [Get output-[Get level]]
    # FRINK: nocheck
    set [Var output-[Get level]] ""
    # FRINK: nocheck
    set [Var name-[Get level]] ""

    foreach elt [array names "Info data-[Get level]-*"] {
        unset Info($elt)
    }

    # FRINK: nocheck
    incr [Var level] -1
    return $result
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_ctopandclear
#
# INPUTS:
#	None.
#
# RETURNS:
#	The accumulated output in the topmost context, clears the context,
#	but does not pop it.
#
# DESCRIPTION:
#       Returns the accumulated output for the current context, first
#	popping the context from the stack.  The expected context name
#	must match the real name, or an error occurs.

proc ::textutil::expander::Op_ctopandclear {name} {
    variable Info

    if {[Get level] == 0} {
        error "$name cpop underflow on '[Op_cname $name]'"
    }

    set result [Get output-[Get level]]
    Set output-[Get level] ""
    return $result
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_cappend text
#
# INPUTS:
#	text		Text to add to the output
#
# RETURNS:
#	The accumulated output
#
# DESCRIPTION:
#       Appends the text to the accumulated output in the current context.

proc ::textutil::expander::Op_cappend {name text} {
    # FRINK: nocheck
    append [Var output-[Get level]] $text
}

#-------------------------------------------------------------------------
# Macro-expansion:  The following code is the heart of the module.
# Given a text string, and the current variable settings, this code
# returns an expanded string, with all macros replaced.

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_expand inputString ?brackets?
#
# INPUTS:
#	inputString		The text to expand.
#	brackets		A list of two bracket tokens.
#
# RETURNS:
#	The expanded text.
#
# DESCRIPTION:
#	Finds all embedded macros in the input string, and expands them.
#	If ?brackets? is given, it must be list of length 2, containing
#	replacement left and right macro brackets; otherwise the default
#	brackets are used.

proc ::textutil::expander::Op_expand {name inputString {brackets ""}} {
    # FIRST, push a new context onto the stack, and save the current
    # brackets.

    Op_cpush $name expand
    Op_cset $name lb [Get lb]
    Op_cset $name rb [Get rb]

    # Keep position information in context variables as well.
    # Line we are in, counting from 1; column we are at,
    # counting from 0, and index of character we are at,
    # counting from 0. Tabs counts as '1' when computing
    # the column.

    LocInit $name

    # SF Tcllib Bug #530056.
    set start_level [Get level] ; # remember this for check at end

    # NEXT, use the user's brackets, if given.
    if {[llength $brackets] == 2} {
        Set lb [lindex $brackets 0]
        Set rb [lindex $brackets 1]
    }

    # NEXT, loop over the string, finding and expanding macros.
    while {[string length $inputString] > 0} {
        set plainText [ExtractToToken inputString [Get lb] exclude]

        # FIRST, If there was plain text, append it to the output, and 
        # continue.
        if {$plainText != ""} {
	    set input $plainText
	    set tc [Get textcmd]
	    if {[string length $tc] > 0} {
		lappend tc $plainText

		if {![catch "[Get evalcmd] [list $tc]" result]} {
		    set plainText $result
		} else {
		    HandleError $name {plain text} $tc $result
		}
	    }
            Op_cappend $name $plainText
	    LocUpdate  $name $input

            if {[string length $inputString] == 0} {
                break
            }
        }

        # NEXT, A macro is the next thing; process it.
        if {[catch {GetMacro inputString} macro]} {
	    # SF tcllib bug 781973 ... Do not throw a regular
	    # error. Use HandleError to give the user control of the
	    # situation, via the defined error mode. The continue
	    # intercepts if the user allows the expansion to run on,
	    # yet we must not try to run the non-existing macro.

	    HandleError $name {reading macro} $inputString $macro
	    continue
        }

        # Expand the macro, and output the result, or
        # handle an error.
        if {![catch "[Get evalcmd] [list $macro]" result]} {
            Op_cappend $name $result 

	    # We have to advance the location by the length of the
	    # macro, plus the two brackets. They were stripped by
	    # GetMacro, so we have to add them here again to make
	    # computation correct.

	    LocUpdate $name [Get lb]${macro}[Get rb]
            continue
        } 

	HandleError $name macro $macro $result
    }

    # SF Tcllib Bug #530056.
    if {[Get level] > $start_level} {
	# The user macros pushed additional contexts, but forgot to
	# pop them all. The main work here is to place all the still
	# open contexts into the error message, and to produce
	# syntactically correct english.

	set c [list]
	set n [expr {[Get level] - $start_level}]
	if {$n == 1} {
	    set ctx  context
	    set verb was
	} else {
	    set ctx  contexts
	    set verb were
	}
	for {incr n -1} {$n >= 0} {incr n -1} {
	    lappend c [Get name-[expr {[Get level]-$n}]]
	}
	return -code error \
		"The following $ctx pushed by the macros $verb not popped: [join $c ,]."
    } elseif {[Get level] < $start_level} {
	set n [expr {$start_level - [Get level]}]
	if {$n == 1} {
	    set ctx  context
	} else {
	    set ctx  contexts
	}
	return -code error \
		"The macros popped $n more $ctx than they had pushed."
    }

    Op_lb $name [Op_cget $name lb]
    Op_rb $name [Op_cget $name rb]

    return [Op_cpop $name expand]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_where
#
# INPUTS:
#	None.
#
# RETURNS:
#	The current location in the input.
#
# DESCRIPTION:
#	Retrieves the current location the expander
#	is at during processing.

proc ::textutil::expander::Op_where {name} {
    return [LocGet $name]
}

#---------------------------------------------------------------------
# FUNCTION
#	HandleError name title command errmsg
#
# INPUTS:
#	name		The name of the expander object in question.
#	title		A title text
#	command		The command which caused the error.
#	errmsg		The error message to report
#
# RETURNS:
#	Nothing
#
# DESCRIPTIONS
#	Is executed when an error in a macro or the plain text handler
#	occurs. Generates an error message according to the current
#	error mode.

proc ::textutil::expander::HandleError {name title command errmsg} {
    switch [Get errmode] {
	nothing { }
	macro {
	    # The location is irrelevant here.
	    Op_cappend $name "[Get lb]$command[Get rb]" 
	}
	error {
	    foreach {ch line col} [LocGet $name] break
	    set display [DisplayOf $command]

	    Op_cappend $name "\n=================================\n"
	    Op_cappend $name "*** Error in $title at line $line, column $col:\n"
	    Op_cappend $name "*** [Get lb]$display[Get rb]\n--> $errmsg\n"
	    Op_cappend $name "=================================\n"
	}
	fail   { 
	    foreach {ch line col} [LocGet $name] break
	    set display [DisplayOf $command]

	    return -code error "Error in $title at line $line,\
		    column $col:\n[Get lb]$display[Get rb]\n-->\
		    $errmsg"
	}
	default {
	    return -code error "Unknown error mode: [Get errmode]"
	}
    }
}

#---------------------------------------------------------------------
# FUNCTION:
# 	ExtractToToken string token mode
#
# INPUTS:
#	string		The text to process.
#	token		The token to look for
#	mode		include or exclude
#
# RETURNS:
#	The extracted text
#
# DESCRIPTION:
# 	Extract text from a string, up to or including a particular
# 	token.  Remove the extracted text from the string.
# 	mode determines whether the found token is removed;
# 	it should be "include" or "exclude".  The string is
# 	modified in place, and the extracted text is returned.

proc ::textutil::expander::ExtractToToken {string token mode} {
    upvar $string theString

    # First, determine the offset
    switch $mode {
        include { set offset [expr {[string length $token] - 1}] }
        exclude { set offset -1 }
        default { error "::expander::ExtractToToken: unknown mode $mode" }
    }

    # Next, find the first occurrence of the token.
    set tokenPos [string first $token $theString]

    # Next, return the entire string if it wasn't found, or just
    # the part upto or including the character.
    if {$tokenPos == -1} {
        set theText $theString
        set theString ""
    } else {
        set newEnd    [expr {$tokenPos + $offset}]
        set newBegin  [expr {$newEnd + 1}]
        set theText   [string range $theString 0 $newEnd]
        set theString [string range $theString $newBegin end]
    }

    return $theText
}

#---------------------------------------------------------------------
# FUNCTION:
# 	GetMacro string
#
# INPUTS:
#	string		The text to process.
#
# RETURNS:
#	The macro, stripped of its brackets.
#
# DESCRIPTION:

proc ::textutil::expander::GetMacro {string} {
    upvar $string theString

    # FIRST, it's an error if the string doesn't begin with a
    # bracket.
    if {[string first [Get lb] $theString] != 0} {
        error "::expander::GetMacro: assertion failure, next text isn't a command! '$theString'"
    }

    # NEXT, extract a full macro
    set macro [ExtractToToken theString [Get lb] include]
    while {[string length $theString] > 0} {
        append macro [ExtractToToken theString [Get rb] include]

        # Verify that the command really ends with the [rb] characters,
        # whatever they are.  If not, break because of unexpected
        # end of file.
        if {![IsBracketed $macro]} {
            break;
        }

        set strippedMacro [StripBrackets $macro]

        if {[info complete "puts \[$strippedMacro\]"]} {
            return $strippedMacro
        }
    }

    if {[string length $macro] > 40} {
        set macro "[string range $macro 0 39]...\n"
    }
    error "Unexpected EOF in macro:\n$macro"
}

# Strip left and right bracket tokens from the ends of a macro,
# provided that it's properly bracketed.
proc ::textutil::expander::StripBrackets {macro} {
    set llen [string length [Get lb]]
    set rlen [string length [Get rb]]
    set tlen [string length $macro]

    return [string range $macro $llen [expr {$tlen - $rlen - 1}]]
}

# Return 1 if the macro is properly bracketed, and 0 otherwise.
proc ::textutil::expander::IsBracketed {macro} {
    set llen [string length [Get lb]]
    set rlen [string length [Get rb]]
    set tlen [string length $macro]

    set leftEnd  [string range $macro 0       [expr {$llen - 1}]]
    set rightEnd [string range $macro [expr {$tlen - $rlen}] end]

    if {$leftEnd != [Get lb]} {
        return 0
    } elseif {$rightEnd != [Get rb]} {
        return 0
    } else {
        return 1
    }
}

#---------------------------------------------------------------------
# FUNCTION:
# 	LocInit name
#
# INPUTS:
#	name		The expander object to use.
#
# RETURNS:
#	No result.
#
# DESCRIPTION:
#	A convenience wrapper around LocSet. Initializes the location
#	to the start of the input (char 0, line 1, column 0).

proc ::textutil::expander::LocInit {name} {
    LocSet $name {0 1 0}
    return
}

#---------------------------------------------------------------------
# FUNCTION:
# 	LocSet name loc
#
# INPUTS:
#	name		The expander object to use.
#	loc		Location, list containing character position,
#			line number and column, in this order.
#
# RETURNS:
#	No result.
#
# DESCRIPTION:
#	Sets the current location in the expander to 'loc'.

proc ::textutil::expander::LocSet {name loc} {
    foreach {ch line col} $loc break
    Op_cset  $name char $ch
    Op_cset  $name line $line
    Op_cset  $name col  $col
    return
}

#---------------------------------------------------------------------
# FUNCTION:
# 	LocGet name
#
# INPUTS:
#	name		The expander object to use.
#
# RETURNS:
#	A list containing the current character position, line number
#	and column, in this order.
#
# DESCRIPTION:
#	Returns the current location as stored in the expander.

proc ::textutil::expander::LocGet {name} {
    list [Op_cget $name char] [Op_cget $name line] [Op_cget $name col]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	LocUpdate name text
#
# INPUTS:
#	name		The expander object to use.
#	text		The text to process.
#
# RETURNS:
#	No result.
#
# DESCRIPTION:
#	Takes the current location as stored in the expander, computes
#	a new location based on the string (its length and contents
#	(number of lines)), and makes that new location the current
#	location.

proc ::textutil::expander::LocUpdate {name text} {
    foreach {ch line col} [LocGet $name] break
    set numchars [string length $text]
    #8.4+ set numlines [regexp -all "\n" $text]
    set numlines [expr {[llength [split $text \n]]-1}]

    incr ch   $numchars
    incr line $numlines
    if {$numlines} {
	set col [expr {$numchars - [string last \n $text] - 1}]
    } else {
	incr col $numchars
    }

    LocSet $name [list $ch $line $col]
    return
}

#---------------------------------------------------------------------
# FUNCTION:
# 	LocRange name text
#
# INPUTS:
#	name		The expander object to use.
#	text		The text to process.
#
# RETURNS:
#	A text range description, compatible with the 'location' data
#	used in the tcl debugger/checker.
#
# DESCRIPTION:
#	Takes the current location as stored in the expander object
#	and the length of the text to generate a character range.

proc ::textutil::expander::LocRange {name text} {
    # Note that the structure is compatible with
    # the ranges uses by tcl debugger and checker.
    # {line {charpos length}}

    foreach {ch line col} [LocGet $name] break
    return [list $line [list $ch [string length $text]]]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	DisplayOf text
#
# INPUTS:
#	text		The text to process.
#
# RETURNS:
#	The text, cut down to at most 30 bytes.
#
# DESCRIPTION:
#	Cuts the incoming text down to contain no more than 30
#	characters of the input. Adds an ellipsis (...) if characters
#	were actually removed from the input.

proc ::textutil::expander::DisplayOf {text} {
    set ellip ""
    while {[string bytelength $text] > 30} {
	set ellip ...
	set text [string range $text 0 end-1]
    }
    set display $text$ellip
}

#---------------------------------------------------------------------
# Provide the package only if the code above was read and executed
# without error.

package provide textutil::expander 1.3
# 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]} {
    # FRINK: nocheck
    return
}
package ifneeded textutil           0.6.2 [list source [file join $dir textutil.tcl]]
package ifneeded textutil::expander 1.3   [list source [file join $dir expander.tcl]]
namespace eval ::textutil {

    namespace eval split {

	namespace export splitx

	# This will be redefined later. We need it just to let
	# a chance for the next import subcommand to work
	#
	proc splitx [list str [list regexp "\[\t \r\n\]+"]] {}
    }

    namespace import -force split::splitx
    namespace export splitx

}

########################################################################
# This one was written by Bob Techentin (RWT in Tcl'ers Wiki):
# http://www.techentin.net
# mailto:techentin.robert@mayo.edu
#
# Later, he send me an email stated that I can use it anywhere, because
# no copyright was added, so the code is defacto in the public domain.
#
# You can found it in the Tcl'ers Wiki here:
# http://mini.net/cgi-bin/wikit/460.html
#
# Bob wrote:
# If you need to split string into list using some more complicated rule
# than builtin split command allows, use following function. It mimics
# Perl split operator which allows regexp as element separator, but,
# like builtin split, it expects string to split as first arg and regexp
# as second (optional) By default, it splits by any amount of whitespace. 
# Note that if you add parenthesis into regexp, parenthesed part of separator
# would be added into list as additional element. Just like in Perl. -- cary 
#
# Speed improvement by Reinhard Max:
# Instead of repeatedly copying around the not yet matched part of the
# string, I use [regexp]'s -start option to restrict the match to that
# part. This reduces the complexity from something like O(n^1.5) to
# O(n). My test case for that was:
# 
# foreach i {1 10 100 1000 10000} {
#     set s [string repeat x $i]
#     puts [time {splitx $s .}]
# }
#

if {[package vsatisfies [package provide Tcl] 8.3]} {

    proc ::textutil::split::splitx {str {regexp {[\t \r\n]+}}} {
        # Bugfix 476988
        if {[string length $str] == 0} {
            return {}
        }
        if {[string length $regexp] == 0} {
            return [::split $str ""]
        }
        set list  {}
        set start 0
        while {[regexp -start $start -indices -- $regexp $str match submatch]} {
            foreach {subStart subEnd} $submatch break
            foreach {matchStart matchEnd} $match break
            incr matchStart -1
            incr matchEnd
            lappend list [string range $str $start $matchStart]
            if {$subStart >= $start} {
                lappend list [string range $str $subStart $subEnd]
            }
            set start $matchEnd
        }
        lappend list [string range $str $start end]
        return $list
    }

} else {
    
    # For tcl <= 8.2 we do not have regexp -start...
    proc ::textutil::split::splitx [list str [list regexp "\[\t \r\n\]+"]] {

        if {[string length $str] == 0} {
            return {}
        }
        if {[string length $regexp] == 0} {
            return [::split $str {}]
        }

        set list  {}
        while {[regexp -indices -- $regexp $str match submatch]} {
            lappend list [string range $str 0 [expr {[lindex $match 0] -1}]]
            if {[lindex $submatch 0] >= 0} {
                lappend list [string range $str [lindex $submatch 0] \
                                  [lindex $submatch 1]]
            }
            set str [string range $str [expr {[lindex $match 1]+1}] end]
        }
        lappend list $str
        return $list
    }
    
}
#
# As the author of the procs 'tabify2' and 'untabify2' I suggest that the
# comments explaining their behaviour be kept in this file.
# 1) Beginners in any programming language (I am new to Tcl so I know what I
#    am talking about) can profit enormously from studying 'correct' code.
#    Of course comments will help a lot in this regard.
# 2) Many problems newbies face can be solved by directing them towards
#    available libraries - after all, libraries have been written to solve
#    recurring problems. Then they can just use them, or have a closer look
#    to see and to discover how things are done the 'Tcl way'.
# 3) And if ever a proc from a library should be less than perfect, having
#    comments explaining the behaviour of the code will surely help.
#
# This said, I will welcome any error reports or suggestions for improvements
# (especially on the 'doing things the Tcl way' aspect).
#
# Use of these sources is licensed under the same conditions as is Tcl.
#
# June 2001, Helmut Giese (hgiese@ratiosoft.com)
#
# ----------------------------------------------------------------------------
#
# The original procs 'tabify' and 'untabify' each work with complete blocks
# of $num spaces ('num' holding the tab size). While this is certainly useful
# in some circumstances, it does not reflect the way an editor works:
# 	Counting columns from 1, assuming a tab size of 8 and entering '12345'
#   followed by a tab, you expect to advance to column 9. Your editor might
#   put a tab into the file or 3 spaces, depending on its configuration.
#	Now, on 'tabifying' you will expect to see those 3 spaces converted to a
#	tab (and on the other hand expect the tab *at this position* to be
#	converted to 3 spaces).
#
#	This behaviour is mimicked by the new procs 'tabify2' and 'untabify2'.
#   Both have one feature in common: They accept multi-line strings (a whole
#   file if you want to) but in order to make life simpler for the programmer,
#   they split the incoming string into individual lines and hand each line to
#   a proc that does the real work.
#
#   One design decision worth mentioning here:
#      A single space is never converted to a tab even if its position would
#      allow to do so.
#   Single spaces occur very often, say in arithmetic expressions like
#   [expr (($a + $b) * $c) < $d]. If we didn't follow the above rule we might
#   need to replace one or more of them to tabs. However if the tab size gets
#   changed, this expression would be formatted quite differently - which is
#   probably not a good idea.
#
#   'untabifying' on the other hand might need to replace a tab with a single
#   space: If the current position requires it, what else to do?
#   As a consequence those two procs are unsymmetric in this aspect, but I
#   couldn't think of a better solution. Could you?
#
# ----------------------------------------------------------------------------
#

namespace eval ::textutil {

    namespace eval tabify {
	variable StrRepeat [ namespace parent ]::strRepeat
	variable TabLen  8
	variable TabStr  [ $StrRepeat " " $TabLen ]

	namespace export tabify untabify tabify2 untabify2

	# This will be redefined later. We need it just to let
	# a chance for the next import subcommand to work
	#
	proc tabify    { string { num 8 } } { }
	proc untabify  { string { num 8 } } { }
	proc tabify2   { string { num 8 } } { }
	proc untabify2 { string { num 8 } } { }

	# The proc 'untabify2' uses the following variables for efficiency.
	# Since a tab can be replaced by one up to 'tab size' spaces, it is handy
	# to have the appropriate 'space strings' available. This is the use of
	# the array 'Spaces', where 'Spaces(n)' contains just 'n' spaces.
	# The variable 'TabLen2' remembers the biggest tab size used.

	variable  TabLen2 0
	variable  Spaces
	array set Spaces {0 ""}
    }

    namespace import -force tabify::tabify tabify::untabify \
	    tabify::tabify2 tabify::untabify2
    namespace export tabify untabify tabify2 untabify2
}

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

proc ::textutil::tabify::tabify { string { num 8 } } {
    return [string map [list [MakeTabStr $num] \t] $string]
}

proc ::textutil::tabify::untabify { string { num 8 } } {
    return [string map [list \t [MakeTabStr $num]] $string]
}

proc ::textutil::tabify::MakeTabStr { num } {
    variable StrRepeat
    variable TabStr
    variable TabLen

    if { $TabLen != $num } then {
	set TabLen $num
	set TabStr [ $StrRepeat " " $num ]
    }

    return $TabStr
}

# ----------------------------------------------------------------------------
#
# tabifyLine: Works on a single line of text, replacing 'spaces at correct
# 		positions' with tabs. $num is the requested tab size.
#		Returns the (possibly modified) line.
#
# 'spaces at correct positions': Only spaces which 'fill the space' between
# an arbitrary position and the next tab stop can be replaced. 
# Example: With tab size 8, spaces at positions 11 - 13 will *not* be replaced,
#          because an expansion of a tab at position 11 will jump up to 16.
# See also the comment at the beginning of this file why single spaces are
# *never* replaced by a tab.
#
# The proc works backwards, from the end of the string up to the beginning:
#	- Set the position to start the search from ('lastPos') to 'end'.
#	- Find the last occurrence of ' ' in 'line' with respect to 'lastPos'
#         ('currPos' below). This is a candidate for replacement.
#       - Find to 'currPos' the following tab stop using the expression
#           set nextTab [expr ($currPos + $num) - ($currPos % $num)]
#         and get the previous tab stop as well (this will be the starting 
#         point for the next iteration).
#	- The ' ' at 'currPos' is only a candidate for replacement if
#	  1) it is just one position before a tab stop *and*
#	  2) there is at least one space at its left (see comment above on not
#	     touching an isolated space).
#	  Continue, if any of these conditions is not met.
#	- Determine where to put the tab (that is: how many spaces to replace?)
#	  by stepping up to the beginning until
#		-- you hit a non-space or
#		-- you are at the previous tab position
#	- Do the replacement and continue.
#
# This algorithm only works, if $line does not contain tabs. Otherwise our 
# interpretation of any position beyond the tab will be wrong. (Imagine you 
# find a ' ' at position 4 in $line. If you got 3 leading tabs, your *real*
# position might be 25 (tab size of 8). Since in real life some strings might 
# already contain tabs, we test for it (and eventually call untabifyLine).
#

proc ::textutil::tabify::tabifyLine { line num } {
    if { [string first \t $line] != -1 } { 		
	# assure array 'Spaces' is set up 'comme il faut'
	checkArr $num
	# remove existing tabs
	set line [untabifyLine $line $num]
    }

    set lastPos end

    while { $lastPos > 0 } {
	set currPos [string last " " $line $lastPos]
	if { $currPos == -1 } {
	    # no more spaces
	    break;
	}

	set nextTab [expr {($currPos + $num) - ($currPos % $num)}]
	set prevTab [expr {$nextTab - $num}]

	# prepare for next round: continue at 'previous tab stop - 1'
	set lastPos [expr {$prevTab - 1}]

	if { ($currPos + 1) != $nextTab } {
	    continue			;# crit. (1)
	}

	if { [string index $line [expr {$currPos - 1}]] != " " } {
	    continue			;# crit. (2)
	}

	# now step backwards while there are spaces
	for {set pos [expr {$currPos - 2}]} {$pos >= $prevTab} {incr pos -1} {
	    if { [string index $line $pos] != " " } {
		break;
	    }
	}

	# ... and replace them
	set line [string replace $line [expr {$pos + 1}] $currPos \t]
    }
    return $line
}

#
# Helper proc for 'untabifyLine': Checks if all needed elements of array
# 'Spaces' exist and creates the missing ones if needed.
#

proc ::textutil::tabify::checkArr { num } {
    variable TabLen2
    variable Spaces
    variable StrRepeat

    if { $num > $TabLen2 } {
	for { set i [expr {$TabLen2 + 1}] } { $i <= $num } { incr i } {
	    set Spaces($i) [$StrRepeat " " $i]
	}
	set TabLen2 $num
    }
}


# untabifyLine: Works on a single line of text, replacing tabs with enough
#		spaces to get to the next tab position.
#		Returns the (possibly modified) line.
#
# The procedure is straight forward:
#	- Find the next tab.
#	- Calculate the next tab position following it.
#	- Delete the tab and insert as many spaces as needed to get there.
#

proc ::textutil::tabify::untabifyLine { line num } {
    variable Spaces

    set currPos 0
    while { 1 } {
	set currPos [string first \t $line $currPos]
	if { $currPos == -1 } {
	    # no more tabs
	    break
	}

	# how far is the next tab position ?
	set dist [expr {$num - ($currPos % $num)}]
	# replace '\t' at $currPos with $dist spaces
	set line [string replace $line $currPos $currPos $Spaces($dist)]

	# set up for next round (not absolutely necessary but maybe a trifle
	# more efficient)
	incr currPos $dist
    }
    return $line
}

# tabify2: Replace all 'appropriate' spaces as discussed above with tabs.
#	'string' might hold any number of lines, 'num' is the requested tab size.
#	Returns (possibly modified) 'string'.
#
proc ::textutil::tabify::tabify2 { string { num 8 } } {

    # split string into individual lines
    set inLst [split $string \n]

    # now work on each line
    set outLst [list]
    foreach line $inLst {
	lappend outLst [tabifyLine $line $num]
    }

    # return all as one string
    return [join $outLst \n]
}


# untabify2: Replace all tabs with the appropriate number of spaces.
#	'string' might hold any number of lines, 'num' is the requested tab size.
#	Returns (possibly modified) 'string'.
#
proc ::textutil::tabify::untabify2 { string { num 8 } } {

    # assure array 'Spaces' is set up 'comme il faut'
    checkArr $num

    set inLst [split $string \n]

    set outLst [list]
    foreach line $inLst {
	lappend outLst [untabifyLine $line $num]
    }

    return [join $outLst \n]
}
package require Tcl 8.2

namespace eval ::textutil {
    namespace export strRepeat
    
    variable HaveStrRepeat [ expr {![ catch { string repeat a 1 } ]} ]

    if {0} {
	# Problems with the deactivated code:
	# - Linear in 'num'.
	# - Tests for 'string repeat' in every call!
	#   (Ok, just the variable, still a test every call)
	# - Fails for 'num == 0' because of undefined 'str'.

	proc StrRepeat { char num } {
	    variable HaveStrRepeat
	    if { $HaveStrRepeat == 0 } then {
		for { set i 0 } { $i < $num } { incr i } {
		    append str $char
		}
	    } else {
		set str [ string repeat $char $num ]
	    }
	    return $str
	}
    }

}

if {$::textutil::HaveStrRepeat} {
    proc ::textutil::strRepeat {char num} {
	return [string repeat $char $num]
    }

    proc ::textutil::blank {n} {
	return [string repeat " " $n]
    }

} else {
    proc ::textutil::strRepeat {char num} {
	if {$num <= 0} {
	    # No replication required
	    return ""
	} elseif {$num == 1} {
	    # Quick exit for recursion
	    return $char
	} elseif {$num == 2} {
	    # Another quick exit for recursion
	    return $char$char
	} elseif {0 == ($num % 2)} {
	    # Halving the problem results in O (log n) complexity.
	    set result [strRepeat $char [expr {$num / 2}]]
	    return "$result$result"
	} else {
	    # Uneven length, reduce problem by one
	    return "$char[strRepeat $char [incr num -1]]"
	}
    }

    proc ::textutil::blank {n} {
	return [strRepeat " " $n]
    }
}


# @c Removes the last character from the given <a string>.
#
# @a string: The string to manipulate.
#
# @r The <a string> without its last character.
#
# @i chopping

proc ::textutil::chop {string} {
    return [string range $string 0 [expr {[string length $string]-2}]]
}



# @c Removes the first character from the given <a string>.
# @c Convenience procedure.
#
# @a string: string to manipulate.
#
# @r The <a string> without its first character.
#
# @i tail

proc ::textutil::tail {string} {
    return [string range $string 1 end]
}



# @c Capitalizes first character of the given <a string>.
# @c Complementary procedure to <p ::textutil::uncap>.
#
# @a string: string to manipulate.
#
# @r The <a string> with its first character capitalized.
#
# @i capitalize

proc ::textutil::cap {string} {
    return [string toupper [string index $string 0]][string range $string 1 end]
}

# @c unCapitalizes first character of the given <a string>.
# @c Complementary procedure to <p ::textutil::cap>.
#
# @a string: string to manipulate.
#
# @r The <a string> with its first character uncapitalized.
#
# @i uncapitalize

proc ::textutil::uncap {string} {
    return [string tolower [string index $string 0]][string range $string 1 end]
}


# Compute the longest string which is common to all strings given to
# the command, and at the beginning of said strings, i.e. a prefix. If
# only one argument is specified it is treated as a list of the
# strings to look at. If more than one argument is specified these
# arguments are the strings to be looked at. If only one string is
# given, in either form, the string is returned, as it is its own
# longest common prefix.

proc ::textutil::longestCommonPrefix {args} {
    return [longestCommonPrefixList $args]
}

proc ::textutil::longestCommonPrefixList {list} {
    if {[llength $list] == 0} {
	return ""
    } elseif {[llength $list] == 1} {
	return [lindex $list 0]
    }

    set list [lsort  $list]
    set min  [lindex $list 0]
    set max  [lindex $list end]

    # Min and max are the two strings which are most different. If
    # they have a common prefix, it will also be the common prefix for
    # all of them.

    # Fast bailouts for common cases.

    set n [string length $min]
    if {$n == 0}                         {return ""}
    if {0 == [string compare $min $max]} {return $min}

    set prefix ""
    for {set i 0} {$i < $n} {incr i} {
	if {0 == [string compare [set x [string range $min 0 $i]] [string range $max 0 $i]]} {
	    set prefix $x
	    continue
	}
	break
    }
    return $prefix
}



source [ file join [ file dirname [ info script ] ] adjust.tcl ]
source [ file join [ file dirname [ info script ] ] split.tcl ]
source [ file join [ file dirname [ info script ] ] tabify.tcl ]
source [ file join [ file dirname [ info script ] ] trim.tcl ]

# Do the [package provide] last, in case there is an error in the code above.
package provide textutil 0.6.2
namespace eval ::textutil {
	
    namespace eval trim {
    
	variable StrU "\[ \t\]+"
	variable StrR "(${StrU})\$"
	variable StrL "^(${StrU})"

	namespace export trim trimright trimleft \
		trimPrefix trimEmptyHeading

	# This will be redefined later. We need it just to let
	# a chance for the next import subcommand to work
	#
	proc trimleft  { text { trim "[ \t]+" } } { }
	proc trimright { text { trim "[ \t]+" } } { }
	proc trim      { text { trim "[ \t]+" } } { }

	proc trimPrefix {text prefix} {}
	proc trimEmptyHeading {text} {}
    }

    namespace import -force trim::trim trim::trimleft trim::trimright trim::trimPrefix trim::trimEmptyHeading
    namespace export trim trimleft trimright trimPrefix trimEmptyHeading
}


proc ::textutil::trim::trimleft {text {trim "[ \t]+"}} {
    regsub -line -all -- [MakeStr $trim left] $text {} text
    return $text
}

proc ::textutil::trim::trimright {text {trim "[ \t]+"}} {
    regsub -line -all -- [MakeStr $trim right] $text {} text
    return $text
}

proc ::textutil::trim::trim {text {trim "[ \t]+"}} {
    regsub -line -all -- [MakeStr $trim left]  $text {} text
    regsub -line -all -- [MakeStr $trim right] $text {} text
    return $text
}

proc ::textutil::trim::MakeStr { string pos }  {
    variable StrU
    variable StrR
    variable StrL

    if { "$string" != "$StrU" } {
        set StrU $string
        set StrR "(${StrU})\$"
        set StrL "^(${StrU})"
    }
    if { "$pos" == "left" } {
        return $StrL
    }
    if { "$pos" == "right" } {
        return $StrR
    }

    return -code error "Panic, illegal position key \"$pos\""
}


# @c Strips <a prefix> from <a text>, if found at its start.
#
# @a text: The string to check for <a prefix>.
# @a prefix: The string to remove from <a text>.
#
# @r The <a text>, but without <a prefix>.
#
# @i remove, prefix

proc ::textutil::trim::trimPrefix {text prefix} {
    if {[string first $prefix $text] == 0} {
	return [string range $text [string length $prefix] end]
    } else {
	return $text
    }
}


# @c Removes the Heading Empty Lines of <a text>.
#
# @a text: The text block to manipulate.
#
# @r The <a text>, but without heading empty lines.
#
# @i remove, empty lines

proc ::textutil::trim::trimEmptyHeading {text} {
    regsub -- "^(\[ \t\]*\n)*" $text {} text
    return $text
}
% This is `dehypht.tex' as of 03 March 1999.
%
% Copyright (C) 1988,1991 Rechenzentrum der Ruhr-Universitaet Bochum
%               [german hyphen patterns]
% Copyright (C) 1993,1994,1999 Bernd Raichle/DANTE e.V.
%               [macros, adaption for TeX 2]
%
% -----------------------------------------------------------------
% IMPORTANT NOTICE:
%
% This program can be redistributed and/or modified under the terms
% of the LaTeX Project Public License Distributed from CTAN
% archives in directory macros/latex/base/lppl.txt; either
% version 1 of the License, or any later version.
% -----------------------------------------------------------------
%
%
% This file contains german hyphen patterns following traditional
% hyphenation rules and includes umlauts and sharp s, but without
% `c-k' and triple consonants.  It is based on hyphen patterns
% containing 5719 german hyphen patterns with umlauts in the
% recommended version of September 27, 1990.
%
% For use with TeX generated by
%
%          Norbert Schwarz
%          Rechenzentrum Ruhr-Universitaet Bochum
%          Universitaetsstrasse 150
%          D-44721 Bochum, FRG
%
%
% Adaption of these patterns for TeX, Version 2.x and 3.x and
% all fonts in T1/`Cork'/EC/DC and/or OT1/CM encoding by
%
%          Bernd Raichle
%          Stettener Str. 73
%          D-73732 Esslingen, FRG
%   Email: raichle@Informatik.Uni-Stuttgart.DE
%
%
% Error reports in case of UNCHANGED versions to
%
%          DANTE e.V., Koordinator `german.sty'
%          Postfach 10 18 40
%          D-69008 Heidelberg, FRG
%   Email: german@Dante.DE
%
% or one of the addresses given above.
%
%
% Changes:
%  1990-09-27 First version of `ghyphen3.tex' (Norbert Schwarz)
%  1991-02-13 PC umlauts changed to ^^xx  (Norbert Schwarz)
%  1993-08-27 Umlauts/\ss changed to "a/\3 macros, added macro
%             definitions and additional logic to select correct
%             patterns/encoding  (Bernd Raichle)
%  1994-02-13 Release of `ghyph31.tex' V3.1a (Bernd Raichle)
%  1999-03-03 Renamed file to `dehypht.tex' according to the
%             naming scheme using the ISO country code `de', the
%             common part `hyph' for all hyphenation patterns files,
%             and the additional postfix `t' for traditional,
%             removed wrong catcode change of ^^e (the comment
%             character %) and ^^f (the character &),
%             do _not_ change \catcode, \lccode, \uccode to avoid
%             problems with other hyphenation pattern files,
%             changed code to distinguish TeX 2.x/3.x,
%             changed license conditions to LPPL (Bernd Raichle)
%
%
% For more information see the additional documentation
% at the end of this file.
%
% -----------------------------------------------------------------
%
\message{German Traditional Hyphenation Patterns %
         `dehypht' Version 3.2a <1999/03/03>}
\message{(Formerly known under the name `ghyph31' and `ghyphen'.)}
%
%
% Next we define some commands which are used inside the patterns.
% To keep them local, we enclose the rest of the file in a group
% (The \patterns command globally changes the hyphenation trie!).
%
\begingroup
%
%
% Make sure that doublequote is not active:
\catcode`\"=12
%
%
% Because ^^e4 is used in the following macros which is read by
% TeX 2.x as ^^e or %, the comment character of TeX, some trick
% has to be found to avoid this problem.  The same is true for the
% character ^^f or & in the TeX 2.x code.
% Therefore in the code the exclamationmark ! is used instead of
% the circumflex ^ and its \catcode is set appropriately
% (normally \catcode`\!=12, in the code \catcode`\!=7).
%
% The following \catcode, \lccode assignments and macro definitions
% are defined in such a way that the following \pattern{...} list
% can be used for both, TeX 2.x and TeX 3.x.
%
% We first change the \lccode of ^^Y to make sure that we can
% include this character in the hyphenation patterns.
%
\catcode`\^^Y=11 \lccode`\^^Y=`\^^Y
%
% Then we have to define some macros depending on the TeX version.
% Therefore we have to distinguish TeX version 2.x and 3.x:
%
\ifnum`\@=`\^^40 % true => TeX 3.x
  %
  % For TeX 3:
  % ----------
  %
  % Assign appropriate \catcode and \lccode values for all
  % accented characters used in the patterns (\uccode changes are
  % not used within \patterns{...} and thus not necessary):
  %
  \catcode"E4=11 \catcode"C4=11 % \"a \"A
  \catcode"F6=11 \catcode"D6=11 % \"o \"O
  \catcode"FC=11 \catcode"DC=11 % \"u \"U
  \catcode"FF=11 \catcode"DF=11 % \ss  SS
  %
  \lccode"C4="E4 \uccode"C4="C4  \lccode"E4="E4 \uccode"E4="C4
  \lccode"D6="F6 \uccode"D6="D6  \lccode"F6="F6 \uccode"F6="D6
  \lccode"DC="FC \uccode"DC="DC  \lccode"FC="FC \uccode"FC="DC
  \lccode"DF="FF \uccode"DF="DF  \lccode"FF="FF \uccode"FF="DF
  %
  % In the following definitions we use ??xy instead of ^^xy
  % to avoid errors when reading the following macro definitions
  % with TeX 2.x (remember ^^e(4) is the comment character):
  %
  \catcode`\?=7
  %
  % Define the accent macro " in such a way that it
  % expands to single letters in font encoding T1.
  \catcode`\"=13
  \def"#1{\ifx#1a??e4\else \ifx#1o??f6\else \ifx#1u??fc\else
      \errmessage{Hyphenation pattern file corrupted!}%
    \fi\fi\fi}
  %
  %   - patterns with umlauts are ok
  \def\n#1{#1}
  %
  % For \ss which exists in T1 _and_ OT1 encoded fonts but with
  % different glyph codes, duplicated patterns for both encodings
  % are included.  Thus you can use these hyphenation patterns for
  % T1 and OT1 encoded fonts:
  %   - define \3 to be code `\^^ff (\ss in font encoding T1)
  %   - define \9 to be code `\^^Y  (\ss in font encoding OT1)
  \def\3{??ff}
  \def\9{??Y}
  %   - duplicated patterns to support font encoding OT1 are ok
  \def\c#1{#1}
  %   >>>>>>  UNCOMMENT the next line, if you do not want
  %   >>>>>>  to use fonts in font encoding OT1
  %\def\c#1{}
  %
  \catcode`\?=12
  %
\else
  %
  % For TeX 2:
  % ----------
  %
  % Define the accent macro " to throw an error message.
  \catcode`\"=13
  \def"#1{\errmessage{Hyphenation pattern file corrupted!}}
  %
  %   - ignore all patterns with umlauts
  \def\n#1{}
  %
  % With TeX 2 fonts in encoding T1 can be used, but all glyphs
  % in positions > 127 can not be used in hyphenation patterns.
  % Thus only patterns with glyphs in OT1 positions are included:
  %   - define \3 to be code ^^Y (\ss in CM font encoding)
  %   - define \9 to throw an error message
  \def\3{^^Y}
  \def\9{\errmessage{Hyphenation pattern file corrupted!}}
  %   - ignore all duplicated patterns with \ss in T1 encoding
  \def\c#1{}
  %
\fi
%
%
\patterns{%
.aa6l .ab3a4s .ab3ei .abi2 .ab3it .ab1l .ab1r .ab3u .ad3o4r .alti6
.ana3c .an5alg .an1e .ang8s .an1s .ap1p .ar6sc .ar6ta .ar6tei .as2z
.au2f1 .au2s3 .be5erb .be3na .ber6t5r .bie6r5 .bim6s5t .brot3 .bru6s
.ch6 .che6f5 .da8c .da2r .dar5in .dar5u .den6ka .de5r6en .des6pe
.de8spo .de3sz .dia3s4 .dien4 .dy2s1 .ehren5 .eine6 .ei6n5eh .ei8nen
.ein5sa .en6der .en6d5r .en3k4 .en8ta8 .en8tei .en4t3r .epo1 .er6ban
.er6b5ei .er6bla .er6d5um .er3ei .er5er .er3in .er3o4b .erwi5s .es1p
.es8t .ex1a2 .ex3em .fal6sc .fe6st5a .flu4g3 .furch8 .ga6ner .ge3n4a
\n{.ge5r"o} .ges6 .halb5 .halbe6 .hal6br .haup4 .hau4t .heima6 .he4r3e
.her6za .he5x .hin3 .hir8sc .ho4c .hu3sa .hy5o .ibe5 .ima6ge .in1
.ini6 .is5chi .jagd5 .kal6k5o .ka6ph .ki4e .kop6f3 .kraf6 \n{.k"u5ra}
.lab6br .liie6 .lo6s5k \n{.l"o4s3t} .ma5d .mi2t1 .no6th .no6top
.obe8ri .ob1l .obs2 .ob6st5e .or3c .ort6s5e .ost3a .oste8r .pe4re
.pe3ts .ph6 .po8str .rau4m3 .re5an .ro8q .ru5the \n{.r"u5be}
\n{.r"u8stet} .sch8 .se6e .se5n6h .se5ra .si2e .spi6ke .st4 .sy2n
.tages5 .tan6kl .ta8th .te6e .te8str .to6der .to8nin .to6we .um1
.umpf4 .un1 .une6 .unge5n .ur1c .ur5en .ve6rin .vora8 .wah6l5 .we8ges
.wo6r .wor3a .wun4s .zi4e .zuch8 \n{."ande8re} \n{."och8} aa1c aa2gr
aal5e aa6r5a a5arti aa2s1t aat2s 6aba ab3art 1abdr 6abel aben6dr
ab5erk ab5err ab5esse 1abf 1abg \n{1abh"a} ab1ir 1abko a1bl ab1la
5ablag a6bla\3 \c{a6bla\9} ab4ler ab1lu \n{a8bl"a} \n{5a6bl"o} abma5c
1abn ab1ra ab1re 5a6brec ab1ro ab1s ab8sk abs2z 3abtei ab1ur 1abw
5abze 5abzu \n{ab1"an} \n{ab"au8} a4ce.  a5chal ach5art ach5au a1che
a8chent ach6er.  a6ch5erf a1chi ach1l ach3m ach5n a1cho ach3re a1chu
ach1w a1chy \n{ach5"af} ack1o acks6t ack5sta a1d 8ad.  a6d5ac ad3ant
ad8ar 5addi a8dein ade5o8 adi5en 1adj 1adle ad1op a2dre 3adres adt1
1adv \n{a6d"a} a1e2d ae1r a1er.  1aero 8afa a3fal af1an a5far a5fat
af1au a6fentl a2f1ex af1fr af5rau af1re 1afri af6tent af6tra aft5re
a6f5um \n{8af"a} ag5abe 5a4gent ag8er ages5e 1aggr ag5las ag1lo a1gn
ag2ne 1agog a6g5und a1ha a1he ah5ein a4h3erh a1hi ahl1a ah1le ah4m3ar
ahn1a a5ho ahra6 ahr5ab ah1re ah8rei ahren8s ahre4s3 ahr8ti ah1ru a1hu
\n{ah8"o} ai3d2s ai1e aif6 a3inse ai4re.  a5isch.  ais8e a3ismu ais6n
aiso6 a1j 1akad a4kade a1ke a1ki 1akko 5akro1 a5lal al5ans 3al8arm
al8beb al8berw alb5la 3album al1c a1le a6l5e6be a4l3ein a8lel a8lerb
a8lerh a6lert 5a6l5eth 1algi al4gli al3int al4lab al8lan al4l3ar
alle3g a1lo a4l5ob al6schm al4the altist5 al4t3re 8a1lu alu5i a6lur
alu3ta \n{a1l"a} a6mate 8ame.  5a6meise am6m5ei am6mum am2n ampf3a
am6schw am2ta a1mu \n{a1m"a} a3nac a1nad anadi5e an3ako an3alp 3analy
an3ame an3ara a1nas an5asti a1nat anat5s an8dent ande4s3 an1ec an5eis
an1e2k 4aner.  a6n5erd a8nerf a6n5erke 1anfa 5anfert \n{1anf"a} 3angab
5angebo an3gli ang6lis an2gn 3angri ang5t6 \n{5anh"a} ani5g ani4ka
an5i8on an1kl an6kno an4kro 1anl anma5c anmar4 3annah anne4s3 a1no
5a6n1o2d 5a6n3oma 5a6nord 1anr an1sa 5anschl an4soz an1st 5anstal
an1s2z 5antenn an1th \n{5anw"a} a5ny an4z3ed 5anzeig 5anzieh 3anzug
\n{an1"a} \n{5an"as} \n{a1n"o} \n{an"o8d} a1os a1pa 3apfel a2ph1t
\n{aph5"a6} a1pi 8apl apo1c apo1s a6poste a6poth 1appa ap1pr a1pr
\n{a5p"a} \n{a3p"u} a1ra a4r3af ar3all 3arbei 2arbt ar1c 2a1re ar3ein
ar2gl 2a1ri ari5es ar8kers ar6les ar4nan ar5o6ch ar1o2d a1rol ar3ony
a8ror a3ros ar5ox ar6schl 8artei ar6t5ri a1ru a1ry 1arzt arz1w
\n{ar8z"a} \n{ar"a8m} \n{ar"o6} \n{ar5"om} \n{ar1"u2} a1sa a6schec
asch5l asch3m a6schn a3s4hi as1pa asp5l a8steb as5tev 1asth a6stoc
a1str ast3re 8a1ta ata5c ata3la a6tapf ata5pl a1te a6teli aten5a
ate5ran 6atf 6atg a1th at3hal 1athl 2a1ti 5atlant 3atlas 8atmus 6atn
a1to a6t5ops ato6ra a6t5ort.  4a1tr a6t5ru at2t1h \n{at5t6h"a} 6a1tu
atz1w \n{a1t"a} \n{a1t"u} au1a au6bre auch3a au1e aue4l 5aufent
\n{3auff"u} 3aufga 1aufn auf1t 3auftr 1aufw 3auge.  au4kle aule8s 6aum
au8mar aum5p 1ausb 3ausd 1ausf 1ausg au8sin 3auss au4sta 1ausw 1ausz
aut5eng au1th 1auto au\3e8 \c{au\9e8} a1v ave5r6a aver6i a1w a6wes a1x
a2xia a6xio a1ya a1z azi5er.  8a\3 \c{8a\9} 1ba 8ba8del ba1la ba1na
ban6k5r ba5ot bardi6n ba1ro basten6 bau3sp 2b1b bb6le b2bli 2b1c 2b1d
1be be1a be8at.  be1ch 8becht 8becke.  be5el be1en bee8rei be5eta bef2
8beff be1g2 \n{beh"o8} bei1s 6b5eisen bei3tr b8el bel8o belu3t be3nac
bend6o be6ners be6nerw be4nor ben4se6 bens5el \n{be1n"a} \n{be1n"u}
be1o2 b8er.  be1ra be8rac ber8gab.  ber1r \n{be1r"u} bes8c bes5erh
bes2p be5tha bet5sc be1un be1ur 8bex be6zwec 2b1f8 bfe6st5e 2b1g2
bga2s5 bge1 2b1h bhole6 1bi bi1bl b6ie bi1el bi1la \n{bil"a5} bi1na
bi4nok bi5str bi6stu bi5tr bit4t5r b1j 2b1k2 \n{bk"u6} bl8 b6la.
6b1lad 6blag 8blam 1blat b8latt 3blau.  b6lav 3ble.  b1leb b1led
8b1leg 8b1leh 8bleid 8bleih 6b3lein blei3s ble4m3o 4blich b4lind
8bling b2lio 5blit b4litz b1loh 8b1los 1blu 5blum 2blun blut3a blut5sc
\n{3bl"a} \n{bl"as5c} \n{5bl"o} \n{3bl"u} \n{bl"u8sc} 2b1m 2b1n 1bo
bo1ch bo5d6s boe5 8boff 8bonk bo1ra b1ort 2b1p2 b1q 1br brail6 brast8
bre4a b5red 8bref 8b5riem b6riga bro1s b1rup b2ruz \n{8br"oh}
\n{br"os5c} 8bs b1sa b8sang b2s1ar b1sc bs3erl bs3erz b8sof b1s2p
bst1h b3stru \n{b5st"a} b6sun 2b1t b2t1h 1bu bu1ie bul6k b8ure bu6sin
6b1v 2b1w 1by1 by6te.  8b1z bzi1s \n{1b"a} \n{b5"a6s5} \n{1b"u}
\n{b6"u5bere} \n{b"uge6} \n{b"ugel5e} \n{b"ur6sc} 1ca cag6 ca5la ca6re
ca5y c1c 1ce celi4c celich5 ce1ro c8h 2ch.  1chae ch1ah ch3akt cha6mer
8chanz 5chara 3chari 5chato 6chb 1chef 6chei ch3eil ch3eis 6cherkl
6chf 4chh 5chiad 5chias 6chins 8chj chl6 5chlor 6ch2m 2chn6 ch8nie
5cho.  8chob choi8d 6chp ch3ren ch6res \n{ch3r"u} 2chs 2cht cht5ha
cht3hi 5chthon ch6tin 6chuh chu4la 6ch3unt chut6t 8chw 1ci ci5tr c2k
2ck.  ck1ei 4ckh ck3l ck3n ck5o8f ck1r 2cks ck5stra ck6s5u c2l 1c8o
con6ne 8corb cos6t c3q 1c6r 8c1t 1cu 1cy \n{5c"a1} \n{c"o5} 1da.
8daas 2dabg 8dabr 6dabt 6dabw 1dac da2gr 6d5alk 8d5amt dan6ce.
dani5er dan8ker 2danl danla6 6dans 8danzi 6danzu d1ap da2r1a8 2d1arb
d3arc dar6men 4d3art 8darz 1dat 8datm 2d1auf 2d1aus 2d1b 2d1c 2d1d
d5de d3d2h \n{dd"amme8} 1de 2deal de5an de3cha de1e defe6 6deff 2d1ehr
5d4eic de5isc de8lar del6s5e del6spr de4mag de8mun de8nep dene6r
8denge.  8dengen de5o6d 2deol de5ram 8derdb der5ein de1ro der1r d8ers
der5um de4s3am de4s3an de4sau de6sil de4sin de8sor de4spr de2su 8deul
de5us.  2d1f df2l 2d1g 2d1h 1di dia5c di5ara dice5 di3chr di5ena di1gn
di1la dil8s di1na 8dind 6dinf 4d3inh 2d1ins di5o6d di3p4t di8sen dis1p
di5s8per di6s5to dis5tra di8tan di8tin d1j 6dje 2dju 2d1k 2d1l 2d1m
2d1n6 dni6 dnje6 1do 6d5obe do6berf 6d5ony do3ran 6dord 2d1org dor4t3h
do6ste 6doth dott8e 2d1p d5q dr4 1drah 8drak d5rand 6dre.  4drech
d6reck 4d3reg 8d3reic d5reife 8drem 8d1ren 2drer 8dres.  6d5rh 1dria
d1ric 8drind droi6 dro5x 1dru 8drut \n{dr"os5c} \n{1dr"u} \n{dr"u5b}
\n{dr"u8sc} 2ds d1sa d6san dsat6 d1sc 5d6scha.  5dschik dse8e d8serg
8dsl d1sp d4spak ds2po \n{d8sp"a} d1st \n{d1s"u} 2dt d1ta d1te d1ti
d1to dt1s6 d1tu \n{d5t"a} 1du du5als du1b6 du1e duf4t3r 4d3uh du5ie
8duml 8dumw 2d1und du8ni 6d5unt dur2c durch3 6durl 6dursa 8durt du1s
du8schr 2d1v 2d1w dwa8l 2d1z \n{1d"a} \n{6d"ah} \n{8d"and} \n{d"a6r}
\n{d"o8bl} \n{d5"ol} \n{d"or6fl} \n{d"o8sc} \n{d5"o4st} \n{d"os3te}
\n{1d"u} ea4ben e1ac e1ah e1akt e1al.  e5alf e1alg e5a8lin e1alk e1all
e5alp e1alt e5alw e1am e1and ea6nim e1ar.  e5arf e1ark e5arm e3art
e5at.  e6ate e6a5t6l e8ats e5att e6au.  e1aus e1b e6b5am ebens5e
eb4lie eb4ser eb4s3in e1che e8cherz e1chi ech3m 8ech3n ech1r ech8send
ech4su e1chu eck5an e5cl e1d ee5a ee3e ee5g e1ei ee5isc eei4s3t
ee6lend e1ell \n{ee5l"o} e1erd ee3r4e ee8reng eere6s5 \n{ee5r"a}
ee6tat e1ex e1f e6fau e8fe8b 3effek ef3rom ege6ra eglo6si 1egy e1ha
e6h5ach eh5ans e6hap eh5auf e1he e1hi ehl3a eh1le ehl5ein eh1mu ehn5ec
e1ho ehr1a eh1re ehre6n eh1ri eh1ru ehr5um e1hu eh1w e1hy \n{e1h"a}
\n{e1h"o} \n{e3h"ut} ei1a eia6s ei6bar eich3a eich5r ei4dar ei6d5ei
ei8derf ei3d4sc ei1e 8eifen 3eifri 1eign eil1d ei6mab ei8mag ein1a4
ei8nat ei8nerh ei8ness ei6nete ein1g e8ini ein1k ei6n5od ei8nok ei4nor
\n{e3ins"a} ei1o e1irr ei5ru ei8sab ei5schn ei6s5ent ei8sol ei4t3al
eit3ar eit1h ei6thi ei8tho eit8samt ei6t5um e1j 1ekd e1ke e1ki e1k2l
e1kn ekni4 e1la e2l1al 6elan e6lanf e8lanl e6l5ans el3arb el3arm
e6l3art 5e6lasti e6lauge elbst5a e1le 6elef ele6h e6l5ehe e8leif
e6l5einh 1elek e8lel 3eleme e6lemen e6lente el5epi e4l3err e6l5ersc
elf2l elg2 e6l5ins ell8er 4e1lo e4l3ofe el8soh el8tent 5eltern e1lu
elut2 \n{e1l"a} \n{e1l"u} em8dei em8meis 4emo emo5s 1emp1f 1empt 1emto
e1mu emurk4 emurks5 \n{e1m"a} en5a6ben en5achs en5ack e1nad en5af
en5all en3alt en1am en3an.  en3ant en3anz en1a6p en1ar en1a6s 6e1nat
en3auf en3aus en2ce enda6l end5erf end5erg en8dess 4ene.  en5eck
e8neff e6n5ehr e6n5eim en3eis 6enem.  6enen e4nent 4ener.  e8nerd
e6n3erf e4nerg 5energi e6n5erla en5ers e6nerst en5erw 6enes e6n5ess
e2nex en3glo 2eni enni6s5 ennos4 enns8 e1no e6nober eno8f en5opf
e4n3ord en8sers ens8kl en1sp ens6por en5t6ag enta5go en8terbu en6tid
3entla ent5ric 5entwic 5entwu 1entz enu5i e3ny en8zan \n{en1"of}
\n{e1n"os} \n{e1n"ug} eo1c e5o6fe e5okk e1on.  e3onf e5onk e5onl e5onr
e5opf e5ops e5or.  e1ord e1org eo5r6h eo1t e1pa e8pee e6p5e6g ep5ent
e1p2f e1pi 5epid e6pidem e1pl 5epos e6pos.  ep4p3a e1pr \n{e1p"a} e1q
e1ra.  er5aal 8eraba e5rabel er5a6ben e5rabi er3abs er3ach era5e
era5k6l er3all er3amt e3rand e3rane er3ans e5ranz.  e1rap er3arc
e3rari er3a6si e1rat erat3s er3auf e3raum 3erbse er1c e1re 4e5re.
er3eck er5egg er5e2h 2erei e3rei.  e8reine er5einr 6eren.  e4r3enm
4erer.  e6r5erm er5ero er5erst e4r3erz er3ess \n{5erf"ul} er8gan.
5ergebn er2g5h \n{5erg"anz} \n{5erh"ohu} 2e1ri eri5ak e6r5iat e4r3ind
e6r5i6n5i6 er5ins e6r5int er5itio er1kl \n{3erkl"a} \n{5erl"os.}
ermen6s er6nab 3ernst 6e1ro.  e1rod er1o2f e1rog 6e3roi ero8ide e3rol
e1rom e1ron e3rop8 e2r1or e1ros e1rot er5ox ersch4 5erstat er6t5ein
er2t1h er5t6her 2e1ru eruf4s3 e4r3uhr er3ums e5rus 5erwerb e1ry er5zwa
er3zwu \n{er"a8m} \n{er5"as} \n{er"o8} \n{e3r"os.} \n{e6r1"u2b} e1sa
esa8b e8sap e6s5a6v e1sc esch4l ese1a es5ebe eserve5 e8sh es5ill
es3int es4kop e2sl eso8b e1sp espei6s5 es2po es2pu 5essenz e6stabs
e6staf e6st5ak est3ar e8stob e1str est5res es3ur e2sz \n{e1s"u} e1ta
et8ag etari5e eta8ta e1te eten6te et5hal e5thel e1ti 1etn e1to e1tr
et3rec e8tscha et8se et6tei et2th et2t1r e1tu etu1s et8zent et8zw
\n{e1t"a} \n{e1t"o} \n{e1t"u} eu1a2 eu1e eue8rei eu5fe euin5 euk2
e1um.  eu6nio e5unter eu1o6 eu5p 3europ eu1sp eu5str eu8zo e1v eval6s
eve5r6en ever4i e1w e2wig ex1or 1exp 1extr ey3er.  e1z \n{e1"a2}
\n{e5"o8} \n{e1"u} e8\3es \c{e8\9es} fa6ch5i fade8 fa6del fa5el.
fal6lo falt8e fa1na fan4gr 6fanl 6fap far6ba far4bl far6r5a 2f1art
fa1sc fau8str fa3y 2f1b2 6f1c 2f1d 1fe 2f1eck fe6dr feh6lei f6eim
8feins f5eis fel5en 8feltern 8femp fe5rant 4ferd.  ferri8 fe8stof
fe6str fe6stum fe8tag fet6ta fex1 2ff f1fa f6f5arm f5fe ffe5in ffe6la
ffe8ler ff1f f1fla ff3lei ff4lie ff8sa ff6s5ta 2f1g2 fgewen6 4f1h 1fi
fid4 fi3ds fieb4 fi1la fi8lei fil4m5a f8in.  fi1na 8finf fi8scho fi6u
6f1j 2f1k2 f8lanz fl8e 4f3lein 8flib 4fling f2lix 6f3lon 5flop 1flor
\n{5f8l"ac} \n{3fl"ot} 2f1m 2f1n 1fo foh1 f2on fo6na 2f1op fo5ra
for8mei for8str for8th for6t5r fo5ru 6f5otte 2f1p8 f1q fr6 f5ram
1f8ran f8ra\3 \c{f8ra\9} f8re.  frei1 5frei.  f3reic f3rest f1rib
8f1ric 6frig 1fris fro8na \n{fr"as5t} 2fs f1sc f2s1er f5str
\n{fs3t"at} 2ft f1tak f1te ft5e6h ftere6 ft1h f1ti f5to f1tr ft5rad
ft1sc ft2so f1tu ftwi3d4 ft1z 1fu 6f5ums 6funf fun4ka fu8\3end
\c{fu8\9end} 6f1v 2f1w 2f1z \n{1f"a} \n{f"a1c} \n{8f"arm} \n{6f"aug}
\n{f"a8\3} \n{\c{f"a8\9}} \n{f"ode3} \n{8f"of} \n{3f"or} \n{1f"u}
\n{f"un4f3u} 1ga ga6bl 6gabw 8gabz g3a4der ga8ho ga5isc 4gak ga1la
6g5amt ga1na gan5erb gan6g5a ga5nj 6ganl 8gansc 6garb 2g1arc 2g1arm
ga5ro 6g3arti ga8sa ga8sc ga6stre 2g1atm 6g5auf gau5fr g5aus 2g1b g5c
6gd g1da 1ge ge1a2 ge6an ge8at.  ge1e2 ge6es gef2 8geff ge1g2l ge1im
4g3eise geist5r gel8bra gelt8s \n{ge5l"o} ge8nin gen3k 6g5entf
\n{ge3n"a} ge1or ge1ra ge6rab ger8au \n{8gerh"o} ger8ins ge1ro 6g5erz.
\n{ge1r"a} \n{ge1r"u} ge1s ges2p ge5unt 4g3ex3 2g1f8 2g1g g1ha 6g1hei
5ghel.  g5henn 6g1hi g1ho 1ghr \n{g1h"o} 1gi gi5la gi8me.  gi1na
4g3ins gi3str g1j 2g1k 8gl.  1glad g5lag glan4z3 1glas 6glass 5glaub
g3lauf 1gle.  g5leb 3gleic g3lein 5gleis 1glem 2gler 8g3leu gli8a
g2lie 3glied 1g2lik 1g2lim g6lio 1gloa 5glom 1glon 1glop g1los g4loss
g5luf 1g2ly \n{1gl"u} 2g1m gn8 6gn.  1gna 8gnach 2gnah g1nas g8neu
g2nie g3nis 1gno 8gnot 1go goe1 8gof 2gog 5gogr 6g5oh goni5e 6gonist
go1ra 8gord 2g1p2 g1q 1gr4 g5rahm gra8m gra4s3t 6g1rec gre6ge 4g3reic
g5reit 8grenn gri4e g5riem 5grif 2grig g5ring 6groh 2grot gro6\3
\c{gro6\9} 4grut 2gs gs1ab g5sah gs1ak gs1an gs8and gs1ar gs1au g1sc
gs1ef g5seil gs5ein g2s1er gs1in g2s1o gso2r gs1pr g2s1u 2g1t g3te
g2t1h 1gu gu5as gu2e 2gue.  6gued 4g3uh 8gums 6g5unt gu1s gut3h gu2tu
4g1v 2g1w gy1n g1z \n{1g"a} \n{8g"a8m} \n{6g"arm} \n{1g"o} \n{1g"u}
\n{6g"ub} 1haa hab8r ha8del hade4n 8hae ha5el.  haf6tr 2hal.  ha1la
hal4b5a 6hale 8han.  ha1na han6dr han6ge.  2hani h5anth 6hanz 6harb
h3arbe h3arme ha5ro ha2t1h h1atm hau6san ha8\3 \c{ha8\9} h1b2 h1c h1d
he2bl he3cho h3echt he5d6s 5heft h5e6he.  hei8ds h1eif 2hein he3ism
he5ist.  heit8s3 hek6ta hel8lau 8helt he6mer 1hemm 6h1emp hen5end
hen5klo hen6tri he2nu 8heo he8q her3ab he5rak her3an 4herap her3au
h3erbi he1ro he8ro8b he4r3um her6z5er he4spe he1st heta6 het5am he5th
heu3sc he1xa hey5e h1f2 h1g hgol8 h1h h1iat hie6r5i hi5kt hil1a2
hil4fr hi5nak hin4ta hi2nu hi5ob hirn5e hir6ner hi1sp hi1th hi5tr
5hitz h1j h6jo h1k2 hlabb4 hla4ga hla6gr h5lai hl8am h1las h1la\3
\c{h1la\9} hl1c h1led h3lein h5ler.  h2lif h2lim h8linf hl5int h2lip
h2lit h4lor h3lose \n{h1l"as} hme5e h2nee h2nei hn3eig h2nel hne8n
hne4p3f hn8erz h6netz h2nip h2nit h1nol hn5sp h2nuc h2nud h2nul hoch1
1hoh hoh8lei 2hoi ho4l3ar 1holz h2on ho1ra 6horg 5horn.  ho3sl hos1p
ho4spi h1p hpi6 h1q 6hr h1rai h8rank h5raum hr1c hrcre8 h1red h3reg
h8rei.  h4r3erb h8rert hrg2 h1ric hr5ins h2rom hr6t5erl hr2t1h hr6t5ra
hr8tri h6rum hr1z hs3ach h6s5amt h1sc h6s5ec h6s5erl hs8erle h4sob
h1sp h8spa\3 \c{h8spa\9} h8spel hs6po h4spun h1str h4s3tum hs3und
\n{h1s"u} h5ta.  h5tab ht3ac ht1ak ht3ang h5tanz ht1ar ht1at h5taub
h1te h2t1ec ht3eff ht3ehe h4t3eif h8teim h4t3ein ht3eis h6temp h8tentf
hte8ren \n{h6terf"u} h8tergr h4t3erh h6t5ersc h8terst h8tese h8tess
h2t1eu h4t3ex ht1he ht5hu h1ti ht5rak hts3ah ht1sc ht6sex ht8sk ht8so
h1tu htz8 \n{h5t"um} hub5l hu6b5r huh1l h5uhr.  huld5a6 hu8lent
\n{hu8l"a} h5up.  h1v h5weib h3weis h1z \n{h"a8kl} \n{h"al8s}
\n{h"ama8tu8} \n{h"a8sche.} \n{h"at1s} \n{h"au4s3c} \n{2h"o.}
\n{2h"oe} \n{8h"oi} \n{h"o6s} \n{h"os5c} \n{h"uhne6} \n{h"ul4s3t}
\n{h"utte8re} i5adn i1af i5ak.  i1al.  i1al1a i1alb i1ald i5alei i1alf
i1alg i3alh i1alk i1all i1alp i1alr i1als i1alt i1alv i5alw i3alz
i1an.  ia5na i3and ian8e ia8ne8b i1ang i3ank i5ann i1ant i1anz i6apo
i1ar.  ia6rab i5arr i1as.  i1asm i1ass i5ast.  i1at.  i5ats i1au i5azz
i6b5eig i6b5eis ib2le i4blis i6brig i6b5unt \n{i6b"ub} i1che ich5ei
i6cherb i1chi ich5ins ich1l ich3m ich1n i1cho icht5an icht3r i1chu
ich1w ick6s5te ic5l i1d id3arm 3ideal ide8na 3ideol \n{ide5r"o} i6diot
id5rec id1t ie1a ie6b5ar iebe4s3 ie2bl ieb1r ie8bra ie4bre \n{ie8b"a}
ie2dr ie1e8 ie6f5ad ief5f ie2f1l ie4fro ief1t i1ei ie4l3ec ie8lei
ie4lek i3ell i1en.  i1end ien6e i3enf i5enn ien6ne.  i1enp i1enr
i5ensa ien8stal i5env i1enz ie5o ier3a4b ie4rap i2ere ie4rec ie6r5ein
ie6r5eis ier8er i3ern.  ie8rum ie8rund ie6s5che ie6tau ie8tert ie5the
ie6t5ri i1ett ie5un iex5 2if i1fa if5ang i6fau if1fr if5lac i5f6lie
i1fre ift5a if6t5r ig3art 2ige i8gess ig5he i5gla ig2ni i5go ig3rot
ig3s2p i1ha i8ham i8hans i1he i1hi ih1n ih1r i1hu i8hum ih1w 8i1i ii2s
ii2t i1j i1k i6kak i8kerz i6kes ik4ler i6k5unt 2il i5lac i1lag il3ans
i5las i1lau il6auf i1le ile8h i8lel il2fl il3ipp il6l5enn i1lo ilt8e
i1lu \n{i1l"a} i8mart imb2 i8mele i8mid imme6l5a i1mu \n{i1m"a}
\n{i5m"o} ina5he i1nat in1au inau8s 8ind.  in4d3an 5index ind2r 3indus
i5nec i2n1ei i8nerw 3infek 1info 5ingeni ing5s6o 5inhab ini5er.  5inj
\n{in8k"at} in8nan i1no inoi8d in3o4ku in5sau in1sp 5inspe 5instit
5instru ins4ze 5intere 5interv in3the in5t2r i5ny \n{in"a2} \n{i1n"ar}
\n{in1"as} \n{in"o8} \n{in5"od} \n{i1n"os} 2io io1a8 io1c iode4 io2di
ioi8 i1ol.  i1om.  i1on.  i5onb ion2s1 i1ont i5ops i5o8pt i1or.
i3oral io3rat i5orc i1os.  i1ot.  i1o8x 2ip i1pa i1pi i1p2l i1pr i1q
i1ra ir6bl i1re i1ri ir8me8d ir2m1o2 ir8nak i1ro ir5rho ir6schl
ir6sch5r i5rus i5ry \n{i5r"a} i1sa i8samt i6sar i2s1au i8scheh i8schei
isch5m isch3r \n{isch"a8} is8ele ise3ra i4s3erh is3err isi6de i8sind
is4kop ison5e is6por i8s5tum i5sty \n{i5s"o} i1ta it5ab.  i2t1a2m
i8tax i1te i8tersc i1thi i1tho i5thr \n{it8h"a} i1ti i8ti8d iti6kl
itmen4 i1to i8tof it3ran it3rau i1tri itri5o it1sc it2se it5spa it8tru
i1tu it6z5erg it6z1w \n{i1t"a} \n{it"a6r5e} \n{it"at2} \n{it"ats5}
\n{i1t"u} i1u iu6r 2i1v i6vad iva8tin i8vei i6v5ene i8verh i2vob i8vur
i1w iwi2 i5xa i1xe i1z ize8n i8zir i6z5w \n{i"a8m} \n{i1"a6r}
\n{i5"at.} \n{i5"av} \n{i1"o8} \n{i"u8} i6\35ers \c{i6\95ers} ja5la
je2t3r 6jm 5jo jo5as jo1ra jou6l ju5cha jugen4 jugend5 jung5s6 ju1s
\n{3j"a} 1ka 8kachs 8kakz ka1la kal5d kam5t ka1na 2kanl 8kapf ka6pl
ka5r6a 6k3arbe ka1ro kar6p5f 4k3arti 8karz \n{ka1r"a} kasi5e ka6teb
kat8ta kauf6s kau3t2 2k1b 2k1c 4k1d kehr6s kehrs5a 8keic 2k1eig 6k5ein
6k5eis ke6lar ke8leis ke8lo 8kemp k5ente.  k3entf 8k5ents 6kentz ke1ra
k5erlau 2k1f8 2k1g 2k1h ki5fl 8kik king6s5 6kinh ki5os ki5sp ki5th
\n{8ki8"o} 2k1k2 kl8 1kla 8klac k5lager kle4br k3leib 3kleid kle5isc
4k3leit k3lek 6k5ler.  5klet 2klic 8klig k2lim k2lin 5klip 5klop k3lor
\n{1kl"a} 2k1m kmani5e kn8 6kner k2ni \n{kn"a8} 1k2o ko1a2 ko6de.
ko1i koi8t ko6min ko1op ko1or ko6pht ko3ra kor6d5er ko5ru ko5t6sc k3ou
3kow 6k5ox 2k1p2 k1q 1kr8 4k3rad 2k1rec 4k3reic kre5ie 2krib 6krig
2krip 6kroba 2ks k1sa k6sab ksal8s k8samt k6san k1sc k2s1ex k5spat
k5spe k8spil ks6por k1spr kst8 k2s1uf 2k1t kta8l kt5a6re k8tein kte8re
k2t1h k8tinf kt3rec kt1s 1ku ku1ch kuck8 k3uhr ku5ie kum2s1 kunfts5
kun2s kunst3 ku8rau ku4ro kurz1 ku1st 4kusti ku1ta ku8\3 \c{ku8\9}
6k1v 2k1w ky5n 2k1z \n{1k"a} \n{k"a4m} \n{4k3"ami} \n{k"ase5} \n{1k"o}
\n{k"o1c} \n{k"o1s} \n{1k"u} \n{k"u1c} \n{k"ur6sc} \n{k"u1s} 1la.
8labf 8labh lab2r 2l1abs lach3r la8dr 5ladu 8ladv 6laff laf5t la2gn
5laken 8lamb la6mer 5lampe.  2l1amt la1na 1land lan4d3a lan4d3r lan4gr
8lanme 6lann 8lanw \n{6lan"a} 8lappa lap8pl lap6pr l8ar.  la5ra lar4af
la8rag la8ran la6r5a6s l3arbe la8rei 6larm.  la8sa la1sc la8sta lat8i
6l5atm 4lauss 4lauto 1law 2lb l8bab l8bauf l8bede l4b3ins l5blo
lbst5an lbst3e 8lc l1che l8chert l1chi lch3m l5cho lch5w 6ld l4d3ei
ld1re \n{l6d"ub} le2bl le8bre lecht6s5 led2r 6leff le4gas 1lehr lei6br
le8inf 8leinn 5leistu 4lektr le6l5ers lemo2 8lemp l8en.  8lends
6lendun le8nend len8erw 6l5ents 4l3entw 4lentz 8lenzy 8leoz 6lepi
le6pip 8lepo 1ler l6er.  8lerbs 6l5erde le8reis le8rend le4r3er 4l3erg
l8ergr 6lerkl 6l5erzie \n{8ler"o} 8lesel lesi5e le3sko le3tha let1s
5leuc 4leuro leu4s3t le5xe 6lexp l1f 2l1g lgend8 l8gh lglie3 lglied6
6l1h 1li li1ar li1as 2lick li8dr li1en lien6n li8ers li8ert 2lie\3
\c{2lie\9} 3lig li8ga8b li1g6n li1l8a 8limb li1na 4l3indu lings5
4l3inh 6linj link4s3 4linkt 2lint 8linv lion5s6t 4lipp 5lipt 4lisam
livi5e 6l1j 6l1k l8keim l8kj lk2l lko8f lkor8 lk2sa lk2se 6ll l1la
ll3a4be l8labt ll8anl ll1b ll1c ll1d6 l1le l4l3eim l6l5eise ller3a
l4leti l5lip l1lo ll3ort ll5ov ll6spr llte8 l1lu ll3urg \n{l1l"a}
\n{l5l"u} \n{l6l"ub} 2l1m l6m5o6d 6ln l1na l1no 8lobl lo6br 3loch.
l5o4fen 5loge.  5lohn 4l3ohr 1lok l2on 4l3o4per lo1ra 2l1ord 6lorg
4lort lo1ru 1los.  lo8sei 3losig lo6ve lowi5 6l1p lp2f l8pho l8pn
lp4s3te l2pt l1q 8l1r 2ls l1sa l6sarm l1sc l8sec l6s5erg l4s3ers l8sh
l5s6la l1sp ls4por ls2pu l1str l8suni \n{l1s"u} 2l1t lt5amp l4t3ein
l5ten l6t5eng l6t5erp l4t3hei lt3her l2t1ho l6t5i6b lti1l \n{l8tr"o}
lt1sc lt6ser lt4s3o lt5ums lu8br lu2dr lu1en8 8lu8fe luft3a luf8tr
lu6g5r 2luh l1uhr lu5it 5luk 2l1umf 2l1umw 1lun 6l5u6nio 4l3unte lu5ol
4lurg 6lurs l3urt lu4sto lu3str lu6st5re lu8su lu6tal lu6t5e6g lu8terg
lu3the lu6t5or lu2t1r lu6\35 \c{lu6\95} l1v lve5r6u 2l1w 1ly lya6
6lymp ly1no l8zess l8zo8f l3zwei lz5wu \n{3l"and} \n{l"a5on}
\n{l"a6sc} \n{l"at1s} \n{5l"auf} \n{2l"aug} \n{l"au6s5c} \n{l"a5v}
\n{l1"ol} \n{1l"os} \n{l"o1\36t} \n{\c{l"o1\96t}} \n{6l1"ube} 1ma
8mabg ma5chan mad2 ma5el 4magg mag8n ma1la ma8lau mal5d 8malde mali5e
malu8 ma8lut 2m1amp 3man mand2 man3ds 8mangr mani5o 8m5anst 6mappa
4m3arbe mar8kr ma1r4o mar8schm 3mas ma1sc \n{ma1t"o} 4m5auf ma5yo 2m1b
mb6r 2m1c 2m1d \n{md6s"a} 1me me1ch me5isc 5meld mel8sa 8memp me5nal
men4dr men8schl men8schw 8mentsp me1ra mer4gl me1ro 3mes me6s5ei me1th
me8\3 \c{me8\9} 2m1f6 2m1g 2m1h 1mi mi1a mi6ale mi1la 2m1imm mi1na
\n{mi5n"u} mi4s3an mit1h mi5t6ra 3mitt mitta8 mi6\35 \c{mi6\95} 6mj
2m1k8 2m1l 2m1m m6mad m6m5ak m8menth m8mentw mme6ra m2mn mm5sp mm5ums
mmut5s \n{m8m"an} m1n8 m5ni 1mo mo5ar mo4dr 8mof mo8gal mo4kla mol5d
m2on mon8do mo4n3od mont8a 6m5ony mopa6 mo1ra mor8d5a mo1sc mo1sp 5mot
moy5 2mp m1pa mpfa6 mpf3l mphe6 m1pi mpin6 m1pl mp2li m2plu mpo8ste
m1pr \n{mpr"a5} mp8th mput6 mpu5ts \n{m1p"o} 8m1q 2m1r 2ms ms5au m1sc
msch4l ms6po m3spri m1str 2m1t mt1ar m8tein m2t1h mt6se \n{mt8s"a}
mu5e 6m5uh mumi1 1mun mun6dr muse5e mu1ta 2m1v mvol2 mvoll3 2m1w 1my
2m1z \n{m"a6kl} \n{1m"an} \n{m"a1s} \n{m"a5tr} \n{m"au4s3c} \n{3m"a\3}
\n{\c{3m"a\9}} \n{m"ob2} \n{6m"ol} \n{1m"u} \n{5m"un} \n{3m"ut} 1na.
n5ab.  8nabn n1abs n1abz \n{na6b"a} na2c nach3e 3nacht 1nae na5el
n1afr 1nag 1n2ah na8ha na8ho 1nai 6nair na4kol n1akt nal1a 8naly 1nama
na4mer na1mn n1amp 8n1amt 5nanc nan6ce n1and n6and.  2n1ang 1nani
1nann n1ans 8nanw 5napf.  1n2ar.  na2ra 2n1arc n8ard 1nari n8ark
6n1arm 5n6ars 2n1art n8arv 6natm nat6s5e 1naue 4nauf n3aug 5naui n5auk
na5um 6nausb 6nauto 1nav 2nax 3naz 1na\3 \c{1na\9} n1b2 nbau5s n1c
nche5e nch5m 2n1d nda8d n2d1ak nd5ans n2d1ei nde8lac ndel6sa n8derhi
nde4se nde8stal n2dj ndnis5 n6d5or6t nd3rec nd3rot nd8samt nd6sau
ndt1h n8dumd 1ne ne5as ne2bl 6n5ebn 2nec 5neei ne5en ne1g4l 2negy
4n1ein 8neis 4n3e4lem 8nemb 2n1emp nen1a 6n5energ nen3k 8nentb
4n3en3th 8nentl 8n5entn 8n5ents ne1ra ne5r8al ne8ras 8nerbi 6n5erde.
nere5i6d nerfor6 \n{6n5erh"o} \n{8nerl"o} 2n1err n8ers.  6n5ertra
2n1erz nesi3e net1h neu4ra neu5sc 8neu\3 \c{8neu\9} n1f nf5f nf2l
nflei8 nf5lin nft8st n8g5ac ng5d ng8en nge8ram ngg2 ng1h n6glic ng3rip
ng8ru ng2se4 ng2si n2g1um n1gy \n{n8g"al} n1h nhe6r5e 1ni ni1bl
\n{ni5ch"a} ni8dee n6ie ni1en nie6s5te niet5h ni8etn 4n3i6gel n6ik
ni1la 2n1imp ni5na 2n1ind 8ninf 6n5inh ni8nit 6n5inn 2n1ins 4n1int
n6is ni3str ni1th ni1tr n1j n6ji n8kad nk5ans n1ke n8kerla n1ki nk5inh
\n{n5kl"o} n1k2n n8k5not nk3rot \n{n8kr"u} nk5spo nk6t5r n8kuh
\n{n6k"ub} n5l6 nli4mi n1m nmen4s n1na n8nerg nni5o n1no nn4t3ak nnt1h
nnu1e n1ny \n{n1n"a} \n{n1n"o} \n{n1n"u} no5a no4b3la 4n3obs 2nobt
noche8 no6die no4dis no8ia no5isc 6n5o6leu no4mal noni6er 2n1onk n1ony
4n3o4per 6nopf 6nopti no3ra no4ram nor6da 4n1org 2n1ort n6os no1st
8nost.  no8tan no8ter noty6pe 6n5ox n1p2 n1q n1r \n{nr"os3} 6ns n1sac
ns3ang n1sc n8self n8s5erf n8serg n6serk ns5erw n8sint n1s2pe n1spr
n6s5tat.  n5s6te.  n6stob n1str n1ta n4t3a4go nt5anh nt3ark nt3art
n1te nt3eis nte5n6ar nte8nei nter3a nte6rei nt1ha nt6har n3ther nt5hie
n3thus n1ti nti1c n8tinh nti1t ntlo6b ntmen8 n1to nt3o4ti n1tr ntra5f
ntra5ut nt8rea nt3rec nt8rep n4t3rin nt8rop n4t3rot \n{n4tr"u} nt1s
nts6an nt2sk n1tu nt1z \n{n1t"a} \n{n1t"o} \n{n8t"ol} \n{n1t"u} 1nu
nu1a nu5el nu5en 4n1uhr nu5ie 8numl 6n5ums 6n5umw 2n1und 6nuni 6n5unr
2n1unt 2nup 2nu6r n5uri nu3skr nu5ta n1v 8n1w 1nys n1za n6zab n2z1ar
n6zaus nzi4ga n8zof n6z5unt n1zw n6zwir \n{1n"ac} \n{5n"ae} \n{5n"ai}
\n{n8"al} \n{n"a6m} \n{n"a6re} \n{n5"arz} \n{5n"aus} \n{n1"ol}
\n{1n"ot} \n{n5"oz} \n{5n"u.} \n{6n1"u2b} \n{5n"u\3} \n{\c{5n"u\9}}
o5ab.  oa2l o8ala o1a2m o1an ob1ac obe4ra o6berh 5o4bers o4beru
obe6ser 1obj o1bl o2bli ob5sk 3obst.  ob8sta obst5re ob5sz o1che
oche8b o8chec o3chi och1l och3m ocho8f o3chro och3to o3chu och1w o1d
o2d1ag od2dr ode5i ode6n5e od1tr o5e6b o5e6der.  oe8du o1ef o1e2l
o1e2p o1er.  o5e8x o1fa of8fan 1offi of8fin of6f5la o5fla o1fr 8o1g
og2n o1ha o1he o6h5eis o1hi ohl1a oh1le oh4l3er 5ohm.  oh2ni o1ho
oh1re oh1ru o1hu oh1w o1hy \n{o1h"a} o5ia o1id.  o8idi oi8dr o5ids
o5isch.  oiset6 o1ism o3ist.  o5i6tu o1j o1k ok2l ok3lau \n{o8kl"a}
1okta o1la old5am old5r o1le ole5in ole1r ole3u ol6gl ol2kl olk4s1
ol8lak ol8lauf.  ol6lel ol8less o1lo ol1s ol6sk o1lu oly1e2 5olym
o2mab om6an o8mau ombe4 o8merz om5sp o1mu o8munt \n{o1m"a} \n{o1m"o}
o1na ona8m on1ax on8ent o6n5erb 8oni oni5er.  on1k on6n5a6b o1no ono1c
o4nokt 1ons onts8 \n{o1n"a} oo8f 1oog oo2pe oo2sa o1pa 3o4pera o3pfli
opf3lo opf3r o1pi o1pl o2pli o5p6n op8pa op6pl o1pr o3p4ter 1opti
\n{o1p"a} \n{o5p"o} o1q o1ra.  o3rad o8radd 1oram o6rang o5ras o8rauf
or5cha or4d3a4m or8dei or8deu 1ordn or4dos o1re o5re.  ore2h o8r5ein
ore5isc or6enn or8fla or8fli 1orga 5orgel.  or2gl o1ri 5o6rient or8nan
\n{or8n"a} o1ro or1r2h or6t5an or8tau or8tere o1rus o1ry \n{o1r"a}
\n{or1"u2} o1sa osa3i 6ose o8serk o1sk o6ske o6ski os2kl os2ko os2kr
osni5e o2s1o2d o3s4per o4stam o6stau o3stra ost3re osu6 o6s5ur o5s6ze
o1ta ot3auf o6taus o1te o6terw o1th othe5u o2th1r o1ti o1to oto1a
ot1re o1tri o1tro ot1sc o3tsu ot6t5erg ot2t3h ot2t5r \n{ot8t"o} o1tu
ou3e ouf1 ou5f6l o5u6gr ou5ie ou6rar ou1t6a o1v o1wa o1we o6wer.  o1wi
owid6 o1wo o5wu o1xe oy5al.  oy1e oy1i o5yo o1z oza2r 1o2zea ozo3is
\n{o"o8} o\35elt \c{o\95elt} o\31t \c{o\91t} 3paa pa6ce 5pad pag2 1pak
pa1la pa8na8t pani5el pa4nor pan1s2 1pap pap8s pa8rei par8kr paro8n
par5o6ti part8e 5partei 3partn pas6sep pa4tha 1pau 6paug pau3sc p1b
8p5c 4p1d 1pe 4peic pe5isc 2pek pen3k pen8to8 p8er pe1ra pere6 per5ea
per5eb pe4rem 2perr per8ran 3pers 4persi \n{pe3r"u} pe4sta pet2s
p2f1ec p4fei pf1f pf2l 5pflanz pf8leg pf3lei 2pft pf3ta p1g 1ph 2ph.
2p1haf 6phb 8phd 6p5heit ph5eme 6phg phi6e 8phk 6phn p5holl pht2
ph3tha 4ph3the phu6 6phz pi1en pi5err pi1la pi1na 5pinse pioni8e 1pis
pi1s2k pi1th p1k pl8 5pla p2lau 4plei p3lein 2pler 6p5les 2plig p6lik
6p5ling p2liz plo8min 6p1m p1n 1p2o 8poh 5pol po8lan poly1 po3ny po1ra
2porn por4t3h \n{po5r"o} 5poti p1pa p6p5ei ppe6la pp5f p2p1h p1pi pp1l
ppp6 pp5ren pp1s \n{p5p"o} pr6 3preis 1pres 2p3rig 5prinz 1prob 1prod
5prog pro8pt pro6t5a prote5i 8pro\3 \c{8pro\9} \n{pr"a3l} \n{1pr"as}
\n{pr"ate4} \n{1pr"uf} p5schl 2pst 1p2sy p1t p8to8d pt1s 5p6ty 1pu
pu1b2 2puc pu2dr puf8fr 6p5uh pun8s pu8rei pu5s6h pu1ta p1v p3w 5py
py5l p1z \n{p"a6der} \n{p5"a6m} \n{p"a8nu} \n{8p"ar} \n{p"at5h}
\n{p"at1s} qu6 1qui 8rabk ra6bla 3rable ra2br r1abt 6rabz ra4dan ra2dr
5rafal ra4f3er ra5gla ra2g3n 6raha ral5am 5rald 4ralg ra8lins 2rall
ral5t 8ramei r3anal r6and ran8der ran4dr 8ranf 6ranga 5rangi ran8gli
r3angr rans5pa 8ranw r8anz.  ra5or 6rapf ra5pl rap6s5er 2r1arb 1rarh
r1arm ra5ro 2r1art 6r1arz ra8tei ra6t5he 6ratl ra4t3ro r5atta raue4n
6raus.  r5austa rau8tel raut5s ray1 r1b rb5lass r6bler rb4lie rbon6n
r8brecht \n{rb6s5t"a} r8ces r1che rch1l rch3m rch3re rch3tr rch1w 8rd
r1da r8dachs r8dap rda5ro rde5ins rdio5 r8dir rd3ost r1dr r8drau 1re.
re1ak 3reakt re3als re6am.  re1as 4reben re6bl rech5a r8edi re3er
8reff 3refl 2reh 5reha r4ei.  reich6s5 8reier 6reign re5imp 4r3eina
6r3einb 6reing 6r5einn 6reinr 4r3eins r3eint reli3e 8r5elt 6rempf
2remt ren5a6b ren8gl r3enni 1reno 5rente 4r3enth 8rentl 4r3entw 8rentz
ren4zw re1on requi5 1rer rer4bl 6rerbs 4r3erd \n{8rerh"o} 8rerkl
4r3erla \n{8rerl"o} 4r3erns \n{6r5ern"a} rer5o 6r5erreg r5ertr r5erwec
\n{r5er"o} re2sa re8schm 2ress re5u8ni 6rewo 2r1ex r1f r8ferd rf4lie
8r1g r8gah rge4bl rge5na rgest4 rg6ne r2gni2 r8gob r4g3ret rg8sel r1h8
r2hy 5rhyt ri1ar ri5cha rid2g r2ie rieg4s5 ri8ei ri1el ri6ele ri1en
ri3er.  ri5ers.  ri6fan ri8fer ri8fr 1r2ig ri8kn ri5la \n{rim"a8}
ri1na r8inde rin4ga rin6gr 1rinn 6rinner rino1 r8insp 4rinst
\n{ri1n"a} ri5o6ch ri1o2d ri3o6st 2r1ir r2is ri3sko ri8spr \n{ri8st"u}
ri5sv r2it 6r5i6tal ri5tr ri6ve.  8r1j 6rk r1ke rkehrs5 r1ki r3klin
r1k2n rk3str rk4t3an rk6to r6kuh \n{rk"a4s3t} r1l r5li rline5a 6r1m
r6manl rma4p r4m3aph r8minf r8mob rm5sa 2rn r1na rna8be r5ne rn2ei
r6neif r6nex r6nh rn1k r1no r6n5oc rn1sp \n{r1n"a} \n{r1n"u} ro6bern
6robs ro1ch 3rock.  ro5de ro1e 4rofe ro8hert 1rohr ro5id ro1in ro5isc
6rolym r2on 6roog ro6phan r3ort ro1s2p ro5s6w ro4tau ro1tr ro6ts 5rout
r1p rpe8re rp2f r2ps r2pt r1q 2rr r1ra r1re rrer6 rr6hos \n{r5rh"o}
r1ri r1ro rro8f rr8or rror5a r1ru r3ry \n{r1r"a} \n{r1r"o} \n{r1r"u}
2r1s r6sab r4sanf rse6e rse5na r2sh r6ska r6ski rs2kl r8sko r2sl rs2p
r6stauf r8sterw r8stran rswi3d4 r2sz 2r1t rt3art r8taut r5tei rt5eige
r8tepe r4t3erh r8terla r4t3hei r5t6hu r4t3int rt5reif rt1sc rt6ser
rt6s5o rt6s5u rt5und r8turt rube6 ru1en 1r4uf ruf4st ru1ie 2r1umg
2r1uml 2rums run8der run4d5r 6rundz 6runf 8runs 2r1unt 2r1ur r6us
ru6sta ru3str ru6tr 1ruts r1v rven1 rvi2c r1w r1x r1za rz5ac r6z5al
r8z1ar r8zerd r6z5erf rz8erh rz4t3h r8zum \n{r"a4ste} \n{r"au8sc}
\n{r1"of} \n{5r"ohr} \n{r"o5le} \n{3r"oll} \n{5r"omis} \n{r1"or}
\n{r"o2sc} \n{3r"ump} 1sa.  1saa s3a4ben sa2bl 2s1abs 6s1abt 6sabw
3sack.  6s3a4der 1saf sa1fa 4s1aff sa5fr 1sag 1sai sa1i2k1 4s1akt 1sal
sa1la 4s3alpi 6salter salz3a 1sam s5anb san2c 1sand s5angeh 6sanl
2s1ans 6s3antr 8s1anw s1ap s6aph 8sapo sap5p6 s8ar.  2s1arb 3sarg
s1arm sa5ro 2s1art 6s1arz 1sas 1sat sat8a 2s1atl sa8tom 3s8aue s5auff
sau5i s6aur 2s1aus 5s6ause 2s1b2 2sca s4ce 8sch.  3scha.  5schade
3schaf 3schal sch5ame 8schanc 8schb 1sche 6schef 8schex 2schf 2schg
2schh 1schi 2schk 5schlag 5schlu \n{6schm"a\3} \n{\c{6schm"a\9}}
6schna\3 \c{6schna\9} 1scho 6schord 6schp 3schri 8schric 8schrig
8schrou 6schs 2scht sch3ta sch3tr 1schu 8schunt 6schv 2schz \n{5sch"o}
\n{5sch"u} 2sco scre6 6scu 2s1d 1se se5an se1ap se6ben se5ec see5i6g
se3erl 8seff se6han se8hi \n{se8h"o} 6s5eid.  2s1eig s8eil 5sein.
sei5n6e 6s5einh 3s8eit 3sel.  se4lar selb4 6s3e4lem se8lerl 2s1emp
sen3ac se5nec 6s5ents 4sentz s8er.  se8reim ser5inn \n{8serm"a}
8s5erzi \n{6ser"of} se1um 8sexa 6sexp 2s1f2 sfal8ler 2s3g2 sge5b2 s1h
s8hew 5s6hip 5s4hop 1si 2siat si1b sicht6s 6s5i6dee siege6s5 si1en
si5err si1f2 si1g2n si6g5r si8kau sik1i si4kin si2kl \n{si8k"u} si1la
sil6br si1na 2s1inf sin5gh 2s1inh sinne6s5 2s1ins si5ru si5str 4s1j
s1k2 6sk.  2skau skel6c skelch5 s6kele 1s2ki.  3s4kin.  s6kiz s8kj
6skn 2skow 3skrib 3skrip 2sku \n{8sk"u} s1l s8lal slei3t s4low 2s1m
s1n 6sna 6snot 1so so1ch 2s1odo so4dor 6s5o4fen solo3 s2on so5of 4sope
so1ra 2s1ord 4sorga sou5c so3un 4s3ox sp2 8spaa 5spal 1span 2spap
s2pec s4peis 1spek s6perg 4spers s6pes 2s1pf 8sphi \n{1s2ph"a} 1spi
spi4e 6s5pig 6spinse 2spis 2spla 2spol 5s6pom 6s5pos 6spoti 1spra
3s8prec 6spreis 5spring 6sprob 1spru s2pul 1s2pur 6spy \n{5sp"an}
\n{1sp"u} s1q 2s1r 2s1s2 sse8nu ssini6s ssoi6r 2st.  1sta 4stafe 2stag
sta3la 6stale 4stalg 8stalk 8stamt 6st5anf 4stans 6stanw 6starb sta4te
6staus 2stb 6stc 6std 1ste 4steil 3s2tel st3elb 8stemb 6steppi 8stese
8stesse 6stf 2stg 2sth st1ha st3hei s8t1hi st1ho st5hu 1sti sti4el
4stigm sti3na 6stind 4stinf sti8r 2stk 2stl 2stm 1sto 6stoll.  4st3ope
6stopf.  6stord 6stp 5stra.  4strai 3s4tral 6s5traum 3stra\3
\c{3stra\9} 3strec 6s3tref 8streib 5streif 6streno 6stres 6strev
5s6tria 6strig 5strik 8strisi 3s4troa s8troma st5rose 4struf 3strum
\n{6str"ag} 2st1s6 2stt 1stu stu5a 4stuc 2stue 8stun.  2stv 2stw s2tyl
6stz \n{1st"a} \n{8st"ag} \n{1st"o} \n{1st"u} \n{8st"uch} \n{4st"ur.}
1su su2b1 3suc su1e su2fe su8mar 6sumfa 8sumk 2s1unt sup1p2 6s5u6ran
6surte 2s1v 2s1w 1sy 8syl.  sy5la syn1 sy2na syne4 s1z s4zend 5s6zene.
8szu \n{1s"a} \n{6s5"and} \n{6s"augi} \n{6s"au\3} \n{\c{6s"au\9}}
\n{5s"om} \n{2s1"u2b} \n{1s"uc} \n{s"u8di} \n{1s"un} \n{5s"u\3}
\n{\c{5s"u\9}} taats3 4tab.  taba6k ta8ban tab2l ta6bre 4tabs t3absc
8tabz 6t3acht ta6der 6tadr tad6s tad2t 1tafe4 1tag ta6ga6 ta8gei
tage4s tag6s5t tah8 tahl3 tai6ne.  ta5ir.  tak8ta tal3au 1tale ta8leng
tal5ert 6t5a6mer 6tamp tampe6 2t1amt tan5d6a tan8dr tands5a tani5e
6tanl 2tanr t3ans 8t5antr tanu6 t5anw 8tanwa tan8zw ta8rau 6tarbe
1tari 2tark 2t1arm ta1ro 2tart t3arti 6tarz ta1sc ta6sien ta8stem
ta8sto t5aufb 4taufn 8taus.  5tause 8tausf 6tausg t5ausl 2t1b2 2t1c
t6chu 2t1d te2am tea4s te8ben 5techn 4teff te4g3re te6hau 2tehe te4hel
2t1ehr te5id.  teig5l 6teign tei8gr 1teil 4teinh t5einhe 4teis t5eisen
8teiw te8lam te4lar 4telek 8telem te6man te6n5ag ten8erw ten5k tens4p
ten8tro 4t3entw 8tentz te6pli 5teppi ter5a6b te3ral ter5au 8terbar
t5erbe.  6terben 8terbs 4t3erbt t5erde.  ter5ebe ter5ein te8rers terf4
\n{8terh"o} \n{6terkl"a} ter8nor ter6re.  t8erscha t5e6sel te8stau
t3euro te1xa tex3e 8texp tex6ta 2t1f2 2t1g2 2th.  th6a 5tha.  2thaa
6t1hab 6t5haf t5hah 8thak 3thal.  6thals 6t3hand 2t1hau 1the.  3t4hea
t1heb t5heil t3heit t3helf 1theo 5therap 5therf 6t5herz 1thes 1thet
5thi.  2t1hil t3him 8thir 3this t5hj 2th1l 2th1m th1n t5hob t5hof
4tholz 6thopti 1thr6 4ths t1hum 1thy \n{4t1h"a} \n{2t1h"o} \n{t1h"u}
ti1a2m ti1b tie6fer ti1en ti8gerz tig3l ti8kin ti5lat 1tilg t1ind
tin4k3l ti3spa ti5str 5tite ti5tr ti8vel ti8vr 2t1j 2t1k2 2t1l tl8a
2t1m8 2t1n 3tobe 8tobj to3cha 5tocht 8tock tode4 to8del to8du to1e
6t5o6fen to1in toi6r 5toll.  to8mene t2ons 2t1ony to4per 5topf.  6topt
to1ra to1s to6ska tos2l 2toti to1tr t8ou 2t1p2 6t1q tr6 tra5cha
tra8far traf5t 1trag tra6gl tra6gr t3rahm 1trai t6rans tra3sc tra6st
3traue t4re.  2trec t3rech t8reck 6t1red t8ree 4t1reg 3treib 4treif
8t3reis 8trepo tre6t5r t3rev 4t3rez 1trib t6rick tri6er 2trig t8rink
tri6o5d trizi5 tro1a 3troc trocke6 troi8d tro8man.  tro3ny 5tropf
6t5rosa t5ro\3 \c{t5ro\9} 5trub 5trup trut5 \n{1tr"ag} \n{6t1r"oh}
\n{5tr"ub} \n{tr"u3bu} \n{t1r"uc} \n{t1r"us} 2ts ts1ab t1sac tsa8d
ts1ak t6s5alt ts1an ts1ar ts3auf t3schr \n{t5sch"a} tse6e tsee5i
tsein6s ts3ent ts1er t8serf t4serk t8sh 5t6sik t4s3int ts5ort.
t5s6por t6sprei t1st t6s5tanz ts1th t6stit t4s3tor 1t2sua t2s1uf
t8sum.  t2s1u8n t2s1ur 2t1t tt5eif tte6sa tt1ha tt8ret tt1sc tt8ser
tt5s6z 1tuc tuch5a 1tu1e 6tuh t5uhr tu1i tu6it 1tumh 6t5umr 1tums
8tumt 6tund 6tunf 2t1unt tu5ra tu6rau tu6re.  tu4r3er 2t1v 2t1w 1ty1
ty6a ty8la 8tym 6ty6o 2tz tz5al tz1an tz1ar t8zec tzeh6 tzehn5 t6z5ei.
t6zor t4z3um \n{t6z"au} \n{5t"ag} \n{6t"ah} \n{t5"alt} \n{t8"an}
\n{t"are8} \n{8t"a8st} \n{6t"au\3} \n{\c{6t"au\9}} \n{t5"offen}
\n{8t"o8k} \n{1t"on} \n{4t"ub} \n{t6"u5ber.} \n{5t"uch} \n{1t"ur.}
u3al.  u5alb u5alf u3alh u5alk u3alp u3an.  ua5na u3and u5ans u5ar.
ua6th u1au ua1y u2bab ubi5er.  u6b5rit ubs2k \n{u5b"o} \n{u8b"ub} 2uc
u1che u6ch5ec u1chi uch1l uch3m uch5n uch1r uch5to ucht5re u1chu uch1w
uck1a uck5in u1d ud4a u1ei u6ela uene8 u6ep u1er uer1a ue8rerl uer5o
u8esc u2est u8ev u1fa u2f1ei u4f3ent u8ferh uf1fr uf1l uf1ra uf1re
\n{uf1r"a} \n{uf1r"u} uf1s2p uf1st uft1s u8gabt u8gad u6gap ugeb8 u8gn
ugo3s4 u1ha u1he u1hi uh1le u1ho uh1re u1hu uh1w \n{u1h"a} \n{u1h"o}
6ui ui5en u1ig u3ins uin8tes u5isch.  u1j 6uk u1ke u1ki u1kl u8klu
u1k6n u5ky u1la uld8se u1le ul8lac ul6lau ul6le6l ul6lo ulni8 u1lo
ulo6i ult6a ult8e u1lu ul2vr \n{u1l"a} \n{u1l"o} 3umfan 5umlau umo8f
um8pho u1mu umu8s \n{u5m"o} u1n1a un2al un6at unau2 6und.  5undein
un4d3um 3undzw \n{und"u8} \n{un8d"ub} une2b un1ec une2h un3eis 3unfal
\n{1unf"a} 5ungea \n{3ungl"u} ung2s1 \n{un8g"a} 1u2nif un4it un8kro
unk5s u1no unpa2 uns2p unvol4 unvoll5 u5os.  u1pa u1pi u1p2l u1pr
up4s3t up2t1a u1q u1ra ur5abs ura8d ur5ah u6rak ur3alt u6rana u6r5ans
u8rap ur5a6ri u8ratt u1re ur3eig ur8gri u1ri ur5ins 3urlau urmen6
ur8nan u1ro 3ursac ur8sau ur8sei ur4sk 3urtei u1ru uru5i6 uru6r u1ry
ur2za \n{ur6z"a} \n{ur5"a6m} \n{u5r"o} \n{u1r"u} \n{ur"uck3} u1sa
usa4gi u2s1ar u2s1au u8schec usch5wi u2s1ei use8kel u8sl u4st3a4b
us3tau u3s4ter u2s1uf u8surn ut1ac u1tal uta8m u1tan ut1ar u1tas ut1au
u1te u8teic u4tent u8terf u6terin u4t3hei ut5ho ut1hu u1ti utine5
uti6q u1to uto5c u1tr ut1sa ut1s6p ut6stro u1tu utz5w u1u u1v uve5n
\n{uve3r4"a} u1w u1xe u5ya uy5e6 u1yi u2z1eh u8zerh \n{u5"o} u\3e6n
\c{u\9e6n} u\3en5e \c{u\9en5e} 8vanb 6vang 6varb var8d va6t5a va8tei
va2t1r 2v1b 6v5c 6vd 1ve 6ve5g6 ver1 ver5b verb8l ve2re2 verg8 ve2ru8
ve1s ve2s3p ve3xe 2v1f 2v1g 6v5h vi6el vie6w5 vi1g4 vi8leh vil6le.
8vint vi1ru vi1tr 2v1k 2v1l 2v1m 4v5n 8vo8f voi6le vol8lend vol8li
v2or1 vo2re vo8rin vo2ro 2v1p 8vra v6re 2v1s 2v1t 2v1v 4v3w 2v1z
waffe8 wa6g5n 1wah wah8n wa5la wal8din wal6ta wan4dr 5ware wa8ru
war4za 1was w5c w1d 5wech we6fl 1weg we8geng weg5h weg3l we2g1r
weh6r5er 5weise weit3r wel2t welt3r we6rat 8werc 5werdu wer4fl 5werk.
wer4ka wer8ku wer4ta wer8term we2sp we8stend we6steu we8str
\n{we8st"o} wet8ta wich6s5t 1wid wi2dr wiede4 wieder5 wik6 wim6ma
win4d3r 5wirt wisch5l 1wj 6wk 2w1l 8w1n wo1c woche6 wol6f wor6t5r 6ws2
w1sk 6w5t 5wunde.  wun6gr wu1sc wu2t1 6w5w wy5a \n{w"arme5} \n{w"a1sc}
1xag x1ak x3a4men 8xamt x1an 8x1b x1c 1xe.  x3e4g 1xen xe1ro x1erz
1xes 8xf x1g 8x1h 1xi 8xid xi8so 4xiste x1k 6x1l x1m 8xn 1xo 8x5o6d
8x3p2 x1r x1s6 8x1t x6tak x8terf x2t1h 1xu xu1e x5ul 6x3w x1z 5ya.
y5an.  y5ank y1b y1c y6cha y4chia y1d yen6n y5ern y1g y5h y5in y1j
y1k2 y1lak yl1al yla8m y5lax y1le y1lo y5lu y8mn ym1p2 y3mu y1na yno2d
yn1t y1on.  y1o4p y5ou ypo1 y1pr y8ps y1r yri3e yr1r2 y1s ys5iat ys8ty
y1t y3w y1z \n{y"a8m} z5a6b zab5l 8za6d 1zah za5is 4z3ak 6z1am 5zange.
8zanl 2z1ara 6z5as z5auf 3zaun 2z1b 6z1c 6z1d 1ze ze4dik 4z3eff 8zein
zei4ta zei8ters ze6la ze8lec zel8th 4zemp 6z5engel zen8zin \n{8zerg"a}
zer8i ze1ro zers8 zerta8 zer8tab zer8tag 8zerz ze8ste zeu6gr 2z1ex
2z1f8 z1g 4z1h 1zi zi1en zi5es.  4z3imp zi1na 6z5inf 6z5inni zin6s5er
8zinsuf zist5r zi5th zi1tr 6z1j 2z1k 2z1l 2z1m 6z1n 1zo zo6gl 4z3oh
zo1on zor6na8 4z1p z5q 6z1r 2z1s8 2z1t z4t3end z4t3hei z8thi 1zu zu3al
zu1b4 zu1f2 6z5uhr zun2a 8zunem zunf8 8zungl zu1o zup8fi zu1s8 zu1z
2z1v zw8 z1wal 5zweck zwei3s z1wel z1wer z6werg 8z5wes 1zwi zwi1s
6z1wo 1zy 2z1z zz8a zzi1s \n{1z"a} \n{1z"o} \n{6z"ol.} \n{z"o1le}
\n{1z"u} \n{2z1"u2b} \n{"a1a6} \n{"ab1l} \n{"a1che} \n{"a3chi}
\n{"ach8sc} \n{"ach8sp} \n{"a5chu} \n{"ack5a} \n{"ad1a} \n{"ad5era}
\n{"a6d5ia} \n{"a1e} \n{"a5fa} \n{"af1l} \n{"aft6s} \n{"ag1h}
\n{"ag3le} \n{"a6g5nan} \n{"ag5str} \n{"a1he} \n{"a1hi} \n{"ah1le}
\n{"ah5ne} \n{1"ahnl} \n{"ah1re} \n{"ah5ri} \n{"ah1ru} \n{"a1hu}
\n{"ah1w} \n{6"ai} \n{"a1isc} \n{"a6ische} \n{"a5ism} \n{"a5j}
\n{"a1k} \n{"al1c} \n{"a1le} \n{"a8lei} \n{"al6schl} \n{"ami1e}
\n{"am8n} \n{"am8s} \n{"a5na} \n{5"anderu} \n{"ane5i8} \n{"ang3l}
\n{"ank5l} \n{"a1no} \n{"an6s5c} \n{"a1pa} \n{"ap6s5c} \n{3"aq}
\n{"ar1c} \n{"a1re} \n{"are8m} \n{5"argern} \n{"ar6gl} \n{"a1ri}
\n{3"armel} \n{"a1ro} \n{"art6s5} \n{"a1ru} \n{3"arztl} \n{"a5r"o}
\n{"a6s5chen} \n{"asen8s} \n{"as1th} \n{"ata8b} \n{"a1te} \n{"ateri4}
\n{"ater5it} \n{"a6thy} \n{"a1ti} \n{3"atk} \n{"a1to} \n{"at8schl}
\n{"ats1p} \n{"a5tu} \n{"aub1l} \n{"au1e} \n{1"aug} \n{"au8ga}
\n{"au5i} \n{"a1um.} \n{"a1us.} \n{1"au\3} \n{\c{1"au\9}} \n{"a1z}
\n{"o1b} \n{"o1che} \n{"o5chi} \n{"och8stei} \n{"och8str} \n{"ocht6}
\n{5"o6dem} \n{5"offn} \n{"o1he} \n{"oh1l8} \n{"oh1re} \n{"o1hu}
\n{"o1is} \n{"o1ke} \n{1"o2ko} \n{1"ol.} \n{"ol6k5l} \n{"ol8pl}
\n{"o1mu} \n{"o5na} \n{"onig6s3} \n{"o1no} \n{"o5o6t} \n{"opf3l}
\n{"op6s5c} \n{"o1re} \n{"or8gli} \n{"o1ri} \n{"or8tr} \n{"o1ru}
\n{5"osterr} \n{"o1te} \n{"o5th} \n{"o1ti} \n{"o1tu} \n{"o1v} \n{"o1w}
\n{"owe8} \n{"o2z} \n{"ub6e2} \n{3"u4ber1} \n{"ub1l} \n{"ub1r}
\n{5"u2bu} \n{"u1che} \n{"u1chi} \n{"u8ch3l} \n{"uch6s5c} \n{"u8ck}
\n{"uck1a} \n{"uck5ers} \n{"ud1a2} \n{"u6deu} \n{"udi8t} \n{"u2d1o4}
\n{"ud5s6} \n{"uge4l5a} \n{"ug1l} \n{"uh5a} \n{"u1he} \n{"u8heh}
\n{"u6h5erk} \n{"uh1le} \n{"uh1re} \n{"uh1ru} \n{"u1hu} \n{"uh1w}
\n{"u3k} \n{"u1le} \n{"ul4l5a} \n{"ul8lo} \n{"ul4ps} \n{"ul6s5c}
\n{"u1lu} \n{"un8da} \n{"un8fei} \n{"unk5l} \n{"un8za} \n{"un6zw}
\n{"u5pi} \n{"u1re} \n{"u8rei} \n{"ur8fl} \n{"ur8fr} \n{"ur8geng}
\n{"u1ri} \n{"u1ro} \n{"ur8sta} \n{"ur8ster} \n{"u1ru} \n{"use8n}
\n{"u8sta} \n{"u8stes} \n{"u6s5tete} \n{"u3ta} \n{"u1te} \n{"u1ti}
\n{"ut8tr} \n{"u1tu} \n{"ut8zei} \n{"u1v} \31a8 \c{\91a8} 5\3a.
\c{5\9a.} \38as \c{\98as} \31b8 \c{\91b8} \31c \c{\91c} \31d \c{\91d}
1\3e \c{1\9e} \35ec \c{\95ec} 8\3e8g \c{8\9e8g} 8\3e8h \c{8\9e8h}
2\31ei \c{2\91ei} 8\3em \c{8\9em} \31f8 \c{\91f8} \31g \c{\91g} \31h
\c{\91h} 1\3i \c{1\9i} \31k \c{\91k} \31l \c{\91l} \31m \c{\91m}
\3mana8 \c{\9mana8} \31n \c{\91n} \31o \c{\91o} \31p8 \c{\91p8} \35q
\c{\95q} \31r \c{\91r} \31s2 \c{\91s2} \3st8 \c{\9st8} \31ta \c{\91ta}
\31te \c{\91te} \3t3hei \c{\9t3hei} \31ti \c{\91ti} \35to \c{\95to}
\31tr \c{\91tr} 1\3u8 \c{1\9u8} 6\35um \c{6\95um} \31v \c{\91v} \31w
\c{\91w} \31z \c{\91z}
}%
\endgroup
\relax\endinput
%
% -----------------------------------------------------------------
%
% =============== Additional Documentation ===============
%
%
% Older Versions of German Hyphenation Patterns:
% ----------------------------------------------
%
% All older versions of `ghyphen.tex' distributed as
%
%       ghyphen.tex/germhyph.tex   as of 1986/11/01
%       ghyphen.min/ghyphen.max    as of 1988/10/10
%       ghyphen3.tex               as of 1990/09/27 & 1991/02/13
%       ghyph31.tex                as of 1994/02/13
%
% are out of date and it is recommended to replace them
% with the new version `dehypht.tex' as of 1999/03/03.
%
% If you are using `ghyphen.min' (a minor version of `ghyphen')
% because of limited trie memory space, try this version and if
% the space is exceeded get a newer TeX implementation with
% larger or configurable trie memory sizes.
%
%
%
% Trie Memory Requirements/Space for Hyphenation Patterns:
% --------------------------------------------------------
%
% To load this set of german hyphenation patterns the parameters
% of TeX has to have at least these values:
%
% TeX 3.x:
%    IniTeX:    trie_size >= 9733    trie_op_size >= 207
%    VirTeX:    trie_size >= 8375    trie_op_size >= 207
%
% TeX 2.x:
%    IniTeX:    trie_size >= 8675    trie_op_size >= 198
%    VirTeX:    trie_size >= 7560    trie_op_size >= 198
%
% If you want to load more than one set of hyphenation patterns
% (in TeX 3.x), the parameters have to be set to a value larger
% than or equal to the sum of all required values for each set.
%
%
% Setting Trie Memory Parameters:
% -------------------------------
%
% Some implementations allow the user to change the default value
% of a set of the internal TeX parameters including the trie memory
% size parameter specifying the used memory for the hyphenation
% patterns.
% 
% Web2c 7.x (Source), teTeX 0.9 (Unix, Amiga), fpTeX (Win32)
% and newer:
%   The used memory size of the true is usually set high enough.
%   If needed set the size of the trie using the keyword `trie_size'
%   in the configuration file `texmf/web2c/texmf.cnf'.  For details
%   see the included documentation.
%
% emTeX (OS/2, MS-DOS, Windows 3.x/9x/NT):
%   You can set the used memory size of the trie using the
%   `-mt<number>' option on the command line or in the
%   TEXOPTIONS environment variable.
%
% PasTeX (Amiga):
%   The values for the parameters can be set using the keywords
%   `triesize', `itriesize' and `trieopsize' in the configuration
%   file.
%
% others (binaries only):
%   See the documentation of the implementation if it is possible
%   and how to change these values without recompilation.
%
% others (with sources)
%   If the trie memory is too small, you have to recompile TeX
%   using larger values for `trie_size' and `trie_op_size'.
%   Modify the change file `tex.ch' and recompile TeX.
%   For details see the documentation included in the sources.
%
%
%
% Necessary Settings in TeX macro files:
% --------------------------------------
%
% \lefthyphenmin, \righthyphenmin:
%   You can set both parameters to 2.
%
% \lccode <char>:
%   To get correct hyphenation points within words containing
%   umlauts or \ss, it's necessary to assign values > 0 to the
%   appropriate \lccode <char> positions.
%
% These changes are _not_ done when reading this file and have to
% be included in the language switching mechanism as is done in,
% for example, `german.sty' (\lccode change for ^^Y = \ss in OT1,
% \left-/\righthyphenmin settings).
%
%
%% \CharacterTable
%%  {Upper-case    \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
%%   Lower-case    \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
%%   Digits        \0\1\2\3\4\5\6\7\8\9
%%   Exclamation   \!     Double quote  \"     Hash (number) \#
%%   Dollar        \$     Percent       \%     Ampersand     \&
%%   Acute accent  \'     Left paren    \(     Right paren   \)
%%   Asterisk      \*     Plus          \+     Comma         \,
%%   Minus         \-     Point         \.     Solidus       \/
%%   Colon         \:     Semicolon     \;     Less than     \<
%%   Equals        \=     Greater than  \>     Question mark \?
%%   Commercial at \@     Left bracket  \[     Backslash     \\
%%   Right bracket \]     Circumflex    \^     Underscore    \_
%%   Grave accent  \`     Left brace    \{     Vertical bar  \|
%%   Right brace   \}     Tilde         \~}
%%
\endinput
%% 
%% End of file `dehypht.tex'.
.\'a2
.\'aa2
.\'ae2
.\'ai2
.\'ao2
.\'au2
.\'e2
.\'ea2
.\'ee2
.\'ei2
.\'eo2
.\'eu2
.\'i2
.\'ia2
.\'ie2
.\'ii2
.\'io2
.\'iu2
.\'o2
.\'oa2
.\'oe2
.\'oi2
.\'oo2
.\'ou2
.\'u2
.\'ua2
.\'ue2
.\'ui2
.\'uo2
.\'uu2
.a2
.a\'a2
.a\'e2
.a\'i2
.a\'o2
.a\'u2
.aa2
.ae2
.ai2
.ao2
.au2
.e2
.e\'a2
.e\'e2
.e\'i2
.e\'o2
.e\'u2
.ea2
.ee2
.ei2
.eo2
.eu2
.i2
.i\'a2
.i\'e2
.i\'i2
.i\'o2
.i\'u2
.ia2
.ie2
.ii2
.io2
.iu2
.o2
.o\'a2
.o\'e2
.o\'i2
.o\'o2
.o\'u2
.oa2
.oe2
.oi2
.oo2
.ou2
.u2
.u\'a2
.u\'e2
.u\'i2
.u\'o2
.u\'u2
.ua2
.ue2
.ui2
.uo2
.uu2
2\'a.
2\'aa.
2\'ae.
2\'ai.
2\'ao.
2\'au.
2\'e.
2\'ea.
2\'ee.
2\'ei.
2\'eo.
2\'eu.
2\'i.
2\'ia.
2\'ie.
2\'ii.
2\'io.
2\'iu.
2\'o.
2\'oa.
2\'oe.
2\'oi.
2\'oo.
2\'ou.
2\'u.
2\'ua.
2\'ue.
2\'ui.
2\'uo.
2\'uu.
2\~n1\~n
2\~n1b
2\~n1c
2\~n1d
2\~n1f
2\~n1g
2\~n1h
2\~n1j
2\~n1k
2\~n1m
2\~n1n
2\~n1p
2\~n1q
2\~n1s
2\~n1t
2\~n1v
2\~n1w
2\~n1x
2\~n1y
2\~n1z
2a.
2a\'a.
2a\'e.
2a\'i.
2a\'o.
2a\'u.
2aa.
2ae.
2ai.
2ao.
2au.
2b1\~n
2b1b
2b1c
2b1d
2b1f
2b1g
2b1h
2b1j
2b1k
2b1m
2b1n
2b1p
2b1q
2b1s
2b1t
2b1v
2b1w
2b1x
2b1y
2b1z
2c1\~n
2c1b
2c1c
2c1d
2c1f
2c1g
2c1j
2c1k
2c1m
2c1n
2c1p
2c1q
2c1s
2c1t
2c1v
2c1w
2c1x
2c1y
2c1z
2d1\~n
2d1b
2d1c
2d1d
2d1f
2d1g
2d1h
2d1j
2d1k
2d1m
2d1n
2d1p
2d1q
2d1s
2d1t
2d1v
2d1w
2d1x
2d1y
2d1z
2e.
2e\'a.
2e\'e.
2e\'i.
2e\'o.
2e\'u.
2ea.
2ee.
2ei.
2eo.
2eu.
2f1\~n
2f1b
2f1c
2f1d
2f1f
2f1g
2f1h
2f1j
2f1k
2f1m
2f1n
2f1p
2f1q
2f1s
2f1t
2f1v
2f1w
2f1x
2f1y
2f1z
2g1\~n
2g1b
2g1c
2g1d
2g1f
2g1g
2g1h
2g1j
2g1k
2g1m
2g1n
2g1p
2g1q
2g1s
2g1t
2g1v
2g1w
2g1x
2g1y
2g1z
2h1\~n
2h1b
2h1c
2h1d
2h1f
2h1g
2h1h
2h1j
2h1k
2h1m
2h1n
2h1p
2h1q
2h1s
2h1t
2h1v
2h1w
2h1x
2h1y
2h1z
2i.
2i\'a.
2i\'e.
2i\'i.
2i\'o.
2i\'u.
2ia.
2ie.
2ii.
2io.
2iu.
2j1\~n
2j1b
2j1c
2j1d
2j1f
2j1g
2j1h
2j1j
2j1k
2j1m
2j1n
2j1p
2j1q
2j1s
2j1t
2j1v
2j1w
2j1x
2j1y
2j1z
2k1\~n
2k1b
2k1c
2k1d
2k1f
2k1g
2k1h
2k1j
2k1k
2k1m
2k1n
2k1p
2k1q
2k1s
2k1t
2k1v
2k1w
2k1x
2k1y
2k1z
2l1\~n
2l1b
2l1c
2l1d
2l1f
2l1g
2l1h
2l1j
2l1k
2l1m
2l1n
2l1p
2l1q
2l1s
2l1t
2l1v
2l1w
2l1x
2l1y
2l1z
2m1\~n
2m1b
2m1c
2m1d
2m1f
2m1g
2m1h
2m1j
2m1k
2m1l
2m1m
2m1n
2m1p
2m1q
2m1r
2m1s
2m1t
2m1v
2m1w
2m1x
2m1y
2m1z
2n1\~n
2n1b
2n1c
2n1d
2n1f
2n1g
2n1h
2n1j
2n1k
2n1l
2n1m
2n1n
2n1p
2n1q
2n1r
2n1s
2n1t
2n1v
2n1w
2n1x
2n1y
2n1z
2o.
2o\'a.
2o\'e.
2o\'i.
2o\'o.
2o\'u.
2oa.
2oe.
2oi.
2oo.
2ou.
2p1\~n
2p1b
2p1c
2p1d
2p1f
2p1g
2p1h
2p1j
2p1k
2p1m
2p1n
2p1p
2p1q
2p1s
2p1t
2p1v
2p1w
2p1x
2p1y
2p1z
2q1\~n
2q1b
2q1c
2q1d
2q1f
2q1g
2q1h
2q1j
2q1k
2q1m
2q1n
2q1p
2q1q
2q1s
2q1t
2q1v
2q1w
2q1x
2q1y
2q1z
2r1\~n
2r1b
2r1c
2r1d
2r1f
2r1g
2r1h
2r1j
2r1k
2r1m
2r1n
2r1p
2r1q
2r1s
2r1t
2r1v
2r1w
2r1x
2r1y
2r1z
2s1\~n
2s1b
2s1c
2s1d
2s1f
2s1g
2s1h
2s1j
2s1k
2s1m
2s1n
2s1p
2s1q
2s1s
2s1t
2s1v
2s1w
2s1x
2s1y
2s1z
2t1\~n
2t1b
2t1c
2t1d
2t1f
2t1g
2t1h
2t1j
2t1k
2t1m
2t1n
2t1p
2t1q
2t1s
2t1t
2t1v
2t1w
2t1x
2t1y
2t1z
2u.
2u\'a.
2u\'e.
2u\'i.
2u\'o.
2u\'u.
2ua.
2ue.
2ui.
2uo.
2uu.
2v1\~n
2v1b
2v1c
2v1d
2v1f
2v1g
2v1h
2v1j
2v1k
2v1m
2v1n
2v1p
2v1q
2v1s
2v1t
2v1v
2v1w
2v1x
2v1y
2v1z
2w1\~n
2w1b
2w1c
2w1d
2w1f
2w1g
2w1h
2w1j
2w1k
2w1m
2w1n
2w1p
2w1q
2w1s
2w1t
2w1v
2w1w
2w1x
2w1y
2w1z
2x1\~n
2x1b
2x1c
2x1d
2x1f
2x1g
2x1h
2x1j
2x1k
2x1m
2x1n
2x1p
2x1q
2x1s
2x1t
2x1v
2x1w
2x1x
2x1y
2x1z
2y1\~n
2y1b
2y1c
2y1d
2y1f
2y1g
2y1h
2y1j
2y1k
2y1m
2y1n
2y1p
2y1q
2y1s
2y1t
2y1v
2y1w
2y1x
2y1y
2y1z
2z1\~n
2z1b
2z1c
2z1d
2z1f
2z1g
2z1h
2z1j
2z1k
2z1m
2z1n
2z1p
2z1q
2z1s
2z1t
2z1v
2z1w
2z1x
2z1y
2z1z
\'a1\'i
\'a1\'u
\'a1\~n
\'a1a
\'a1b
\'a1c
\'a1d
\'a1e
\'a1f
\'a1g
\'a1h
\'a1j
\'a1k
\'a1l
\'a1m
\'a1n
\'a1o
\'a1p
\'a1q
\'a1r
\'a1s
\'a1t
\'a1v
\'a1w
\'a1x
\'a1y
\'a1z
\'a2\~n.
\'a2b.
\'a2c.
\'a2d.
\'a2f.
\'a2g.
\'a2h.
\'a2j.
\'a2k.
\'a2l.
\'a2m.
\'a2n.
\'a2p.
\'a2q.
\'a2r.
\'a2s.
\'a2t.
\'a2v.
\'a2w.
\'a2x.
\'a2y.
\'a2z.
\'e1\'i
\'e1\'u
\'e1\~n
\'e1a
\'e1b
\'e1c
\'e1d
\'e1e
\'e1f
\'e1g
\'e1h
\'e1j
\'e1k
\'e1l
\'e1m
\'e1n
\'e1o
\'e1p
\'e1q
\'e1r
\'e1s
\'e1t
\'e1v
\'e1w
\'e1x
\'e1y
\'e1z
\'e2\~n.
\'e2b.
\'e2c.
\'e2d.
\'e2f.
\'e2g.
\'e2h.
\'e2j.
\'e2k.
\'e2l.
\'e2m.
\'e2n.
\'e2p.
\'e2q.
\'e2r.
\'e2s.
\'e2t.
\'e2v.
\'e2w.
\'e2x.
\'e2y.
\'e2z.
\'i1\'a
\'i1\'e
\'i1\'o
\'i1\~n
\'i1a
\'i1b
\'i1c
\'i1d
\'i1e
\'i1f
\'i1g
\'i1h
\'i1j
\'i1k
\'i1l
\'i1m
\'i1n
\'i1o
\'i1p
\'i1q
\'i1r
\'i1s
\'i1t
\'i1v
\'i1w
\'i1x
\'i1y
\'i1z
\'i2\~n.
\'i2b.
\'i2c.
\'i2d.
\'i2f.
\'i2g.
\'i2h.
\'i2j.
\'i2k.
\'i2l.
\'i2m.
\'i2n.
\'i2p.
\'i2q.
\'i2r.
\'i2s.
\'i2t.
\'i2v.
\'i2w.
\'i2x.
\'i2y.
\'i2z.
\'o1\'i
\'o1\'u
\'o1\~n
\'o1a
\'o1b
\'o1c
\'o1d
\'o1e
\'o1f
\'o1g
\'o1h
\'o1j
\'o1k
\'o1l
\'o1m
\'o1n
\'o1o
\'o1p
\'o1q
\'o1r
\'o1s
\'o1t
\'o1v
\'o1w
\'o1x
\'o1y
\'o1z
\'o2\~n.
\'o2b.
\'o2c.
\'o2d.
\'o2f.
\'o2g.
\'o2h.
\'o2j.
\'o2k.
\'o2l.
\'o2m.
\'o2n.
\'o2p.
\'o2q.
\'o2r.
\'o2s.
\'o2t.
\'o2v.
\'o2w.
\'o2x.
\'o2y.
\'o2z.
\'u1\'a
\'u1\'e
\'u1\'o
\'u1\~n
\'u1a
\'u1b
\'u1c
\'u1d
\'u1e
\'u1f
\'u1g
\'u1h
\'u1j
\'u1k
\'u1l
\'u1m
\'u1n
\'u1o
\'u1p
\'u1q
\'u1r
\'u1s
\'u1t
\'u1v
\'u1w
\'u1x
\'u1y
\'u1z
\'u2\~n.
\'u2b.
\'u2c.
\'u2d.
\'u2f.
\'u2g.
\'u2h.
\'u2j.
\'u2k.
\'u2l.
\'u2m.
\'u2n.
\'u2p.
\'u2q.
\'u2r.
\'u2s.
\'u2t.
\'u2v.
\'u2w.
\'u2x.
\'u2y.
\'u2z.
a1\'a
a1\'e
a1\'i
a1\'o
a1\'u
a1\~n
a1a
a1b
a1c
a1d
a1e
a1f
a1g
a1h
a1j
a1k
a1l
a1m
a1n
a1o
a1p
a1q
a1r
a1s
a1t
a1v
a1w
a1x
a1y
a1z
a2\~n.
a2b.
a2c.
a2d.
a2f.
a2g.
a2h.
a2j.
a2k.
a2l.
a2m.
a2n.
a2p.
a2q.
a2r.
a2s.
a2t.
a2v.
a2w.
a2x.
a2y.
a2z.
e1\'a
e1\'e
e1\'i
e1\'o
e1\'u
e1\~n
e1a
e1b
e1c
e1d
e1e
e1f
e1g
e1h
e1j
e1k
e1l
e1m
e1n
e1o
e1p
e1q
e1r
e1s
e1t
e1v
e1w
e1x
e1y
e1z
e2\~n.
e2b.
e2c.
e2d.
e2f.
e2g.
e2h.
e2j.
e2k.
e2l.
e2m.
e2n.
e2p.
e2q.
e2r.
e2s.
e2t.
e2v.
e2w.
e2x.
e2y.
e2z.
i1\~n
i1b
i1c
i1d
i1f
i1g
i1h
i1j
i1k
i1l
i1m
i1n
i1p
i1q
i1r
i1s
i1t
i1v
i1w
i1x
i1y
i1z
i2\~n.
i2b.
i2c.
i2d.
i2f.
i2g.
i2h.
i2j.
i2k.
i2l.
i2m.
i2n.
i2p.
i2q.
i2r.
i2s.
i2t.
i2v.
i2w.
i2x.
i2y.
i2z.
o1\'a
o1\'e
o1\'i
o1\'o
o1\'u
o1\~n
o1a
o1b
o1c
o1d
o1e
o1f
o1g
o1h
o1j
o1k
o1l
o1m
o1n
o1o
o1p
o1q
o1r
o1s
o1t
o1v
o1w
o1x
o1y
o1z
o2\~n.
o2b.
o2c.
o2d.
o2f.
o2g.
o2h.
o2j.
o2k.
o2l.
o2m.
o2n.
o2p.
o2q.
o2r.
o2s.
o2t.
o2v.
o2w.
o2x.
o2y.
o2z.
u1\~n
u1b
u1c
u1d
u1f
u1g
u1h
u1j
u1k
u1l
u1m
u1n
u1p
u1q
u1r
u1s
u1t
u1v
u1w
u1x
u1y
u1z
u2\~n.
u2b.
u2c.
u2d.
u2f.
u2g.
u2h.
u2j.
u2k.
u2l.
u2m.
u2n.
u2p.
u2q.
u2r.
u2s.
u2t.
u2v.
u2w.
u2x.
u2y.
u2z.

%%%%%%%%%%%%%%%%%%%% file ithyph.tex

%%%%%%%%%%%%%%%%%%%%%%%%%%%  file ithyph.tex  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Prepared by Claudio Beccari   e-mail  beccari@polito.it
%
%                                       Dipartimento di Elettronica
%                                       Politecnico di Torino
%                                       Corso Duca degli Abruzzi, 24
%                                       10129 TORINO
%
% Copyright  1998, 2001 Claudio Beccari
%
% This program can be redistributed and/or modified under the terms
% of the LaTeX Project Public License Distributed from CTAN
% archives in directory macros/latex/base/lppl.txt; either
% version 1 of the License, or any later version.
%
% \versionnumber{4.8d}   \versiondate{2001/11/21}
%
% These hyphenation patterns for the Italian language are supposed to comply
% with the Reccomendation UNI 6461 on hyphenation issued by the Italian
% Standards Institution (Ente Nazionale di Unificazione UNI).  No guarantee
% or declaration of fitness to any particular purpose is given and any
% liability is disclaimed.
%
% See comments and loading instructions at the end of the file after the
% \endinput line
%
{\lccode`\'=`\'      % Apostrophe has its own lccode so that it is treated
                     % as a letter
                     %>> 1998/04/14 inserted grouping
                     %
%\lccode23=23        % Compound word mark is a letter in encoding T1
%\def\W{^^W}         % ^^W =\char23 = \char"17 =\char'27
%
\patterns{
.a3p2n               % After the Garzanti dictionary: a-pnea, a-pnoi-co,...
.anti1  .anti3m2n
.bio1
.ca4p3s
.circu2m1
.di2s3cine
%.e2x
.fran2k3
.free3
.narco1
.opto1
.orto3p2
.para1
.poli3p2
.pre1
.p2s
%.ri1a2   .ri1e2    .re1i2  .ri1o2  .ri1u2
.sha2re3
.tran2s3c .tran2s3d .tran2s3f .tran2s3l .tran2s3n .tran2s3p .tran2s3r .tran2s3t
.su2b3lu   .su2b3r
.wa2g3n
.wel2t1
a1ia a1ie  a1io  a1iu a1uo a1ya 2at.
e1iu e2w
o1ia o1ie  o1io  o1iu
%u1u
%
%1\W0a2 1\W0e2 1\W0i2 1\W0o2 1\W0u2
'2
1b   2bb   2bc   2bd  2bf  2bm  2bn  2bp  2bs  2bt  2bv
     b2l   b2r   2b.  2b'. 2b''
1c   2cb   2cc   2cd  2cf  2ck  2cm  2cn  2cq  2cs  2ct  2cz
     2chh  c2h   2chb ch2r 2chn c2l  c2r  2c.  2c'. 2c'' .c2
1d   2db   2dd   2dg  2dl  2dm  2dn  2dp  d2r  2ds  2dt  2dv  2dw
     2d.   2d'.  2d'' .d2
1f   2fb   2fg   2ff  2fn  f2l  f2r  2fs  2ft  2f.  2f'. 2f''
1g   2gb   2gd   2gf  2gg  g2h  g2l  2gm  g2n  2gp  g2r  2gs  2gt
     2gv   2gw   2gz  2gh2t     2g.  2g'. 2g''
1h   2hb   2hd   2hh  hi3p2n    h2l  2hm  2hn  2hr  2hv  2h.  2h'.  2h''
1j   2j.   2j'.  2j''
1k   2kg   2kf   k2h  2kk  k2l  2km  k2r  2ks  2kt  2k.  2k'. 2k''
1l   2lb   2lc   2ld  2l3f2     2lg  l2h  2lk  2ll  2lm  2ln  2lp
     2lq   2lr   2ls  2lt  2lv  2lw  2lz  2l.  2l'. 2l''
1m   2mb   2mc   2mf  2ml  2mm  2mn  2mp  2mq  2mr  2ms  2mt  2mv  2mw
     2m.   2m'.  2m''
1n   2nb   2nc   2nd  2nf  2ng  2nk  2nl  2nm  2nn  2np  2nq  2nr
     2ns   2nt   2nv  2nz  n2g3n     2nheit.   2n.  2n'  2n''
1p   2pd   p2h   p2l  2pn  3p2ne 2pp p2r  2ps  3p2sic 2pt  2pz  2p.  2p'. 2p''
1q   2qq   2q.   2q'. 2q''
1r   2rb   2rc   2rd  2rf  r2h  2rg  2rk  2rl  2rm  2rn  2rp
     2rq   2rr   2rs  2rt  rt2s3 2rv 2rx  2rw  2rz  2r.  2r'. 2r''
1s2  2shm  2s3s  s4s3m 2s3p2n   2stb 2stc 2std 2stf 2stg 2stm 2stn
     2stp  2sts  2stt 2stv 2sz  4s.  4s'. 4s''
1t   2tb   2tc   2td  2tf  2tg  t2h  t2l  2tm  2tn  2tp  t2r  2ts
     3t2sch      2tt  2tv  2tw  t2z  2tzk 2tzs 2t.  2t'. 2t''
1v   2vc   v2l   v2r  2vv  2v.  2v'. 2v''
1w   w2h   wa2r  2w1y 2w.  2w'. 2w''
1x   2xt   2xw   2x.   2x'. 2x''
y1ou y1i
1z   2zb   2zd   2zl  2zn  2zp  2zt  2zs  2zv  2zz  2z.  2z'. 2z''  .z2
}}                          % Pattern end

\endinput

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Information %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


                           LOADING THESE PATTERNS

These patterns, as well  as  those  for  any  other  language, do not become
effective until they are loaded in a special form into a format  file;  this
task  is  performed  by  the  TeX  initializer;  any  TeX system has its own
initializer with its special way  of  being activated.  Before loading these
patterns, then, it is necessary to read very carefully the instructions that
come with your TeX system.

Here I describe how to load the  patterns with the freeware TeX system named
MiKTeX version 2.x for Windows 9x, NT, 2000,  XP;  with  minor  changes  the
whole  procedure  is applicable with other TeX systems, but the details must
be deduced from your TeX system documentation at the section/chapter "How to
build or to rebuild a format file".

With MikTeX:

a) copy this file and replace  the existing file ithyph.tex in the directory
   \texmf\tex\generic\hyphen if the existing one has an older  version  date
   and number.
b) select Start|Programs|MiKTeX|MiKTeX options.
c) in  the  Language tab add a check mark to the line concerning the Italian
   language.
d) in the Geneal tab click "Update format files".
e) That's all!  

For the activation of these  patterns  with the specific Italian typesetting
features, use the babel package as this:

\documentclass{article} % Or whatever other class
\usepackage[italian]{babel}
...
\begin{document}
...
\end{document}


                           ON ITALIAN HYPHENATION

I have been working on patterns for the Italian language since 1987; in 1992
I published

C. Beccari, "Computer aided hyphenation for Italian and Modern
      Latin", TUG vol. 13, n. 1, pp. 23-33 (1992)

which contained a set of patterns that allowed hyphenation for both  Italian
and  Latin;  a  slightly  modified  version of the patterns published in the
above paper is contained in LAHYPH.TEX available on the CTAN archives.

From  the  above  patterns  I  extracted  the  minimum  set  necessary   for
hyphenating  Italian  that  was made available on the CTAN archives with the
name ITHYPH.tex the version number  3.5  on  the  16th of August 1994.  

The  original  pattern  set  required  37  ops;  being interested in a local
version of TeX/LaTeX  capable  of  dealing  with  half  a dozen languages, I
wanted to reduce memory occupation and therefore the number of ops.

Th new version (4.0 released  in  1996)  of  ITHYPH.TEX is much simpler than
version 3.5 and requires just 29 ops while  it  retains  all  the  power  of
version  3.5;  it  contains  many  more new patterns that allow to hyphenate
unusual words that generally have  a  root borrowed from a foreign language.
Updated versions 4.x contain minor  additions  and  the  number  of  ops  is
increased to 30 (version 4.7 of 1998/06/01).

This new pattern set has been tested  with the same set of difficult Italian
words that was used to test version 3.5 and it yields the  same  results  (a
part  a  minor  change  that was deliberately introduced so as to reduce the
typographical hyphenation  with  hyathi,  since  hyphenated  hyathi  are not
appreciated by Italian readers).   A  new  enlarged  word  set  for  testing
purposes  gets correct hyphen points that were missed or wrongly placed with
version 3.5, although no error had  been reported, because such words are of
very specialized nature and are seldom used.

As the previous version, this new set  of  patterns  does  not  contain  any
accented  character  so  that  the hyphenation algorithm behaves properly in
both cases, that is with cm  and  with dc/ec fonts.  With LaTeXe terminology
the difference is between OT1 and T1 encodings;  with  the  former  encoding
fonts  do  not  contain  accented characters, while with the latter accented
characters are present and sequences  such  as  \`a map directly to slot "E0
that contains "agrave".

Of course if you use dc/ec fonts (or any other real or virtual font with  T1
encoding)  you get the full power of the hyphenation algorithm, while if you
use cm fonts (or any other real or virtual font with OT1 encoding) you  miss
some  possible  break  points;  this  is  not a big inconvenience in Italian
because:

1) The Regulation UNI 6015 on  accents  specifies  that  compulsory  accents
   appear  only  on the ending vowel of oxitone words; this means that it is
   almost indifferent to have or  to  miss  the dc/ec fonts because the only
   difference consists in how TeX evaluates the end of the word; in practice
   if you have these special facilities you get "qua-li-t\`a", while if  you
   miss them, you get "qua-lit\`a" (assuming that \righthyphenmin > 1).

2)  Optional  accents are so rare in Italian, that if you absolutely want to
   use  them  in  those  rare  instances,  and  you  miss  the  T1  encoding
   facilities, you should also provide  explicit discretionary hyphens as in
   "s\'e\-gui\-to".

There is no explicit  hyphenation  exception  list  because  these  patterns
proved  to  hyphenate correctly a very large set of words suitably chosen in
order to test them in the most heavy circumstances; these patterns were used
in the preparation of a number of books and no errors were discovered.

Nevertheless if you frequently use  technical terms that you want hyphenated
differently  from  what  is  normally  done  (for  example  if  you   prefer
etymological  hyphenation  of  prefixed  and/or  suffixed  words) you should
insert a specific hyphenation  list  in  the  preamble of your document, for
example:

\hyphenation{su-per-in-dut-to-re su-per-in-dut-to-ri}

Should you find any word that gets hyphenated in a wrong way, please, AFTER
CHECKING ON A RELIABLE MODERN DICTIONARY, report to the author, preferably
by e-mail.


                       Happy multilingual typesetting !
adjust.tcl {F 21021 137097} expander.tcl {F 28215 116076} tabify.tcl {F 9970 83740} textutil.tcl {F 4413 73770} eshyph_vo.tex {F 6121 15692} split.tcl {F 3394 87134} trim.tcl {F 2320 69357} dehypht.tex {F 51345 67037} ithyph.tex {F 9571 9571} pkgIndex.tcl {F 727 87861}trofs01

# htmlparse.tcl --
#
#	This file implements a simple HTML parsing library in Tcl.
#	It may take advantage of parsers coded in C in the future.
#
#	The functionality here is a subset of the
#
#		Simple HTML display library by Stephen Uhler (stephen.uhler@sun.com)
#		Copyright (c) 1995 by Sun Microsystems
#		Version 0.3 Fri Sep  1 10:47:17 PDT 1995
#
#	The main restriction is that all Tk-related code in the above
#	was left out of the code here. It is expected that this code
#	will go into a 'tklib' in the future.
#
# Copyright (c) 2001 by ActiveState Tool Corp.
# See the file license.terms.

package require Tcl       8.2
#package require struct    2
package require struct::stack	1.3
package require cmdline   1.1

namespace eval ::htmlparse {
    namespace export		\
	    parse		\
	    debugCallback	\
	    mapEscapes		\
	    2tree		\
	    removeVisualFluff	\
	    removeFormDefs

    # Table of escape characters. Maps from their names to the actual
    # character.  See http://htmlhelp.org/reference/html40/entities/

    variable namedEntities

    # I. Latin-1 Entities (HTML 4.01)
    array set namedEntities {
	nbsp \xa0 iexcl \xa1 cent \xa2 pound \xa3 curren \xa4
	yen \xa5 brvbar \xa6 sect \xa7 uml \xa8 copy \xa9
	ordf \xaa laquo \xab not \xac shy \xad reg \xae
	macr \xaf deg \xb0 plusmn \xb1 sup2 \xb2 sup3 \xb3
	acute \xb4 micro \xb5 para \xb6 middot \xb7 cedil \xb8
	sup1 \xb9 ordm \xba raquo \xbb frac14 \xbc frac12 \xbd
	frac34 \xbe iquest \xbf Agrave \xc0 Aacute \xc1 Acirc \xc2
	Atilde \xc3 Auml \xc4 Aring \xc5 AElig \xc6 Ccedil \xc7
	Egrave \xc8 Eacute \xc9 Ecirc \xca Euml \xcb Igrave \xcc
	Iacute \xcd Icirc \xce Iuml \xcf ETH \xd0 Ntilde \xd1
	Ograve \xd2 Oacute \xd3 Ocirc \xd4 Otilde \xd5 Ouml \xd6
	times \xd7 Oslash \xd8 Ugrave \xd9 Uacute \xda Ucirc \xdb
	Uuml \xdc Yacute \xdd THORN \xde szlig \xdf agrave \xe0
	aacute \xe1 acirc \xe2 atilde \xe3 auml \xe4 aring \xe5
	aelig \xe6 ccedil \xe7 egrave \xe8 eacute \xe9 ecirc \xea
	euml \xeb igrave \xec iacute \xed icirc \xee iuml \xef
	eth \xf0 ntilde \xf1 ograve \xf2 oacute \xf3 ocirc \xf4
	otilde \xf5 ouml \xf6 divide \xf7 oslash \xf8 ugrave \xf9
	uacute \xfa ucirc \xfb uuml \xfc yacute \xfd thorn \xfe
	yuml \xff
    }

    # II. Entities for Symbols and Greek Letters (HTML 4.01)
    array set namedEntities {
	fnof \u192 Alpha \u391 Beta \u392 Gamma \u393 Delta \u394
	Epsilon \u395 Zeta \u396 Eta \u397 Theta \u398 Iota \u399
	Kappa \u39A Lambda \u39B Mu \u39C Nu \u39D Xi \u39E
	Omicron \u39F Pi \u3A0 Rho \u3A1 Sigma \u3A3 Tau \u3A4
	Upsilon \u3A5 Phi \u3A6 Chi \u3A7 Psi \u3A8 Omega \u3A9
	alpha \u3B1 beta \u3B2 gamma \u3B3 delta \u3B4 epsilon \u3B5
	zeta \u3B6 eta \u3B7 theta \u3B8 iota \u3B9 kappa \u3BA
	lambda \u3BB mu \u3BC nu \u3BD xi \u3BE omicron \u3BF
	pi \u3C0 rho \u3C1 sigmaf \u3C2 sigma \u3C3 tau \u3C4
	upsilon \u3C5 phi \u3C6 chi \u3C7 psi \u3C8 omega \u3C9
	thetasym \u3D1 upsih \u3D2 piv \u3D6 bull \u2022
	hellip \u2026 prime \u2032 Prime \u2033 oline \u203E
	frasl \u2044 weierp \u2118 image \u2111 real \u211C
	trade \u2122 alefsym \u2135 larr \u2190 uarr \u2191
	rarr \u2192 darr \u2193 harr \u2194 crarr \u21B5
	lArr \u21D0 uArr \u21D1 rArr \u21D2 dArr \u21D3 hArr \u21D4
	forall \u2200 part \u2202 exist \u2203 empty \u2205
	nabla \u2207 isin \u2208 notin \u2209 ni \u220B prod \u220F
	sum \u2211 minus \u2212 lowast \u2217 radic \u221A
	prop \u221D infin \u221E ang \u2220 and \u2227 or \u2228
	cap \u2229 cup \u222A int \u222B there4 \u2234 sim \u223C
	cong \u2245 asymp \u2248 ne \u2260 equiv \u2261 le \u2264
	ge \u2265 sub \u2282 sup \u2283 nsub \u2284 sube \u2286
	supe \u2287 oplus \u2295 otimes \u2297 perp \u22A5
	sdot \u22C5 lceil \u2308 rceil \u2309 lfloor \u230A
	rfloor \u230B lang \u2329 rang \u232A loz \u25CA
	spades \u2660 clubs \u2663 hearts \u2665 diams \u2666
    }

    # III. Special Entities (HTML 4.01)
    array set namedEntities {
	quot \x22 amp \x26 lt \x3C gt \x3E OElig \u152 oelig \u153
	Scaron \u160 scaron \u161 Yuml \u178 circ \u2C6
	tilde \u2DC ensp \u2002 emsp \u2003 thinsp \u2009
	zwnj \u200C zwj \u200D lrm \u200E rlm \u200F ndash \u2013
	mdash \u2014 lsquo \u2018 rsquo \u2019 sbquo \u201A
	ldquo \u201C rdquo \u201D bdquo \u201E dagger \u2020
	Dagger \u2021 permil \u2030 lsaquo \u2039 rsaquo \u203A
	euro \u20AC
    }

    # Internal cache for the foreach variable-lists and the
    # substitution strings used to split a HTML string into
    # incrementally handleable scripts. This should reduce the
    # time compute this information for repeated calls with the same
    # split-factor. The array is indexed by a combination of the
    # numerical split factor and the length of the command prefix and
    # maps this to a 2-element list containing variable- and
    # subst-string.

    variable  splitdata
    array set splitdata {}

}

# htmlparse::parse --
#
#	This command is the basic parser for HTML. It takes a HTML
#	string, parses it and invokes a command prefix for every tag
#	encountered. It is not necessary for the HTML to be valid for
#	this parser to function. It is the responsibility of the
#	command invoked for every tag to check this. Another
#	responsibility of the invoked command is the handling of tag
#	attributes and character entities (escaped characters). The
#	parser provides the un-interpreted tag attributes to the
#	invoked command to aid in the former, and the package at large
#	provides a helper command, '::htmlparse::mapEscapes', to aid
#	in the handling of the latter. The parser *does* ignore
#	leading DOCTYPE declarations and all valid HTML comments it
#	encounters.
#
#	All information beyond the HTML string itself is specified via
#	options, these are explained below.
#
#	To help understanding the options some more background
#	information about the parser.
#
#	It is capable to detect incomplete tags in the HTML string
#	given to it. Under normal circumstances this will cause the
#	parser to throw an error, but if the option '-incvar' is used
#	to specify a global (or namespace) variable the parser will
#	store the incomplete part of the input into this variable
#	instead. This will aid greatly in the handling of
#	incrementally arriving HTML as the parser will handle whatever
#	he can and defer the handling of the incomplete part until
#	more data has arrived.
#
#	Another feature of the parser are its two possible modes of
#	operation. The normal mode is activated if the option '-queue'
#	is not present on the command line invoking the parser. If it
#	is present the parser will go into the incremental mode instead.
#
#	The main difference is that a parser in normal mode will
#	immediately invoke the command prefix for each tag it
#	encounters. In incremental mode however the parser will
#	generate a number of scripts which invoke the command prefix
#	for groups of tags in the HTML string and then store these
#	scripts in the specified queue. It is then the responsibility
#	of the caller of the parser to ensure the execution of the
#	scripts in the queue.
#
#	Note: The queue objecct given to the parser has to provide the
#	same interface as the queue defined in tcllib -> struct. This
#	does for example mean that all queues created via that part of
#	tcllib can be immediately used here. Still, the queue doesn't
#	have to come from tcllib -> struct as long as the same
#	interface is provided.
#
#	In both modes the parser will return an empty string to the
#	caller.
#
#	To a parser in incremental mode the option '-split' can be
#	given and will specify the size of the groups he creates. In
#	other words, -split 5 means that each of the generated scripts
#	will invoke the command prefix for 5 consecutive tags in the
#	HTML string. A parser in normal mode will ignore this option
#	and its value.
#
#	The option '-vroot' specifies a virtual root tag. A parser in
#	normal mode will invoke the command prefix for it immediately
#	before and after he processes the tags in the HTML, thus
#	simulating that the HTML string is enclosed in a <vroot>
#	</vroot> combination. In incremental mode however the parser
#	is unable to provide the closing virtual root as he never
#	knows when the input is complete. In this case the first
#	script generated by each invocation of the parser will contain
#	an invocation of the command prefix for the virtual root as
#	its first command.
#
#	Interface to the command prefix:
#
#	In normal mode the parser will invoke the command prefix with
#	for arguments appended. See '::htmlparse::debugCallback' for a
#	description. In incremental mode however the generated scripts
#	will invoke the command prefix with five arguments
#	appended. The last four of these are the same which were
#	mentioned above. The first however is a placeholder string
#	(\win\) for a clientdata value to be supplied later during the
#	actual execution of the generated scripts. This could be a tk
#	window path, for example. This allows the user of this package
#	to preprocess HTML strings without commiting them to a
#	specific window, object, whatever during parsing. This
#	connection can be made later. This also means that it is
#	possible to cache preprocessed HTML. Of course, nothing
#	prevents the user of the parser to replace the placeholder
#	with an empty string.
#
# Arguments:
#	args	An option/value-list followed by the string to
#		parse. Available options are:
#
#		-cmd	The command prefix to invoke for every tag in
#			the HTML string. Defaults to
#			'::htmlparse::debugCallback'.
#
#		-vroot	The virtual root tag to add around the HTML in
#			normal mode. In incremental mode it is the
#			first tag in each chunk processed by the
#			parser, but there will be no closing tags.
#			Defaults to 'hmstart'.
#
#		-split	The size of the groups produced by an
#			incremental mode parser. Ignored when in
#			normal mode. Defaults to 10. Values <= 0 are
#			not allowed.
#
#		-incvar	The name of the variable where to store any
#			incomplete HTML into. Optional.
#
#		-queue
#			The handle/name of the queue objecct to store
#			the generated scripts into. Activates
#			incremental mode. Normal mode is used if this
#			option is not present.
#
#		After the option the command explect a single argument
#		containing the HTML string to parse.
#
# Side Effects:
#	In normal mode as of the invoked command. Else none.
#
# Results:
#	None.

proc ::htmlparse::parse {args} {
    # Convert the HTML string into a evaluable command sequence.

    variable splitdata

    # Option processing, start with the defaults, then run through the
    # list of arguments.

    set cmd    ::htmlparse::debugCallback
    set vroot  hmstart
    set incvar ""
    set split  10
    set queue  ""

    while {[set err [cmdline::getopt args {cmd.arg vroot.arg incvar.arg split.arg queue.arg} opt arg]]} {
	if {$err < 0} {
	    return -code error "::htmlparse::parse : $arg"
	}
	switch -exact -- $opt {
	    cmd    -
	    vroot  -
	    incvar -
	    queue  {
		if {[string length $arg] == 0} {
		    return -code error "::htmlparse::parse : -$opt illegal argument (empty)"
		}
		# Each option has an variable with the same name associated with it.
		# FRINK: nocheck
		set $opt $arg
	    }
	    split  {
		if {$arg <= 0} {
		    return -code error "::htmlparse::parse : -split illegal argument (<= 0)"
		}
		set split $arg
	    }
	    default {# Can't happen}
	}
    }

    if {[llength $args] > 1} {
	return -code error "::htmlparse::parse : to many arguments behind the options, expected one"
    }
    if {[llength $args] < 1} {
	return -code error "::htmlparse::parse : html string missing"
    }

    set html [PrepareHtml [lindex $args 0]]

    # Look for incomplete HTML from the last iteration and prepend it
    # to the input we just got.

    if {$incvar != {}} {
	upvar $incvar incomplete
    } else {
	set incomplete ""
    }

    if {[catch {set new $incomplete$html}]} {set new $html}
    set html $new

    # Handle incomplete HTML (Recognize incomplete tag at end, buffer
    # it up for the next call).

    set end [lindex \{$html\} end]
    if {[set idx [string last < $end]] > [string last > $end]} {

	if {$incvar == {}} {
	    return -code error "::htmlparse::parse : HTML is incomplete, option -incvar is missing"
	}

	#  upvar $incvar incomplete -- Already done, s.a.
	set incomplete [string range $end $idx end]
	incr idx -1
	set html       [string range $end 0 $idx]
	
    } else {
	set incomplete ""
    }

    # Convert the HTML string into a script.

    set sub "\}\n$cmd {\\1} {} {\\2} \{\}\n$cmd {\\1} {/} {} \{"
    regsub -all -- {<([^\s>]+)\s*([^>]*)/>} $html $sub html

    set sub "\}\n$cmd {\\2} {\\1} {\\3} \{"
    regsub -all -- {<(/?)([^\s>]+)\s*([^>]*)>} $html $sub html

    # The value of queue now determines wether we process the HTML by
    # ourselves (queue is empty) or if we generate a list of  scripts
    # each of which processes n tags, n the argument to -split.

    if {$queue == {}} {
	# And evaluate it. This is the main parsing step.

	eval "$cmd {$vroot} {} {} \{$html\}"
	eval "$cmd {$vroot} /  {} {}"
    } else {
	# queue defined, generate list of scripts doing small chunks of tags.

	set lcmd [llength $cmd]
	set key  $split,$lcmd

	if {![info exists splitdata($key)]} {
	    for {set i 0; set group {}} {$i < $split} {incr i} {
		# Use the length of the command prefix to generate
		# additional variables before the main variable after
		# which the placeholder will be inserted.

		for {set j 1} {$j < $lcmd} {incr j} {
		    append group "b${j}_$i "
		}

		append group "a$i c$i d$i e$i f$i\n"
	    }
	    regsub -all -- {(a[0-9]+)}          $group    {{$\1} \\\\win\\\\} subgroup
	    regsub -all -- {([b-z_0-9]+[0-9]+)} $subgroup {{$\1}}             subgroup

	    set splitdata($key) [list $group $subgroup]
	}

	foreach {group subgroup} $splitdata($key) break ; # lassign
	foreach $group "$cmd {$vroot} {} {} \{$html\}" {
	    $queue put [string trimright [subst $subgroup]]
	}
    }
    return
}

# htmlparse::PrepareHtml --
#
#	Internal helper command of '::htmlparse::parse'. Removes
#	leading DOCTYPE declarations and comments, protects the
#	special characters of tcl from evaluation.
#
# Arguments:
#	html	The HTML string to prepare
#
# Side Effects:
#	None.
#
# Results:
#	The provided HTML string with the described modifications
#	applied to it.

proc ::htmlparse::PrepareHtml {html} {
    # Remove the following items from the text:
    # - A leading	<!DOCTYPE...> declaration.
    # - All comments	<!-- ... -->
    #
    # Also normalize the line endings (\r -> \n).

    # Tcllib SF Bug 861287 - Processing of comments.
    # Recognize EOC by RE, instead of fixed string.

    set html [string map [list \r \n] $html]

    regsub -- "^.*<!DOCTYPE\[^>\]*>"    $html {}     html
    regsub -all -- "--(\[ \t\n\]*)>"      $html "\001\\1\002" html

    # Recognize borken beginnings of a comment and convert them to PCDATA.
    regsub -all -- "<--(\[^\001\]*)\001(\[^\002\]*)\002" $html {\&lt;--\1--\2\&gt;} html

    # And now recognize true comments, remove them.
    regsub -all -- "<!--\[^\001\]*\001(\[^\002\]*)\002"  $html {}                   html

    # Protect characters special to tcl (braces, slashes) by
    # converting them to their escape sequences.

    return [string map [list \
		    "\{" "&#123;" \
		    "\}" "&#125;" \
		    "\\" "&#92;"] $html]
}



# htmlparse::debugCallback --
#
#	The standard callback used by the parser in
#	'::htmlparse::parse' if none was specified by the user. Simply
#	dumps its arguments to stdout.  This callback can be used for
#	both normal and incremental mode of the calling parser. In
#	other words, it accepts four or five arguments. The last four
#	arguments are described below. The optional fifth argument
#	contains the clientdata value given to the callback by a
#	parser in incremental mode. All callbacks have to follow the
#	signature of this command in the last four arguments, and
#	callbacks used in incremental parsing have to follow this
#	signature in the last five arguments.
#
# Arguments:
#	tag			The name of the tag currently
#				processed by the parser.
#
#	slash			Either empty or a slash. Allows us to
#				distinguish between opening (slash is
#				empty) and closing tags (slash is
#				equal to a '/').
#
#	param			The un-interpreted list of parameters
#				to the tag.
#
#	textBehindTheTag	The text found by the parser behind
#				the tag named in 'tag'.
#
# Side Effects:
#	None.
#
# Results:
#	None.

proc ::htmlparse::debugCallback {args} {
    # args = ?clientData? tag slash param textBehindTheTag
    puts "==> $args"
    return
}

# htmlparse::mapEscapes --
#
#	Takes a HTML string, substitutes all escape sequences with
#	their actual characters and returns the resulting string.
#	HTML not containing escape sequences or invalid escape
#	sequences is returned unchanged.
#
# Arguments:
#	html	The string to modify
#
# Side Effects:
#	None.
#
# Results:
#	The argument string with all escape sequences replaced with
#	their actual characters.

proc ::htmlparse::mapEscapes {html} {
    # Find HTML escape characters of the form &xxx(;|EOW)

    # Quote special Tcl chars so they pass through [subst] unharmed.
    set new [string map [list \] \\\] \[ \\\[ \$ \\\$ \\ \\\\] $html]
    regsub -all -- {&([[:alnum:]]{2,7})(;|\M)} $new {[DoNamedMap \1 {\2}]} new
    regsub -all -- {&#([[:digit:]]{1,5})(;|\M)} $new {[DoDecMap \1 {\2}]} new
    regsub -all -- {&#x([[:xdigit:]]{1,4})(;|\M)} $new {[DoHexMap \1 {\2}]} new
    return [subst $new]
}

proc ::htmlparse::DoNamedMap {name endOf} {
    variable namedEntities
    if {[info exist namedEntities($name)]} {
	return $namedEntities($name)
    } else {
	# Put it back..
	return "&$name$endOf"
    }
}

proc ::htmlparse::DoDecMap {dec endOf} {
    scan $dec %d dec
    if {$dec <= 0xFFFD} {
	return [format %c $dec]
    } else {
	# Put it back..
	return "&#$dec$endOf"
    }
}

proc ::htmlparse::DoHexMap {hex endOf} {
    scan $hex %x value
    if {$value <= 0xFFFD} {
	return [format %c $value]
    } else {
	# Put it back..
	return "&#x$hex$endOf"
    }
}

# htmlparse::2tree --
#
#	This command is a wrapper around '::htmlparse::parse' which
#	takes a HTML string and converts it into a tree containing the
#	logical structure of the parsed document. The tree object has
#	to be created by the caller. It is also expected that the tree
#	object provides the same interface as the tree object from
#	tcllib -> struct. It doesn't have to come from that module
#	though. The internal callback does some basic checking of HTML
#	validity and tries to recover from the most basic errors.
#
# Arguments:
#	html	The HTML string to parse and convert.
#	tree	The name of the tree to fill.
#
# Side Effects:
#	Creates a tree object (see tcllib -> struct)
#	and modifies it.
#
# Results:
#	The contents of 'tree'.

proc ::htmlparse::2tree {html tree} {

    # One internal datastructure is required, a stack of open
    # tags. This stack is also provided by the 'struct' module of
    # tcllib. As the operation of this command is synchronuous we
    # don't have to take care against multiple running copies at the
    # same times (Such are possible, but will be in different
    # interpreters and true concurrency is possible only if they are
    # in different threads too). IOW, no need for tricks to make the
    # internal datastructure unique.

    catch {::htmlparse::tags destroy}

    ::struct::stack ::htmlparse::tags
    ::htmlparse::tags push root
    $tree set root type root

    parse -cmd [list ::htmlparse::2treeCallback $tree] $html

    # A bit hackish, correct the ordering of nodes for the optional
    # tag types, over a larger area when was seen by the parser itself.

    $tree walk root -order post n {
	::htmlparse::Reorder $tree $n
    }

    ::htmlparse::tags destroy
    return $tree
}

# htmlparse::2treeCallback --
#
#	Internal helper command. A special callback to
#	'::htmlparse::parse' used by '::htmlparse::2tree' which takes
#	the incoming stream of tags and converts them into a tree
#	representing the inner structure of the parsed HTML
#	document. Recovers from simple HTML errors like missing
#	opening tags, missing closing tags and overlapping tags.
#
# Arguments:
#	tree			The name of the tree to manipulate.
#	tag			See '::htmlparse::debugCallback'.
#	slash			See '::htmlparse::debugCallback'.
#	param			See '::htmlparse::debugCallback'.
#	textBehindTheTag	See '::htmlparse::debugCallback'.
#
# Side Effects:
#	Manipulates the tree object whose name was given as the first
#	argument.
#
# Results:
#	None.

proc ::htmlparse::2treeCallback {tree tag slash param textBehindTheTag} {
    # This could be table-driven I think but for now the switches
    # should work fine.

    # Normalize tag information for later comparisons. Also remove
    # superfluous whitespace. Don't forget to decode the standard
    # entities.

    set  tag  [string tolower $tag]
    set  textBehindTheTag [string trim $textBehindTheTag]
    if {$textBehindTheTag != {}} {
	set text [mapEscapes $textBehindTheTag]
    }

    if {"$slash" == "/"} {
	# Handle closing tags. Standard operation is to pop the tag
	# from the stack of open tags. We don't do this for </p> and
	# </li>. As they were optional they were never pushed onto the
	# stack (Well, actually they are just popped immediately after
	# they were pusheed, see below).

	switch -exact -- $tag {
	    base - option - meta - li - p {
		# Ignore, nothing to do.		
	    }
	    default {
		# The moment we get a closing tag which does not match
		# the tag on the stack we have two possibilities on how
		# this came into existence to choose from:
		#
		# a) A tag is now closed but was never opened.
		# b) A tag requiring an end tag was opened but the end
		#    tag was omitted and we now are at a tag which was
		#    opened before the one with the omitted end tag.

		# NOTE:
		# Pages delivered from the amazon.uk site contain both
		# cases: </a> without opening, <b> & <font> without
		# closing. Another error: <a><b></a></b>, i.e. overlapping
		# tags. Fortunately this can be handled by the algorithm
		# below, in two cycles, one of which is case (b), followed
		# by case (a). It seems as if Amazon/UK believes that visual
		# markup like <b> and <font> is an option (switch-on) instead
		# of a region.

		# Algorithm used here to deal with these:
		# 1) Search whole stack for the matching opening tag.
		#    If there is one assume case (b) and pop everything
		#    until and including this opening tag.
		# 2) If no matching opening tag was found assume case
		#    (a) and ignore the tag.
		#
		# Part (1) also subsumes the normal case, i.e. the
		# matching tag is at the top of the stack.

		set nodes [::htmlparse::tags peek [::htmlparse::tags size]]
		# Note: First item is top of stack, last item is bottom of stack !
		# (This behaviour of tcllib stacks is not documented
		# -> we should update the manpage).

		#foreach n $nodes {lappend tstring [p get $n -key type]}
		#puts stderr --[join $tstring]--

		set level 1
		set found 0
		foreach n $nodes {
		    set type [$tree get $n type]
		    if {0 == [string compare $tag $type]} {
			# Found an earlier open tag -> (b).
			set found 1
			break
		    }
		    incr level
		}
		if {$found} {
		    ::htmlparse::tags pop $level
		    if {$level > 1} {
			#foreach n $nodes {lappend tstring [$tree get $n type]}
			#puts stderr "\tdesync at <$tag> ($tstring) => pop $level"
		    }
		} else {
		    #foreach n $nodes {lappend tstring [$tree get $n type]}
		    #puts stderr "\tdesync at <$tag> ($tstring) => ignore"
		}
	    }
	}

	# If there is text behind a closing tag X it belongs to the
	# parent tag of X.

	if {$textBehindTheTag != {}} {
	    # Attach the text behind the closing tag to the reopened
	    # context.

	    set        pcd  [$tree insert [::htmlparse::tags peek] end]
	    $tree set $pcd  type PCDATA
	    $tree set $pcd  data $textBehindTheTag
	}

    } else {
	# Handle opening tags. The standard operation for most is to
	# push them onto the stack and thus open a nested context.
	# This does not happen for both the optional tags (p, li) and
	# the ones which don't have closing tags (meta, br, option,
	# input, area, img).
	#
	# The text coming with the tag will be added after the tag if
	# it is a tag without a matching close, else it will be added
	# as a node below the tag (as it is the region between the
	# opening and closing tag and thus nested inside). Empty text
	# is ignored under all circcumstances.

	set        node [$tree insert [::htmlparse::tags peek] end]
	$tree set $node type $tag
	$tree set $node data $param

	if {$textBehindTheTag != {}} {
	    switch -exact -- $tag {
		input -	area - img - br {
		    set pcd  [$tree insert [::htmlparse::tags peek] end]
		}
		default {
		    set pcd  [$tree insert $node end]
		}
	    }
	    $tree set $pcd type PCDATA
	    $tree set $pcd data $textBehindTheTag
	}

	::htmlparse::tags push $node

	# Special handling: <p>, <li> may have no closing tag => pop
	#                 : them immediately.
	#
	# Special handling: <meta>, <br>, <option>, <input>, <area>,
	#                 : <img>: no closing tags for these.

	switch -exact -- $tag {
	    hr - base - meta - li - br - option - input - area - img - p - h1 - h2 - h3 - h4 - h5 - h6 {
		::htmlparse::tags pop
	    }
	    default {}
	}
    }
}

# htmlparse::removeVisualFluff --
#
#	This command walks a tree as generated by '::htmlparse::2tree'
#	and removes all the nodes which represent visual tags and not
#	structural ones. The purpose of the command is to make the
#	tree easier to navigate without getting bogged down in visual
#	information not relevant to the search.
#
# Arguments:
#	tree	The name of the tree to cut down.
#
# Side Effects:
#	Modifies the specified tree.
#
# Results:
#	None.

proc ::htmlparse::removeVisualFluff {tree} {
    $tree walk root -order post n {
	::htmlparse::RemoveVisualFluff $tree $n
    }
    return
}

# htmlparse::removeFormDefs --
#
#	Like '::htmlparse::removeVisualFluff' this command is here to
#	cut down on the size of the tree as generated by
#	'::htmlparse::2tree'. It removes all nodes representing forms
#	and form elements.
#
# Arguments:
#	tree	The name of the tree to cut down.
#
# Side Effects:
#	Modifies the specified tree.
#
# Results:
#	None.

proc ::htmlparse::removeFormDefs {tree} {
    $tree walk root -order post n {
	::htmlparse::RemoveFormDefs $tree $n
    }
    return
}

# htmlparse::RemoveVisualFluff --
#
#	Internal helper command to
#	'::htmlparse::removeVisualFluff'. Does the actual work.
#
# Arguments:
#	tree	The name of the tree currently processed
#	node	The name of the node to look at.
#
# Side Effects:
#	Modifies the specified tree.
#
# Results:
#	None.

proc ::htmlparse::RemoveVisualFluff {tree node} {
    switch -exact -- [$tree get $node type] {
	hmstart - html - font - center - div - sup - b - i {
	    # Removes the node, but does not affect the nodes below
	    # it. These are just made into chiildren of the parent of
	    # this node, in its place.

	    $tree cut $node
	}
	script - option - select - meta - map - img {
	    # Removes this node and everything below it.
	    $tree delete $node
	}
	default {
	    # Ignore tag
	}
    }
}

# htmlparse::RemoveFormDefs --
#
#	Internal helper command to
#	'::htmlparse::removeFormDefs'. Does the actual work.
#
# Arguments:
#	tree	The name of the tree currently processed
#	node	The name of the node to look at.
#
# Side Effects:
#	Modifies the specified tree.
#
# Results:
#	None.

proc ::htmlparse::RemoveFormDefs {tree node} {
    switch -exact -- [$tree get $node type] {
	form {
	    $tree delete $node
	}
	default {
	    # Ignore tag
	}
    }
}

# htmlparse::Reorder --

#	Internal helper command to '::htmlparse::2tree'. Moves the
#	nodes between p/p, li/li and h<i> sequences below the
#	paragraphs and items. IOW, corrects misconstructions for
#	the optional node types.
#
# Arguments:
#	tree	The name of the tree currently processed
#	node	The name of the node to look at.
#
# Side Effects:
#	Modifies the specified tree.
#
# Results:
#	None.

proc ::htmlparse::Reorder {tree node} {
    switch -exact -- [set tp [$tree get $node type]] {
	h1 - h2 - h3 - h4 - h5 - h6 - p - li {
	    # Look for right siblings until the next node with the
	    # same type (or end of level) and move these below this
	    # node.

	    while {1} {
		set sibling [$tree next $node]
		if {
		    $sibling == {} ||
		    (![string compare $tp [$tree get $sibling type]])
		} {
		    break
		}
		$tree move $node end $sibling
	    }
	}
	default {
	    # Ignore tag
	}
    }
}

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

package provide htmlparse 1.1
package require Tcl 8.5
package require trofs 0.4

		source [file join [trofs::mount [info script]] log.tcl]
	
# 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
# logger.tcl --
#
#   Tcl implementation of a general logging facility.
#
# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com>
# Copyright (c) 2004 by Michael Schlenker <mic42@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.5

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

# ::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::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
        
    # 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
    }

    lappend services $service

    set [namespace current]::tree::${service}::service $service
    set [namespace current]::tree::${service}::levels $levels

    namespace eval tree::${service} {
    # Defaults to 'debug' level - show everything.  I don't
    # want people to wonder where there debug messages are
    # going.  They can turn it off themselves.
    variable enabled "debug"

    # Callback to use when the service in question is shut down.
    variable delcallback {}

    # 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} {
        if {[catch {
            disable $lv
            enable $lv
        } msg] == 1} {
            return -code error -errorcode $::errorCode $msg
        }
    }

    # 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} {
        variable levels
        set lvnum [lsearch -exact $levels $lv]
        if { $lvnum == -1 } {
        return -code error "Invalid level '$lv' - levels are $levels"
        }

        variable enabled
        set elnum [lsearch -exact $levels $enabled]
        if {($elnum == -1) || ($elnum > $lvnum)} {
            set enabled $lv
        }
        
        while { $lvnum <  [llength $levels] } {
        interp alias {} [namespace current]::[lindex $levels $lvnum] \
            {} [namespace current]::[lindex $levels $lvnum]cmd
        incr lvnum
        }
        logger::walk [namespace current] [list enable $lv]
    }

    # 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} {
        variable levels
        set lvnum [lsearch -exact $levels $lv]
        if { $lvnum == -1 } {
        return -code error "Invalid level '$lv' - levels are $levels"
        }

        variable enabled
        set elnum [lsearch -exact $levels $enabled]
        if {($elnum > -1) && ($elnum <= $lvnum)} {
            if {$lvnum+1 >= [llength $levels]} {
                set enabled "none"
            } else {
                set enabled [lindex $levels [expr {$lvnum+1}]]
            }
        }
        
        while { $lvnum >= 0 } {
        interp alias {} [namespace current]::[lindex $levels $lvnum] {} \
            [namespace current]::no-op
        incr lvnum -1
        }
        logger::walk [namespace current] [list disable $lv]
    }

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

    # 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
        set lvnum [lsearch -exact $levels $lv]
        if { $lvnum == -1 } {
        return -code error "Invalid level '$lv' - levels are $levels"
        }
        switch -exact -- [llength $args] {
        0  {
            if {[llength [::info proc ${lv}cmd]]} {
                set proc [namespace current]::${lv}cmd
            } else {
                set proc [interp alias {} [namespace current]::${lv}cmd]
            }
            return $proc
           }
        1  {
            set cmd [lindex $args 0]
            if {[llength [::info commands $cmd]]} {
            interp alias {} [namespace current]::${lv}cmd {} $cmd
            } else {
            return -code error "Invalid cmd '$cmd' - does not exist"
            }
        }
        2  {
            foreach {arg body} $args {break}
            proc ${lv}cmd $arg $body
        }
        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   {set delcallback [lindex $args 0]}
                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
        catch { uplevel \#0 $delcallback }
        
        # 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
    }
    
    
    # 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
        }
    } else {
        foreach lvl [::logger::levels] {
            proc ${lvl}cmd {txt} "stdoutcmd $lvl \$txt"
        }
    }
    }
    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
    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]
    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 {
        interp alias {} $target {} $source
    }
}

# 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]} {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.5 [list source [file join $dir logger.tcl]]
logger.tcl {F 16384 17107} log.tcl {F 18580 35687} pkgIndex.tcl {F 723 723}trofs01Kpackage require Tcl 8.5
package require trofs 0.4

		source [file join [trofs::mount [info script]] base64.tcl]
	
# 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$

# 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
# base64c - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# This package is a place-holder for the critcl enhanced code present in
# the tcllib base64 module.
#
# Normally this code will become part of the tcllibc library.
#

package require critcl
package provide base64c 0.1.0

namespace eval ::base64c {
    variable base64c_rcsid {$Id$}
}
# 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]]
# uuencode - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# Provide a Tcl only implementation of uuencode and uudecode.
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
# @(#)$Id: uuencode.tcl,v 1.14 2004/03/09 23:53:49 hobbs Exp $

package require Tcl 8.2;                # tcl minimum version

# Try and get some compiled helper package.
if {[catch {package require tcllibc}]} {
    catch {package require Trf}
}

namespace eval ::uuencode {
    variable version 1.1.2

    namespace export encode decode uuencode uudecode
}

proc ::uuencode::Enc {c} {
    return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]]
}

proc ::uuencode::Encode {s} {
    set r {}
    binary scan $s c* d
    foreach {c1 c2 c3} $d {
        if {$c1 == {}} {set c1 0}
        if {$c2 == {}} {set c2 0}
        if {$c3 == {}} {set c3 0}
        append r [Enc [expr {$c1 >> 2}]]
        append r [Enc [expr {(($c1 << 4) & 060) | (($c2 >> 4) & 017)}]]
        append r [Enc [expr {(($c2 << 2) & 074) | (($c3 >> 6) & 003)}]]
        append r [Enc [expr {($c3 & 077)}]]
    }
    return $r
}


proc ::uuencode::Decode {s} {
    if {[string length $s] == 0} {return ""}
    set r {}
    binary scan [pad $s] c* d
        
    foreach {c0 c1 c2 c3} $d {
        append r [format %c [expr {((($c0-0x20)&0x3F) << 2) & 0xFF
                                   | ((($c1-0x20)&0x3F) >> 4) & 0xFF}]]
        append r [format %c [expr {((($c1-0x20)&0x3F) << 4) & 0xFF
                                   | ((($c2-0x20)&0x3F) >> 2) & 0xFF}]]
        append r [format %c [expr {((($c2-0x20)&0x3F) << 6) & 0xFF
                                   | (($c3-0x20)&0x3F) & 0xFF}]]
    }
    return $r
}

# -------------------------------------------------------------------------
# C coded version of the Encode/Decode functions for base64c package.
# -------------------------------------------------------------------------
if {[package provide critcl] != {}} {
    namespace eval ::uuencode {
        critcl::ccode {
            #include <string.h>
            static unsigned char Enc(unsigned char c) {
                return (c != 0) ? ((c & 0x3f) + 0x20) : 0x60;
            }
        }
        critcl::ccommand CEncode {dummy interp objc objv} {
            Tcl_Obj *inputPtr, *resultPtr;
            int len, rlen, xtra;
            unsigned char *input, *p, *r;
            
            if (objc !=  2) {
                Tcl_WrongNumArgs(interp, 1, objv, "data");
                return TCL_ERROR;
            }
            
            inputPtr = objv[1];
            input = Tcl_GetByteArrayFromObj(inputPtr, &len);
            if ((xtra = (3 - (len % 3))) != 3) {
                if (Tcl_IsShared(inputPtr))
                    inputPtr = Tcl_DuplicateObj(inputPtr);
                input = Tcl_SetByteArrayLength(inputPtr, len + xtra);
                memset(input + len, 0, xtra);
                len += xtra;
            }

            rlen = (len / 3) * 4;
            resultPtr = Tcl_GetObjResult(interp);
            if (Tcl_IsShared(resultPtr)) {
                resultPtr = Tcl_DuplicateObj(resultPtr);
                Tcl_SetObjResult(interp, resultPtr);
            }
            r = Tcl_SetByteArrayLength(resultPtr, rlen);
            memset(r, 0, rlen);
            
            for (p = input; p < input + len; p += 3) {
                char a, b, c;
                a = *p; b = *(p+1), c = *(p+2);
                *r++ = Enc(a >> 2);
                *r++ = Enc(((a << 4) & 060) | ((b >> 4) & 017));
                *r++ = Enc(((b << 2) & 074) | ((c >> 6) & 003));
                *r++ = Enc(c & 077);
            }
            
            return TCL_OK;
        }

        critcl::ccommand CDecode {dummy interp objc objv} {
            Tcl_Obj *inputPtr, *resultPtr;
            int len, rlen, xtra;
            unsigned char *input, *p, *r;
            
            if (objc !=  2) {
                Tcl_WrongNumArgs(interp, 1, objv, "data");
                return TCL_ERROR;
            }
            
            /* if input is not mod 4, extend it with nuls */
            inputPtr = objv[1];
            input = Tcl_GetByteArrayFromObj(inputPtr, &len);
            if ((xtra = (4 - (len % 4))) != 4) {
                if (Tcl_IsShared(inputPtr))
                    inputPtr = Tcl_DuplicateObj(inputPtr);
                input = Tcl_SetByteArrayLength(inputPtr, len + xtra);
                memset(input + len, 0, xtra);
                len += xtra;
            }

            /* output will be 1/3 smaller than input and a multiple of 3 */
            rlen = (len / 4) * 3;
            resultPtr = Tcl_GetObjResult(interp);
            if (Tcl_IsShared(resultPtr)) {
                resultPtr = Tcl_DuplicateObj(resultPtr);
                Tcl_SetObjResult(interp, resultPtr);
            }
            r = Tcl_SetByteArrayLength(resultPtr, rlen);
            memset(r, 0, rlen);
            
            for (p = input; p < input + len; p += 4) {
                char a, b, c, d;
                a = *p; b = *(p+1), c = *(p+2), d = *(p+3);
                *r++ = (((a - 0x20) & 0x3f) << 2) | (((b - 0x20) & 0x3f) >> 4);
                *r++ = (((b - 0x20) & 0x3f) << 4) | (((c - 0x20) & 0x3f) >> 2);
                *r++ = (((c - 0x20) & 0x3f) << 6) | (((d - 0x20) & 0x3f) );
            }
            
            return TCL_OK;
        }
    }
}

# -------------------------------------------------------------------------

# Description:
#  Permit more tolerant decoding of invalid input strings by padding to
#  a multiple of 4 bytes with nulls.
# Result:
#  Returns the input string - possibly padded with uuencoded null chars.
#
proc ::uuencode::pad {s} {
    if {[set mod [expr {[string length $s] % 4}]] != 0} {
        append s [string repeat "`" [expr {4 - $mod}]]
    }
    return $s
}

# -------------------------------------------------------------------------

# If the Trf package is available then we shall use this by default but the
# Tcllib implementations are always visible if needed (ie: for testing)
if {[info command ::uuencode::CDecode] != {}} {    
    # tcllib critcl package
    interp alias {} ::uuencode::encode {} ::uuencode::CEncode
    interp alias {} ::uuencode::decode {} ::uuencode::CDecode
} elseif {[package provide Trf] != {}} {
    proc ::uuencode::encode {s} {
        return [::uuencode -mode encode -- $s]
    }
    proc ::uuencode::decode {s} {
        return [::uuencode -mode decode -- [pad $s]]
    }
} else {
    # pure-tcl then
    interp alias {} ::uuencode::encode {} ::uuencode::Encode
    interp alias {} ::uuencode::decode {} ::uuencode::Decode
}

# -------------------------------------------------------------------------

proc ::uuencode::uuencode {args} {
    array set opts {mode 0644 filename {} name {}}
    while {[string match -* [lindex $args 0]]} {
        switch -glob -- [lindex $args 0] {
            -f* {
                set opts(filename) [lindex $args 1]
                set args [lreplace $args 0 0]
            }
            -m* {
                set opts(mode) [lindex $args 1]
                set args [lreplace $args 0 0]
            }
            -n* {
                set opts(name) [lindex $args 1]
                set args [lreplace $args 0 0]
            }
            -- {
                set args [lreplace $args 0 0]
                break
            }
            default {
                return -code error "bad option [lindex $args 0]:\
                      must be -filename or -mode"
            }
        }
        set args [lreplace $args 0 0]
    }

    if {$opts(name) == {}} {
        set opts(name) $opts(filename)
    }
    if {$opts(name) == {}} {
        set opts(name) "data.dat"
    }

    if {$opts(filename) != {}} {
        set f [open $opts(filename) r]
        fconfigure $f -translation binary
        set data [read $f]
        close $f
    } else {
        if {[llength $args] != 1} {
            return -code error "wrong \# args: should be\
                  \"uuencode ?-mode oct? -file name | data\""
        }
        set data [lindex $args 0]
    }

    set r {}
    append r [format "begin %o %s" $opts(mode) $opts(name)] "\n"
    for {set n 0} {$n < [string length $data]} {incr n 45} {
        set s [string range $data $n [expr {$n + 44}]]
        append r [Enc [string length $s]]
        append r [encode $s] "\n"
    }
    append r "`\nend"
    return $r
}

# -------------------------------------------------------------------------
# Description:
#  Perform uudecoding of a file or data. A file may contain more than one
#  encoded data section so the result is a list where each element is a 
#  three element list of the provided filename, the suggested mode and the 
#  data itself.
#
proc ::uuencode::uudecode {args} {
    array set opts {mode 0644 filename {}}
    while {[string match -* [lindex $args 0]]} {
        switch -glob -- [lindex $args 0] {
            -f* {
                set opts(filename) [lindex $args 1]
                set args [lreplace $args 0 0]
            }
            -- {
                set args [lreplace $args 0 0]
                break
            }
            default {
                return -code error "bad option [lindex $args 0]:\
                      must be -filename or -mode"
            }
        }
        set args [lreplace $args 0 0]
    }

    if {$opts(filename) != {}} {
        set f [open $opts(filename) r]
        set data [read $f]
        close $f
    } else {
        if {[llength $args] != 1} {
            return -code error "wrong \# args: should be\
                  \"uudecode -file name | data\""
        }
        set data [lindex $args 0]
    }

    set state false
    set result {}

    foreach {line} [split $data "\n"] {
        switch -exact -- $state {
            false {
                if {[regexp {^begin ([0-7]+) ([^\s]*)} $line \
                         -> opts(mode) opts(name)]} {
                    set state true
                    set r {}
                }
            }

            true {
                if {[string match "end" $line]} {
                    set state false
                    lappend result [list $opts(name) $opts(mode) $r]
                } else {
                    scan $line %c c
                    set n [expr {($c - 0x21)}]
                    append r [string range \
                                  [decode [string range $line 1 end]] 0 $n]
                }
            }
        }
    }

    return $result
}

# -------------------------------------------------------------------------

package provide uuencode $::uuencode::version

# -------------------------------------------------------------------------
#
# Local variables:
#   mode: tcl
#   indent-tabs-mode: nil
# End:

# yencode.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# Provide a Tcl only implementation of yEnc encoding algorithm
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
# @(#)$Id$

package require Tcl 8.2;                # tcl minimum version
catch {package require crc32};          # tcllib 1.1
catch {package require tcllibc};        # critcl enhancements for tcllib

namespace eval ::yencode {
    variable version 1.1.1
    namespace export encode decode yencode ydecode
}

# -------------------------------------------------------------------------

proc ::yencode::Encode {s} {
    set r {}
    binary scan $s c* d
    foreach {c} $d {
        set v [expr {($c + 42) % 256}]
        if {$v == 0x00 || $v == 0x09 || $v == 0x0A 
            || $v == 0x0D || $v == 0x3D} {
            append r "="
            set v [expr {($v + 42) % 256}]
        }
        append r [format %c $v]
    }
    return $r
}

proc ::yencode::Decode {s} {
    if {[string length $s] == 0} {return ""}
    set r {}
    set esc 0
    binary scan $s c* d
    foreach c $d {
        if {$c == 61 && $esc == 0} {
            set esc 1
            continue
        }
        set v [expr {($c - 42) % 256}]
        if {$esc} {
            set v [expr {($v - 42) % 256}]
            set esc 0
        }
        append r [format %c $v]
    }
    return $r
}

# -------------------------------------------------------------------------
# C coded versions for critcl built base64c package
# -------------------------------------------------------------------------

if {[package provide critcl] != {}} {
    namespace eval ::yencode {
        critcl::ccode {
            #include <string.h>
        }
        critcl::ccommand CEncode {dummy interp objc objv} {
            Tcl_Obj *inputPtr, *resultPtr;
            int len, rlen, xtra;
            unsigned char *input, *p, *r, v;
            
            if (objc !=  2) {
                Tcl_WrongNumArgs(interp, 1, objv, "data");
                return TCL_ERROR;
            }
            
            /* fetch the input data */
            inputPtr = objv[1];
            input = Tcl_GetByteArrayFromObj(inputPtr, &len);

            /* calculate the length of the encoded result */
            rlen = len;
            for (p = input; p < input + len; p++) {
                v = (*p + 42) % 256;
                if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D)
                   rlen++;
            }
            
            /* allocate the output buffer */
            resultPtr = Tcl_GetObjResult(interp);
            if (Tcl_IsShared(resultPtr)) {
                resultPtr = Tcl_DuplicateObj(resultPtr);
                Tcl_SetObjResult(interp, resultPtr);
            }
            r = Tcl_SetByteArrayLength(resultPtr, rlen);
            
            /* encode the input */
            for (p = input; p < input + len; p++) {
                v = (*p + 42) % 256;
                if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) {
                    *r++ = '=';
                    v = (v + 42) % 256;
                }
                *r++ = v;
            }

            return TCL_OK;
        }

        critcl::ccommand CDecode {dummy interp objc objv} {
            Tcl_Obj *inputPtr, *resultPtr;
            int len, rlen, esc;
            unsigned char *input, *p, *r, v;
            
            if (objc !=  2) {
                Tcl_WrongNumArgs(interp, 1, objv, "data");
                return TCL_ERROR;
            }
            
            /* fetch the input data */
            inputPtr = objv[1];
            input = Tcl_GetByteArrayFromObj(inputPtr, &len);

            /* allocate the output buffer */
            resultPtr = Tcl_GetObjResult(interp);
            if (Tcl_IsShared(resultPtr)) {
                resultPtr = Tcl_DuplicateObj(resultPtr);
                Tcl_SetObjResult(interp, resultPtr);
            }
            r = Tcl_SetByteArrayLength(resultPtr, len);
            
            /* encode the input */
            for (p = input, esc = 0, rlen = 0; p < input + len; p++) {
                if (*p == 61 && esc == 0) {
                    esc = 1;
                    continue;
                }
                v = (*p - 42) % 256;
                if (esc) {
                    v = (v - 42) % 256;
                    esc = 0;
                }
                *r++ = v;
                rlen++;
            }
            Tcl_SetByteArrayLength(resultPtr, rlen);

            return TCL_OK;
        }
    }
}

if {[info command ::yencode::CEncode] != {}} {
    interp alias {} ::yencode::encode {} ::yencode::CEncode
    interp alias {} ::yencode::decode {} ::yencode::CDecode
} else {
    interp alias {} ::yencode::encode {} ::yencode::Encode
    interp alias {} ::yencode::decode {} ::yencode::Decode
}

# -------------------------------------------------------------------------
# Description:
#  Pop the nth element off a list. Used in options processing.
#
proc ::yencode::Pop {varname {nth 0}} {
    upvar $varname args
    set r [lindex $args $nth]
    set args [lreplace $args $nth $nth]
    return $r
}

# -------------------------------------------------------------------------

proc ::yencode::yencode {args} {
    array set opts {mode 0644 filename {} name {} line 128 crc32 1}
    while {[string match -* [lindex $args 0]]} {
        switch -glob -- [lindex $args 0] {
            -f* { set opts(filename) [Pop args 1] }
            -m* { set opts(mode) [Pop args 1] }
            -n* { set opts(name) [Pop args 1] }
            -l* { set opts(line) [Pop args 1] }
            -c* { set opts(crc32) [Pop args 1] }
            --  { Pop args ; break }
            default {
                set options [join [lsort [array names opts]] ", -"]
                return -code error "bad option [lindex $args 0]:\
                      must be -$options"
            }
        }
        Pop args
    }

    if {$opts(name) == {}} {
        set opts(name) $opts(filename)
    }
    if {$opts(name) == {}} {
        set opts(name) "data.dat"
    }
    if {! [string is boolean $opts(crc32)]} {
        return -code error "bad option -crc32: argument must be true or false"
    }

    if {$opts(filename) != {}} {
        set f [open $opts(filename) r]
        fconfigure $f -translation binary
        set data [read $f]
        close $f
    } else {
        if {[llength $args] != 1} {
            return -code error "wrong \# args: should be\
                  \"yencode ?options? -file name | data\""
        }
        set data [lindex $args 0]
    }
    
    set opts(size) [string length $data]
    
    set r {}
    append r [format "=ybegin line=%d size=%d name=%s" \
                  $opts(line) $opts(size) $opts(name)] "\n"

    set ndx 0
    while {$ndx < $opts(size)} {
        set pln [string range $data $ndx [expr {$ndx + $opts(line) - 1}]]
        set enc [encode $pln]
        incr ndx [string length $pln]
        append r $enc "\r\n"
    }

    append r [format "=yend size=%d" $ndx]
    if {$opts(crc32)} {
        append r " crc32=" [crc::crc32 -format %x $data]
    }
    return $r
}

# -------------------------------------------------------------------------
# Description:
#  Perform ydecoding of a file or data. A file may contain more than one
#  encoded data section so the result is a list where each element is a 
#  three element list of the provided filename, the file size and the 
#  data itself.
#
proc ::yencode::ydecode {args} {
    array set opts {mode 0644 filename {} name default.bin}
    while {[string match -* [lindex $args 0]]} {
        switch -glob -- [lindex $args 0] {
            -f* { set opts(filename) [Pop args 1] }
            -- { Pop args ; break; }
            default {
                set options [join [lsort [array names opts]] ", -"]
                return -code error "bad option [lindex $args 0]:\
                      must be -$opts"
            }
        }
        Pop args
    }

    if {$opts(filename) != {}} {
        set f [open $opts(filename) r]
        set data [read $f]
        close $f
    } else {
        if {[llength $args] != 1} {
            return -code error "wrong \# args: should be\
                  \"ydecode ?options? -file name | data\""
        }
        set data [lindex $args 0]
    }

    set state false
    set result {}

    foreach {line} [split $data "\n"] {
        set line [string trimright $line "\r\n"]
        switch -exact -- $state {
            false {
                if {[string match "=ybegin*" $line]} {
                    regexp {line=(\d+)} $line -> opts(line)
                    regexp {size=(\d+)} $line -> opts(size)
                    regexp {name=(\d+)} $line -> opts(name)

                    if {$opts(name) == {}} {
                        set opts(name) default.bin
                    }

                    set state true
                    set r {}
                }
            }

            true {
                if {[string match "=yend*" $line]} {
                    set state false
                    lappend result [list $opts(name) $opts(size) $r]
                } else {
                    append r [decode $line]
                }
            }
        }
    }

    return $result
}

# -------------------------------------------------------------------------

package provide yencode $::yencode::version

# -------------------------------------------------------------------------
#
# Local variables:
#   mode: tcl
#   indent-tabs-mode: nil
# End:

yencode.tcl {F 9765 9765} base64c.tcl {F 363 21877} uuencode.tcl {F 10996 20761} base64.tcl {F 9273 31150} pkgIndex.tcl {F 753 21514}trofs01…##################################################
#
# sha1.tcl - SHA1 in Tcl
# Author: Don Libes <libes@nist.gov>, May 2001
# Version 1.0.3
#
# SHA1 defined by FIPS 180-1, "The SHA1 Message-Digest Algorithm",
#          http://www.itl.nist.gov/fipspubs/fip180-1.htm
# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
#
# Some of the comments below come right out of FIPS 180-1; That's why
# they have such peculiar numbers.  In addition, I have retained
# original syntax, etc. from the FIPS.  All remaining bugs are mine.
#
# HMAC implementation by D. J. Hagberg <dhagberg@millibits.com> and
# is based on C code in FIPS 2104.
#
# For more info, see: http://expect.nist.gov/sha1pure
#
# - Don
##################################################

### Code speedups by Donal Fellows <fellowsd@cs.man.ac.uk> who may well
### have added some extra bugs of his own...  :^)

### Changed the code to use Trf if this package is present on the
### system requiring the sha1 package. Analogous to md5.

package require Tcl 8.2
namespace eval ::sha1 {
}

if {![catch {package require Trf 2.0}] && ![catch {::sha1 -- test}]} {
    # Trf is available, so implement the functionality provided here
    # in terms of calls to Trf for speed.

    proc ::sha1::sha1 {msg} {
	string tolower [::hex -mode encode -- [::sha1 -- $msg]]
    }

    # hmac: hash for message authentication

    # SHA1 of Trf and SHA1 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. (Not all, the first place must not the changed,
    # see [x]

    proc ::sha1::hmac {key text} {
	# if key is longer than 64 bytes, reset it to SHA1(key).  If shorter, 
	# pad it out with null (\x00) chars.
	set keyLen [string length $key]
	if {$keyLen > 64} {
	    set key [binary format H32 [sha1 $key]]
	    # [x] set key [::sha1 -- $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 sha1, appending its results to the outer key
	append k_ipad $text
	#append k_opad [binary format H* [sha1 $k_ipad]]
	append k_opad [::sha1 -- $k_ipad]

	# Perform outer sha1
	#sha1 $k_opad
	string tolower [::hex -mode encode -- [::sha1 -- $k_opad]]
    }

} else {
    # Without Trf use the all-tcl implementation by Don Libes.

    namespace eval ::sha1 {
	variable K

	proc initK {} {
	    variable K {}
	    foreach t {
		0x5A827999
		0x6ED9EBA1
		0x8F1BBCDC
		0xCA62C1D6
	    } {
		for {set i 0} {$i < 20} {incr i} {
		    lappend K [expr {int($t)}]
		}
	    }
	}
	initK
    }

    # test sha1
    #
    # This proc is not necessary during runtime and may be omitted if you
    # are simply inserting this file into a production program.
    #
    proc ::sha1::test {} {
	foreach {msg expected} {
	    "abc"
	    "a9993e364706816aba3e25717850c26c9cd0d89d"
	    "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
	    "84983e441c3bd26ebaae4aa1f95129e5e54670f1"
	    "[string repeat a 1000000]"
	    "34aa973cd4c4daa4f61eeb2bdbad27316534016f"
	} {
	    puts "testing: sha1 \"$msg\""
	    set msg [subst $msg]
	    set msgLen [string length $msg]
	    if {$msgLen > 10000} {
		puts "warning: msg length = $msgLen; this may take a while . . ."
	    }
	    set computed [sha1 $msg]
	    puts "expected: $expected"
	    puts "computed: $computed"
	    if {0 != [string compare $computed $expected]} {
		puts "FAILED"
	    } else {
		puts "SUCCEEDED"
	    }
	}
    }

    # time sha1
    #
    # This proc is not necessary during runtime and may be omitted if you
    # are simply inserting this file into a production program.
    #
    proc ::sha1::time {} {
	foreach len {10 50 100 500 1000 5000 10000} {
	    set time [::time {sha1 [format %$len.0s ""]} 10]
	    set msec [lindex $time 0]
	    puts "input length $len: [expr {$msec/1000}] milliseconds per interation"
	}
    }

    proc ::sha1::sha1 {msg} {
	variable K

	#
	# 4. MESSAGE PADDING
	#

	# pad to 512 bits (512/8 = 64 bytes)

	set msgLen [string length $msg]

	# last 8 bytes are reserved for msgLen
	# plus 1 for "1"

	set padLen [expr {56 - $msgLen%64}]
	if {$msgLen % 64 >= 56} {
	    incr padLen 64
	}

	# 4a. and b. append single 1b followed by 0b's
	append msg [binary format "a$padLen" \200]

	# 4c. append 64-bit length
	# Our implementation obviously limits string length to 32bits.
	append msg \0\0\0\0[binary format "I" [expr {8*$msgLen}]]
    
	#
	# 7. COMPUTING THE MESSAGE DIGEST
	#

	# initial H buffer

	set H0 [expr {int(0x67452301)}]
	set H1 [expr {int(0xEFCDAB89)}]
	set H2 [expr {int(0x98BADCFE)}]
	set H3 [expr {int(0x10325476)}]
	set H4 [expr {int(0xC3D2E1F0)}]

	#
	# process message in 16-word blocks (64-byte blocks)
	#

	# convert message to array of 32-bit integers
	# each block of 16-words is stored in M($i,0-16)

	binary scan $msg I* words
	set blockLen [llength $words]

	for {set i 0} {$i < $blockLen} {incr i 16} {
	    # 7a. Divide M[i] into 16 words W[0], W[1], ...
	    set W [lrange $words $i [expr {$i+15}]]

	    # 7b. For t = 16 to 79 let W[t] = ....
	    set t   16
	    set t3  12
	    set t8   7
	    set t14  1
	    set t16 -1
	    for {} {$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 {($x << 1) | (($x >> 31) & 1)}]
	    }

	    # 7c. Let A = H[0] ....
	    set A $H0
	    set B $H1
	    set C $H2
	    set D $H3
	    set E $H4

	    # 7d. For t = 0 to 79 do
	    for {set t 0} {$t < 20} {incr t} {
		set TEMP [expr {(($A << 5) | (($A >> 27) & 0x1f)) + \
			(($B & $C) | ((~$B) & $D)) \
			+ $E + [lindex $W $t] + [lindex $K $t]}]
		set E $D
		set D $C
		set C [expr {($B << 30) | (($B >> 2) & 0x3fffffff)}]
		set B $A
		set A $TEMP
	    }
	    for {} {$t<40} {incr t} {
		set TEMP [expr {(($A << 5) | (($A >> 27) & 0x1f)) + \
			($B ^ $C ^ $D) \
			+ $E + [lindex $W $t] + [lindex $K $t]}]
		set E $D
		set D $C
		set C [expr {($B << 30) | (($B >> 2) & 0x3fffffff)}]
		set B $A
		set A $TEMP
	    }
	    for {} {$t<60} {incr t} {
		set TEMP [expr {(($A << 5) | (($A >> 27) & 0x1f)) + \
			(($B & $C) | ($B & $D) | ($C & $D)) \
			+ $E + [lindex $W $t] + [lindex $K $t]}]
		set E $D
		set D $C
		set C [expr {($B << 30) | (($B >> 2) & 0x3fffffff)}]
		set B $A
		set A $TEMP
	    }
	    for {} {$t<80} {incr t} {
		set TEMP [expr {(($A << 5) | (($A >> 27) & 0x1f)) + \
			($B ^ $C ^ $D) \
			+ $E + [lindex $W $t] + [lindex $K $t]}]
		set E $D
		set D $C
		set C [expr {($B << 30) | (($B >> 2) & 0x3fffffff)}]
		set B $A
		set A $TEMP
	    }

	    set H0 [expr {int(($H0 + $A) & 0xffffffff)}]
	    set H1 [expr {int(($H1 + $B) & 0xffffffff)}]
	    set H2 [expr {int(($H2 + $C) & 0xffffffff)}]
	    set H3 [expr {int(($H3 + $D) & 0xffffffff)}]
	    set H4 [expr {int(($H4 + $E) & 0xffffffff)}]
	}

	return [format %0.8x%0.8x%0.8x%0.8x%0.8x $H0 $H1 $H2 $H3 $H4]
    }

    ### These procedures are either inlined or replaced with a normal [format]!
    #
    #proc ::sha1::f {t B C D} {
    #    switch [expr {$t/20}] {
    #	 0 {
    #	     expr {($B & $C) | ((~$B) & $D)}
    #	 } 1 - 3 {
    #	     expr {$B ^ $C ^ $D}
    #	 } 2 {
    #	     expr {($B & $C) | ($B & $D) | ($C & $D)}
    #	 }
    #    }
    #}
    #
    #proc ::sha1::byte0 {i} {expr {0xff & $i}}
    #proc ::sha1::byte1 {i} {expr {(0xff00 & $i) >> 8}}
    #proc ::sha1::byte2 {i} {expr {(0xff0000 & $i) >> 16}}
    #proc ::sha1::byte3 {i} {expr {((0xff000000 & $i) >> 24) & 0xff}}
    #
    #proc ::sha1::bytes {i} {
    #    format %0.2x%0.2x%0.2x%0.2x [byte3 $i] [byte2 $i] [byte1 $i] [byte0 $i]
    #}

    # hmac: hash for message authentication
    proc ::sha1::hmac {key text} {
	# if key is longer than 64 bytes, reset it to SHA1(key).  If shorter, 
	# pad it out with null (\x00) chars.
	set keyLen [string length $key]
	if {$keyLen > 64} {
	    set key [binary format H32 [sha1 $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 sha1, appending its results to the outer key
	append k_ipad $text
	append k_opad [binary format H* [sha1 $k_ipad]]

	# Perform outer sha1
	sha1 $k_opad
    }
}

package provide sha1 1.0.3
package require Tcl 8.5
package require trofs 0.4

		source [file join [trofs::mount [info script]] cmdline.tcl]
	
# cmdline.tcl --
#
#	This package provides a utility for parsing command line
#	arguments that are processed by our various applications.
#	It also includes a utility routine to determine the
#	application name for use in command line errors.
#
# 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$

package require Tcl 8.2
package provide cmdline 1.2.3

namespace eval ::cmdline {
    namespace export getArgv0 getopt getKnownOpt getfiles getoptions \
	    getKnownOptions usage
}

# Load the typed versions of these functions
source [file join [file dirname [info script]] typedCmdline.tcl]

# ::cmdline::getopt --
#
#	The cmdline::getopt works in a fashion like the standard
#	C based getopt function.  Given an option string and a 
#	pointer to an array or args this command will process the
#	first argument and return info on how to proceed.
#
# Arguments:
#	argvVar		Name of the argv list that you
#			want to process.  If options are found the
#			arg list is modified and the processed arguments
#			are removed from the start of the list.
#	optstring	A list of command options that the application
#			will accept.  If the option ends in ".arg" the
#			getopt routine will use the next argument as 
#			an argument to the option.  Otherwise the option	
#			is a boolean that is set to 1 if present.
#	optVar		The variable pointed to by optVar
#			contains the option that was found (without the
#			leading '-' and without the .arg extension).
#	valVar		Upon success, the variable pointed to by valVar
#			contains the value for the specified option.
#			This value comes from the command line for .arg
#			options, otherwise the value is 1.
#			If getopt fails, the valVar is filled with an
#			error message.
#
# Results:
# 	The getopt function returns 1 if an option was found, 0 if no more
# 	options were found, and -1 if an error occurred.

proc ::cmdline::getopt {argvVar optstring optVar valVar} {
    upvar 1 $argvVar argsList
    upvar 1 $optVar option
    upvar 1 $valVar value

    set result [getKnownOpt argsList $optstring option value]

    if {$result < 0} {
        # Collapse unknown-option error into any-other-error result.
        set result -1
    }
    return $result
}

# ::cmdline::getKnownOpt --
#
#	The cmdline::getKnownOpt works in a fashion like the standard
#	C based getopt function.  Given an option string and a 
#	pointer to an array or args this command will process the
#	first argument and return info on how to proceed.
#
# Arguments:
#	argvVar		Name of the argv list that you
#			want to process.  If options are found the
#			arg list is modified and the processed arguments
#			are removed from the start of the list.  Note that
#			unknown options and the args that follow them are
#			left in this list.
#	optstring	A list of command options that the application
#			will accept.  If the option ends in ".arg" the
#			getopt routine will use the next argument as 
#			an argument to the option.  Otherwise the option	
#			is a boolean that is set to 1 if present.
#	optVar		The variable pointed to by optVar
#			contains the option that was found (without the
#			leading '-' and without the .arg extension).
#	valVar		Upon success, the variable pointed to by valVar
#			contains the value for the specified option.
#			This value comes from the command line for .arg
#			options, otherwise the value is 1.
#			If getopt fails, the valVar is filled with an
#			error message.
#
# Results:
# 	The getKnownOpt function returns 1 if an option was found,
#	0 if no more options were found, -1 if an unknown option was
#	encountered, and -2 if any other error occurred. 

proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} {
    upvar 1 $argvVar argsList
    upvar 1 $optVar  option
    upvar 1 $valVar  value

    # default settings for a normal return
    set value ""
    set option ""
    set result 0

    # check if we're past the end of the args list
    if {[llength $argsList] != 0} {

	# if we got -- or an option that doesn't begin with -, return (skipping
	# the --).  otherwise process the option arg.
	switch -glob -- [set arg [lindex $argsList 0]] {
	    "--" {
		set argsList [lrange $argsList 1 end]
	    }

	    "-*" {
		set option [string range $arg 1 end]

		if {[lsearch -exact $optstring $option] != -1} {
		    # Booleans are set to 1 when present
		    set value 1
		    set result 1
		    set argsList [lrange $argsList 1 end]
		} elseif {[lsearch -exact $optstring "$option.arg"] != -1} {
		    set result 1
		    set argsList [lrange $argsList 1 end]
		    if {[llength $argsList] != 0} {
			set value [lindex $argsList 0]
			set argsList [lrange $argsList 1 end]
		    } else {
			set value "Option \"$option\" requires an argument"
			set result -2
		    }
		} else {
		    # Unknown option.
		    set value "Illegal option \"$option\""
		    set result -1
		}
	    }
	    default {
		# Skip ahead
	    }
	}
    }

    return $result
}

# ::cmdline::getoptions --
#
#	Process a set of command line options, filling in defaults
#	for those not specified.  This also generates an error message
#	that lists the allowed flags if an incorrect flag is specified.
#
# Arguments:
#	arglistVar	The name of the argument list, typically argv.
#			We remove all known options and their args from it.
#	optlist		A list-of-lists where each element specifies an option
#			in the form:
#				(where flag takes no argument) 
#					flag comment 
#
#				(or where flag takes an argument) 
#					flag default comment
#
#			If flag ends in ".arg" then the value is taken from the
#			command line. Otherwise it is a boolean and appears in
#			the result if present on the command line. If flag ends
#			in ".secret", it will not be displayed in the usage.
#	usage		Text to include in the usage display. Defaults to
#			"options:"
#
# Results
#	Name value pairs suitable for using with array set.

proc ::cmdline::getoptions {arglistVar optlist {usage options:}} {
    upvar 1 $arglistVar argv

    set opts [GetOptionDefaults $optlist result]

    set argc [llength $argv]
    while {[set err [getopt argv $opts opt arg]]} {
	if {$err < 0} {
            set result(?) ""
            break
	}
	set result($opt) $arg
    }
    if {[info exist result(?)] || [info exists result(help)]} {
	error [usage $optlist $usage]
    }
    return [array get result]
}

# ::cmdline::getKnownOptions --
#
#	Process a set of command line options, filling in defaults
#	for those not specified.  This ignores unknown flags, but generates
#	an error message that lists the correct usage if a known option
#	is used incorrectly.
#
# Arguments:
#	arglistVar	The name of the argument list, typically argv.  This
#			We remove all known options and their args from it.
#	optlist		A list-of-lists where each element specifies an option
#			in the form:
#				flag default comment
#			If flag ends in ".arg" then the value is taken from the
#			command line. Otherwise it is a boolean and appears in
#			the result if present on the command line. If flag ends
#			in ".secret", it will not be displayed in the usage.
#	usage		Text to include in the usage display. Defaults to
#			"options:"
#
# Results
#	Name value pairs suitable for using with array set.

proc ::cmdline::getKnownOptions {arglistVar optlist {usage options:}} {
    upvar 1 $arglistVar argv

    set opts [GetOptionDefaults $optlist result]

    # As we encounter them, keep the unknown options and their
    # arguments in this list.  Before we return from this procedure,
    # we'll prepend these args to the argList so that the application
    # doesn't lose them.

    set unknownOptions [list]

    set argc [llength $argv]
    while {[set err [getKnownOpt argv $opts opt arg]]} {
	if {$err == -1} {
            # Unknown option.

            # Skip over any non-option items that follow it.
            # For now, add them to the list of unknownOptions.
            lappend unknownOptions [lindex $argv 0]
            set argv [lrange $argv 1 end]
            while {([llength $argv] != 0) \
                    && ![string match "-*" [lindex $argv 0]]} {
                lappend unknownOptions [lindex $argv 0]
                set argv [lrange $argv 1 end]
            }
	} elseif {$err == -2} {
            set result(?) ""
            break
        } else {
            set result($opt) $arg
        }
    }

    # Before returning, prepend the any unknown args back onto the
    # argList so that the application doesn't lose them.
    set argv [concat $unknownOptions $argv]

    if {[info exist result(?)] || [info exists result(help)]} {
	error [usage $optlist $usage]
    }
    return [array get result]
}

# ::cmdline::GetOptionDefaults --
#
#	This internal procedure processes the option list (that was passed to
#	the getopt or getKnownOpt procedure).  The defaultArray gets an index
#	for each option in the option list, the value of which is the option's
#	default value.
#
# Arguments:
#	optlist		A list-of-lists where each element specifies an option
#			in the form:
#				flag default comment
#			If flag ends in ".arg" then the value is taken from the
#			command line. Otherwise it is a boolean and appears in
#			the result if present on the command line. If flag ends
#			in ".secret", it will not be displayed in the usage.
#	defaultArrayVar	The name of the array in which to put argument defaults.
#
# Results
#	Name value pairs suitable for using with array set.

proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} {
    upvar 1 $defaultArrayVar result

    set opts {? help}
    foreach opt $optlist {
	set name [lindex $opt 0]
	if {[regsub -- .secret$ $name {} name] == 1} {
	    # Need to hide this from the usage display and getopt
	}   
	lappend opts $name
	if {[regsub -- .arg$ $name {} name] == 1} {

	    # Set defaults for those that take values.

	    set default [lindex $opt 1]
	    set result($name) $default
	} else {
	    # The default for booleans is false
	    set result($name) 0
	}
    }
    return $opts
}

# ::cmdline::usage --
#
#	Generate an error message that lists the allowed flags.
#
# Arguments:
#	optlist		As for cmdline::getoptions
#	usage		Text to include in the usage display. Defaults to
#			"options:"
#
# Results
#	A formatted usage message

proc ::cmdline::usage {optlist {usage {options:}}} {
    set str "[getArgv0] $usage\n"
    foreach opt [concat $optlist \
	    {{help "Print this message"} {? "Print this message"}}] {
	set name [lindex $opt 0]
	if {[regsub -- .secret$ $name {} name] == 1} {
	    # Hidden option
	    continue
	}
	if {[regsub -- .arg$ $name {} name] == 1} {
	    set default [lindex $opt 1]
	    set comment [lindex $opt 2]
	    append str [format " %-20s %s <%s>\n" "-$name value" \
		    $comment $default]
	} else {
	    set comment [lindex $opt 1]
	    append str [format " %-20s %s\n" "-$name" $comment]
	}
    }
    return $str
}

# ::cmdline::getfiles --
#
#	Given a list of file arguments from the command line, compute
#	the set of valid files.  On windows, file globbing is performed
#	on each argument.  On Unix, only file existence is tested.  If
#	a file argument produces no valid files, a warning is optionally
#	generated.
#
#	This code also uses the full path for each file.  If not
#	given it prepends [pwd] to the filename.  This ensures that
#	these files will never conflict with files in our zip file.
#
# Arguments:
#	patterns	The file patterns specified by the user.
#	quiet		If this flag is set, no warnings will be generated.
#
# Results:
#	Returns the list of files that match the input patterns.

proc ::cmdline::getfiles {patterns quiet} {
    set result {}
    if {$::tcl_platform(platform) == "windows"} {
	foreach pattern $patterns {
	    set pat [file join $pattern]
	    set files [glob -nocomplain -- $pat]
	    if {$files == {}} {
		if {! $quiet} {
		    puts stdout "warning: no files match \"$pattern\""
		}
	    } else {
		foreach file $files {
		    lappend result $file
		}
	    }
	}
    } else {
	set result $patterns
    }
    set files {}
    foreach file $result {
	# Make file an absolute path so that we will never conflict
	# with files that might be contained in our zip file.
	set fullPath [file join [pwd] $file]
	
	if {[file isfile $fullPath]} {
	    lappend files $fullPath
	} elseif {! $quiet} {
	    puts stdout "warning: no files match \"$file\""
	}
    }
    return $files
}

# ::cmdline::getArgv0 --
#
#	This command returns the "sanitized" version of argv0.  It will strip
#	off the leading path and remove the ".bin" extensions that our apps
#	use because they must be wrapped by a shell script.
#
# Arguments:
#	None.
#
# Results:
#	The application name that can be used in error messages.

proc ::cmdline::getArgv0 {} {
    global argv0

    set name [file tail $argv0]
    return [file rootname $name]
}


# 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 cmdline 1.2.3 [list source [file join $dir cmdline.tcl]]
# typedCmdline.tcl --
#
#    This package provides a utility for parsing typed command
#    line arguments that may be processed by various applications.
#
# Copyright (c) 2000 by Ross Palmer Mohn.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id$

namespace eval ::cmdline {
    namespace export typedGetopt typedGetoptions typedUsage

    # variable cmdline::charclasses --
    #
    #    Create regexp list of allowable character classes
    #    from "string is" error message.
    #
    # Results:
    #    String of character class names separated by "|" characters.

    variable charclasses
    catch {string is . .} charclasses
    regexp -- {must be (.+)$} $charclasses dummy charclasses
    regsub -all -- {, (or )?} $charclasses {|} charclasses

}

# ::cmdline::typedGetopt --
#
#	The cmdline::typedGetopt works in a fashion like the standard
#	C based getopt function.  Given an option string and a
#	pointer to a list of args this command will process the
#	first argument and return info on how to proceed. In addition,
#	you may specify a type for the argument to each option.
#
# Arguments:
#	argvVar		Name of the argv list that you want to process.
#			If options are found, the arg list is modified
#			and the processed arguments are removed from the
#			start of the list.
#
#	optstring	A list of command options that the application
#			will accept.  If the option ends in ".xxx", where
#			xxx is any valid character class to the tcl
#			command "string is", then typedGetopt routine will
#			use the next argument as a typed argument to the
#			option. The argument must match the specified
#			character classes (e.g. integer, double, boolean,
#			xdigit, etc.). Alternatively, you may specify
#			".arg" for an untyped argument.
#
#	optVar		Upon success, the variable pointed to by optVar
#			contains the option that was found (without the
#			leading '-' and without the .xxx extension).  If
#			typedGetopt fails the variable is set to the empty
#			string. SOMETIMES! Different for each -value!
#
#	argVar		Upon success, the variable pointed to by argVar
#			contains the argument for the specified option.
#			If typedGetopt fails, the variable is filled with
#			an error message.
#
# Argument type syntax:
#	Option that takes no argument.
#		foo
#
#	Option that takes a typeless argument.
#		foo.arg
#
#	Option that takes a typed argument. Allowable types are all
#	valid character classes to the tcl command "string is".
#	Currently must be one of alnum, alpha, ascii, control,
#	boolean, digit, double, false, graph, integer, lower, print,
#	punct, space, true, upper, wordchar, or xdigit.
#		foo.double
#
#	Option that takes an argument from a list.
#		foo.(bar|blat)
#
# Argument quantifier syntax:
#	Option that takes an optional argument.
#		foo.arg?
#
#	Option that takes a list of arguments terminated by "--".
#		foo.arg+
#
#	Option that takes an optional list of arguments terminated by "--".
#		foo.arg*
#
#	Argument quantifiers work on all argument types, so, for
#	example, the following is a valid option specification.
#		foo.(bar|blat|blah)?
#
# Argument syntax miscellany:
#	Options may be specified on the command line using a unique,
#	shortened version of the option name. Given that program foo
#	has an option list of {bar.alpha blah.arg blat.double},
#	"foo -b fob" returns an error, but "foo -ba fob"
#	successfully returns {bar fob}
#
# Results:
#	The typedGetopt function returns one of the following:
#	 1	a valid option was found
#	 0	no more options found to process
#	-1	invalid option
#	-2	missing argument to a valid option
#	-3	argument to a valid option does not match type
#
# Known Bugs:
#	When using options which include special glob characters,
#	you must use the exact option. Abbreviating it can cause
#	an error in the "cmdline::prefixSearch" procedure.

proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} {
    variable charclasses

    upvar $argvVar argsList

    upvar $optVar retvar
    upvar $argVar optarg

    # default settings for a normal return
    set optarg ""
    set retvar ""
    set retval 0

    # check if we're past the end of the args list
    if {[llength $argsList] != 0} {

        # if we got -- or an option that doesn't begin with -, return (skipping
        # the --).  otherwise process the option arg.
        switch -glob -- [set arg [lindex $argsList 0]] {
            "--" {
                set argsList [lrange $argsList 1 end]
            }

            "-*" {
                # Create list of options without their argument extensions

                set optstr ""
                foreach str $optstring {
                    lappend optstr [file rootname $str]
                }

                set _opt [string range $arg 1 end]

                set i [prefixSearch $optstr [file rootname $_opt]]
                if {$i != -1} {
                    set opt [lindex $optstring $i]

                    set quantifier "none"
                    if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} {
                        set opt [string range $opt 0 end-1]
                    }

                    if {[string first . $opt] == -1} {
                        set retval 1
                        set retvar $opt
                        set argsList [lrange $argsList 1 end]

                    } elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass]
                            || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} {
				if {[string equal arg $charclass]} {
                            set type arg
			} elseif {[regexp -- "^($charclasses)\$" $charclass]} {
                            set type class
                        } else {
                            set type oneof
                        }

                        set argsList [lrange $argsList 1 end]
                        set opt [file rootname $opt]

                        while {1} {
                            if {[llength $argsList] == 0
                                    || [string equal "--" [lindex $argsList 0]]} {
                                if {[string equal "--" [lindex $argsList 0]]} {
                                    set argsList [lrange $argsList 1 end]
                                }

                                set oneof ""
                                if {$type == "arg"} {
                                    set charclass an
                                } elseif {$type == "oneof"} {
                                    set oneof ", one of $charclass"
                                    set charclass an
                                }
    
                                if {$quantifier == "?"} {
                                    set retval 1
                                    set retvar $opt
                                    set optarg ""
                                } elseif {$quantifier == "+"} {
                                    set retvar $opt
                                    if {[llength $optarg] < 1} {
                                        set retval -2
                                        set optarg "Option requires at least one $charclass argument$oneof -- $opt"
                                    } else {
                                        set retval 1
                                    }
                                } elseif {$quantifier == "*"} {
                                    set retval 1
                                    set retvar $opt
                                } else {
                                    set optarg "Option requires $charclass argument$oneof -- $opt"
                                    set retvar $opt
                                    set retval -2
                                }
                                set quantifier ""
                            } elseif {($type == "arg")
                                    || (($type == "oneof")
                                    && [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1)
                                    || (($type == "class")
                                    && [string is $charclass [lindex $argsList 0]])} {
                                set retval 1
                                set retvar $opt
                                lappend optarg [lindex $argsList 0]
                                set argsList [lrange $argsList 1 end]
                            } else {
                                set oneof ""
                                if {$type == "arg"} {
                                    set charclass an
                                } elseif {$type == "oneof"} {
                                    set oneof ", one of $charclass"
                                    set charclass an
                                }
                                set optarg "Option requires $charclass argument$oneof -- $opt"
                                set retvar $opt
                                set retval -3
    
                                if {$quantifier == "?"} {
                                    set retval 1
                                    set optarg ""
                                }
                                set quantifier ""
                            }
                             if {![regexp -- {[+*]} $quantifier]} {
                                break;
                            }
                        }
                    } else {
                        error "Illegal option type specification:\
                                must be one of $charclasses"
                    }
                } else {
                    set optarg "Illegal option -- $_opt"
                    set retvar $_opt
                    set retval -1
                }
            }
	    default {
		# Skip ahead
	    }
        }
    }

    return $retval
}

# ::cmdline::typedGetoptions --
#
#	Process a set of command line options, filling in defaults
#	for those not specified. This also generates an error message
#	that lists the allowed options if an incorrect option is
#	specified.
#
# Arguments:
#	arglistVar	The name of the argument list, typically argv
#	optlist		A list-of-lists where each element specifies an option
#			in the form:
#
#				option default comment
#
#			Options formatting is as described for the optstring
#			argument of typedGetopt. Default is for optionally
#			specifying a default value. Comment is for optionally
#			specifying a comment for the usage display. The
#			options "-help" and "-?" are automatically included
#			in optlist.
#
# Argument syntax miscellany:
#	Options formatting and syntax is as described in typedGetopt.
#	There are two additional suffixes that may be applied when
#	passing options to typedGetoptions.
#
#	You may add ".multi" as a suffix to any option. For options
#	that take an argument, this means that the option may be used
#	more than once on the command line and that each additional
#	argument will be appended to a list, which is then returned
#	to the application.
#		foo.double.multi
#
#	If a non-argument option is specified as ".multi", it is
#	toggled on and off for each time it is used on the command
#	line.
#		foo.multi
#
#	If an option specification does not contain the ".multi"
#	suffix, it is not an error to use an option more than once.
#	In this case, the behavior for options with arguments is that
#	the last argument is the one that will be returned. For
#	options that do not take arguments, using them more than once
#	has no additional effect.
#
#	Options may also be hidden from the usage display by
#	appending the suffix ".secret" to any option specification.
#	Please note that the ".secret" suffix must be the last suffix,
#	after any argument type specification and ".multi" suffix.
#		foo.xdigit.multi.secret
#
# Results
#	Name value pairs suitable for using with array set.

proc ::cmdline::typedGetoptions {arglistVar optlist {usage options:}} {
    variable charclasses

    upvar 1 $arglistVar argv

    set opts {? help}
    foreach opt $optlist {
        set name [lindex $opt 0]
        if {[regsub -- {\.secret$} $name {} name] == 1} {
            # Remove this extension before passing to typedGetopt.
        }
        if {[regsub -- {\.multi$} $name {} name] == 1} {
            # Remove this extension before passing to typedGetopt.

            regsub -- {\..*$} $name {} temp
            set multi($temp) 1
        }
        lappend opts $name
        if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} {
            # Set defaults for those that take values.
            # Booleans are set just by being present, or not

            set dflt [lindex $opt 1]
            if {$dflt != {}} {
                set defaults($name) $dflt
            }
        }
    }
    set argc [llength $argv]
    while {[set err [typedGetopt argv $opts opt arg]]} {
        if {$err == 1} {
            if {[info exists result($opt)]
                    && [info exists multi($opt)]} {
                # Toggle boolean options or append new arguments

                if {$arg == ""} {
                    unset result($opt)
                } else {
                    set result($opt) "$result($opt) $arg"
                }
            } else {
                set result($opt) "$arg"
            }
        } elseif {($err == -1) || ($err == -3)} {
            error [typedUsage $optlist $usage]
        } elseif {$err == -2 && ![info exists defaults($opt)]} {
            error [typedUsage $optlist $usage]
        }
    }
    if {[info exists result(?)] || [info exists result(help)]} {
        error [typedUsage $optlist $usage]
    }
    foreach {opt dflt} [array get defaults] {
        if {![info exists result($opt)]} {
            set result($opt) $dflt
        }
    }
    return [array get result]
}

# ::cmdline::typedUsage --
#
#	Generate an error message that lists the allowed flags,
#	type of argument taken (if any), default value (if any),
#	and an optional description.
#
# Arguments:
#	optlist		As for cmdline::typedGetoptions
#
# Results
#	A formatted usage message

proc ::cmdline::typedUsage {optlist {usage {options:}}} {
    variable charclasses

    set str "[getArgv0] $usage\n"
    foreach opt [concat $optlist \
            {{help "Print this message"} {? "Print this message"}}] {
        set name [lindex $opt 0]
        if {[regsub -- {\.secret$} $name {} name] == 1} {
            # Hidden option

        } else {
            if {[regsub -- {\.multi$} $name {} name] == 1} {
                # Display something about multiple options
            }

            if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass]
                    || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} {
                   regsub -- "\\..+\$" $name {} name
                set comment [lindex $opt 2]
                set default "<[lindex $opt 1]>"
                if {$default == "<>"} {
                    set default ""
                }
                append str [format " %-20s %s %s\n" "-$name $charclass" \
                        $comment $default]
            } else {
                set comment [lindex $opt 1]
		append str [format " %-20s %s\n" "-$name" $comment]
            }
        }
    }
    return $str
}

# ::cmdline::prefixSearch --
#
#	Search a Tcl list for a pattern; searches first for an exact match,
#	and if that fails, for a unique prefix that matches the pattern 
#	(i.e, first "lsearch -exact", then "lsearch -glob $pattern*"
#
# Arguments:
#	list		list of words
#	pattern		word to search for
#
# Results:
#	Index of found word is returned. If no exact match or
#	unique short version is found then -1 is returned.

proc ::cmdline::prefixSearch {list pattern} {
    # Check for an exact match

    if {[set pos [::lsearch -exact $list $pattern]] > -1} {
        return $pos
    }

    # Check for a unique short version

    set slist [lsort $list]
    if {[set pos [::lsearch -glob $slist $pattern*]] > -1} {
        # What if there is nothing for the check variable?

        set check [lindex $slist [expr {$pos + 1}]]
        if {[string first $pattern $check] != 0} {
            return [::lsearch -exact $list [lindex $slist $pos]]
        }
    }
    return -1
}
cmdline.tcl {F 12923 29894} pkgIndex.tcl {F 602 16971} typedCmdline.tcl {F 16369 16369}trofs01Wpackage require Tcl 8.5
package require trofs 0.4
source [file join [trofs::mount [info script]] wrapper.tcl]
################################################################################
#
# wrapper.tcl 
#
# This file defines wrapper procedures.  These
# procedures are called by functions in jabberlib, and
# they in turn call the TclXML library functions.
#
# Seems to be originally written by Kerem HADIMLI, with additions
# from Todd Bradley. Completely rewritten from scratch by Mats Bengtsson.
# The algorithm for building parse trees has been completely redesigned.
# Only some structures and API names are kept essentially unchanged.
#
# $Id: wrapper.tcl,v 1.11 2004/10/18 14:01:04 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}]} {
    source [file join [file dirname [info script]] wrapper-tdom.tcl]
    return
}

# We have a dummy version number 99.0 as a workaround for the buggy tclparser.
package require xml 99.0

# For experiments...
#if {[catch {package require expat}]} {
#    package require xml 99.0
#}

namespace eval wrapper {

    # The public interface.
    namespace export what

    # Keep all internal data in this array, with 'id' as first index.
    variable wrapper
    variable debug 0
    
    # Running id that is never reused; start from 0.
    set wrapper(freeid) 0
    
    # Keep all 'id's in this list.
    set wrapper(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
    variable debug
    
    if {$debug > 1}  {
	puts "wrapper::new"
    }
    
    # Handle id of the wrapper.
    set id "wrap$wrapper(freeid)"
    incr wrapper(freeid)
    lappend wrapper(list) $id
    
    set wrapper($id,streamstartcmd) $streamstartcmd
    set wrapper($id,streamendcmd) $streamendcmd
    set wrapper($id,parsecmd) $parsecmd
    set wrapper($id,errorcmd) $errorcmd
    
    # Create the actual XML parser. It is created in our present namespace,
    # at least for the tcl parser!!!
    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
    }
    
    # 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) {}        
    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 ???
    set parser $wrapper($id,parser)
    parsereentrant $parser $xml
    return {}
}

# Reentrant xml parser wrapper. This ought to go in the parser!

namespace eval wrapper {

    # A reference counter for reentries.
    variable refcount 0
    
    # Stack for xml.
    variable stack ""
}

# 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:
#       p:           the parser.
#       xml:         raw xml data to be parsed.
#       
# Results:
#       none.

proc wrapper::parsereentrant {p xml} {
    variable refcount
    variable stack
    
    incr 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 $stack] > 0} {
	    set tmpstack $stack
	    set stack ""
	    $p parse $tmpstack
	}
    } else {
	
	# Reentry, put on stack for delayed execution.
	append stack $xml
    }
    incr refcount -1
    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
    variable debug
    
    if {$debug > 1}  {
	puts "wrapper::elementstart id=$id, tagname=$tagname,  \
	  attrlist='$attrlist', args=$args"
    }
    
    # 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,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
    variable debug
    
    if {$debug > 1}  {
	puts "wrapper::elementend id=$id, tagname=$tagname,  \
	  args='$args', level=$wrapper($id,level)"
    }
    
    # Check args, to see if empty element
    set isempty 0
    set ind [lsearch $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.
	set level [incr wrapper($id,level) -1]
	append_child $id $level $wrapper($id,tree,$childlevel)

	if {$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
    variable debug

    if {$debug > 1} {
	puts "wrapper::append_child id=$id, level=$level, childtree='$childtree'"
    }

    # 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
    variable debug

    if {$debug > 2}  {
	puts "wrapper::chdata id=$id, chardata='$chardata',  \
	  level=$wrapper($id,level)"
    }
    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::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
    variable debug

    if {$debug > 1} {
	puts "wrapper::reset id=$id"
    }

    if {1} {
	
    # This resets the actual XML parser. Not sure this is actually needed.
    $wrapper($id,parser) reset
    if {$debug > 1} {
	puts "   wrapper::reset configure parser"
    }
    
    # Unfortunately it also removes all our callbacks and options.
    if {$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 {
	$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.
    set lev 2
    while {[info exists wrapper($id,tree,$lev)]} {
	unset wrapper($id,tree,$lev)
	incr lev
    }
    
    # Reset also our internal wrapper to its initial position.
    set wrapper($id,level) 0
    set wrapper($id,levelonetag) {}
    set wrapper($id,tree,2) {}  
}

# 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
    variable debug

    if {$debug > 1} {
	puts "wrapper::xmlerror id=$id, args='$args'"
    }

    # Resets the wrapper and XML parser to be prepared for a fresh new document.
    #reset $id
    #uplevel #0 $wrapper($id,errorcmd) [list $args] ????
    uplevel #0 $wrapper($id,errorcmd) $args
    #reset $id
    return -code error {Fatal XML error}
}

# 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 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::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] > 0} {
	array set xmlarr $args
    }
    if {!(($xmlarr(-chdata) == "") && ($xmlarr(-subtags) == ""))} {
	set xmlarr(-isempty) 0
    }
    
    # Build sub elements list.
    set sublist {}
    foreach child $xmlarr(-subtags) {
	lappend sublist $child
    }
    set xmllist [list $tagname $xmlarr(-attrlist) $xmlarr(-isempty)  \
      $xmlarr(-chdata) $sublist]
    return $xmllist
}

# 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 {}
    foreach celem [lindex $xmllist 4] {
	if {[string equal [lindex $celem 0] $tag]} {
	    lappend clist $celem
	}
    }
    return $clist
}

proc wrapper::getchildwithtaginnamespace {xmllist tag ns} {
    
    set clist {}
    foreach celem [lindex $xmllist 4] {
	if {[string equal [lindex $celem 0] $tag]} {
	    unset -nocomplain attrArr
	    array set attrArr [lindex $celem 1]
	    if {[info exists attrArr(xmlns)] &&  \
	      [string equal $attrArr(xmlns) $ns]} {
		lappend clist $celem
		break
	    }
	}
    }
    return $clist
}

proc wrapper::getfromchilds {childs tag} {
    
    set clist {}
    foreach celem $childs {
	if {[string equal [lindex $celem 0] $tag]} {
	    lappend clist $celem
	}
    }
    return $clist
}

proc wrapper::getnamespacefromchilds {childs tag ns} {
    
    set clist {}
    foreach celem $childs {
	if {[string equal [lindex $celem 0] $tag]} {
	    unset -nocomplain attrArr
	    array set attrArr [lindex $celem 1]
	    if {[info exists attrArr(xmlns)] &&  \
	      [string equal $attrArr(xmlns) $ns]} {
		lappend clist $celem
		break
	    }
	}
    }
    return $clist
}

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::xmlcrypt --
#
#       Makes standard XML entity replacements.
#
# Arguments:
#       chdata:     character data.
#       
# Results:
#       chdata with XML standard entities replaced.

proc wrapper::xmlcrypt {chdata} {

    foreach from {\& < > {"} {'}}   \
      to {{\&amp;} {\&lt;} {\&gt;} {\&quot;} {\&apos;}} {
	regsub -all $from $chdata $to chdata
    }	
    return $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} {

    foreach from {{\&amp;} {\&lt;} {\&gt;} {\&quot;} {\&apos;}}   \
      to {{\&} < > {"} {'}} {
	regsub -all $from $chdata $to chdata
    }	
    return $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.0
    
################################################################################
#
# wrapper.tcl 
#
# This file defines wrapper procedures.  These
# procedures are called by functions in jabberlib, and
# they in turn call the TclXML library functions.
#
# Seems to be originally written by Kerem HADIMLI, with additions
# from Todd Bradley. Completely rewritten from scratch by Mats Bengtsson.
# The algorithm for building parse trees has been completely redesigned.
# Only some structures and API names are kept essentially unchanged.
#
# $Id: wrapper.tcl,v 1.2 2004/12/09 09:12:55 pat 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

package require tdom

namespace eval wrapper {

    # The public interface.
    namespace export what

    # Keep all internal data in this array, with 'id' as first index.
    variable wrapper
    variable debug 1
    
    # Running id that is never reused; start from 0.
    set wrapper(freeid) 0
    
    # Keep all 'id's in this list.
    set wrapper(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
    variable debug
    
    if {$debug > 1}  {
	puts "wrapper::new"
    }
    
    # Handle id of the wrapper.
    set id "wrap$wrapper(freeid)"
    incr wrapper(freeid)
    lappend wrapper(list) $id
    
    set wrapper($id,streamstartcmd) $streamstartcmd
    set wrapper($id,streamendcmd) $streamendcmd
    set wrapper($id,parsecmd) $parsecmd
    set wrapper($id,errorcmd) $errorcmd
    
    # Create the actual XML parser. It is created in our present namespace,
    # at least for the tcl parser!!!
    set wrapper($id,parser) [xml::parser -namespace 1]
    set wrapper($id,class) "expat"
    $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

    # 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) {}        
    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 ???
    set parser $wrapper($id,parser)
    parsereentrant $parser $xml
    return {}
}

# Reentrant xml parser wrapper. This ought to go in the parser!

namespace eval wrapper {

    # A reference counter for reentries.
    variable refcount 0
    
    # Stack for xml.
    variable stack ""
}

# 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:
#       p:           the parser.
#       xml:         raw xml data to be parsed.
#       
# Results:
#       none.

proc wrapper::parsereentrant {p xml} {
    variable refcount
    variable stack
    
    incr 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 $stack] > 0} {
	    set tmpstack $stack
	    set stack ""
	    $p parse $tmpstack
	}
    } else {
	
	# Reentry, put on stack for delayed execution.
	append stack $xml
    }
    incr refcount -1
    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
    variable debug
    
    if {$debug > 1}  {
	puts "wrapper::elementstart id=$id, tagname=$tagname,  \
	  attrlist='$attrlist', args=$args"
    }
    
    # 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 {[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 {$debug > 1} {
            puts "        exploded [list $ns $tagname]"
        }
    }

    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
    variable debug
    
    if {$debug > 1}  {
	puts "wrapper::elementend id=$id, tagname=$tagname,  \
	  args='$args', level=$wrapper($id,level)"
    }
    
    # Check args, to see if empty element
    set isempty 0
    set ind [lsearch $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.
	set level [incr wrapper($id,level) -1]
	append_child $id $level $wrapper($id,tree,$childlevel)

	if {$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
    variable debug

    if {$debug > 1} {
	puts "wrapper::append_child id=$id, level=$level, childtree='$childtree'"
    }

    # 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
    variable debug

    if {$debug > 2}  {
	puts "wrapper::chdata id=$id, chardata='$chardata',  \
	  level=$wrapper($id,level)"
    }
    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
    variable debug

    if {$debug > 1} {
	puts "wrapper::reset id=$id"
    }

    # We cannot reset a tdom expat parser from within a callback. However,
    # we can always replace it with a new one.
    #$wrapper($id,parser) reset
    set old $wrapper($id,parser)
    after idle [list [namespace origin free] $old]
    set wrapper($id,parser) [xml::parser -namespace 1]

    if {$debug > 1} {
        puts "   wrapper::reset configure parser"
    }
    
    $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
    
    # Cleanup internal state vars.
    set lev 2
    while {[info exists wrapper($id,tree,$lev)]} {
	unset wrapper($id,tree,$lev)
	incr lev
    }
    
    # Reset also our internal wrapper to its initial position.
    set wrapper($id,level) 0
    set wrapper($id,levelonetag) {}
    set wrapper($id,tree,2) {}  
}

# 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
    variable debug

    if {$debug > 1} {
	puts "wrapper::xmlerror id=$id, args='$args'"
    }

    # Resets the wrapper and XML parser to be prepared for a fresh new document.
    #reset $id
    #uplevel #0 $wrapper($id,errorcmd) [list $args] ????
    uplevel #0 $wrapper($id,errorcmd) $args
    #reset $id
    return -code error {Fatal XML error}
}

# 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 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::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] > 0} {
	array set xmlarr $args
    }
    if {!(($xmlarr(-chdata) == "") && ($xmlarr(-subtags) == ""))} {
	set xmlarr(-isempty) 0
    }
    
    # Build sub elements list.
    set sublist {}
    foreach child $xmlarr(-subtags) {
	lappend sublist $child
    }
    set xmllist [list $tagname $xmlarr(-attrlist) $xmlarr(-isempty)  \
      $xmlarr(-chdata) $sublist]
    return $xmllist
}

# 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 {}
    foreach celem [lindex $xmllist 4] {
	if {[string equal [lindex $celem 0] $tag]} {
	    lappend clist $celem
	}
    }
    return $clist
}

proc wrapper::getchildwithtaginnamespace {xmllist tag ns} {
    
    set clist {}
    foreach celem [lindex $xmllist 4] {
	if {[string equal [lindex $celem 0] $tag]} {
	    unset -nocomplain attrArr
	    array set attrArr [lindex $celem 1]
	    if {[info exists attrArr(xmlns)] &&  \
	      [string equal $attrArr(xmlns) $ns]} {
		lappend clist $celem
		break
	    }
	}
    }
    return $clist
}

proc wrapper::getfromchilds {childs tag} {
    
    set clist {}
    foreach celem $childs {
	if {[string equal [lindex $celem 0] $tag]} {
	    lappend clist $celem
	}
    }
    return $clist
}

proc wrapper::getnamespacefromchilds {childs tag ns} {
    
    set clist {}
    foreach celem $childs {
	if {[string equal [lindex $celem 0] $tag]} {
	    unset -nocomplain attrArr
	    array set attrArr [lindex $celem 1]
	    if {[info exists attrArr(xmlns)] &&  \
	      [string equal $attrArr(xmlns) $ns]} {
		lappend clist $celem
		break
	    }
	}
    }
    return $clist
}

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::xmlcrypt --
#
#       Makes standard XML entity replacements.
#
# Arguments:
#       chdata:     character data.
#       
# Results:
#       chdata with XML standard entities replaced.

proc wrapper::xmlcrypt {chdata} {

    foreach from {\& < > {"} {'}}   \
      to {{\&amp;} {\&lt;} {\&gt;} {\&quot;} {\&apos;}} {
	regsub -all $from $chdata $to chdata
    }	
    return $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} {

    foreach from {{\&amp;} {\&lt;} {\&gt;} {\&quot;} {\&apos;}}   \
      to {{\&} < > {"} {'}} {
	regsub -all $from $chdata $to chdata
    }	
    return $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.0
wrapper.tcl {F 23168 46116} wrapper-tdom.tcl {F 22948 22948}trofs01<################################################################################
#
# This is JabberLib (abbreviated jlib), the Tcl library for 
# use in making Jabber clients.
# Is originally written by Kerem HADIMLI, with additions
# from Todd Bradley. 
# Completely rewritten from scratch by Mats Bengtsson.
# The algorithm for building parse trees has been completely redesigned.
# Only some structures and API names are kept essentially unchanged.
#
# $Id: jabberlib.tcl,v 1.82 2005/02/09 14:30:32 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(rostername)            : the name of the roster object
#	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 server domain name or ip number
#       locals(username)
#       locals(myjid)
#       locals(myjid2)
#	                               
############################# SCHEMA ###########################################
#
#                                         -> roster >-  
#                                        /            \ 
#                                       /              \
#   TclXML <---> wrapper <---> jabberlib <-----------> client
#                                       
#                                       
#   
#   Note the one-way communication with the 'roster' object since it may only
#   be set by the server, that is, from 'jabberlib'. 
#   The client only "gets" the roster.
#
############################# USAGE ############################################
#
#   NAME
#      jabberlib - an interface between Jabber clients and the wrapper
#      
#   SYNOPSIS
#      jlib::new rosterName 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
#	-autoaway             boolean 0/1 if to send away message after inactivity
#	-xautoaway            boolean 0/1 if to send xaway message after inactivity
#	-awaymin              if -away send away message after this many minutes
#	-xawaymin             if -xaway send xaway message after this many minutes
#	-awaymsg              the away message 
#	-xawaymsg             the xaway message
#	
#   INSTANCE COMMANDS
#      jlibName agent_get to cmd
#      jlibName agents_get to cmd
#      jlibName config ?args?
#      jlibName openstream server ?args?
#      jlibName closestream
#      jlibName element_deregister tag func
#      jlibName element_register tag func ?seq?
#      jlibName getstreamattr name
#      jlibName havefeatures name
#      jlibName get_last to cmd
#      jlibName get_time to cmd
#      jlibName get_version to cmd
#      jlibName getagent jid
#      jlibName getrecipientjid jid
#      jlibName haveagent jid
#      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 mystatus
#      jlibName oob_set to cmd url ?args?
#      jlibName presence_register type cmd
#      jlibName registertransport initProc sendProc resetProc
#      jlibName register_set username password cmd ?args?
#      jlibName register_get cmd ?args?
#      jlibName register_remove to cmd ?args?
#      jlibName resetstream
#      jlibName roster_get cmd
#      jlibName roster_set item cmd ?args?
#      jlibName roster_remove item cmd
#      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 vcard_get to cmd
#      jlibName vcard_set cmd ?args?
#      
#  o using the experimental 'conference' protocol:  OUTDATED!
#      jlibName conference get_enter room cmd
#      jlibName conference set_enter room subelements cmd
#      jlibName conference get_create server cmd
#      jlibName conference set_create room subelements cmd
#      jlibName conference delete room cmd
#      jlibName conference exit room
#      jlibName conference set_user room name jid cmd
#      jlibName conference hashandnick room
#      jlibName conference roomname room
#      jlibName conference allroomsin
#      
#      
#   The callbacks given for any of the '-iqcommand', '-messagecommand', 
#   or '-presencecommand' must have the following form:
#   
#      Callback {jlibName type args}
#      
#   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, iqreply, message, xmlerror,
#   version, presence, networkerror, oob, away, xaway, .... Iq elements have
#   the what equal to the last namespace specifier.
#   'args' is a list of '-key value' pairs.
#      
############################# CHANGES ##########################################
#
#       0.*      by Kerem HADIMLI and Todd Bradley
#       1.0a1    complete rewrite, and first release by Mats Bengtsson
#       1.0a2    minor additions and fixes
#       1.0a3    added vCard, '-cmd' to 'connect', private_get/set
#       1.0b1    few bugfixes, added browse_get, agent_get
#       1.0b2    type attribute in send_message wrong
#       1.0b3    added support for conferencing, many rewrites
#       1.0b4    added time, last, version
#       1.0b5    added better error catching
#       1.0b6    added config and auto away support
#       1.0b7    fixed bug in send_message for x elements
#       1.0b8    fixed bug in send_iq if xmldata empty
#	1.0b9    added configurable transport layer, incompatible change
#		     of 'connect' command
#                placed debug printouts in one proc; access function for debug
#                added caching of agent(s) stuff
#                added a 'service' subcommand
#                added the old groupchat interface
#                added a 'conference' subcommand, removed conf_* methods
#                added -streamnamespace option
#                completely reworked client callback structure
#                'register_remove' is now an iq-set command, new 'to' argument
#       1.0b10   fixed a number of problems with groupchat-conference compatibility,
#                added presence callback
#       1.0b11   changed 'browse_get' command 
#                added 'mystatus' command, added 'setgroupchatpriority',
#                'setgroupchatprotocol' and reworked all groupchat protocol
#                dispatching.
#       030523   added 'getagent' and 'haveagent' commands.
#       030611   added 'setroomprotocol' command and modified service dispatching
#       030705   jlib::new generates self token
#       030726   made browse object optional, jlib::new api changed!
#       031022   added iq_get and iq_set methods
#       031101   added 'service gettransportjids' and 'gettype'
#       031107   added 'getrecipientjid' command
#       040111   new iq callback mechanism 'iq_register'
#       
#       04*      started with 2.0 version; 
#                removed all browse stuff, added presence_register, muc as a
#                standalone component, jlibname now always fully qualified,
#                connect -> openstream, disconnect -> closestream
#                
#       050201  all network errors handled via client command (clientcmd)
#               individual commands shall never throw network errors!

package require wrapper
package require roster
package require service
package require stanzaerror
package require streamerror
package require groupchat

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)}
    
    variable version 1.0
    
    # Running number.
    variable uid 0
    
    # Some common xmpp xml namespaces.
    variable xmppns
    array set xmppns {
	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
    }
}

# Collects the 'conference' subcommand.
namespace eval jlib::conference { }

# jlib::new --
#
#       This creates a new instance jlib interpreter.
#       
# Arguments:
#       rostername: the name of the roster object
#       clientcmd:  callback procedure for the client
#       args:       
#	-iqcommand            
#	-messagecommand       
#	-presencecommand      
#	-streamnamespace      
#	-keepalivesecs        
#	-autoaway             
#	-xautoaway            
#	-awaymin              
#	-xawaymin             
#	-awaymsg              
#	-xawaymsg             
#       
# Results:
#       jlibname which is the namespaced instance command
  
proc jlib::new {rostername clientcmd args} {    

    variable statics
    variable objectmap
    variable uid
    
    # 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 opts
	variable agent
	# Cache for the 'conference' subcommand.
	variable conf
    }
            
    # Set simpler variable names.
    upvar ${jlibname}::lib      lib
    upvar ${jlibname}::iqcmd    iqcmd
    upvar ${jlibname}::prescmd  prescmd
    upvar ${jlibname}::opts     opts
    upvar ${jlibname}::conf     conf
    upvar ${jlibname}::locals   locals
    
    array set opts {
	-iqcommand            ""
	-messagecommand       ""
	-presencecommand      ""
	-streamnamespace      "jabber:client"
	-keepalivesecs        30
	-autoaway             0
	-xautoaway            0
	-awaymin              0
	-xawaymin             0
	-awaymsg              ""
	-xawaymsg             ""
    }
    
    # Verify options.
    if {[catch {eval jlib::verify_options $jlibname $args} msg]} {
	return -code error $msg
    }
    
    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 lib(rostername)   $rostername
    set lib(clientcmd)    $clientcmd
    set lib(wrap)         $wrapper
    
    set lib(isinstream) 0
    set locals(server) ""
    
    # 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
    iq_register $jlibname get jabber:iq:version \
      [namespace current]::handle_get_version
        
    # Any of {available away dnd invisible unavailable}
    set locals(status) "unavailable"
    set locals(myjid) ""
    
    # Init conference and groupchat state.
    set conf(allroomsin) {}
    jlib::groupchat::init $jlibname

    # Create the actual jlib instance procedure.
    proc $jlibname {cmd args}   \
      "eval jlib::cmdproc {$jlibname} \$cmd \$args"
    
    # Init the service layer for this jlib instance.
    jlib::service::init $jlibname
    
    return $jlibname
}


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::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)
}

# 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} {
    
    Debug 5 "jlib::cmdproc: jlibname=$jlibname, cmd='$cmd', args='$args'"

    # Which command? Just dispatch the command to the right procedure.
    return [eval {$cmd $jlibname} $args]
}

# jlib::getrostername --
# 
#       Just returns the roster instance for this jlib instance.

proc jlib::getrostername {jlibname} {
    
    upvar ${jlibname}::lib lib
    
    return $lib(rostername)
}

# jlib::config --
#
#	See documentaion for details.
#
# Arguments:
#	args		Options parsed by the procedure.
#	
# Results:
#       depending on args.

proc jlib::config {jlibname args} {    

    upvar ${jlibname}::opts opts
    
    array set argsArr $args
    set options [lsort [array names opts -*]]
    set usage [join $options ", "]
    if {[llength $args] == 0} {
	set result {}
	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 {
	foreach {flag value} $args {
	    if {[regexp -- $pat $flag]} {
		set opts($flag) $value		
	    } else {
		return -code error "Unknown option $flag, must be: $usage"
	    }
	}
    }
    
    # Reschedule auto away if changed.
    if {[info exists argsArr(-autoaway)] || \
      [info exists argsArr(-xautoaway)] || \
      [info exists argsArr(-awaymin)] || \
      [info exists argsArr(-xawaymin)]} {
	schedule_auto_away $jlibname
    }
    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::registertransport --
# 
# 

proc jlib::registertransport {jlibname initProc sendProc resetProc} {
    
    upvar ${jlibname}::lib lib

    set lib(transportinit)  $initProc
    set lib(transportsend)  $sendProc
    set lib(transportreset) $resetProc
}

# 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(transportinit)  [list [namespace current]::initsocket $jlibname]
    set lib(transportsend)  [list [namespace current]::putssocket $jlibname]
    set lib(transportreset) [list [namespace current]::resetsocket $jlibname]
}

# The procedures for the standard socket transport layer -----------------------

# jlib::initsocket
#
#	Default transport mechanism; init 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 $opts(-keepalivesecs)  \
	  [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 {[catch {puts -nonewline $lib(sock) $xml} err]} {
	# Error propagated to the caller that calls clientcmd.
	return -code error
    }
}

# 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)}
}

# 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
	uplevel #0 $lib(clientcmd) [list $jlibname networkerror]	  
	return
    }
    
    # Read what we've got.
    if {[catch {read $lib(sock)} temp]} {
	kill $jlibname

	# We need to call clientcmd here since async event.
	uplevel #0 $lib(clientcmd) [list $jlibname networkerror]	  
	return
    }
    Debug 2 "RECV: $temp"
    
    # 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) $temp
}

# standard socket transport layer end ------------------------------------------

# 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 xmppns

    array set argsArr $args
    set locals(server) $server
    set locals(last) [clock seconds]

    # Register a <stream> callback proc.
    if {[info exists argsArr(-cmd)] && [llength $argsArr(-cmd)]} {
	set lib(streamcmd) $argsArr(-cmd)
    }
    set optattr ""
    foreach {key value} $args {
	
	switch -- $key {
	    -cmd - -socket {
		# empty
	    }
	    default {
		set attr [string trimleft $key "-"]
		append optattr " $attr='$value'"
	    }
	}
    }

    if {[catch {

	# This call to the transport layer shall set up fileevent callbacks etc.
   	# to handle all incoming xml.
	eval $lib(transportinit)
        
    	# 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='$xmppns(stream)'\
	  xml:lang='[getlang]' to='$server'$optattr>"

	eval $lib(transportsend) {$xml}
    } err]} {
	
	# The socket probably was never connected,
	# or the connection dropped later.
	closestream $jlibname
	return -code error "The connection failed or dropped later: $err"
    }
    return ""
}

# jlib::closestream --
#
#       Closes the stream down, closes socket, and resets internal variables.
#       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 3 "jlib::closestream"

    set xml "</stream:stream>"
    catch {eval $lib(transportsend) {$xml}}
    kill $jlibname
}

# jlib::kill --
# 
#       Like closestream but without any network transactions.

proc jlib::kill {jlibname} {
    
    upvar ${jlibname}::lib lib

    Debug 3 "jlib::kill"
    
    catch {eval $lib(transportreset)}
    reset $jlibname
    
    # Be sure to reset the wrapper, which implicitly resets the XML parser.
    wrapper::reset $lib(wrap)
}

# 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} {
    
    Debug 5 "jlib::dispatcher jlibname=$jlibname, xmldata=$xmldata"
    
    # 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 $tag $xmldata
	}
    }
}

# jlib::iq_handler --
#
#       Callback for incoming <iq> elements.
#       The handling sequence is the following:
#       1) handle all roster pushes (set) internally
#       2) handle all preregistered callbacks via id attributes
#       3) handle callbacks specific for 'type' and 'xmlns' that have been
#          registered with 'iq_register'
#       4) if unhandled by 3, use any -iqcommand callback
#       5) if still, use the client command callback
#       6) 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    
    variable xmppns

    Debug 5 "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 {}
    foreach {key value} [array get attrArr] {
	set $key $value
	lappend arglist -$key $value
    }
    
    # The 'type' attribute must exist! Else we return silently.
    if {![info exists type]} {	
	return
    }
    if {![info exists from]} {
	set afrom ""
    } else {
	set afrom $from
    }
    
    # The child must be a single <query> element (or any namespaced element).
    # WRONG WRONG !!!!!!!!!!!!!!!
    set childlist [wrapper::getchildren $xmldata]
    set subiq [lindex $childlist 0]
    set xmlns [wrapper::getattribute $subiq xmlns]
    
    if {[string equal $type "error"]} {
	set callbackType "error"
    } elseif {[regexp {.*:([^ :]+)$} $xmlns match callbackType]} {
	# empty
    } else {
	set callbackType "iqreply"
    }
    set ishandled 0

    # (1) This is a server push! Handle internally.

    if {[string equal $type "set"]} {
	
	switch -- $xmlns {
	    jabber:iq:roster {
		
		# Found a roster-push, typically after a subscription event.
		# First, we reply to the server, saying that, we 
		# got the data, and accepted it. ???		    
		# We call the 'parse_roster_get', because this
		# data is the same as the one we get from a 'roster_get'.
		
		parse_roster_get $jlibname 1 {} ok $subiq
		#parse_roster_get $jlibname 1 {} set $subiq
		set ishandled 1
	    }
	}
    }
    
    # (2) Handle all preregistered callbacks via id attributes.
    #     Must be type 'result' or 'error'.

    switch -- $type {
	result {

	    # A request for the entire roster is coming this way, 
	    # and calls 'parse_roster_set'.
	    # $iqcmd($id) contains the 'parse_...' call as 1st element.
	    if {[info exists id] && [info exists iqcmd($id)]} {
		
		# TODO: add attrArr to callback.
		uplevel #0 $iqcmd($id) [list result $subiq]
		        
		#uplevel #0 $iqcmd($id) [list result $subiq] $arglist
		
		# 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)]} {
		uplevel #0 $iqcmd($id) [list error $errspec]
		
		#uplevel #0 $iqcmd($id) [list error $xmldata]
		
		unset -nocomplain iqcmd($id)
		set ishandled 1
	    }	    
	}
    }
	        
    # (3) 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]
    }
    
    # (4) If unhandled by 3, use any -iqcommand callback.

    if {[string equal $ishandled "0"]} {	
	if {[string length $opts(-iqcommand)]} {
	    set iqcallback [concat  \
	      [list $jlibname $type -query $subiq] $arglist]
	    set ishandled [uplevel #0 $opts(-iqcommand) $iqcallback]
	} 
	    
	# (5) If unhandled by 3 and 4, use the client command callback.

	if {[string equal $ishandled "0"]} {
	    set clientcallback [concat  \
	      [list $jlibname $callbackType -query $subiq] $arglist]
	    set ishandled [uplevel #0 $lib(clientcmd) $clientcallback]
	}

	# (6) 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)]} {
		set attrArr(to) $attrArr(from)
		unset attrArr(from)
		set attrArr(type) "error"
		set xmldata [wrapper::setattrlist $xmldata [array get attrArr]]
		
		set errstanza [wrapper::createtag "feature-not-implemented" \
		  -attrlist [list xmlns $xmppns(stanzas)]]
		set errtag [wrapper::createtag "error" -subtags [list $errstanza] \
		  -attrlist {code 501 type cancel}]
		
		lappend childlist $errtag
		set xmldata [wrapper::setchildlist $xmldata $childlist]
		
		send $jlibname $xmldata
	    }
	}
    }
}
    
# 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
    
    # 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.
    set arglist {}
    foreach {key value} [array get attrArr] {
	lappend arglist -$key $value
    }
    set ishandled 0
    
    switch -- $type {
	error {
	    set errspec [getstanzaerrorspec $xmldata]
	    lappend arglist -error $errspec
	}
    }
   
    # Extract the message sub-elements.
    set x {}
    set xxmlnsList {}
    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 {
		lappend arglist -$ctag $cchdata
	    }
	    x {
		lappend x $child
		lappend xxmlnsList [wrapper::getattribute $child xmlns]
	    }
	}
    }
    if {[llength $x]} {
	lappend arglist -x $x
	set xxmlnsList [lsort -unique $xxmlnsList]
	
	# Invoke any registered message handlers.
	foreach xxmlns $xxmlnsList {
	    set ishandled [eval {
		message_run_hook $jlibname $type $xxmlns} $arglist]
	    if {$ishandled} {
		break
	    }
	}
    }
    if {[string equal $ishandled "0"]} {	
    
	# Invoke callback to client.
	if {[string length $opts(-messagecommand)]} {
	    uplevel #0 $opts(-messagecommand) [list $jlibname $type] $arglist
	} else {
	    uplevel #0 $lib(clientcmd) [list $jlibname message] $arglist
	}
    }
}
    
# 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} { 

    upvar ${jlibname}::lib lib
    upvar ${jlibname}::prescmd prescmd
    upvar ${jlibname}::opts opts
    
    # Extract the command level XML data items.
    set attrlist  [wrapper::getattrlist $xmldata]
    set childlist [wrapper::getchildren $xmldata]
    array set attrArr $attrlist
    
    # Make an argument list ('-key value' pairs) suitable for callbacks.
    # Make variables of the attributes.
    set arglist {}
    set type "available"
    foreach {attrkey attrval} $attrlist {
	set $attrkey $attrval
	lappend arglist -$attrkey $attrval
    }
    
    # Check first if this is an error element (from conferencing?).
    if {[string equal $type "error"]} {
	set errspec [getstanzaerrorspec $xmldata]
	lappend arglist -error $errspec
    } else {
	
	# Extract the presence sub-elements. Separate the x element.
	set x {}
	set extras {}
	foreach child $childlist {
	    
	    # Extract the presence sub-elements XML data items.
	    set ctag [wrapper::gettag $child]
	    set cchdata [wrapper::getcdata $child]
	    
	    switch -- $ctag {
		status - priority - show {
		    lappend params $ctag $cchdata
		    lappend arglist -$ctag $cchdata
		}
		x {
		    lappend x $child
		}
		default {
		    
		    # This can be anything properly namespaced.
		    lappend extras $child
		}
	    }
	}	    
	if {[llength $x] > 0} {
	    lappend arglist -x $x
	}
	if {[llength $extras] > 0} {
	    lappend arglist -extras $extras
	}
	
	# Do different things depending on the 'type' attribute.
	if {[string equal $type "available"] ||  \
	  [string equal $type "unavailable"]} {
	    
	    # Not sure if we should exclude roster here since this
	    # is not pushed to us but requested.
	    # It must be set for presence sent to groupchat rooms!
	    
	    # Set presence in our roster object
	    eval {$lib(rostername) setpresence $from $type} $arglist
	} else {
	    
	    # We probably need to respond to the 'presence' element;
	    # 'subscribed'?. ????????????????? via lib(rostername)
	    # If we have 'unsubscribe'd another users presence it cannot be
	    # anything else than 'unavailable' anymore.
	    if {[string equal $type "unsubscribed"]} {
		$lib(rostername) setpresence $from "unsubscribed"
	    }
	    if {[string length $opts(-presencecommand)]} {
		uplevel #0 $opts(-presencecommand) [list $jlibname $type] $arglist
	    } else {
		uplevel #0 $lib(clientcmd) [list $jlibname presence] $arglist
	    }	
	}
    }
    
    # Invoke any callback before the rosters callback.
    if {[info exists id] && [info exists prescmd($id)]} {
	uplevel #0 $prescmd($id) [list $jlibname $type] $arglist
	unset -nocomplain prescmd($id)
    }	
    if {![string equal $type "error"]} {
	eval {$lib(rostername) invokecommand $from $type} $arglist
    }
    
    #     Handle callbacks specific for 'type' that have been
    #     registered with 'presence_register'

    eval {presence_run_hook $jlibname $from $type} $arglist
}

# jlib::features_handler --
# 
# 

proc jlib::features_handler {jlibname xmllist} {

    upvar ${jlibname}::locals locals
    variable xmppns
    
    foreach child [wrapper::getchildren $xmllist] {
	wrapper::splitxml $child tag attr chdata children
	
	switch -- $tag {
	    mechanisms {
		if {[wrapper::getattr $attr xmlns] == $xmppns(sasl)} {
		    set mechanisms {}
		    foreach mechelem $children {
			wrapper::splitxml $mechelem mtag mattr mchdata mchild
			if {$mtag == "mechanism"} {
			    lappend mechanisms $mchdata
			}
		    }

		    # Variable that may trigger a trace event.
		    set locals(features,mechanisms) $mechanisms
		}
	    }
	    starttls {
		if {[wrapper::getattr $attr xmlns] == $xmppns(tls)} {
		    set locals(features,starttls) 1
		    set childs [wrapper::getchildswithtag $xmllist required]
		    if {$childs != ""} {
			set locals(features,starttls,required) 1
		    }
		}
	    }
	    default {
		set locals(features,$tag) 1
	    }
	}
    }
    
    # Variable that may trigger a trace event.
    set locals(features) 1
}

# jlib::havefeatures --
# 
#       Just to get access of the stream features.

proc jlib::havefeatures {jlibname name {name2 ""}} {
    
    upvar ${jlibname}::locals locals

    set ans 0
    if {$name2 != ""} {
	if {[info exists locals(features,$name,$name2)]} {
	    set ans $locals(features,$name,$name2)
	}
    } else {
	if {[info exists locals(features,$name)]} {
	    set ans $locals(features,$name)
	}
    }
    return $ans
}

# 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>

proc jlib::error_handler {jlibname xmllist} {

    upvar ${jlibname}::lib lib
    variable xmppns
    
    closestream $jlibname
    
    # Be sure to reset the wrapper, which implicitly resets the XML parser.
    wrapper::reset $lib(wrap)
    if {[llength [wrapper::getchildren $xmllist]]} {
	set errspec [getstreamerrorspec $xmllist]
    } else {
	set errspec [list unknown [wrapper::getcdata $xmllist]]
    }
    uplevel #0 $lib(clientcmd) [list $jlibname streamerror -errormsg $errspec]
}

# 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 3 "jlib::got_stream jlibname=$jlibname, args='$args'"
    
    # Cache stream attributes.
    foreach {name value} $args {
	set locals(streamattr,$name) $value
    }
    uplevel #0 $lib(clientcmd) [list $jlibname connect]
    schedule_auto_away $jlibname
    set lib(isinstream) 1
    
    # 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 3 "jlib::end_of_parse jlibname=$jlibname"
    
    catch {eval $lib(transportreset)}
    uplevel #0 $lib(clientcmd) [list $jlibname disconnect]
    reset $jlibname
}

# 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} {

    upvar ${jlibname}::lib lib

    Debug 3 "jlib::xmlerror jlibname=$jlibname, args='$args'"
    
    catch {eval $lib(transportreset)}
    uplevel #0 $lib(clientcmd) [list $jlibname xmlerror -errormsg $args]
    reset $jlibname
}

# 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}::agent agent
    upvar ${jlibname}::locals locals
    variable statics
    
    Debug 3 "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 agent
    
    unset -nocomplain locals
    set locals(status) "unavailable"
    set locals(server) ""
    set locals(myjid)  ""

    set lib(isinstream) 0
    
    stream_reset $jlibname
    sasl_reset $jlibname
    if {[havetls]} {
	tls_reset $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
    
    array unset locals features*
    array unset locals streamattr,*
}

# 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>

proc jlib::getstanzaerrorspec {stanza} {
    
    variable xmppns

    set errcode ""
    set errmsg  ""
        
    # First search children of stanza (<iq> element) for error element.
    foreach subiq [wrapper::getchildren $stanza] {
	set tag [wrapper::gettag $subiq]
	if {[string equal $tag "error"]} {
	    set errelem $subiq
	}
	if {[string equal $tag "query"]} {
	    set queryelem $subiq
	}
    }
    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:
#       none.

proc jlib::geterrspecfromerror {errelem kind} {
       
    variable xmppns
    variable errCodeToText

    set cchdata [wrapper::getcdata $errelem]
    array set msgproc {
	stanzas  stanzaerror::getmsg
	streams  streamerror::getmsg
    }
    set errcode [wrapper::getattribute $errelem code]
    if {[string is integer $errcode]} {
	if {[info exists errCodeToText($errcode)]} {
	    set errmsg $errCodeToText($errcode)
	} else {
	    set errmsg "Unknown"
	}
    } elseif {$cchdata != ""} {
	
	# Old jabber way.
	set errmsg $cchdata
    } else {
	set errcode ""
	set errmsg  ""
	
	# 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]
		    if {[string equal $xmlns $xmppns($kind)] && \
		      [string equal $lang [getlang]]} {
			set errstr [wrapper::getcdata $c]
		    }
		} 
		default {
		    set xmlns [wrapper::getattribute $c xmlns]
		    if {[string equal $xmlns $xmppns($kind)]} {
			set errcode $tag
			set errmsg [$msgproc($kind) $tag]
		    }
		}
	    }
	}
	if {[info exists errstr]} {
	    append $errmsg " $errstr"
	}
    }
    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 xmppns

    set xmllist [wrapper::createtag bind \
      -attrlist [list xmlns $xmppns(bind)] \
      -subtags [list [wrapper::createtag resource -chdata $resource]]]
    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 xmppns
    
    # 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] $xmppns(bind)]} {
	set jidelem [wrapper::getchildswithtag $subiq jid]
	if {$jidelem != {}} {
	    set sjid [wrapper::getcdata $jidelem]
	    splitjid $sjid sjid2 sresource
	    if {![string equal [resourcemap $locals(resource)] $sresource]} {
		set locals(resource) $sresource
		set locals(myjid) "$locals(myjid2)/$sresource"
	    }
	}
    }    
    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_roster_get --
#
#       Callback command from the 'roster_get' call.
#       Could also be a roster push from the server.
#
# Arguments:
#       jlibname:   the instance of this jlib.
#       ispush:     is this the result of a roster push or from our 
#                   'roster_set' call?
#       cmd:        callback command for an error element.
#       type:       "error" or "ok"
#       thequery:       
#       
# Results:
#       the roster object is populated.

proc jlib::parse_roster_get {jlibname ispush cmd type thequery} {

    upvar ${jlibname}::lib lib

    Debug 3 "jlib::parse_roster_get ispush=$ispush, cmd=$cmd, type=$type,"
    Debug 3 "   thequery=$thequery"
    if {[string equal $type "error"]} {
	
	# We've got an error reply. Roster pushes should never be an error!
	if {[string length $cmd] > 0} {
	    uplevel #0 $cmd [list $jlibname error]
	}
	return
    }
    if {!$ispush} {
	
	# Clear the roster and presence.
	$lib(rostername) enterroster
    }
    
    # Extract the XML data items.
    if {![string equal [wrapper::getattribute $thequery xmlns] "jabber:iq:roster"]} {
    
	# Here we should issue a warning:
	# attribute of query tag doesn't match 'jabber:iq:roster'
	
    }    
    if {$ispush} {
	set what "roster_push"
    } else {
	set what "roster_item"
    }
    foreach child [wrapper::getchildren $thequery] {
	
	# Extract the message sub-elements XML data items.
	set ctag [wrapper::gettag $child]
	set cattrlist [wrapper::getattrlist $child]
	set cchdata [wrapper::getcdata $child]
	
	if {[string equal $ctag "item"]} {
	    
	    # Add each item to our roster object.
	    # Build the argument list of '-key value' pairs. Extract the jid.
	    set arglist {}
	    set subscription {}
	    foreach {key value} $cattrlist {
		if {[string equal $key "jid"]} {
		    set jid $value
		} else {
		    lappend arglist -$key $value
		    if {[string equal $key "subscription"]} {
			set subscription $value
		    }
		}
	    }
	    
	    # Check if item should be romoved (subscription='remove').
	    if {[string equal $subscription "remove"]} {
		$lib(rostername) removeitem $jid
	    } else {
	    
		# Collect the group elements.
		set groups {}
		foreach subchild [wrapper::getchildren $child] {
		    set subtag [wrapper::gettag $subchild]
		    if {[string equal $subtag "group"]} {
			lappend groups [wrapper::getcdata $subchild]
		    }
		}
		if {[string length $groups]} {
		    lappend arglist -groups $groups
		}
		
		# Fill in our roster with this.
		eval {$lib(rostername) setrosteritem $jid} $arglist
	    }
	}
    }
    
    # Tell our roster object that we leave...
    if {!$ispush} {
	$lib(rostername) exitroster
    }
}

# jlib::parse_roster_set --
#
#       Callback command from the 'roster_set' call.
#
# Arguments:
#       jlibname:   the instance of this jlib.
#       jid:        the jabber id (without resource).
#       cmd:        callback command for an error query element.
#       groups:     
#       name:       
#       type:       "error" or "ok"
#       thequery:
#       
# Results:
#       none.

proc jlib::parse_roster_set {jlibname jid cmd groups name type thequery} {

    upvar ${jlibname}::lib lib

    Debug 3 "jlib::parse_roster_set jid=$jid"
    if {[string equal $type "error"]} {
	
	# We've got an error reply.
	uplevel #0 $cmd [list $jlibname error]
	return
    }
}

# jlib::parse_roster_remove --
#
#       Callback command from the 'roster_remove' command.
#
# Arguments:
#       jlibname:   the instance of this jlib.
#       jid:        the jabber id (without resource).
#       cmd:        callback command for an error query element.
#       type:
#       thequery:
#       
# Results:
#       none.

proc jlib::parse_roster_remove {jlibname jid cmd type thequery} {

    Debug 3 "jlib::parse_roster_remove jid=$jid, cmd=$cmd, type=$type,"
    Debug 3 "   thequery=$thequery"
    if {[string equal $type "error"]} {
	uplevel #0 $cmd [list $jlibname error]
    }
}

# 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 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] $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
}

# jlib::presence_register --
# 
#       Handler for registered presence callbacks.

proc jlib::presence_register {jlibname type func {seq 50}} {
    
    upvar ${jlibname}::preshook preshook
    
    lappend preshook($type) [list $func $seq]
    set preshook($type)  \
      [lsort -integer -index 1 [lsort -unique $preshook($type)]]
}

proc jlib::presence_run_hook {jlibname from type args} {
    
    upvar ${jlibname}::preshook preshook

    set ishandled 0
    
    if {[info exists preshook($type)]} {
	foreach spec $preshook($type) {
	    set func [lindex $spec 0]
	    set code [catch {
		uplevel #0 $func [list $jlibname $from $type] $args
	    } ans]
	    if {$code} {
		bgerror "preshook $func failed: $code\n$::errorInfo"
	    }
	    if {[string equal $ans "1"]} {
		set ishandled 1
		break
	    }
	}
    }
    return $ishandled
}

# jlib::element_register --
# 
#       Used to get callbacks from non stanza elements, like sasl etc.

proc jlib::element_register {jlibname tag func {seq 50}} {
    
    upvar ${jlibname}::elementhook elementhook
    
    lappend elementhook($tag) [list $func $seq]
    set elementhook($tag)  \
      [lsort -integer -index 1 [lsort -unique $elementhook($tag)]]
}

proc jlib::element_deregister {jlibname tag func} {
    
    upvar ${jlibname}::elementhook elementhook
    
    if {![info exists elementhook($tag)]} {
	return ""
    }
    set ind -1
    set found 0
    foreach spec $elementhook($tag) {
	incr ind
	if {[string equal $func [lindex $spec 0]]} {
	    set found 1
	    break
	}
    }
    if {$found} {
	set elementhook($tag) [lreplace $elementhook($tag) $ind $ind]
    }
}

proc jlib::element_run_hook {jlibname tag xmldata} {
    
    upvar ${jlibname}::elementhook elementhook

    set ishandled 0
    
    if {[info exists elementhook($tag)]} {
	foreach spec $elementhook($tag) {
	    set func [lindex $spec 0]
	    set code [catch {
		uplevel #0 $func [list $jlibname $tag $xmldata]
	    } ans]
	    if {$code} {
		bgerror "preshook $func failed: $code\n$::errorInfo"
	    }
	    if {[string equal $ans "1"]} {
		set ishandled 1
		break
	    }
	}
    }
    return $ishandled
}

# 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
    upvar ${jlibname}::locals locals
        
    Debug 3 "jlib::send_iq type='$type', xmldata='$xmldata', args='$args'"
    
    set locals(last) [clock seconds]
    array set argsArr $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 argsArr(-command)]} {
	    set iqcmd($iqcmd(uid)) $argsArr(-command)
	}
	incr iqcmd(uid)
    } elseif {[info exists argsArr(-id)]} {
	lappend attrlist "id" $argsArr(-id)
    }
    if {[info exists argsArr(-to)]} {
	lappend attrlist "to" $argsArr(-to)
    }
    if {[llength $xmldata]} {
	set xmllist [wrapper::createtag "iq" -attrlist $attrlist \
	  -subtags $xmldata]
    } else {
	set xmllist [wrapper::createtag "iq" -attrlist $attrlist]
    }
    
    send $jlibname $xmllist
}

# 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 {}
    set sublists {}
    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
}

proc jlib::iq_set {jlibname xmlns args} {

    set opts {}
    set sublists {}
    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
}

# 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 {}

    foreach {key value} $args {
	switch -- $key {
	    -password - -digest {
		lappend subelements [wrapper::createtag  \
		  [string trimleft $key -] -chdata $value]
	    }
	    -to {
		set toopt [list -to $value]
	    }
	}
    }

    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
    
    # Cache our login jid.
    set locals(username) $username
    set locals(resource) $resource
    set locals(myjid2)   ${username}@$locals(server)
    set locals(myjid)    ${username}@$locals(server)/${resource}
}

# 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 argsArr $args
    set xmllist [wrapper::createtag "query" -attrlist {xmlns jabber:iq:register}]
    if {[info exists argsArr(-to)]} {
	set toopt [list -to $argsArr(-to)]
    } else {
	set toopt ""
    }
    eval {send_iq $jlibname "get" [list $xmllist] -command  \
      [list [namespace current]::invoke_iq_callback $jlibname $cmd]} $toopt
}

# 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 argsArr $args
    foreach argsswitch [array names argsArr] {
	if {[string equal $argsswitch "-to"]} {
	    continue
	}
	set par [string trimleft $argsswitch {-}]
	lappend subelements [wrapper::createtag $par  \
	  -chdata $argsArr($argsswitch)]
    }
    set xmllist [wrapper::createtag "query"  \
      -attrlist {xmlns jabber:iq:register}   \
      -subtags $subelements]
    
    if {[info exists argsArr(-to)]} {
	set toopt [list -to $argsArr(-to)]
    } else {
	set toopt ""
    }
    eval {send_iq $jlibname "set" [list $xmllist] -command  \
      [list [namespace current]::invoke_iq_callback $jlibname $cmd]} $toopt
}

# 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 argsArr $args
    if {[info exists argsArr(-key)]} {
	lappend subelements [wrapper::createtag "key" -chdata $argsArr(-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
}

# 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]
}

# 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} {

    array set argsarr $args

    if {[info exists argsarr(-subtags)]} {
	set xmllist [wrapper::createtag "query"  \
	  -attrlist {xmlns jabber:iq:search}   \
	  -subtags $argsarr(-subtags)]
    } else {
	set xmllist [wrapper::createtag "query"  \
	  -attrlist {xmlns jabber:iq:search}]
    }
    send_iq $jlibname "set" [list $xmllist] -to $to -command  \
      [list [namespace current]::parse_search_set $jlibname $cmd]
}

# 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
#
#                   -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. 
#                   
# Results:
#       none.

proc jlib::send_message {jlibname to args} {

    upvar ${jlibname}::locals locals

    Debug 3 "jlib::send_message to=$to, args=$args"
    
    array set argsArr $args
    set locals(last) [clock seconds]
    set attrlist [list to $to]
    set children {}
    
    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 attrlist "type" $value
		}
	    }
	    -id {
		lappend attrlist $par $value
	    }
	    default {
		lappend children [wrapper::createtag $par -chdata $value]
	    }
	}
    }
    set xmllist [wrapper::createtag "message" -attrlist $attrlist  \
      -subtags $children]
    
    # For the auto away function.
    schedule_auto_away $jlibname
    
    send $jlibname $xmllist
}

# jlib::send_presence --
#
#       To send your presence.
#
# Arguments:
# 
#       jlibname:   the instance of this jlib.
#       args:
#           -to     the jabber id of the recepient.
#           -from   should never be set by client!
#           -type   one of 'available', 'unavailable', 'subscribe', 
#                   'unsubscribe', 'subscribed', 'unsubscribed', 'invisible'.
#           -status
#           -priority
#           -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
    
    Debug 3 "jlib::send_presence args='$args'"
    
    set locals(last) [clock seconds]
    set attrlist {}
    set children {}
    set type "available"
    array set argsArr $args
    
    foreach {key value} $args {
	set par [string trimleft $key -]
	
	switch -- $par {
	    type {
		set type $value
		if {[regexp $statics(presenceTypeExp) $type]} {
		    lappend attrlist $par $type
		} else {
		    return -code error "Is not valid presence type: \"$type\""
		}
	    }
	    from - to {
		lappend attrlist $par $value
	    }
	    xlist - extras {
		foreach xchild $value {
		    lappend children $xchild
		}
	    }
	    command {
		
		# Use iq things for this; needs to be renamed.
		lappend attrlist "id" $prescmd(uid)
		set prescmd($prescmd(uid)) $value
		incr prescmd(uid)
	    }
	    default {
		lappend children [wrapper::createtag $par -chdata $value]
	    }
	}
    }
    set xmllist [wrapper::createtag "presence" -attrlist $attrlist  \
      -subtags $children]
    
    # Be sure to cancel auto away scheduling if necessary.
    if {[info exists argsArr(-type)]} {
	if {[string equal $argsArr(-type) "available"]} {
	    if {[info exists argsArr(-show)] && \
	      ![string equal $argsArr(-show) "chat"]} {
		cancel_auto_away $jlibname
	    }
	} else {
	    cancel_auto_away $jlibname
	}
    }
    
    # Any of {available away dnd invisible unavailable}
    # Must be destined to login server (by default).
    if {![info exists argsArr(-to)] || \
      [string equal $argsArr(-to) $locals(server)]} {
	set locals(status) $type
	if {[info exists argsArr(-show)]} {
	    set locals(status) $argsArr(-show)
	}
    }
    
    send $jlibname $xmllist
}

# jlib::send --
# 
#       Sends general xml using a xmllist.

proc jlib::send {jlibname xmllist} {
    
    upvar ${jlibname}::lib lib
    
    set xml [wrapper::createxml $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 client.
    if {$lib(isinstream) && [catch {eval $lib(transportsend) {$xml}} err]} {
	#closestream $jlibname
	kill $jlibname
	uplevel #0 $lib(clientcmd) [list $jlibname networkerror]
    }
}

# jlib::mystatus --
# 
#       Returns any of {available away dnd invisible unavailable}
#       for our status with the login server.

proc jlib::mystatus {jlibname} {

    upvar ${jlibname}::locals locals
    
    return $locals(status)
}

# jlib::myjid --
# 
#       Returns our 3-tier jid as authorized with the login server.

proc jlib::myjid {jlibname} {

    upvar ${jlibname}::locals locals
    
    return $locals(myjid)
}

# 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 argsarr $args
    if {[info exists argsarr(-desc)] && [string length $argsarr(-desc)]} {
	lappend children [wrapper::createtag {desc} -chdata $argsarr(-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]
}

# jlib::agent_get --
#
#       It implements the 'jabber:iq:agent' get method.
#
# Arguments:
#       jlibname:   the instance of this jlib.
#       to:         the *server's* name! (users.jabber.org, for instance)
#       cmd:        client command to be executed at the iq "result" element.
#       
# Results:
#       none.

proc jlib::agent_get {jlibname to cmd} {

    set xmllist [wrapper::createtag "query" -attrlist {xmlns jabber:iq:agent}]
    send_iq $jlibname "get" [list $xmllist] -to $to -command   \
      [list [namespace current]::parse_agent_get $jlibname $to $cmd]
}

proc jlib::agents_get {jlibname to cmd} {

    set xmllist [wrapper::createtag "query" -attrlist {xmlns jabber:iq:agents}]
    send_iq $jlibname "get" [list $xmllist] -to $to -command   \
      [list [namespace current]::parse_agents_get $jlibname $to $cmd]
}

# parse_agent_get, parse_agents_get --
#
#       Callbacks for the agent(s) methods. Caches agent information,
#       and makes registered client callback.
#       
# Arguments:
#       jlibname:   the instance of this jlib.
#       jid:        the 'to' attribute of our agent(s) request.
#       cmd:        client command to be executed.
#       
# Results:
#       none.

proc jlib::parse_agent_get {jlibname jid cmd type subiq} {

    upvar ${jlibname}::lib lib
    upvar ${jlibname}::agent agent
    upvar [namespace current]::service::services services

    Debug 3 "jlib::parse_agent_get jid=$jid, cmd=$cmd, type=$type, subiq=$subiq"

    switch -- $type {
	error {
	    uplevel #0 $cmd [list $jlibname error $subiq]
	} 
	default {
     
	    # Loop through the subelement to see what we've got.
	    foreach elem [wrapper::getchildren $subiq] {
		set tag [wrapper::gettag $elem]
		set agent($jid,$tag) [wrapper::getcdata $elem]
		if {[lsearch $services $tag] >= 0} {
		    lappend agent($tag) $jid
		}
		if {[string equal $tag "groupchat"]} {
		    [namespace current]::service::registergcprotocol  \
		      $jlibname $jid "gc-1.0"
		}
	    }    
	    uplevel #0 $cmd [list $jlibname $type $subiq]
	}
    }
}

proc jlib::parse_agents_get {jlibname jid cmd type subiq} {

    upvar ${jlibname}::locals locals
    upvar ${jlibname}::agent agent
    upvar [namespace current]::service::services services

    Debug 3 "jlib::parse_agents_get jid=$jid, cmd=$cmd, type=$type, subiq=$subiq"

    switch -- $type {
	error {
	    uplevel #0 $cmd [list $jlibname error $subiq]
	} 
	default {
	    
	    # Be sure that the login jabber server is the root.
	    if {[string equal $locals(server) $jid]} {
		set agent($jid,parent) {}
	    }
	    # ???
	    set agent($jid,parent) {}
	    
	    # Cache the agents info we've got.
	    foreach agentElem [wrapper::getchildren $subiq] {
		if {![string equal [wrapper::gettag $agentElem] "agent"]} {
		    continue
		}
		set jidAgent [wrapper::getattribute $agentElem jid]
		set subAgent [wrapper::getchildren $agentElem]
		
		# Loop through the subelement to see what we've got.
		foreach elem $subAgent {
		    set tag [wrapper::gettag $elem]
		    set agent($jidAgent,$tag) [wrapper::getcdata $elem]
		    if {[lsearch $services $tag] >= 0} {
			lappend agent($tag) $jidAgent
		    }
		    if {[string equal $tag "groupchat"]} {
			[namespace current]::service::registergcprotocol  \
			  $jlibname $jid "gc-1.0"
		    }
		}
		set agent($jidAgent,parent) $jid
		lappend agent($jid,childs) $jidAgent	
	    }
	    uplevel #0 $cmd [list $jlibname $type $subiq]
	}
    }
}

# jlib::getagent --
# 
#       Accessor function for the agent stuff.

proc jlib::getagent {jlibname jid} {

    upvar ${jlibname}::agent agent

    if {[info exists agent($jid,parent)]} {
	return [array get agent "$jid,*"]
    } else {
	return ""
    }
}

proc jlib::have_agent {jlibname jid} {

    upvar ${jlibname}::agent agent

    if {[info exists agent($jid,parent)]} {
	return 1
    } else {
	return 0
    }
}

# jlib::vcard_get --
#
#       It implements the 'jabber:iq:vcard-temp' get method.
#
# Arguments:
#       jlibname:   the instance of this jlib.
#       to:
#       cmd:        client command to be executed at the iq "result" element.
#       
# Results:
#       none.

proc jlib::vcard_get {jlibname to cmd} {

    set attrlist [list xmlns vcard-temp]    
    set xmllist [wrapper::createtag "vCard" -attrlist $attrlist]
    send_iq $jlibname "get" [list $xmllist] -to $to -command   \
      [list [namespace current]::invoke_iq_callback $jlibname $cmd]
}

# jlib::vcard_set --
#
#       Sends our vCard to the server. Internally we use all lower case
#       but the spec (JEP-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_set {jlibname cmd args} {

    set attrlist [list xmlns vcard-temp]    
    
    # Form all the sub elements by inspecting the -key.
    array set arr $args
    set subelem {}
    set subsubelem {}
    
    # All "sub" elements with no children.
    foreach tag {fn nickname bday url title role desc} {
	if {[info exists arr(-$tag)]} {
	    lappend subelem [wrapper::createtag [string toupper $tag] \
	      -chdata $arr(-$tag)]
	}
    }
    if {[info exists arr(-email_internet_pref)]} {
	set elem {}
	lappend elem [wrapper::createtag "INTERNET"]
	lappend elem [wrapper::createtag "PREF"]
	lappend subelem [wrapper::createtag "EMAIL" \
	  -chdata $arr(-email_internet_pref) -subtags $elem]
    }
    if {[info exists arr(-email_internet)]} {
	foreach email $arr(-email_internet) {
	    set elem {}
	    lappend elem [wrapper::createtag "INTERNET"]
	    lappend subelem [wrapper::createtag "EMAIL" \
	      -chdata $email -subtags $elem]
	}
    }
    
    # All "subsub" elements.
    foreach tag {n org} {
	set elem {}
	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 subelem [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 subelem [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 subelem [wrapper::createtag "TEL" -chdata $arr($tag) \
	      -subtags $elem]
	}
    }

    set xmllist [wrapper::createtag vCard -attrlist $attrlist \
      -subtags $subelem]
    send_iq $jlibname "set" [list $xmllist] -command \
      [list [namespace current]::invoke_iq_callback $jlibname $cmd]    
}

# 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]
}

# 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 argsarr $args

    set secs [expr [clock seconds] - $locals(last)]
    set xmllist [wrapper::createtag "query"  \
      -attrlist [list xmlns jabber:iq:last seconds $secs]]
    
    set opts {}
    if {[info exists argsarr(-from)]} {
	lappend opts -to $argsarr(-from)
    }
    if {[info exists argsarr(-id)]} {
	lappend opts -id $argsarr(-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]
}

# jlib::handle_get_time --
#
#       Send our time. Response to 'jabber:iq:time' get.

proc jlib::handle_get_time {jlibname from subiq args} {
    
    array set argsarr $args
    
    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 {}
    if {[info exists argsarr(-from)]} {
	lappend opts -to $argsarr(-from)
    }
    if {[info exists argsarr(-id)]} {
	lappend opts -id $argsarr(-id)
    }
    eval {send_iq $jlibname "result" [list $xmllist]} $opts

    # Tell jlib's iq-handler that we handled the event.
    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]
}

# jlib::handle_get_time --
#
#       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 argsArr $args
    
    # Return any id!
    set opts {}
    if {[info exists argsArr(-id)]} {
	set opts [list -id $argsArr(-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::roster_get --
#
#       To get your roster from server.
#       All roster info is propagated to the client via the callback in the
#       roster object. The 'cmd' is only called as a response to an iq-result
#       element.
#
# Arguments:
#       
#       jlibname:   the instance of this jlib.
#       args:       ?
#       cmd:        callback command for an error query element.
#     
# Results:
#       none.
  
proc jlib::roster_get {jlibname cmd args} {

    array set argsArr $args  
    
    # Perhaps we should clear our roster object here?
    
    set xmllist [wrapper::createtag "query"  \
      -attrlist {xmlns jabber:iq:roster}]
    send_iq $jlibname "get" [list $xmllist] -command   \
      [list [namespace current]::parse_roster_get $jlibname 0 $cmd]
}

# jlib::roster_set --
#
#       To set/add an jid in/to your roster.
#       All roster info is propagated to the client via the callback in the
#       roster object. The 'cmd' is only called as a response to an iq-result
#       element.
#
# Arguments:
#       jlibname:   the instance of this jlib.
#       jid:        jabber user id to add/set.
#       cmd:        callback command for an error query element.
#       args:
#           -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_set {jlibname jid cmd args} {

    upvar ${jlibname}::lib lib

    Debug 3 "jlib::roster_set jid=$jid, cmd=$cmd, args='$args'"
    array set argsArr $args  

    # Find group(s).
    if {![info exists argsArr(-groups)]} {
	set groups [$lib(rostername) getgroups $jid]
    } else {
	set groups $argsArr(-groups)
    }
    
    set attrlist [list {jid} $jid]
    set name {}
    if {[info exists argsArr(-name)]} {
	set name $argsArr(-name)
	lappend attrlist {name} $name
    }
    set subdata {}
    foreach group $groups {
    	if {$group != ""} {
	    lappend subdata [wrapper::createtag "group" -chdata $group]
	}
    }
    
    set xmllist [wrapper::createtag "query"   \
      -attrlist {xmlns jabber:iq:roster}      \
      -subtags [list [wrapper::createtag {item} -attrlist $attrlist  \
      -subtags $subdata]]]
    send_iq $jlibname "set" [list $xmllist] -command   \
      [list [namespace current]::parse_roster_set $jlibname $jid $cmd  \
      $groups $name]
}

# jlib::roster_remove --
#
#       To remove an item in your roster.
#       All roster info is propagated to the client via the callback in the
#       roster object. The 'cmd' is only called as a response to an iq-result
#       element.
#
# Arguments:
#       jlibname:   the instance of this jlib.
#       jid:        jabber user id.
#       cmd:        callback command for an error query element.
#       args:       ?
#       
# Results:
#       none.

proc jlib::roster_remove {jlibname jid cmd args} {

    Debug 3 "jlib::roster_remove jid=$jid, cmd=$cmd, args=$args"
    
    array set argsArr $args  
    set xmllist [wrapper::createtag "query"   \
      -attrlist {xmlns jabber:iq:roster}      \
      -subtags [list  \
      [wrapper::createtag "item"   \
      -attrlist [list jid $jid subscription remove]]]]
    send_iq $jlibname "set" [list $xmllist] -command   \
      [list [namespace current]::parse_roster_remove $jlibname $jid $cmd]
}

proc jlib::schedule_keepalive {jlibname} {   

    upvar ${jlibname}::locals locals
    upvar ${jlibname}::opts opts
    upvar ${jlibname}::lib lib

    if {$opts(-keepalivesecs) && $lib(isinstream)} {
	if {[catch {puts $lib(sock) "\n"} err]} {
	    closestream $jlibname
	    set errmsg "Network was disconnected"
	    uplevel #0 $lib(clientcmd) [list $jlibname networkerror -body $errmsg]
	      
	    return
	}
	set locals(aliveid) [after [expr 1000 * $opts(-keepalivesecs)] \
	  [list [namespace current]::schedule_keepalive $jlibname]]
    }
}

# jlib::schedule_auto_away, cancel_auto_away, auto_away_cmd
#
#       Procedures for auto away things.

proc jlib::schedule_auto_away {jlibname} {       

    upvar ${jlibname}::locals locals
    upvar ${jlibname}::opts opts
    
    cancel_auto_away $jlibname
    if {$opts(-autoaway) && $opts(-awaymin) > 0} {
	set locals(afterawayid) [after [expr 60000 * $opts(-awaymin)] \
	  [list [namespace current]::auto_away_cmd $jlibname away]]
    }
    if {$opts(-xautoaway) && $opts(-xawaymin) > 0} {
	set locals(afterxawayid) [after [expr 60000 * $opts(-xawaymin)] \
	  [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"

proc jlib::auto_away_cmd {jlibname what} {      

    upvar ${jlibname}::locals locals
    upvar ${jlibname}::lib lib
    upvar ${jlibname}::opts opts

    Debug 3 "jlib::auto_away_cmd what=$what"
    
    switch -- $what {
	away {
	    send_presence $jlibname -type "available" -show "away"  \
	      -status $opts(-awaymsg)
	}
	xaway {
	    send_presence $jlibname -type "available" -show "xa"  \
	      -status $opts(-xawaymsg)
	}
    }        
    uplevel #0 $lib(clientcmd) [list $jlibname $what]
}

# jlib::getrecipientjid --
# 
#       Tries to obtain the correct form of jid to send message to.
#       Follows the XMPP spec, section 4.1.

proc jlib::getrecipientjid {jlibname jid} {

    upvar ${jlibname}::lib lib
    
    jlib::splitjid $jid jid2 resource 
    set isroom [[namespace current]::service::isroom $jlibname $jid2]
    if {$isroom} {
	return $jid
    } elseif {[$lib(rostername) 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.
    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....................................

proc jlib::UnicodeListToRE {ulist} {
    
    set str [string map {- -\\u} $ulist]
    set str "\\u[join $str \\u]"
    return [subst $str]
}

namespace eval jlib {
    
    # Characters that need to be escaped since non valid.
    #       JEP-0106 EXPERIMENTAL!  Think OUTDATED???
    variable 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.
    #x22 (") 
    #x26 (&) 
    #x27 (') 
    #x2F (/) 
    #x3A (:) 
    #x3C (<) 
    #x3E (>) 
    #x40 (@) 
    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 ind [string first / $jid]
    if {$ind == -1} {
	uplevel 1 [list set $jid2Var $jid]
	uplevel 1 [list set $resourceVar {}]
    } else {
	set jid2 [string range $jid 0 [expr $ind - 1]]
	set res [string range $jid [expr $ind + 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.

proc jlib::splitjidex {jid nodeVar domainVar resourceVar} {
    
    set node   ""
    set domain ""
    set res    ""
    if {[regexp {^(([^@]+)@)?([^ /@]+)(/(.*))?$} $jid m x node domain y res]} {
	uplevel 1 [list set $nodeVar $node]
	uplevel 1 [list set $domainVar $domain]
	uplevel 1 [list set $resourceVar $res]
    } elseif {$jid == ""} {
	uplevel 1 [list set $nodeVar $node]
	uplevel 1 [list set $domainVar $domain]
	uplevel 1 [list set $resourceVar $res]
    } else {
	return -code error "not valid jid form"
    }
}

# 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 != ""} {
	set jid ${node}@${jid}
    }
    if {$resource != ""} {
	set jid ${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 == ""} {
	return 0
    } elseif {[catch {splitjidex $jid node name resource} ans]} {
	return 0
    }
    foreach what {node name resource} {
	if {$what != ""} {
	    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 "username 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 == ""} {
	return ""
    }
    # Guard against spurious spaces.
    set jid [string trim $jid]
    if {[catch {splitjidex $jid node domain resource} res]} {
	return -code error $res
    }
    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 == ""} {
	return ""
    }
    if {[catch {splitjidex $jid node domain resource} res]} {
	return -code error $res
    }
    if {[catch {
	set node     [nodeprep $node]
	set domain   [nameprep $domain]
	set resource [resourceprep $resource]
    } err]} {
	return -code error $err
    }
    return [joinjid $node $domain $resource]
}

proc jlib::MapStr {str } {
    
    # TODO
}

# jlib::encodeusername, decodeusername, decodejid --
# 
#       Jid escaping.
#       JEP-0106 EXPERIMENTAL!

proc jlib::encodeusername {username} {    
    variable jidesc
    
    set str $username
    set ndx 0
    while {[regexp -start $ndx -indices -- "\[$jidesc\]" $str r]} {
	set ndx [lindex $r 0]
	scan [string index $str $ndx] %c chr
	set rep "#[format %.2x $chr];"
	set str [string replace $str $ndx $ndx $rep]
	incr ndx 3
    }
    return $str
}

proc jlib::decodeusername {username} {
    
    # Be sure that only the specific characters are being decoded.
    foreach sub {{#(20);} {#(22);} {#(23);} {#(26);} {#(27);} {#(2f);}  \
      {#(3a);} {#(3c);} {#(3e);} {#(40);}} {
	regsub -all $sub $username {[format %c 0x\1]} username
    }	
    return [subst $username]
}

proc jlib::decodejid {jid} {
    
    set jidlist [split $jid @]
    if {[llength $jidlist] == 2} {
	return "[decodeusername [lindex $jidlist 0]]@[lindex $jidlist 1]"
    } else {
	return $jid
    }
}

proc jlib::getdisplayusername {jid} {

    set jidlist [split $jid @]
    if {[llength $jidlist] == 2} {
	return [decodeusername [lindex $jidlist 0]]
    } 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?"
    }
}

proc jlib::Debug {num str} {
    global  fdDebug
    variable debug
    if {$num <= $debug} {
	if {[info exists fdDebug]} {
	    puts $fdDebug $str
	    flush $fdDebug
	}
	puts $str
    }
}

#--- namespace jlib::conference ------------------------------------------------

# jlib::conference --
#
#       Provides API's for the conference protocol using jabber:iq:conference.

proc jlib::conference {jlibname cmd args} {
    
    # Which command? Just dispatch the command to the right procedure.
    if {[catch {
	eval {[namespace current]::conference::$cmd $jlibname} $args
    } ans]} {
	return -code error $ans
    }
    return $ans
}

# jlib::conference::get_enter, set_enter --
#
#       Request conference enter room, and do enter room.
#
# Arguments:
#       jlibname:   the instance of this jlib.
#       to:         'roomname@conference.jabber.org' typically.
#       subelements xml list
#       cmd:        callback command for iq result element.
#       
# Results:
#       none.

proc jlib::conference::get_enter {jlibname room cmd} {

    [namespace parent]::Debug 3 "jlib::conference::get_enter room=$room, cmd=$cmd"
    
    set xmllist [wrapper::createtag "enter"  \
      -attrlist {xmlns jabber:iq:conference}]
    [namespace parent]::send_iq $jlibname "get" [list $xmllist] -to $room -command  \
      [list [namespace parent]::invoke_iq_callback $jlibname $cmd]
    [namespace parent]::service::setroomprotocol $jlibname $room "conference"
    return ""
}

proc jlib::conference::set_enter {jlibname room subelements cmd} {

    [namespace parent]::send_presence $jlibname -to $room
    [namespace parent]::send_iq $jlibname "set"  \
      [list [wrapper::createtag "enter" -attrlist {xmlns jabber:iq:conference} \
      -subtags $subelements]] -to $room -command  \
      [list [namespace current]::parse_set_enter $jlibname $room $cmd]
    return ""
}

# jlib::conference::parse_set_enter --
#
#       Callback for 'set_enter' and 'set_create'. 
#       Cache useful info to unburden client.
#       
# Arguments:
#       jlibname:   the instance of this jlib.
#       jid:        the jid we browsed.
#       cmd:        for callback to client.
#       type:       "ok" or "error"
#       subiq:

proc jlib::conference::parse_set_enter {jlibname room cmd type subiq} {    

    upvar ${jlibname}::conf conf

    [namespace parent]::Debug 3 "jlib::conference::parse_set_enter room=$room, cmd='$cmd', type=$type, subiq='$subiq'"
    
    if {[string equal $type "error"]} {
	uplevel #0 $cmd [list $jlibname error $subiq]
    } else {
	
	# Cache useful info:    
	# This should be something like:
	# <query><id>myroom@server/7y3jy7f03</id><nick/>snuffie<nick><query/>
	# Use it to cache own room jid.
	foreach child [wrapper::getchildren $subiq] {
	    set tagName [wrapper::gettag $child]
	    set value [wrapper::getcdata $child]
	    set $tagName $value
	}
	if {[info exists id] && [info exists nick]} {
	    set conf($room,hashandnick) [list $id $nick]
	}
	if {[info exists name]} {
	    set conf($room,roomname) $name
	}
	lappend conf(allroomsin) $room
	
	# And finally let client know.
	uplevel #0 $cmd [list $jlibname $type $subiq]
    }
}

# jlib::conference::get_create, set_create --
#
#       Request conference creation of room.
#
# Arguments:
#       jlibname:   the instance of this jlib.
#       to:        'conference.jabber.org' typically.
#       cmd:        callback command for iq result element.
#       
# Results:
#       none.

proc jlib::conference::get_create {jlibname to cmd} {

    [namespace parent]::Debug 3 "jlib::conference::get_create cmd=$cmd, to=$to"
    
    [namespace parent]::send_presence $jlibname -to $to
    set xmllist [wrapper::createtag "create"   \
      -attrlist {xmlns jabber:iq:conference}]
    [namespace parent]::send_iq $jlibname "get" [list $xmllist] -to $to -command   \
      [list [namespace parent]::invoke_iq_callback $jlibname $cmd]
}

proc jlib::conference::set_create {jlibname room subelements cmd} {

    # We use the same callback as 'set_enter'.
    [namespace parent]::send_presence $jlibname -to $room
    [namespace parent]::send_iq $jlibname "set"  \
      [list [wrapper::createtag "create" -attrlist {xmlns jabber:iq:conference} \
      -subtags $subelements]] -to $room -command  \
      [list [namespace current]::parse_set_enter $jlibname $room $cmd]
    [namespace parent]::service::setroomprotocol $jlibname $room "conference"
    return ""
}

# jlib::conference::delete --
#
#       Delete conference room.
#
# Arguments:
#       jlibname:   the instance of this jlib.
#       room:       'roomname@conference.jabber.org' typically.
#       cmd:        callback command for iq result element.
#       
# Results:
#       none.

proc jlib::conference::delete {jlibname room cmd} {

    set xmllist [wrapper::createtag {delete}  \
      -attrlist {xmlns jabber:iq:conference}]
    [namespace parent]::send_iq $jlibname "set" [list $xmllist] -to $room -command  \
      [list [namespace parent]::invoke_iq_callback $jlibname $cmd]
    return ""
}

proc jlib::conference::exit {jlibname room} {

    upvar ${jlibname}::conf conf
    upvar ${jlibname}::lib lib

    [namespace parent]::send_presence $jlibname -to $room -type unavailable
    set ind [lsearch -exact $conf(allroomsin) $room]
    if {$ind >= 0} {
	set conf(allroomsin) [lreplace $conf(allroomsin) $ind $ind]
    }
    $lib(rostername) clearpresence "${room}*"
    return ""
}

# jlib::conference::set_user --
#
#       Set user's nick name in conference room.
#
# Arguments:
#       jlibname:   the instance of this jlib.
#       room:       'roomname@conference.jabber.org' typically.
#       name:       nick name.
#       jid:        'roomname@conference.jabber.org/key' typically.
#       cmd:        callback command for iq result element.
#       
# Results:
#       none.

proc jlib::conference::set_user {jlibname room name jid cmd} {

    [namespace parent]::Debug 3 "jlib::conference::set_user cmd=$cmd, room=$room"
    
    set subelem [wrapper::createtag "user"  \
      -attrlist [list name $name jid $jid]]
    set xmllist [wrapper::createtag "conference"  \
      -attrlist {xmlns jabber:iq:browse} -subtags $subelem]
    [namespace parent]::send_iq $jlibname "set" [list $xmllist] -to $room -command  \
      [list [namespace parent]::invoke_iq_callback $jlibname $cmd]
}

# jlib::conference::hashandnick --
#
#       Returns list {kitchen@conf.athlon.se/63264ba6724.. mynickname}

proc jlib::conference::hashandnick {jlibname room} {

    upvar ${jlibname}::conf conf

    if {[info exists conf($room,hashandnick)]} {
	return $conf($room,hashandnick)
    } else {
	return -code error "Unknown room \"$room\""
    }
}

proc jlib::conference::roomname {jlibname room} {

    upvar ${jlibname}::conf conf

    if {[info exists conf($room,roomname)]} {
	return $conf($room,roomname)
    } else {
	return -code error "Unknown room \"$room\""
    }
}

proc jlib::conference::allroomsin {jlibname} {

    upvar ${jlibname}::conf conf
    
    set conf(allroomsin) [lsort -unique $conf(allroomsin)]
    return $conf(allroomsin)
}

#-------------------------------------------------------------------------------
# roster.tcl --
#
#       An object for storing the roster and presence information for a 
#       jabber client. Is used together with jabberlib.
#
# Copyright (c) 2001-2003  Mats Bengtsson
#  
# $Id: roster.tcl,v 1.30 2005/02/09 14:30:33 matben Exp $
# 
# Note that every jid in the rostArr is usually (always) without any resource,
# but the jid's in the presArr are identical to the 'from' attribute, except
# the presArr($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:
# 
#       rostArr(groups)             : List of all groups the exist in roster.
#
#	rostArr($jid,item)          : $jid.
#	
#	rostArr($jid,name)          : Name of $jid.
#	
#	rostArr($jid,groups)        : Groups $jid is in. Note: PLURAL!
#
#	rostArr($jid,subscription)  : Subscription of $jid (to|from|both|"")
#
#	rostArr($jid,ask)           : "Ask" of $jid 
#                                     (subscribe|unsubscribe|"")
#                                       
#	presArr($jid-2,res)         : List of resources for this $jid.
#
#       presArr($from,type)         : One of 'available' or 'unavailable.
#
#       presArr($from,status)       : The presence status element.
#
#       presArr($from,priority)     : The presence priority element.
#
#       presArr($from,show)         : The presence show element.
#
#       presArr($from,x,xmlns)      : Storage for x elements.
#                                     xmlns is a namespace but where any
#                                     http://jabber.org/protocol/ stripped off
#                  
#       oldpresArr                  : As presArr but any previous state.
#                                      
############################# 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
#      roster::roster clientCommand
#      
#   OPTIONS
#      none
#      
#   INSTANCE COMMANDS
#      rostName clearpresence ?jidpattern?
#      rostName enterroster
#      rostName exitroster
#      rostName getgroups ?jid?
#      rostName getask jid
#      rostName getname jid
#      rostName getpresence jid ?-resource, -type?
#      rostName getresources jid
#      rostName gethighestresource jid
#      rostName getrosteritem jid
#      rostName getsubscription jid
#      rostName getusers ?-type available|unavailable?
#      rostName getx jid xmlns
#      rostName getextras jid xmlns
#      rostName isavailable jid
#      rostName isitem jid
#      rostName removeitem jid
#      rostName reset
#      rostName setpresence jid type ?-option value -option ...?
#      rostName setrosteritem jid ?-option value -option ...?
#      rostName wasavailable jid
#      
#   The 'clientCommand' procedure must have the following form:
#   
#      clientCommand {rostName 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)
#      
############################# CHANGES ##########################################
#
#       1.0a1    first release by Mats Bengtsson
#       1.0a2    clear roster and presence array before receiving such elements
#       1.0a3    added reset, isavailable, getresources, and getsubscription 
#       1.0b1    added gethighestresource command
#                changed setpresence arguments
#       1.0b2    changed storage of x elements, added getx command.
#       030602   added clearpresence command.
#       030702   added -type option to getusers command.
#       030703   removed rostName from roster::roster
#       040514   does STRINGPREP on all jids

package provide roster 1.0

namespace eval roster {
    
    variable rostGlobals
    
    # Globals same for all instances of this roster.
    set rostGlobals(debug) 0

    # Running number.
    variable uid 0
    
    # List of all rostArr element sub entries. First the actual roster,
    # with 'rostArr($jid,...)'
    set rostGlobals(tags) {name groups ask subscription} 
    
    # ...and the presence arrays: 'presArr($jid/$resource,...)'
    # The list of resources is treated separately (presArr($jid,res))
    set rostGlobals(presTags) {type status priority show x}
    
    variable xmppxmlns
    array set xmppxmlns {
	caps    http://jabber.org/protocol/caps
    }
}

# roster::roster --
#
#       This creates a new instance of a roster.
#       
# Arguments:
#       clientCmd:  callback procedure when internals of roster or
#                   presence changes.
#       args:            
#       
# Results:
#       rostName which is the command for this instance of the roster
  
proc roster::roster {clientCmd args} {

    variable uid

    # Generate unique command token for this roster instance.
    # Fully qualified!
    set rostName [namespace current]::[incr uid]
      
    # Instance specific namespace.
    namespace eval $rostName {
	variable rostArr
	variable presArr
	variable options
	
	array set rostArr {}
	array set presArr {}
    }
    
    # Set simpler variable names.
    upvar ${rostName}::rostArr rostArr
    upvar ${rostName}::options options
        
    set rostArr(groups) {}
    set options(cmd) $clientCmd
    
    # Create the actual roster instance procedure.
    proc $rostName {cmd args}   \
      "eval roster::CommandProc {$rostName} \$cmd \$args"

    return $rostName
}

# roster::CommandProc --
#
#       Just dispatches the command to the right procedure.
#
# Arguments:
#       rostName:   the instance of this roster.
#       cmd:        .
#       args:       all args to the cmd procedure.
#       
# Results:
#       none.

proc roster::CommandProc {rostName cmd args} {
    
    # Which command? Just dispatch the command to the right procedure.
    return [eval {$cmd $rostName} $args]
}

# roster::setrosteritem --
#
#       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:
#       rostName:   the instance of this roster.
#       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 roster::setrosteritem {rostName jid args} {        
    variable rostGlobals
    upvar ${rostName}::rostArr rostArr
    upvar ${rostName}::options options
    
    Debug 2 "roster::setrosteritem rostName=$rostName, 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 rostArr($mjid,$key)
    }
    
    # This array is better than list to keep track of users.
    set rostArr($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 rostArr($mjid,$par) $value
	if {[string equal $par "groups"]} {
	    foreach gr $value {
		if {[lsearch $rostArr(groups) $gr] < 0} {
		    lappend rostArr(groups) $gr
		}
	    }
	}
    }
    
    # Be sure to evaluate the registered command procedure.
    if {[string length $options(cmd)]} {
	uplevel #0 $options(cmd) [list $rostName set $jid] $args
    }
    return {}
}

# roster::removeitem --
#
#       Removes an existing roster item and all its presence info.
#
# Arguments:
#       rostName:   the instance of this roster.
#       jid:        2-tier jid with no /resource.
#       
# Results:
#       none.

proc roster::removeitem {rostName jid} {       
    variable rostGlobals

    upvar ${rostName}::rostArr rostArr
    upvar ${rostName}::presArr presArr
    upvar ${rostName}::oldpresArr oldpresArr
    upvar ${rostName}::options options
    
    Debug 2 "roster::removeitem rostName=$rostName, 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 $rostName remove $jid]
    }
    
    # First the roster, then presence...
    foreach name $rostGlobals(tags) {
	unset -nocomplain rostArr($mjid,$name)
    }
    unset -nocomplain rostArr($mjid,item)
    
    # Be sure to unset all, also jid3 entries!
    array unset presArr "${mjid}*"
    array unset oldpresArr "${mjid}*"
    return {}
}

# roster::ClearRoster --
#
#       Removes all existing roster items but keeps all presence info.(?)
#       and list of resources.
#
# Arguments:
#       rostName:   the instance of this roster.
#       
# Results:
#       none. Callback evaluated.

proc roster::ClearRoster {rostName} {    

    variable rostGlobals
    upvar ${rostName}::rostArr rostArr
    upvar ${rostName}::options options
    
    Debug 2 "roster::ClearRoster rostName=$rostName"
        
    # Remove the roster.
    foreach {x mjid} [array get rostArr *,item] {
	foreach key $rostGlobals(tags) {
	    unset -nocomplain rostArr($mjid,$key)
	}
    }
    array unset rostArr *,item
    
    # Be sure to evaluate the registered command procedure.
    if {[string length $options(cmd)]} {
	uplevel #0 $options(cmd) [list $rostName enterroster]
    }
    return {}
}

# roster::enterroster --
#
#       Is called when new roster coming.
#
# Arguments:
#       rostName:   the instance of this roster.
#       
# Results:
#       none.

proc roster::enterroster {rostName} {

    ClearRoster $rostName
}

# roster::exitroster --
#
#       Is called when finished receiving a roster get command.
#
# Arguments:
#       rostName:   the instance of this roster.
#       
# Results:
#       none. Callback evaluated.

proc roster::exitroster {rostName} {    

    upvar ${rostName}::options options

    # Be sure to evaluate the registered command procedure.
    if {[string length $options(cmd)]} {
	uplevel #0 $options(cmd) [list $rostName exitroster]
    }
}

# roster::reset --
#
#       Removes everything stored in the roster object, including all roster
#       items and any presence information.

proc roster::reset {rostName} {

    upvar ${rostName}::rostArr rostArr
    upvar ${rostName}::presArr presArr
    
    unset -nocomplain rostArr presArr
    set rostArr(groups) {}
}

# roster::clearpresence --
# 
#       Removes all presence cached internally for jid glob pattern.
#       Helpful when exiting a room.
#       
# Arguments:
#       rostName:   the instance of this roster.
#       jidpattern: glob pattern for items to remove.
#       
# Results:
#       none.

proc roster::clearpresence {rostName {jidpattern ""}} {

    upvar ${rostName}::presArr presArr
    upvar ${rostName}::oldpresArr oldpresArr

    if {$jidpattern == ""} {
	unset -nocomplain presArr
    } else {
	array unset presArr $jidpattern
	array unset oldpresArr $jidpattern
    }
}

# roster::setpresence --
#
#       Sets the presence of a roster item. Adds the corresponding resource
#       to the list of resources for this jid.
#
# Arguments:
#       rostName:   the instance of this roster.
#       jid:        the from attribute. Usually 3-tier jid with /resource part.
#       type:       one of 'available', 'unavailable', or 'unsubscribed'.
#       args:       a list of '-key value' pairs, where '-key' is any of:
#                     -status value
#                     -priority value
#                     -show value
#                     -x list of xml lists
#       
# Results:
#       none.

proc roster::setpresence {rostName jid type args} { 

    variable rostGlobals
    upvar ${rostName}::rostArr rostArr
    upvar ${rostName}::presArr presArr
    upvar ${rostName}::oldpresArr oldpresArr
    upvar ${rostName}::options options
    
    Debug 2 "roster::setpresence rostName=$rostName, jid='$jid', \
      type='$type', args='$args'"
    
    set mjid [jlib::jidmap $jid]
    jlib::splitjid $mjid mjid2 resource
    jlib::splitjid $jid jid2 x
    
    # XMPP specifies that an 'unavailable' element is sent *after* we've got
    # an subscription='remove' element. Store?
    
    if {[string equal $type "unsubscribed"]} {
	set argList [list -type $type]
    } else {
	
	# Keep cache of any old state.
	array unset oldpresArr "${mjid},*"
	array set oldpresArr [array get presArr "${mjid},*"]
	
	# Clear out the old presence state since elements may still be lurking.
	array unset presArr "${mjid},*"
	
	# Should we add something more to our roster, such as subscription,
	# if we haven't got our roster before this?
	
	# Add to list of resources.
	set presArr($mjid2,res) [lsort -unique [lappend presArr($mjid2,res) \
	  $resource]]
	
	set presArr($mjid,type) $type
	
	foreach {name value} $args {
	    set par [string trimleft $name "-"]
	    
	    switch -- $par {
		x {
		    
		    # This is a list of <x> lists.
		    foreach xelem $value {
			set ns [wrapper::getattribute $xelem xmlns]
			regexp {http://jabber.org/protocol/(.*)$} $ns \
			  match ns
			set presArr($mjid,x,$ns) $xelem
		    }
		}
		extras {

		    # This can be anything properly namespaced.
		    foreach xelem $value {
			set ns [wrapper::getattribute $xelem xmlns]
			set presArr($mjid,extras,$ns) $xelem
		    }
		}
		default {
		    set presArr($mjid,$par) $value
		}
	    }
	}
    }
    return {}
}

# roster::invokecommand --
# 
#       Evaluates the registered command procedure if any.

proc roster::invokecommand {rostName jid type args} { 

    upvar ${rostName}::options options
        
    if {[string length $options(cmd)]} {
	jlib::splitjid $jid jid2 resource
	set argList $args
	lappend argList -type $type -resource $resource
	uplevel #0 $options(cmd) [list $rostName presence $jid2] $argList
    }
}


# Firts attempt to keep the jid's as they are reported, with no separate
# resource part.

proc roster::setpresence2 {rostName jid type args} { 

    variable rostGlobals
    upvar ${rostName}::rostArr rostArr
    upvar ${rostName}::presArr2 presArr2
    upvar ${rostName}::oldpresArr2 oldpresArr2
    upvar ${rostName}::options options

    Debug 2 "roster::setpresence2 rostName=$rostName, jid='$jid', \
      type='$type', args='$args'"
    
    set mjid [jlib::jidmap $jid]
    
    set argList $args
    lappend argList -type $type

    if {[string equal $type "unsubscribed"]} {
	# empty
    } else {
	
	# Keep cache of any old state.
	array unset oldpresArr2 "${mjid},*"
	array set oldpresArr2 [array get presArr2 "${mjid},*"]
	
	# Clear out the old presence state since elements may still be lurking.
	array unset presArr2 "${mjid},*"
    
	set presArr2($mjid,type) $type
	set presArr2($mjid,jid)  $mjid
		
	foreach {name value} $args {
	    set par [string trimleft $name "-"]
	    
	    switch -- $par {
		x {
		    
		    # This is a list of <x> lists.
		    foreach xelem $value {
			set ns [wrapper::getattribute $xelem xmlns]
			regexp {http://jabber.org/protocol/(.*)$} $ns \
			  match ns
			set presArr2($mjid,x,$ns) $xelem
		    }
		}
		extras {

		    # This can be anything properly namespaced.
		    foreach xelem $value {
			set ns [wrapper::getattribute $xelem xmlns]
			set presArr2($mjid,extras,$ns) $xelem
		    }
		}
		default {
		    set presArr2($mjid,$par) $value
		}
	    }
	}
    }
    return {}
}

# roster::getrosteritem --
#
#       Returns the state of an existing roster item.
#
# Arguments:
#       rostName:   the instance of this roster.
#       jid:        .
#       
# Results:
#       a list of '-key value' pairs where key is any of: 
#       name, groups, subscription, ask. Note GROUPS in plural!

proc roster::getrosteritem {rostName jid} {    

    variable rostGlobals
    upvar ${rostName}::rostArr rostArr
    upvar ${rostName}::options options
    
    Debug 2 "roster::getrosteritem rostName=$rostName, jid='$jid'"
    
    set mjid [jlib::jidmap $jid]
    if {![info exists rostArr($mjid,item)]} {
	return {}
    }
    set result {}
    foreach key $rostGlobals(tags) {
	if {[info exists rostArr($mjid,$key)]} {
	    lappend result -$key $rostArr($mjid,$key)
	}
    }
    return $result
}

# roster::isitem --
# 
#       Does the jid exist in the roster?

proc roster::isitem {rostName jid} {
    
    upvar ${rostName}::rostArr rostArr
    
    set mjid [jlib::jidmap $jid]
    if {[info exists rostArr($mjid,item)]} {
	return 1
    } else {
	return 0
    }
}

# roster::getusers --
#
#       Returns a list of jid's of all existing roster items.
#
# Arguments:
#       rostName:   the instance of this roster.
#       args:       -type available|unavailable
#       
# Results:
#       list of all 2-tier jid's in roster

proc roster::getusers {rostName args} {

    upvar ${rostName}::rostArr rostArr
    upvar ${rostName}::presArr presArr    
    
    set all {}
    foreach {x jid} [array get rostArr *,item] {
	lappend all $jid
    }
    array set argsArr $args
    set jidlist {}
    if {$args == {}} {
	set jidlist $all
    } elseif {[info exists argsArr(-type)]} {
	set type $argsArr(-type)
	set jidlist {}
	foreach jid2 $all {
	    set isavailable 0

	    # Be sure to handle empty resources as well: '1234@icq.host'
	    foreach key [array names presArr "${jid2}*,type"] {
		if {[string equal $presArr($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
}

# roster::getpresence --
#
#       Returns the presence state of an existing roster item.
#
# Arguments:
#       rostName:   the instance of this roster.
#       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 roster::getpresence {rostName jid args} {    

    variable rostGlobals
    upvar ${rostName}::rostArr rostArr
    upvar ${rostName}::presArr presArr
    upvar ${rostName}::options options
    
    Debug 2 "roster::getpresence rostName=$rostName, jid=$jid, args='$args'"
    
    set jid [jlib::jidmap $jid]
    array set argsArr $args
    set haveRes 0
    if {[info exists argsArr(-resource)]} {
	set haveRes 1
	set resource $argsArr(-resource)
    }
    
    # It may happen that there is no roster item for this jid (groupchat).
    if {![info exists presArr($jid,res)] || ($presArr($jid,res) == "")} {
	if {[info exists argsArr(-type)] &&  \
	  [string equal $argsArr(-type) "available"]} {
	    return {}
	} else {
	    if {$haveRes} {
		return [list -resource $resource -type unavailable]
	    } else {      
		return [list [list -resource "" -type unavailable]]
	    }
	}
    }
    
    set result {}
    if {$haveRes} {

	# Return presence only from the specified resource.
	# Be sure to handle empty resources as well: '1234@icq.host'
	if {[lsearch -exact $presArr($jid,res) $resource] < 0} {
	    return [list -resource $resource -type unavailable]
	}
	set result [list -resource $resource]
	if {$resource == ""} {
	    set jid3 $jid
	} else {
	    set jid3 $jid/$resource
	}
	if {[info exists argsArr(-type)] &&  \
	  ![string equal $argsArr(-type) $presArr($jid3,type)]} {
	    return {}
	}
	foreach key $rostGlobals(presTags) {
	    if {[info exists presArr($jid3,$key)]} {
		lappend result -$key $presArr($jid3,$key)
	    }
	}
    } else {
	
	# Get presence for all resources.
	# Be sure to handle empty resources as well: '1234@icq.host'
	foreach res $presArr($jid,res) {
	    set thisRes [list -resource $res]
	    if {$res == ""} {
		set jid3 $jid
	    } else {
		set jid3 $jid/$res
	    }
	    if {[info exists argsArr(-type)] &&  \
	      ![string equal $argsArr(-type) $presArr($jid3,type)]} {
		# Empty.
	    } else {
		foreach key $rostGlobals(presTags) {
		    if {[info exists presArr($jid3,$key)]} {
			lappend thisRes -$key $presArr($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 roster::getpresence2 {rostName jid args} {    

    variable rostGlobals
    upvar ${rostName}::rostArr rostArr
    upvar ${rostName}::presArr2 presArr2
    upvar ${rostName}::options options
    
    Debug 2 "roster::getpresence2 rostName=$rostName, jid=$jid, args='$args'"
    
    array set argsArr {
	-type *
    }
    array set argsArr $args

    set mjid [jlib::jidmap $jid]
    jlib::splitjid $mjid jid2 resource
    set result {}
    
    if {$resource == ""} {
	
	# 2-tier jid. Match any resource.
	set arrlist [concat [array get presArr2 $mjid,jid] \
	  [array get presArr2 $mjid/*,jid]]
	foreach {key value} $arrlist {
	    set thejid $value
	    set jidresult {}
	    foreach {akey avalue} [array get presArr2 $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 presArr2($mjid,type)]} {
	    if {[string match $argsArr(-type) $presArr2($mjid,type)]} {
		set result [list [list -jid $jid -type $presArr2($mjid,type)]]
	    }
	} else {
	    set result [list [list -jid $jid -type unavailable]]
	}
    }
    return $result
}

# 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:
#       rostName:   the instance of this roster.
#       jid:        (optional).
#       
# Results:
#       a list of groups or empty.

proc roster::getgroups {rostName {jid {}}} {    

    upvar ${rostName}::rostArr rostArr
   
    Debug 2 "roster::getgroups rostName=$rostName, jid='$jid'"
    
    set jid [jlib::jidmap $jid]
    if {[string length $jid]} {
	if {[info exists rostArr($jid,groups)]} {
	    return $rostArr($jid,groups)
	} else {
	    return {}
	}
    } else {
	set rostArr(groups) [lsort -unique $rostArr(groups)]
	return $rostArr(groups)
    }
}

# roster::getname --
#
#       Returns the roster name of this jid.
#
# Arguments:
#       rostName:   the instance of this roster.
#       jid:        
#       
# Results:
#       the roster name or empty.

proc roster::getname {rostName jid} {

    upvar ${rostName}::rostArr rostArr
       
    set jid [jlib::jidmap $jid]
    if {[info exists rostArr($jid,name)]} {
	return $rostArr($jid,name)
    } else {
	return {}
    }
}

# roster::getsubscription --
#
#       Returns the 'subscription' state of this jid.
#
# Arguments:
#       rostName:   the instance of this roster.
#       jid:        
#       
# Results:
#       the 'subscription' state or "none" if no 'subscription' state.

proc roster::getsubscription {rostName jid} {

    upvar ${rostName}::rostArr rostArr
       
    set jid [jlib::jidmap $jid]
    if {[info exists rostArr($jid,subscription)]} {
	return $rostArr($jid,subscription)
    } else {
	return none
    }
}

# roster::getask --
#
#       Returns the 'ask' state of this jid.
#
# Arguments:
#       rostName:   the instance of this roster.
#       jid:        
#       
# Results:
#       the 'ask' state or empty if no 'ask' state.

proc roster::getask {rostName jid} {

    upvar ${rostName}::rostArr rostArr
   
    Debug 2 "roster::getask rostName=$rostName, jid='$jid'"
    
    if {[info exists rostArr($jid,ask)]} {
	return $rostArr($jid,ask)
    } else {
	return {}
    }
}

# roster::getresources --
#
#       Returns a list of all resources for this jid or empty.
#
# Arguments:
#       rostName:   the instance of this roster.
#       jid:        a jid without any resource (jid2).
#       args        ?-type?
#                   -type: return presence for (un)available only.
#       
# Results:
#       a list of all resources for this jid or empty.

proc roster::getresources {rostName jid args} {

    upvar ${rostName}::presArr presArr
   
    Debug 2 "roster::getresources rostName=$rostName, jid='$jid'"
    array set argsArr $args
    
    if {[info exists presArr($jid,res)]} {
	if {[info exists argsArr(-type)]} {
	    
	    # Need to loop through all resources for this jid.
	    set resList {}
	    set type $argsArr(-type)
	    foreach res $presArr($jid,res) {

		# Be sure to handle empty resources as well: '1234@icq.host'
		if {$res== ""} {
		    set jid3 $jid
		} else {
		    set jid3 $jid/$res
		}
		if {[string equal $argsArr(-type) $presArr($jid3,type)]} {
		    lappend resList $res
		}
	    }
	    return $resList
	} else {
	    return $presArr($jid,res)
	}
    } else {
	return {}
    }
}

proc roster::getmatchingjids2 {rostName jid args} {
    
    upvar ${rostName}::presArr2 presArr2
    
    set jidlist {}
    set arrlist [concat [array get presArr2 $mjid,jid] \
      [array get presArr2 $mjid/*,jid]]
    foreach {key value} $arrlist {
	lappend jidlist $value
    }
    return $jidlist
}

# roster::gethighestresource --
#
#       Returns the resource with highest priority for this jid or empty.
#
# Arguments:
#       rostName:   the instance of this roster.
#       jid:        a jid without any resource (jid2).
#       
# Results:
#       a resource for this jid or empty.

proc roster::gethighestresource {rostName jid} {

    upvar ${rostName}::presArr presArr
   
    Debug 2 "roster::gethighestresource rostName=$rostName, jid='$jid'"
    
    set maxres ""
    if {[info exists presArr($jid,res)]} {
	
	# Find the resource corresponding to the highest priority (D=0).
	set maxpri 0
	set maxres [lindex $presArr($jid,res) 0]
	foreach res $presArr($jid,res) {

	    # Be sure to handle empty resources as well: '1234@icq.host'
	    if {$res== ""} {
		set jid3 $jid
	    } else {
		set jid3 $jid/$res
	    }
	    if {[info exists presArr($jid3,priority)]} {
		if {$presArr($jid3,priority) > $maxpri} {
		    set maxres $res
		    set maxpri $presArr($jid3,priority)
		}
	    }
	}
    }
    return $maxres
}

proc roster::getmaxpriorityjid2 {rostName jid} {

    upvar ${rostName}::presArr2 presArr2
   
    Debug 2 "roster::getmaxpriorityjid2 jid='$jid'"
    
    # Find the resource corresponding to the highest priority (D=0).
    set maxjid ""
    set maxpri 0
    foreach jid3 [getmatchingjids2 $rostName $jid] {
	if {[info exists presArr2($jid3,priority)]} {
	    if {$presArr2($jid3,priority) > $maxpri} {
		set maxjid $jid3
		set maxpri $presArr2($jid3,priority)
	    }
	}
    }
    return $jid3
}

# 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:
#       rostName:   the instance of this roster.
#       jid:        either 'username$hostname', or 'username$hostname/resource'.
#       
# Results:
#       0/1.

proc roster::isavailable {rostName jid} {

    upvar ${rostName}::presArr presArr
   
    Debug 2 "roster::isavailable rostName=$rostName, 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 presArr($jid2/$resource,type)]} {
	    if {[string equal $presArr($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 presArr "${jid2}*,type"] {
	    if {[string equal $presArr($key) "available"]} {
		return 1
	    }
	}
	return 0
    }
}

proc roster::isavailable2 {rostName jid} {

    upvar ${rostName}::presArr2 presArr2
   
    Debug 2 "roster::isavailable rostName=$rostName, 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 presArr($jid2/$resource,type)]} {
	    if {[string equal $presArr($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 presArr "${jid2}*,type"] {
	    if {[string equal $presArr($key) "available"]} {
		return 1
	    }
	}
	return 0
    }
}

# roster::wasavailable --
#
#       As 'isavailable' but for any "old" former presence state.
#
# Arguments:
#       rostName:   the instance of this roster.
#       jid:        either 'username$hostname', or 'username$hostname/resource'.
#       
# Results:
#       0/1.

proc roster::wasavailable {rostName jid} {

    upvar ${rostName}::oldpresArr oldpresArr
   
    Debug 2 "roster::wasavailable rostName=$rostName, 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 oldpresArr($jid2/$resource,type)]} {
	    if {[string equal $oldpresArr($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 oldpresArr "${jid2}*,type"] {
	    if {[string equal $oldpresArr($key) "available"]} {
		return 1
	    }
	}
	return 0
    }
}

# roster::getx --
#
#       Returns the xml list for this jid's x element with given xml namespace.
#       Returns empty if no matching info.
#
# Arguments:
#       rostName:   the instance of this roster.
#       jid:        any jid
#       xmlns:      the (mandatory) xmlns specifier. Any prefix
#                   http://jabber.org/protocol/ must be stripped off.
#       
# Results:
#       xml list or empty.

proc roster::getx {rostName jid xmlns} {

    upvar ${rostName}::presArr presArr
   
    Debug 2 "roster::getx rostName=$rostName, jid='$jid', xmlns=$xmlns"

    set jid [jlib::jidmap $jid]
    if {[info exists presArr($jid,x,$xmlns)]} {
	return $presArr($jid,x,$xmlns)
    } else {
	return ""
    }
}

# roster::getextras --
#
#       Returns the xml list for this jid's extras element with given xml namespace.
#       Returns empty if no matching info.
#
# Arguments:
#       rostName:   the instance of this roster.
#       jid:        any jid
#       xmlns:      the (mandatory) full xmlns specifier.
#       
# Results:
#       xml list or empty.

proc roster::getextras {rostName jid xmlns} {

    upvar ${rostName}::presArr presArr
   
    set jid [jlib::jidmap $jid]
    if {[info exists presArr($jid,extras,$xmlns)]} {
	return $presArr($jid,extras,$xmlns)
    } else {
	return ""
    }
}

# 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:
#       rostName:   the instance of this roster.
#       jid:        any jid
#       attrname:   
#       
# Results:
#       the value of the attribute or empty

proc roster::getcapsattr {rostName jid attrname} {
    
    variable xmppxmlns
    upvar ${rostName}::presArr presArr

    set attr ""
    set jid [jlib::jidmap $jid]
    set xmlnscaps $xmppxmlns(caps)
    if {[info exists presArr($jid,extras,$xmlnscaps)]} {
	set cElem $presArr($jid,extras,$xmlnscaps)
	set attr [wrapper::getattribute $cElem $attrname]
    }
    return $attr
}

proc roster::Debug {num str} {
    variable rostGlobals
    if {$num <= $rostGlobals(debug)} {
	puts $str
    }
}

#-------------------------------------------------------------------------------
# service.tcl --
#
#       This is an abstraction layer for two things; the agent/browse/disco
#       protocols, and for the groupchat protocols gc-1.0/conference/muc.
#       All except disco/muc are EOL!
#       
#  Copyright (c) 2004-2005  Mats Bengtsson
#  
# $Id: service.tcl,v 1.14 2005/02/08 08:57:16 matben Exp $
# 
############################# USAGE ############################################
#
#   NAME
#      service - protocol independent methods for groupchats/conference/muc,
#                agents/browse/disco
#                
#   SYNOPSIS
#      jlib::service::init jlibName
#      
#   INSTANCE COMMANDS
#      jlibName service allroomsin
#      jlibName service childs jid
#      jlibName service exitroom room
#      jlibName service isroom jid
#      jlibName service getjidsfor aservice
#      jlibName service gettransportjids aservice
#      jlibName service gettype jid
#      jlibName service hashandnick jid
#      jlibName service hasfeature jid feature (xmlns)
#      jlibName service nick jid
#      jlibName service parent jid
#      jlibName service register type name
#      jlibName service roomparticipants room
#      jlibName service send_getchildren jid cmd
#      jlibName service setgroupchatpriority priorityList
#      jlibName service setgroupchatprotocol jid protocol
#      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|conference|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 two things; the agent/browse/(disco?)
    # protocols, and for the groupchat protocols gc-1.0/conference/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 | conference | muc )
    variable groupchatTypeExp {(gc-1.0|conference|muc)}
}

proc jlib::service {jlibname cmd args} {
    
    # Which command? Just dispatch the command to the right procedure.
    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 {
	agent    1
	browse   0
	disco    0
	muc      0
    }
	    
    # Maintain a priority list of groupchat protocols in decreasing priority.
    # Entries must match: ( gc-1.0 | conference | muc )
    set serv(gcProtoPriority) {muc conference 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::send_getchildren {jlibname jid cmd} {
    
    upvar ${jlibname}::serv serv
    upvar ${jlibname}::locals locals

    # We must have a way to figure out which method to use!!!
    if {$serv(browse) && [$serv(browse,name) isbrowsed $locals(server)]} {
	$serv(browse,name) send_get $jid $cmd
    } elseif {$serv(disco) && [$serv(disco,name) isdiscoed items $locals(server)]} {
	$serv(disco,name) send_get items $jid $cmd
    }
}

#-------------------------------------------------------------------------------
#
# 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::setgroupchatpriority --
# 
#       Sets the list if groupchat protocols in decreasing priority.
#       The list contains elements 'gc-1.0', 'conference', 'muc',
#       describing which to pick if multiple options.

proc jlib::service::setgroupchatpriority {jlibname priorityList} {

    variable groupchatTypeExp
    upvar ${jlibname}::serv serv

    foreach prot $priorityList {
	if {![regexp $groupchatTypeExp $prot]} {
	    return -code error "Unrecognized groupchat type \"$prot\""
	}
    }
    set serv(gcProtoPriority) $priorityList
}

# jlib::service::setgroupchatprotocol --
# 
#       Explicitly picks a groupchat protocol to use for a groupchat service.
#       
# Arguments:
#       jlibname
#       jid
#       prot        any of 'gc-1.0', 'conference', 'muc'.
#
# Results:
#       None.

proc jlib::service::setgroupchatprotocol {jlibname jid prot} {

    variable groupchatTypeExp
    upvar ${jlibname}::agent agent
    upvar ${jlibname}::serv serv

    set jid [jlib::jidmap $jid]
    if {![regexp $groupchatTypeExp $prot]} {
	return -code error "Unrecognized groupchat type \"$prot\""
    }
    switch -- $prot {
	gc-1.0 {
	    if {![info exists agent($jid,groupchat)]} {
		return -code error  \
		  "No groupchat agent registered for \"$jid\""
	    }
	}
	conference {
	    if {!$serv(browse)} {
		return -code error \
		  "there is no browse object associated with this jlib"
	    }    
	    set confServicesJids [$serv(browse,name) getconferenceservers]
	    if {[lsearch -exact $confServicesJids $jid] < 0} {
		return -code error \
		  "The jid $jid does not know of any \"conference\" service"
	    }
	}
	muc {
	    if {!$serv(browse)} {
		# This must be changed when disco is coming...
		return -code error \
		  "there is no browse object associated with this jlib"
	    }    
	    if {![$serv(browse,name) hasnamespace $jid  \
	      "http://jabber.org/protocol/muc"]} {
		return -code error \
		  "The jid \"$jid\" does not know of any \"muc\" service"
	    }
	}
    }
    set serv(prefgcprot,$jid) $prot
}

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

proc jlib::service::isinvestigated {jlibname jid} {
    
    upvar ${jlibname}::serv serv

    # Try to gather only positive results!
    set ans 0
    if {$serv(browse) && [$serv(browse,name) isbrowsed $jid]} {
	set ans 1
    } elseif {$serv(disco) && [$serv(disco,name) isdiscoed items $jid]} {
	set ans 1
    }
    return $ans
}
   
proc jlib::service::parent {jlibname jid} {    

    upvar ${jlibname}::agent agent
    upvar ${jlibname}::serv serv

    # ???
    if {$serv(browse) && [$serv(browse,name) isbrowsed $jid]} {
	return [$serv(browse,name) getparentjid $jid]
    } elseif {$serv(disco) && [$serv(disco,name) isdiscoed items $jid]} {
	return [$serv(disco,name) parent $jid]
    } else {
	set jid [jlib::jidmap $jid]
	if {[info exists agent($jid,parent)]} {
	    return $agent($jid,parent)
	} else {
	    return -code error "Parent of \"$jid\" cannot be found"
	}
    }
}

proc jlib::service::childs {jlibname jid} {    

    upvar ${jlibname}::agent agent
    upvar ${jlibname}::serv serv

    # ???
    if {$serv(browse) && [$serv(browse,name) isbrowsed $jid]} {
	return [$serv(browse,name) getchilds $jid]
    } elseif {$serv(disco) && [$serv(disco,name) isdiscoed items $jid]} {
	return [$serv(disco,name) children $jid]
    } else {
	set jid [jlib::jidmap $jid]
	if {[info exists agent($jid,childs)]} {
	    set agent($jid,childs) [lsort -unique $agent($jid,childs)]
	    return $agent($jid,childs)
	} else {
	    return -code error "Childs of \"$jid\" cannot be found"
	}
    }
}

# jlib::service::getjidsfor --
#
#       Return a list of jid's that support any of "search", "register",
#       "groupchat". Queries sent to both browser and agent.
#       
#       Problems with groupchat <--> conference Howto?
#
# Arguments:
#       jlibname:   the instance of this jlib.
#       what:       "groupchat", "conference", "muc", "register", "search".
#       
# Results:
#       list of jids supporting this service, possibly empty.

proc jlib::service::getjidsfor {jlibname what} {

    variable services
    upvar ${jlibname}::agent agent
    upvar ${jlibname}::serv serv
    
    if {[lsearch $services $what] < 0} {
	return -code error "\"$what\" is not a recognized service"
    }
    set jids {}
    
    # Browse service if any.
    if {$serv(browse)} {
	set browseNS [$serv(browse,name) getservicesforns jabber:iq:${what}]
	if {[llength $browseNS]} {
	    set jids $browseNS
	}
	
	switch -- $what {
	    groupchat {
		
		# These server components support 'groupchat 1.0' as well.
		# The 'jabber:iq:conference' seems to be lacking in many jabber.xml.
		# Use 'getconferenceservers' as fallback.
		set jids [concat $jids \
		  [$serv(browse,name) getservicesforns jabber:iq:conference]]	    
		set jids [concat $jids [$serv(browse,name) getconferenceservers]]
		set jids [concat $jids [$serv(browse,name) getservicesforns  \
		  "http://jabber.org/protocol/muc"]]
	    }
	    muc {
		set jids [concat $jids [$serv(browse,name) getservicesforns  \
		  "http://jabber.org/protocol/muc"]]
	    }
	}
    }
    
    # Disco
    if {$serv(disco)} {
	set jidsdi [$serv(disco,name) getjidsforfeature jabber:iq:${what}]
	
	switch -- $what {
	    groupchat - muc {
		
		# Rooms also return muc as feature; skip these!
		#set jidsdi [concat $jidsdi [$serv(disco,name) getjidsforfeature \
		#  "http://jabber.org/protocol/muc"]]
		
		set jidsdi [concat $jidsdi [$serv(disco,name) getconferences]]
	    }
	}
	set jids [concat $jids $jidsdi]
    }       
    
    # Agent service if any.
    if {[info exists agent($what)] && [llength $agent($what)]} {
	set agent($what) [lsort -unique $agent($what)]
	set jids [concat $agent($what) $jids]
    }
    return [lsort -unique $jids]
}

proc jlib::service::getconferences {jlibname} {
    
    upvar ${jlibname}::serv serv

    # Try to gather only positive results!
    set jids {}
    if {$serv(browse)} {
	set jids [$serv(browse,name) getconferenceservers]
    }
    if {$serv(disco)} {
	set jids [concat $jids [$serv(disco,name) getconferences]]
    }
    return [lsort -unique $jids]
}

proc jlib::service::hasfeature {jlibname jid xmlns} {

    upvar ${jlibname}::serv serv

    # Try to gather only positive results!
    set ans 0
    if {$serv(browse)} {
	set ans [$serv(browse,name) hasnamespace $jid $xmlns]
    } 
    if {!$ans && $serv(disco) && [$serv(disco,name) isdiscoed info $jid]} {
	set ans [$serv(disco,name) hasfeature $xmlns $jid]
    }
    return $ans
}

# jlib::service::gettransportjids --
#
#       Return a list of jid's that support a specific transport.
#       Queries sent to both browser and agent.
#       
# Arguments:
#       jlibname:   the instance of this jlib.
#       what:       "*", "jabber", "icq", "msn", "yahoo", "aim",...
#       
# Results:
#       list of jids supporting this service, possibly empty.

proc jlib::service::gettransportjids {jlibname what} {

    upvar ${jlibname}::agent agent
    upvar ${jlibname}::serv serv

    set jids {}
    
    # Browse service if any.
    if {$serv(browse)} {
	set jids [concat $jids \
	  [$serv(browse,name) getalljidfortypes "service/$what"]]
    }
    if {$serv(disco)} {
	
	# The Jabber registrar defines the type/subtype for all
	# categories. The actual server is "server/im".
	set jids [concat $jids \
	  [$serv(disco,name) getjidsforcategory "gateway/$what"]]
    }

    # Agent service if any.
    foreach key [array names agent "*,service"] {
	if {[string equal $agent($key) $what] || ($what == "*")} {
	    lappend jids [string map {,service ""} $key]
	}
    }
    return [lsort -unique $jids]
}

# jlib::service::gettype --
# 
#       Returns the 'type/subtype' for this jid if any.
#       
# Arguments:
#       jlibname:   the instance of this jlib.
#       jid:
#       
# Results:
#       type/subtype, possibly empty.

proc jlib::service::gettype {jlibname jid} {

    upvar ${jlibname}::agent agent
    upvar ${jlibname}::serv serv

    set type ""
    
    # Browse service if any. Returns 'service/icq' etc.
    #if {$serv(browse) && [$serv(browse,name) isbrowsed $jid]}
    if {$serv(browse)} {
	set type [$serv(browse,name) gettype $jid]
    }
    if {$serv(disco) && [$serv(disco,name) isdiscoed info $jid]} {
	set type [lindex [$serv(disco,name) types $jid] 0]
    }
    set jid [jlib::jidmap $jid]
    if {[info exists agent($jid,service)]} {
	set type "service/$agent($jid,service)"
    }
    return $type
}

# jlib::service::name --
# 
#       Return any name attribute for jid.

proc jlib::service::name {jlibname jid} {    

    upvar ${jlibname}::serv serv
    upvar ${jlibname}::lib lib
    
    # Check if domain name supports the 'groupchat' service.
    set name ""
    # ????????
    if {$serv(browse) && [$serv(browse,name) isbrowsed $jid]} {
	set name [$serv(browse,name) getname $jid]
    }
    if {$serv(disco) && [$serv(disco,name) isdiscoed info $jid]} {
	set name [$serv(disco,name) name $jid]
    }
    return $name
}

# 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}::agent agent
    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 {$serv(browse) && [$serv(browse,name) isbrowsed $locals(server)]} {
	set isroom [$serv(browse,name) isroom $jid]
    }
    if {!$isroom && $serv(disco) && [$serv(disco,name) isdiscoed info $locals(server)]} {
	set isroom [$serv(disco,name) isroom $jid]
    }
    if {!$isroom && $serv(muc)} {
	set isroom [$serv(muc,name) isroom $jid]
    }
    if {!$isroom && [regexp {^[^@]+@([^@ ]+)$} $jid match domain]} {
	if {[info exists agent($domain,groupchat)]} {
	    set isroom 1
	}
    }
    return $isroom
}

# jlib::service::nick --
#
#       Return nick name for ANY room participant, or the rooms name
#       if jid is a room.
#       For the browser we return the <name> chdata, but for the
#       groupchat-1.0 protocol we use a scheme to find nick.
#       
# Arguments:
#       jlibname:   the instance of this jlib.
#       jid:        'roomname@conference.jabber.org/nickOrHex' typically,
#                   or just room jid.

proc jlib::service::nick {jlibname jid} {   

    upvar ${jlibname}::locals locals
    upvar ${jlibname}::serv serv

    # 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.
    jlib::splitjid $jid room res
        
    # Use fallback here???
    if {![info exists serv(roomprot,$room)]} {
	return $res
	#return -code error "Does not know which protocol to use in $room"
    }
    set nick $res
    if {$res == ""} {
	set nick $jid
    }
    
    switch -- $serv(roomprot,$room) {
	gc-1.0 {
	    
	    # Old-style groupchat just has /nick.
	    if {[regexp {^[^@]+@[^@/]+/(.+)$} $jid match nick]} {
		
		# Else we just use the username. (If room for instance)
	    } elseif {![regexp {^([^@]+)@[^@/]+$} $jid match nick]} {
		set nick $jid
	    }
	}
	muc {
	    
	    # The MUC conference method: nick is always the resource part. 
	    # Rooms lack the */res.
	    if {![regexp {^[^@]+@[^@/]+/(.+)$} $jid match nick]} {
		if {![regexp {^([^@]+)@.+} $jid match nick]} {
		    set nick $jid
		}
	    }
	}	
	conference {
	    if {$serv(browse) && [$serv(browse,name) isbrowsed $locals(server)]} {
		
		# Assume that if the login server is browsed we also should query
		# the browse object.
		set nick [$serv(browse,name) getname $jid]
	    }
	}
    }
    return $nick
}

# jlib::service::hashandnick --
#
#       A way to get our OWN three-tier jid and nickname for a given room
#       independent on if 'conference' or 'groupchat' is used.
#       
# Arguments:
#       jlibname:   the instance of this jlib.
#       room:       'roomname@conference.jabber.org' typically.
#       
# Results:
#       list {kitchen@conf.athlon.se/63264ba6724.. mynickname}

proc jlib::service::hashandnick {jlibname room} {    

    upvar ${jlibname}::locals locals
    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"
    }
    set hashandnick [list ${room}/ ""]
    
    switch -- $serv(roomprot,$room) {
	gc-1.0 {
	
	    # Old-style groupchat just has /nick.
	    set nick [[namespace parent]::groupchat::mynick $jlibname $room]
	    set hashandnick [list ${room}/${nick} $nick]   
	} 
	muc {
	    if {$serv(muc)} {
		set nick [$serv(muc,name) mynick $room]
		set hashandnick [list ${room}/${nick} $nick]   
	    }
	} 
	conference {
	    if {$serv(browse) && [$serv(browse,name) isbrowsed $locals(server)]} {
		set hashandnick  \
		  [[namespace parent]::conference::hashandnick $jlibname $room]
	    }
	}
    }
    
    return $hashandnick
}

# 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] \
      [[namespace parent]::conference::allroomsin $jlibname]]
    if {$serv(muc)} {
	set roomList [concat $roomList [$serv(muc,name) 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 [$serv(muc,name) participants $room]
	}
	conference {
	    if {$serv(browse) && [$serv(browse,name) isbrowsed $locals(server)]} {
		set everyone [$serv(browse,name) getchilds $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 {
	    $serv(muc,name) exit $room
	}
	conference {
	    if {$serv(browse) && [$serv(browse,name) isbrowsed $locals(server)]} {
		[namespace parent]::conference::exit $jlibname $room
	    }
	}
    }
}

#-------------------------------------------------------------------------------
#  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
#  
# $Id: stanzaerror.tcl,v 1.4 2004/09/13 09:05:19 matben Exp $
# 

package provide stanzaerror 1.0

namespace eval stanzaerror {
    
    # This maps Defined Conditions to clear text messages.
    # draft-ietf-xmpp-core23; 9.3.3 Defined Conditions
    
    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 ""
    }
}

#-------------------------------------------------------------------------------

#  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
#  
# $Id: streamerror.tcl,v 1.2 2004/09/18 14:43:29 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
    
    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 ""
    }
}

#-------------------------------------------------------------------------------

    package require xml::tcl 99.0
    package require xmldefs
    package require xml::tclparser 99.0
    package provide xml 99.0
# xml.tcl --
#
#	This file provides generic XML services for all implementations.
#	This file supports Tcl 8.1 regular expressions.
#
#	See tclparser.tcl for the Tcl implementation of a XML parser.
#
# Copyright (c) 1998-2000 Zveno Pty Ltd
# http://www.zveno.com/
# 
# Zveno makes this software and all associated data and documentation
# ('Software') available free of charge for any purpose.
# Copies may be made of this Software but all of this notice must be included
# on any copy.
# 
# The Software was developed for research purposes and Zveno does not warrant
# that it is error free or fit for any purpose.  Zveno disclaims any
# liability for all claims, expenses, losses, damages and costs any user may
# incur as a result of using, copying or modifying the Software.
#
# Copyright (c) 1997 Australian National University (ANU).
# 
# ANU makes this software and all associated data and documentation
# ('Software') available free of charge for any purpose. You may make copies
# of the Software but you must include all of this notice on any copy.
# 
# The Software was developed for research purposes and ANU does not warrant
# that it is error free or fit for any purpose.  ANU disclaims any
# liability for all claims, expenses, losses, damages and costs any user may
# incur as a result of using, copying or modifying the Software.
#
# $Id: xml-8.1.tcl,v 1.2 2004/08/17 14:10:30 matben Exp $

package require Tcl 8.1

package provide xmldefs 2.0

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

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

# 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-2001 Zveno Pty Ltd
# http://www.zveno.com/
#
# Zveno makes this software available free of charge for any purpose.
# Copies may be made of this software but all of this notice must be included
# on any copy.
#
# The software was developed for research purposes only and Zveno does not
# warrant that it is error free or fit for any purpose.  Zveno disclaims any
# liability for all claims, expenses, losses, damages and costs any user may
# incur as a result of using, copying or modifying this software.
#
# Copyright (c) 1997 ANU and CSIRO on behalf of the
# participants in the CRC for Advanced Computational Systems ('ACSys').
# 
# ACSys makes this software and all associated data and documentation 
# ('Software') available free of charge for any purpose.  You may make copies 
# of the Software but you must include all of this notice on any copy.
# 
# The Software was developed for research purposes and ACSys does not warrant
# that it is error free or fit for any purpose.  ACSys disclaims any
# liability for all claims, expenses, losses, damages and costs any user may
# incur as a result of using, copying or modifying the Software.
#
# $Id: sgml-8.1.tcl,v 1.2 2004/08/17 14:10:30 matben Exp $

package require Tcl 8.1

package provide sgml 1.8

namespace eval sgml {

    # Convenience routine
    proc cl x {
	return "\[$x\]"
    }

    # Define various regular expressions

    # Character classes
    variable Char \t\n\r\ -\uD7FF\uE000-\uFFFD\u10000-\u10FFFF
    variable BaseChar \u0041-\u005A\u0061-\u007A\u00C0-\u00D6\u00D8-\u00F6\u00F8-\u00FF\u0100-\u0131\u0134-\u013E\u0141-\u0148\u014A-\u017E\u0180-\u01C3\u01CD-\u01F0\u01F4-\u01F5\u01FA-\u0217\u0250-\u02A8\u02BB-\u02C1\u0386\u0388-\u038A\u038C\u038E-\u03A1\u03A3-\u03CE\u03D0-\u03D6\u03DA\u03DC\u03DE\u03E0\u03E2-\u03F3\u0401-\u040C\u040E-\u044F\u0451-\u045C\u045E-\u0481\u0490-\u04C4\u04C7-\u04C8\u04CB-\u04CC\u04D0-\u04EB\u04EE-\u04F5\u04F8-\u04F9\u0531-\u0556\u0559\u0561-\u0586\u05D0-\u05EA\u05F0-\u05F2\u0621-\u063A\u0641-\u064A\u0671-\u06B7\u06BA-\u06BE\u06C0-\u06CE\u06D0-\u06D3\u06D5\u06E5-\u06E6\u0905-\u0939\u093D\u0958-\u0961\u0985-\u098C\u098F-\u0990\u0993-\u09A8\u09AA-\u09B0\u09B2\u09B6-\u09B9\u09DC-\u09DD\u09DF-\u09E1\u09F0-\u09F1\u0A05-\u0A0A\u0A0F-\u0A10\u0A13-\u0A28\u0A2A-\u0A30\u0A32-\u0A33\u0A35-\u0A36\u0A38-\u0A39\u0A59-\u0A5C\u0A5E\u0A72-\u0A74\u0A85-\u0A8B\u0A8D\u0A8F-\u0A91\u0A93-\u0AA8\u0AAA-\u0AB0\u0AB2-\u0AB3\u0AB5-\u0AB9\u0ABD\u0AE0\u0B05-\u0B0C\u0B0F-\u0B10\u0B13-\u0B28\u0B2A-\u0B30\u0B32-\u0B33\u0B36-\u0B39\u0B3D\u0B5C-\u0B5D\u0B5F-\u0B61\u0B85-\u0B8A\u0B8E-\u0B90\u0B92-\u0B95\u0B99-\u0B9A\u0B9C\u0B9E-\u0B9F\u0BA3-\u0BA4\u0BA8-\u0BAA\u0BAE-\u0BB5\u0BB7-\u0BB9\u0C05-\u0C0C\u0C0E-\u0C10\u0C12-\u0C28\u0C2A-\u0C33\u0C35-\u0C39\u0C60-\u0C61\u0C85-\u0C8C\u0C8E-\u0C90\u0C92-\u0CA8\u0CAA-\u0CB3\u0CB5-\u0CB9\u0CDE\u0CE0-\u0CE1\u0D05-\u0D0C\u0D0E-\u0D10\u0D12-\u0D28\u0D2A-\u0D39\u0D60-\u0D61\u0E01-\u0E2E\u0E30\u0E32-\u0E33\u0E40-\u0E45\u0E81-\u0E82\u0E84\u0E87-\u0E88\u0E8A\u0E8D\u0E94-\u0E97\u0E99-\u0E9F\u0EA1-\u0EA3\u0EA5\u0EA7\u0EAA-\u0EAB\u0EAD-\u0EAE\u0EB0\u0EB2-\u0EB3\u0EBD\u0EC0-\u0EC4\u0F40-\u0F47\u0F49-\u0F69\u10A0-\u10C5\u10D0-\u10F6\u1100\u1102-\u1103\u1105-\u1107\u1109\u110B-\u110C\u110E-\u1112\u113C\u113E\u1140\u114C\u114E\u1150\u1154-\u1155\u1159\u115F-\u1161\u1163\u1165\u1167\u1169\u116D-\u116E\u1172-\u1173\u1175\u119E\u11A8\u11AB\u11AE-\u11AF\u11B7-\u11B8\u11BA\u11BC-\u11C2\u11EB\u11F0\u11F9\u1E00-\u1E9B\u1EA0-\u1EF9\u1F00-\u1F15\u1F18-\u1F1D\u1F20-\u1F45\u1F48-\u1F4D\u1F50-\u1F57\u1F59\u1F5B\u1F5D\u1F5F-\u1F7D\u1F80-\u1FB4\u1FB6-\u1FBC\u1FBE\u1FC2-\u1FC4\u1FC6-\u1FCC\u1FD0-\u1FD3\u1FD6-\u1FDB\u1FE0-\u1FEC\u1FF2-\u1FF4\u1FF6-\u1FFC\u2126\u212A-\u212B\u212E\u2180-\u2182\u3041-\u3094\u30A1-\u30FA\u3105-\u312C\uAC00-\uD7A3  
    variable Ideographic \u4E00-\u9FA5\u3007\u3021-\u3029
    variable CombiningChar \u0300-\u0345\u0360-\u0361\u0483-\u0486\u0591-\u05A1\u05A3-\u05B9\u05BB-\u05BD\u05BF\u05C1-\u05C2\u05C4\u064B-\u0652\u0670\u06D6-\u06DC\u06DD-\u06DF\u06E0-\u06E4\u06E7-\u06E8\u06EA-\u06ED\u0901-\u0903\u093C\u093E-\u094C\u094D\u0951-\u0954\u0962-\u0963\u0981-\u0983\u09BC\u09BE\u09BF\u09C0-\u09C4\u09C7-\u09C8\u09CB-\u09CD\u09D7\u09E2-\u09E3\u0A02\u0A3C\u0A3E\u0A3F\u0A40-\u0A42\u0A47-\u0A48\u0A4B-\u0A4D\u0A70-\u0A71\u0A81-\u0A83\u0ABC\u0ABE-\u0AC5\u0AC7-\u0AC9\u0ACB-\u0ACD\u0B01-\u0B03\u0B3C\u0B3E-\u0B43\u0B47-\u0B48\u0B4B-\u0B4D\u0B56-\u0B57\u0B82-\u0B83\u0BBE-\u0BC2\u0BC6-\u0BC8\u0BCA-\u0BCD\u0BD7\u0C01-\u0C03\u0C3E-\u0C44\u0C46-\u0C48\u0C4A-\u0C4D\u0C55-\u0C56\u0C82-\u0C83\u0CBE-\u0CC4\u0CC6-\u0CC8\u0CCA-\u0CCD\u0CD5-\u0CD6\u0D02-\u0D03\u0D3E-\u0D43\u0D46-\u0D48\u0D4A-\u0D4D\u0D57\u0E31\u0E34-\u0E3A\u0E47-\u0E4E\u0EB1\u0EB4-\u0EB9\u0EBB-\u0EBC\u0EC8-\u0ECD\u0F18-\u0F19\u0F35\u0F37\u0F39\u0F3E\u0F3F\u0F71-\u0F84\u0F86-\u0F8B\u0F90-\u0F95\u0F97\u0F99-\u0FAD\u0FB1-\u0FB7\u0FB9\u20D0-\u20DC\u20E1\u302A-\u302F\u3099\u309A
    variable Digit \u0030-\u0039\u0660-\u0669\u06F0-\u06F9\u0966-\u096F\u09E6-\u09EF\u0A66-\u0A6F\u0AE6-\u0AEF\u0B66-\u0B6F\u0BE7-\u0BEF\u0C66-\u0C6F\u0CE6-\u0CEF\u0D66-\u0D6F\u0E50-\u0E59\u0ED0-\u0ED9\u0F20-\u0F29
    variable Extender \u00B7\u02D0\u02D1\u0387\u0640\u0E46\u0EC6\u3005\u3031-\u3035\u309D-\u309E\u30FC-\u30FE
    variable Letter $BaseChar|$Ideographic

    # white space
    variable Wsp " \t\r\n"
    variable noWsp [cl ^$Wsp]

    # Various XML names
    variable NameChar \[-$Letter$Digit._:$CombiningChar$Extender\]
    variable Name \[_:$BaseChar$Ideographic\]$NameChar*
    variable Names ${Name}(?:$Wsp$Name)*
    variable Nmtoken $NameChar+
    variable Nmtokens ${Nmtoken}(?:$Wsp$Nmtoken)*

    # table of predefined entities for XML

    variable EntityPredef
    array set EntityPredef {
	lt <   gt >   amp &   quot \"   apos '
    }

}

# These regular expressions are defined here once for better performance

namespace eval sgml {
    variable Wsp

    # Watch out for case-sensitivity

    set attlist_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#REQUIRED|#IMPLIED)
    set attlist_enum_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*\\(([cl ^)]*)\\)[cl $Wsp]*("([cl ^")]*)")? ;# "
    set attlist_fixed_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#FIXED)[cl $Wsp]*([cl ^$Wsp]+)

    set param_entity_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^"$Wsp]*)[cl $Wsp]*"([cl ^"]*)"

    set notation_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(.*)

}

### Utility procedures

# sgml::noop --
#
#	A do-nothing proc
#
# Arguments:
#	args	arguments
#
# Results:
#	Nothing.

proc sgml::noop args {
    return 0
}

# sgml::identity --
#
#	Identity function.
#
# Arguments:
#	a	arbitrary argument
#
# Results:
#	$a

proc sgml::identity a {
    return $a
}

# sgml::Error --
#
#	Throw an error
#
# Arguments:
#	args	arguments
#
# Results:
#	Error return condition.

proc sgml::Error args {
    uplevel return -code error [list $args]
}

### Following procedures are based on html_library

# sgml::zapWhite --
#
#	Convert multiple white space into a single space.
#
# Arguments:
#	data	plain text
#
# Results:
#	As above

proc sgml::zapWhite data {
    regsub -all "\[ \t\r\n\]+" $data { } data
    return $data
}

proc sgml::Boolean value {
    regsub {1|true|yes|on} $value 1 value
    regsub {0|false|no|off} $value 0 value
    return $value
}

# 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-2001 Zveno Pty Ltd
# http://www.zveno.com/
#
# Zveno makes this software available free of charge for any purpose.
# Copies may be made of this software but all of this notice must be included
# on any copy.
#
# The software was developed for research purposes only and Zveno does not
# warrant that it is error free or fit for any purpose.  Zveno disclaims any
# liability for all claims, expenses, losses, damages and costs any user may
# incur as a result of using, copying or modifying this software.
#
# Copyright (c) 1997 ANU and CSIRO on behalf of the
# participants in the CRC for Advanced Computational Systems ('ACSys').
# 
# ACSys makes this software and all associated data and documentation 
# ('Software') available free of charge for any purpose.  You may make copies 
# of the Software but you must include all of this notice on any copy.
# 
# The Software was developed for research purposes and ACSys does not warrant
# that it is error free or fit for any purpose.  ACSys disclaims any
# liability for all claims, expenses, losses, damages and costs any user may
# incur as a result of using, copying or modifying the Software.
#
# $Id: sgmlparser.tcl,v 1.4 2004/09/08 13:13:13 matben Exp $

package require sgml 1.8

package provide sgmlparser 99.0

namespace eval sgml {
    namespace export tokenise parseEvent

    namespace export parseDTD

    # NB. Most namespace variables are defined in sgml-8.[01].tcl
    # to account for differences between versions of Tcl.
    # This especially includes the regular expressions used.

    variable ParseEventNum
    if {![info exists ParseEventNum]} {
	set ParseEventNum 0
    }
    variable ParseDTDnum
    if {![info exists ParseDTDNum]} {
	set ParseDTDNum 0
    }

    variable declExpr [cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*)
    variable EntityExpr [cl $::sgml::Wsp]*(%[cl $::sgml::Wsp])?[cl $::sgml::Wsp]*($::sgml::Name)[cl $::sgml::Wsp]+(.*)

    #variable MarkupDeclExpr <([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*)>
    #variable MarkupDeclSub "} {\\1} {\\2} {\\3} {"
    variable MarkupDeclExpr <[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^>]*)>
    variable MarkupDeclSub "\} {\\1} {\\2} \{"

    variable ExternalEntityExpr ^(PUBLIC|SYSTEM)[cl $::sgml::Wsp]+("|')(.*?)\\2([cl $::sgml::Wsp]+("|')(.*?)\\2)?([cl $::sgml::Wsp]+NDATA[cl $::sgml::Wsp]+($::xml::Name))?\$

    variable StdOptions
    array set StdOptions [list \
	-elementstartcommand		[namespace current]::noop	\
	-elementendcommand		[namespace current]::noop	\
	-characterdatacommand		[namespace current]::noop	\
	-processinginstructioncommand	[namespace current]::noop	\
	-externalentitycommand		{}				\
	-xmldeclcommand			[namespace current]::noop	\
	-doctypecommand			[namespace current]::noop	\
	-commentcommand			[namespace current]::noop	\
	-entitydeclcommand		[namespace current]::noop	\
	-unparsedentitydeclcommand	[namespace current]::noop	\
	-parameterentitydeclcommand	[namespace current]::noop	\
	-notationdeclcommand		[namespace current]::noop	\
	-elementdeclcommand		[namespace current]::noop	\
	-attlistdeclcommand		[namespace current]::noop	\
	-paramentityparsing		1				\
	-defaultexpandinternalentities	1				\
	-startdoctypedeclcommand	[namespace current]::noop	\
	-enddoctypedeclcommand		[namespace current]::noop	\
	-entityreferencecommand		{}				\
	-warningcommand			[namespace current]::noop	\
	-errorcommand			[namespace current]::Error	\
	-final				1				\
	-validate			0				\
	-baseurl			{}				\
	-name				{}				\
	-emptyelement			[namespace current]::EmptyElement	\
	-parseattributelistcommand	[namespace current]::noop	\
	-parseentitydeclcommand		[namespace current]::noop	\
	-normalize			1				\
	-internaldtd			{}				\
	-reportempty			0				\
    ]
}

# sgml::tokenise --
#
#	Transform the given HTML/XML text into a Tcl list.
#
# Arguments:
#	sgml		text to tokenize
#	elemExpr	RE to recognise tags
#	elemSub		transform for matched tags
#	args		options
#
# Valid Options:
#       -internaldtdvariable
#	-final		boolean		True if no more data is to be supplied
#	-statevariable	varName		Name of a variable used to store info
#
# Results:
#	Returns a Tcl list representing the document.

proc sgml::tokenise {sgml 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
	}

    } 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
#	-baseurl		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
#
# 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
    }

    # 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
		    uplevel #0 $options(-commentcommand) [list $state(commentdata)<$comm1]
		    unset state(commentdata)
		} elseif {[regexp ([cl ^-]*)--\$ $param discard comm1]} {
		    # end of comment (in attributes)
		    uplevel #0 $options(-commentcommand) [list $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)
		    uplevel #0 $options(-commentcommand) [list $state(commentdata)<$close$tag$param>$comm1]
		    unset state(commentdata)
		    set tag {}
		    set param {}
		    set close {}
		    set state(mode) normal
		} else {
		    # comment continues
		    append state(commentdata) <$close$tag$param>$text
		    continue
		}
	    }
	    cdata {
		if {[string length $param] && [regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $tag discard cdata1]} {
		    # end of CDATA (in tag)
		    uplevel #0 $options(-characterdatacommand) [list $state(cdata)<[subst -nocommand -novariable $close$cdata1]]
		    set text [subst -novariable -nocommand $text]
		    set tag {}
		    unset state(cdata)
		    set state(mode) normal
		} elseif {[regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $param discard cdata1]} {
		    # end of CDATA (in attributes)
		    uplevel #0 $options(-characterdatacommand) [list $state(cdata)<[subst -nocommand -novariable $close$tag$cdata1]]
		    set text [subst -novariable -nocommand $text]
		    set tag {}
		    set param {}
		    unset state(cdata)
		    set state(mode) normal
		} elseif {[regexp (.*)\]\][cl $Wsp]*>(.*) $text discard cdata1 text]} {
		    # end of CDATA (in text)
		    uplevel #0 $options(-characterdatacommand) [list $state(cdata)<[subst -nocommand -novariable $close$tag$param>$cdata1]]
		    set text [subst -novariable -nocommand $text]
		    set tag {}
		    set param {}
		    set close {}
		    unset state(cdata)
		    set state(mode) normal
		} else {
		    # CDATA continues
		    append state(cdata) [subst -nocommand -novariable <$close$tag$param>$text]
		    continue
		}
	    }
	    continue {
		# We're skipping elements looking for the close tag
		switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close {
		    0,* {
			continue
		    }
		    *,0, {
			if {![string compare $tag $state(continue:tag)]} {
			    set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]
			    if {![string length $empty]} {
				incr state(continue:level)
			    }
			}
			continue
		    }
		    *,0,/ {
			if {![string compare $tag $state(continue:tag)]} {
			    incr state(continue:level) -1
			}
			if {!$state(continue:level)} {
			    unset state(continue:tag)
			    unset state(continue:level)
			    set state(mode) {}
			}
		    }
		    default {
			continue
		    }
		}
	    }
	    default {
		# The trailing slash on empty elements can't be automatically separated out
		# in the RE, so we must do it here.
		regexp (.*)(/)[cl $Wsp]*$ $param discard param empty
	    }
	}

	# default: normal mode

	# Bug: if the attribute list has a right angle bracket then the empty
	# element marker will not be seen

	set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]

	switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close,$empty {

	    0,0,, {
		# Ignore empty tag - dealt with non-normal mode above
	    }
	    *,0,, {

		# Start tag for an element.

		# Check if the internal DTD entity is in an attribute value
		regsub -all &xml:intdtd\; $param \[$options(-internaldtd)\] param

		set code [catch {ParseEvent:ElementOpen $tag $param [array get options]} msg]
		set state(haveDocElement) 1
		switch $code {
		    0 {# OK}
		    3 {
			# break
			return {}
		    }
		    4 {
			# continue
			# Remember this tag and look for its close
			set state(continue:tag) $tag
			set state(continue:level) 1
			set state(mode) continue
			continue
		    }
		    default {
			return -code $code -errorinfo $::errorInfo $msg
		    }
		}

	    }

	    *,0,/, {

		# End tag for an element.

		set code [catch {ParseEvent:ElementClose $tag [array get options]} msg]
		switch $code {
		    0 {# OK}
		    3 {
			# break
			return {}
		    }
		    4 {
			# continue
			# skip sibling nodes
			set state(continue:tag) [lindex $state(stack) end]
			set state(continue:level) 1
			set state(mode) continue
			continue
		    }
		    default {
			return -code $code -errorinfo $::errorInfo $msg
		    }
		}

	    }

	    *,0,,/ {

		# Empty element

		# The trailing slash sneaks through into the param variable
		regsub -all /[cl $::sgml::Wsp]*\$ $param {} param

		set code [catch {ParseEvent:ElementOpen $tag $param [array get options] -empty 1} msg]
		set state(haveDocElement) 1
		switch $code {
		    0 {# OK}
		    3 {
			# break
			return {}
		    }
		    4 {
			# continue
			# Pretty useless since it closes straightaway
		    }
		    default {
			return -code $code -errorinfo $::errorInfo $msg
		    }
		}
		set code [catch {ParseEvent:ElementClose $tag [array get options] -empty 1} msg]
		switch $code {
		    0 {# OK}
		    3 {
			# break
			return {}
		    }
		    4 {
			# continue
			# skip sibling nodes
			set state(continue:tag) [lindex $state(stack) end]
			set state(continue:level) 1
			set state(mode) continue
			continue
		    }
		    default {
			return -code $code -errorinfo $::errorInfo $msg
		    }
		}

	    }

	    *,1,* {
		# Processing instructions or XML declaration
		switch -glob -- $tag {

		    {\?xml} {
			# XML Declaration
			if {$state(haveXMLDecl)} {
			    uplevel #0 $options(-errorcommand) [list illegalcharacter "unexpected characters \"<$tag\" around line $state(line)"]
			} elseif {![regexp {\?$} $param]} {
			    uplevel #0 $options(-errorcommand) [list missingcharacters "XML Declaration missing characters \"?>\" around line $state(line)"]
			} else {

			    # We can do the parsing in one step with Tcl 8.1 RE's
			    # This has the benefit of performing better WF checking

			    set adv_re [format {^[%s]*version[%s]*=[%s]*("|')(-+|[a-zA-Z0-9_.:]+)\1([%s]+encoding[%s]*=[%s]*("|')([A-Za-z][-A-Za-z0-9._]*)\4)?([%s]*standalone[%s]*=[%s]*("|')(yes|no)\7)?[%s]*\?$} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp]

			    if {[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) {XXX {syntax error: SYSTEM identifier not followed by literal}}
				    }
				}
				PUBLIC {
				    if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x pubidlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x pubidlit param]} {
					if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
					    set externalID [list PUBLIC $pubidlit $systemlit]
					} else {
					    uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: PUBLIC identifier not followed by system literal around line $state(line)"]
					}
				    } else {
					uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: PUBLIC identifier not followed by literal around line $state(line)"]
				    }
				}
			    }
			    if {[regexp -nocase ^[cl $Wsp]+NDATA[cl $Wsp]+($Name)(.*) $param x notation param]} {
				lappend externalID $notation
			    }
			}

			set state(inDTD) 1

			ParseEvent:DocTypeDecl [array get options] $state(doc_name) $pubidlit $systemlit $options(-internaldtd)

			set state(inDTD) 0

		    }

		    !--* {

			# Start of a comment
			# See if it ends in the same tag, otherwise change the
			# parsing mode

			regexp {!--(.*)} $tag discard comm1
			if {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $comm1 discard comm1_1]} {
			    # processed comment (end in tag)
			    uplevel #0 $options(-commentcommand) [list $comm1_1]
			} elseif {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $param discard comm2]} {
			    # processed comment (end in attributes)
			    uplevel #0 $options(-commentcommand) [list $comm1$comm2]
			} elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm2 text]} {
			    # processed comment (end in text)
			    uplevel #0 $options(-commentcommand) [list $comm1$param$empty>$comm2]
			} else {
			    # start of comment
			    set state(mode) comment
			    set state(commentdata) "$comm1$param$empty>$text"
			    continue
			}
		    }

		    {!\[CDATA\[*} {

			regexp {!\[CDATA\[(.*)} $tag discard cdata1
			if {[regexp {(.*)]]$} $cdata1 discard cdata2]} {
			    # processed CDATA (end in tag)
			    uplevel #0 $options(-characterdatacommand) [list [subst -novariable -nocommand $cdata2]]
			    set text [subst -novariable -nocommand $text]
			} elseif {[regexp {(.*)]]$} $param discard cdata2]} {
			    # processed CDATA (end in attribute)
			    # Backslashes in param are quoted at this stage
			    uplevel #0 $options(-characterdatacommand) [list $cdata1[subst -novariable -nocommand $cdata2]]
			    set text [subst -novariable -nocommand $text]
			} elseif {[regexp {(.*)]]>(.*)} $text discard cdata2 text]} {
			    # processed CDATA (end in text)
			    # Backslashes in param and text are quoted at this stage
			    uplevel #0 $options(-characterdatacommand) [list $cdata1[subst -novariable -nocommand $param]$empty>[subst -novariable -nocommand $cdata2]]
			    set text [subst -novariable -nocommand $text]
			} else {
			    # start CDATA
			    set state(cdata) "$cdata1$param>$text"
			    set state(mode) cdata
			    continue
			}

		    }

		    !ELEMENT -
		    !ATTLIST -
		    !ENTITY -
		    !NOTATION {
			uplevel #0 $options(-errorcommand) [list illegaldeclaration "[string range $tag 1 end] declaration not expected in document instance around line $state(line)"]
		    }

		    default {
			uplevel #0 $options(-errorcommand) [list unknowninstruction "unknown processing instruction \"<$tag>\" around line $state(line)"]
		    }
		}
	    }
	    *,1,* -
	    *,0,/,/ {
		# Syntax error
	    	uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: closed/empty tag: tag $tag param $param empty $empty close $close around line $state(line)"]
	    }
	}
	
	# 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) $options(-characterdatacommand) $options(entities)]] [namespace code [list DeProtect $options(-characterdatacommand)]] \{\{] text
		set text "uplevel #0 [namespace code [list DeProtect1 $options(-characterdatacommand)]] {{$text}}"
		eval $text
	    } else {
		# Restore protected special characters
		regsub -all {\\([][{}\\])} $text {\1} text
		uplevel #0 $options(-characterdatacommand) [list $text]
	    }
	} elseif {[string length [string trim $text]]} {
	    uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\" in document prolog around line $state(line)"]
	}

    }

    # If this is the end of the document, close all open containers
    if {$options(-final) && [llength $state(stack)]} {
	eval $options(-errorcommand) [list unclosedelement "element [lindex $state(stack) end] remains unclosed around line $state(line)"]
    }

    return {}
}

# sgml::DeProtect --
#
#	Invoke given command after removing protecting backslashes
#	from given text.
#
# Arguments:
#	cmd	Command to invoke
#	text	Text to deprotect
#
# Results:
#	Depends on command

proc sgml::DeProtect1 {cmd text} {
    if {[string compare {} $text]} {
	regsub -all {\\([][{}\\])} $text {\1} text
	uplevel #0 $cmd [list $text]
    }
}
proc sgml::DeProtect {cmd text} {
    set text [lindex $text 0]
    if {[string compare {} $text]} {
	regsub -all {\\([][{}\\])} $text {\1} text
	uplevel #0 $cmd [list $text]
    }
}

# sgml::ParserDelete --
#
#	Free all memory associated with parser
#
# Arguments:
#	var	global state array
#
# Results:
#	Variables unset

proc sgml::ParserDelete var {
    upvar #0 $var state

    if {![info exists state]} {
	return -code error "unknown parser"
    }

    catch {unset $state(entities)}
    catch {unset $state(parameterentities)}
    catch {unset $state(elementdecls)}
    catch {unset $state(attlistdecls)}
    catch {unset $state(notationdecls)}
    catch {unset $state(namespaces)}

    unset state

    return {}
}

# sgml::ParseEvent:ElementOpen --
#
#	Start of an element.
#
# Arguments:
#	tag	Element name
#	attr	Attribute list
#	opts	Options
#	args	further configuration options
#
# Options:
#	-empty boolean
#		indicates whether the element was an empty element
#
# Results:
#	Modify state and invoke callback

proc sgml::ParseEvent:ElementOpen {tag attr opts args} {
    variable Name
    variable Wsp

    array set options $opts
    upvar #0 $options(-statevariable) state
    array set cfg {-empty 0}
    array set cfg $args

    if {$options(-normalize)} {
	set tag [string toupper $tag]
    }

    # Update state
    lappend state(stack) $tag

    # Parse attribute list into a key-value representation
    if {[string compare $options(-parseattributelistcommand) {}]} {
	if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $attr]} attr]} {
	    if {[string compare [lindex $attr 0] "unterminated attribute value"]} {
		uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
		set attr {}
	    } else {

		# It is most likely that a ">" character was in an attribute value.
		# This manifests itself by ">" appearing in the element's text.
		# In this case the callback should return a three element list;
		# the message "unterminated attribute value", the attribute list it
		# did manage to parse and the remainder of the attribute list.

		foreach {msg attlist brokenattr} $attr break

		upvar text elemText
		if {[string first > $elemText] >= 0} {

		    # Now piece the attribute list back together
		    regexp ($Name)[cl $Wsp]*=[cl $Wsp]*("|')(.*) $brokenattr discard attname delimiter attvalue
		    regexp (.*)>([cl ^>]*)\$ $elemText discard remattlist elemText
		    regexp ([cl ^$delimiter]*)${delimiter}(.*) $remattlist discard remattvalue remattlist

		    append attvalue >$remattvalue
		    lappend attlist $attname $attvalue

		    # Complete parsing the attribute list
		    if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $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]
    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::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(-name) $options(-baseurl) $sysId $pubId]
    }

    return {}
}

# sgml::ParseDTD:Internal --
#
#	Parse the internal DTD subset.
#
#	Parameter entities are only allowed between markup declarations.
#
# Arguments:
#	opts	configuration options
#	dtd	DTD data
#
# Results:
#	Markup declarations parsed may cause callback invocation

proc sgml::ParseDTD:Internal {opts dtd} {
    variable MarkupDeclExpr
    variable MarkupDeclSub

    array set options {}
    array set options $opts

    upvar #0 $options(-statevariable) state
    upvar #0 $options(parameterentities) PEnts
    upvar #0 $options(externalparameterentities) ExtPEnts

    # Tokenize the DTD

    # Protect Tcl special characters
    regsub -all {([{}\\])} $dtd {\\\1} dtd

    regsub -all $MarkupDeclExpr $dtd $MarkupDeclSub dtd

    # Entities may have angle brackets in their replacement
    # text, which breaks the RE processing.  So, we must
    # use a similar technique to processing doc instances
    # to rebuild the declarations from the pieces

    set mode {} ;# normal
    set delimiter {}
    set name {}
    set param {}

    set state(inInternalDTD) 1

    # Process the tokens
    foreach {decl value text} [lrange "{} {} \{$dtd\}" 3 end] {

	# Keep track of line numbers
	incr state(line) [regsub -all \n $text {} discard]

	ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param

	ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode replText text param

	# There may be parameter entity references between markup decls

	if {[regexp {%.*;} $text]} {

	    # Protect Tcl special characters
	    regsub -all {([{}\\])} $text {\\\1} text

	    regsub -all %($::sgml::Name)\; $text "\} {\\1} \{" text

	    set PElist "\{$text\}"
	    set PElist [lreplace $PElist end end]
	    foreach {text entref} $PElist {
		if {[string length [string trim $text]]} {
		    uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text in internal DTD subset around line $state(line)"]
		}

		# Expand parameter entity and recursively parse
		# BUG: no checks yet for recursive entity references

		if {[info exists PEnts($entref)]} {
		    set externalParser [$options(-name) entityparser]
		    $externalParser parse $PEnts($entref) -dtdsubset internal
		} elseif {[info exists ExtPEnts($entref)]} {
		    set externalParser [$options(-name) entityparser]
		    $externalParser parse $ExtPEnts($entref) -dtdsubset external
		    #$externalParser free
		} else {
		    uplevel #0 $options(-errorcommand) [list illegalreference "reference to undeclared parameter entity \"$entref\""]
		}
	    }

	}

    }

    return {}
}

# sgml::ParseDTD:EntityMode --
#
#	Perform special processing for various parser modes
#
# Arguments:
#	opts	configuration options
#	modeVar	pass-by-reference mode variable
#	replTextVar	pass-by-ref
#	declVar	pass-by-ref
#	valueVar	pass-by-ref
#	textVar	pass-by-ref
#	delimiter	delimiter currently in force
#	name
#	param
#
# Results:
#	Depends on current mode

proc sgml::ParseDTD:EntityMode {opts modeVar replTextVar declVar valueVar textVar delimiter name param} {
    upvar 1 $modeVar mode
    upvar 1 $replTextVar replText
    upvar 1 $declVar decl
    upvar 1 $valueVar value
    upvar 1 $textVar text
    array set options $opts

    switch $mode {
	{} {
	    # Pass through to normal processing section
	}
	entity {
	    # Look for closing delimiter
	    if {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $decl discard val1 remainder]} {
		append replText <$val1
		DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
		set decl /
		set text $remainder\ $value>$text
		set value {}
		set mode {}
	    } elseif {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $value discard val2 remainder]} {
		append replText <$decl\ $val2
		DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
		set decl /
		set text $remainder>$text
		set value {}
		set mode {}
	    } elseif {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $text discard val3 remainder]} {
		append replText <$decl\ $value>$val3
		DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
		set decl /
		set text $remainder
		set value {}
		set mode {}
	    } else {

		# Remain in entity mode
		append replText <$decl\ $value>$text
		return -code continue

	    }
	}

	ignore {
	    upvar #0 $options(-statevariable) state

	    if {[regexp {]](.*)$} $decl discard remainder]} {
		set state(condSections) [lreplace $state(condSections) end end]
		set decl $remainder
		set mode {}
	    } elseif {[regexp {]](.*)$} $value discard remainder]} {
		set state(condSections) [lreplace $state(condSections) end end]
		regexp <[cl $::sgml::Wsp]*($::sgml::Name)(.*) $remainder discard decl value
		set mode {}
	    } elseif {[regexp {]]>(.*)$} $text discard remainder]} {
		set state(condSections) [lreplace $state(condSections) end end]
		set decl /
		set value {}
		set text $remainder
		#regexp <[cl $::sgml::Wsp]*($::sgml::Name)([cl ^>]*)>(.*) $remainder discard decl value text
		set mode {}
	    } else {
		set decl /
	    }

	}

	comment {
	    # Look for closing comment delimiter

	    upvar #0 $options(-statevariable) state

	    if {[regexp (.*?)--(.*)\$ $decl discard data1 remainder]} {
	    } elseif {[regexp (.*?)--(.*)\$ $value discard data1 remainder]} {
	    } elseif {[regexp (.*?)--(.*)\$ $text discard data1 remainder]} {
	    } else {
		# comment continues
		append state(commentdata) <$decl\ $value>$text
		set decl /
		set value {}
		set text {}
	    }
	}

    }

    return {}
}

# sgml::ParseDTD:ProcessMarkupDecl --
#
#	Process a single markup declaration
#
# Arguments:
#	opts	configuration options
#	declVar	pass-by-ref
#	valueVar	pass-by-ref
#	delimiterVar	pass-by-ref for current delimiter in force
#	nameVar	pass-by-ref
#	modeVar	pass-by-ref for current parser mode
#	replTextVar	pass-by-ref
#	textVar	pass-by-ref
#	paramVar	pass-by-ref
#
# Results:
#	Depends on markup declaration.  May change parser mode

proc sgml::ParseDTD:ProcessMarkupDecl {opts declVar valueVar delimiterVar nameVar modeVar replTextVar textVar paramVar} {
    upvar 1 $modeVar mode
    upvar 1 $replTextVar replText
    upvar 1 $textVar text
    upvar 1 $declVar decl
    upvar 1 $valueVar value
    upvar 1 $nameVar name
    upvar 1 $delimiterVar delimiter
    upvar 1 $paramVar param

    variable declExpr
    variable ExternalEntityExpr

    array set options $opts
    upvar #0 $options(-statevariable) state

    switch -glob -- $decl {

	/ {
	    # continuation from entity processing
	}

	!ELEMENT {
	    # Element declaration
	    if {[regexp $declExpr $value discard tag cmodel]} {
		DTD:ELEMENT [array get options] $tag $cmodel
	    } else {
		uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed element declaration around line $state(line)"]
	    }
	}

	!ATTLIST {
	    # Attribute list declaration
	    variable declExpr
	    if {[regexp $declExpr $value discard tag attdefns]} {
		if {[catch {DTD:ATTLIST [array get options] $tag $attdefns} err]} {
		    #puts stderr "Stack trace: $::errorInfo\n***\n"
		    # Atttribute parsing has bugs at the moment
		    #return -code error "$err around line $state(line)"
		    return {}
		}
	    } else {
		uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed attribute list declaration around line $state(line)"]
	    }
	}

	!ENTITY {
	    # Entity declaration
	    variable EntityExpr

	    if {[regexp $EntityExpr $value discard param name value]} {

		# Entity replacement text may have a '>' character.
		# In this case, the real delimiter will be in the following
		# text.  This is complicated by the possibility of there
		# being several '<','>' pairs in the replacement text.
		# At this point, we are searching for the matching quote delimiter.

		if {[regexp $ExternalEntityExpr $value]} {
		    DTD:ENTITY [array get options] $name [string trim $param] $value
		} elseif {[regexp ("|')(.*?)\\1(.*) $value discard delimiter replText value]} {

		    if {[string length [string trim $value]]} {
			uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"]
		    } else {
			DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
		    }
		} elseif {[regexp ("|')(.*) $value discard delimiter replText]} {
		    append replText >$text
		    set text {}
		    set mode entity
		} else {
		    uplevel #0 $options(-errorcommand) [list illegaldeclaration "no delimiter for entity declaration around line $state(line)"]
		}

	    } else {
		uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"]
	    }
	}

	!NOTATION {
	    # Notation declaration
	    if {[regexp $declExpr param discard tag notation]} {
		DTD:ENTITY [array get options] $tag $notation
	    } else {
		uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"]
	    }
	}

	!--* {
	    # Start of a comment

	    if {[regexp !--(.*?)--\$ $decl discard data]} {
		if {[string length [string trim $value]]} {
		    uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$value\""]
		}
		uplevel #0 $options(-commentcommand) [list $data]
		set decl /
		set value {}
	    } elseif {[regexp -- ^(.*?)--\$ $value discard data2]} {
		regexp !--(.*)\$ $decl discard data1
		uplevel #0 $options(-commentcommand) [list $data1\ $data2]
		set decl /
		set value {}
	    } elseif {[regexp (.*?)-->(.*)\$ $text discard data3 remainder]} {
		regexp !--(.*)\$ $decl discard data1
		uplevel #0 $options(-commentcommand) [list $data1\ $value>$data3]
		set decl /
		set value {}
		set text $remainder
	    } else {
		regexp !--(.*)\$ $decl discard data1
		set state(commentdata) $data1\ $value>$text
		set decl /
		set value {}
		set text {}
		set mode comment
	    }
	}

	!*INCLUDE* -
	!*IGNORE* {
	    if {$state(inInternalDTD)} {
		uplevel #0 $options(-errorcommand) [list illegalsection "conditional section not permitted in internal DTD subset around line $state(line)"]
	    }

	    if {[regexp {^!\[INCLUDE\[(.*)} $decl discard remainder]} {
		# Push conditional section stack, popped by ]]> sequence

		if {[regexp {(.*?)]]$} $remainder discard r2]} {
		    # section closed immediately
		    if {[string length [string trim $r2]]} {
			uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
		    }
		} elseif {[regexp {(.*?)]](.*)} $value discard r2 r3]} {
		    # section closed immediately
		    if {[string length [string trim $r2]]} {
			uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
		    }
		    if {[string length [string trim $r3]]} {
			uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r3\" in conditional section"]
		    }
		} else {

		    lappend state(condSections) INCLUDE

		    set parser [$options(-name) entityparser]
		    $parser parse $remainder\ $value> -dtdsubset external
		    #$parser free

		    if {[regexp {(.*?)]]>(.*)} $text discard t1 t2]} {
			if {[string length [string trim $t1]]} {
			    uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""]
			}
			if {![llength $state(condSections)]} {
			    uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
			}
			set state(condSections) [lreplace $state(condSections) end end]
			set text $t2
		    }

		}
	    } elseif {[regexp {^!\[IGNORE\[(.*)} $decl discard remainder]} {
		# Set ignore mode.  Still need a stack
		set mode ignore

		if {[regexp {(.*?)]]$} $remainder discard r2]} {
		    # section closed immediately
		    if {[string length [string trim $r2]]} {
			uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
		    }
		} elseif {[regexp {(.*?)]](.*)} $value discard r2 r3]} {
		    # section closed immediately
		    if {[string length [string trim $r2]]} {
			uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
		    }
		    if {[string length [string trim $r3]]} {
			uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r3\" in conditional section"]
		    }
		} else {
		    
		    lappend state(condSections) IGNORE

		    if {[regexp {(.*?)]]>(.*)} $text discard t1 t2]} {
			if {[string length [string trim $t1]]} {
			    uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""]
			}
			if {![llength $state(condSections)]} {
			    uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
			}
			set state(condSections) [lreplace $state(condSections) end end]
			set text $t2
		    }

		}
	    } else {
		uplevel #0 $options(-errorcommand) [list illegaldeclaration "illegal markup declaration \"$decl\" around line $state(line)"]
	    }

	}

	default {
	    if {[regexp {^\?(.*)} $decl discard target]} {
		# Processing instruction
	    } else {
		uplevel #0 $options(-errorcommand) [list illegaldeclaration "illegal markup declaration \"$decl\""]
	    }
	}
    }

    return {}
}

# sgml::ParseDTD:External --
#
#	Parse the external DTD subset.
#
#	Parameter entities are allowed anywhere.
#
# Arguments:
#	opts	configuration options
#	dtd	DTD data
#
# Results:
#	Markup declarations parsed may cause callback invocation

proc sgml::ParseDTD:External {opts dtd} {
    variable MarkupDeclExpr
    variable MarkupDeclSub
    variable declExpr

    array set options $opts
    upvar #0 $options(parameterentities) PEnts
    upvar #0 $options(externalparameterentities) ExtPEnts
    upvar #0 $options(-statevariable) state

    # As with the internal DTD subset, watch out for
    # entities with angle brackets
    set mode {} ;# normal
    set delimiter {}
    set name {}
    set param {}

    set oldState 0
    catch {set oldState $state(inInternalDTD)}
    set state(inInternalDTD) 0

    # Initialise conditional section stack
    if {![info exists state(condSections)]} {
	set state(condSections) {}
    }
    set startCondSectionDepth [llength $state(condSections)]

    while {[string length $dtd]} {
	set progress 0
	set PEref {}
	if {![string compare $mode "ignore"]} {
	    set progress 1
	    if {[regexp {]]>(.*)} $dtd discard dtd]} {
		set remainder {}
		set mode {} ;# normal
		set state(condSections) [lreplace $state(condSections) end end]
		continue
	    } else {
		uplevel #0 $options(-errorcommand) [list missingdelimiter "IGNORE conditional section closing delimiter not found"]
	    }
	} elseif {[regexp ^(.*?)%($::sgml::Name)\;(.*)\$ $dtd discard data PEref remainder]} {
	    set progress 1
	} else {
	    set data $dtd
	    set dtd {}
	    set remainder {}
	}

	# Tokenize the DTD (so far)

	# Protect Tcl special characters
	regsub -all {([{}\\])} $data {\\\1} dataP

	set n [regsub -all $MarkupDeclExpr $dataP $MarkupDeclSub dataP]

	if {$n} {
	    set progress 1
	    # All but the last markup declaration should have no text
	    set dataP [lrange "{} {} \{$dataP\}" 3 end]
	    if {[llength $dataP] > 3} {
		foreach {decl value text} [lrange $dataP 0 [expr [llength $dataP] - 4]] {
		    ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param
		    ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode repltextVar text param

		    if {[string length [string trim $text]]} {
			# check for conditional section close
			if {[regexp {]]>(.*)$} $text discard text]} {
			    if {[string length [string trim $text]]} {
				uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\""]
			    }
			    if {![llength $state(condSections)]} {
				uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
			    }
			    set state(condSections) [lreplace $state(condSections) end end]
			    if {![string compare $mode "ignore"]} {
				set mode {} ;# normal
			    }
			} else {
			    uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\""]
			}
		    }
		}
	    }
	    # Do the last declaration
	    foreach {decl value text} [lrange $dataP [expr [llength $dataP] - 3] end] {
		ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param
		ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode repltextVar text param
	    }
	}

	# Now expand the PE reference, if any
	switch -glob $mode,[string length $PEref],$n {
	    ignore,0,* {
		set dtd $text
	    }
	    ignore,*,* {
		set dtd $text$remainder
	    }
	    *,0,0 {
		set dtd $data
	    }
	    *,0,* {
		set dtd $text
	    }
	    *,*,0 {
		if {[catch {append data $PEnts($PEref)}]} {
		    if {[info exists ExtPEnts($PEref)]} {
			set externalParser [$options(-name) entityparser]
			$externalParser parse $ExtPEnts($PEref) -dtdsubset external
			#$externalParser free
		    } else {
			uplevel #0 $options(-errorcommand) [list entityundeclared "parameter entity \"$PEref\" not declared"]
		    }
		}
		set dtd $data$remainder
	    }
	    default {
		if {[catch {append text $PEnts($PEref)}]} {
		    if {[info exists ExtPEnts($PEref)]} {
			set externalParser [$options(-name) entityparser]
			$externalParser parse $ExtPEnts($PEref) -dtdsubset external
			#$externalParser free
		    } else {
			uplevel #0 $options(-errorcommand) [list entityundeclared "parameter entity \"$PEref\" not declared"]
		    }
		}
		set dtd $text$remainder
	    }
	}

	# Check whether a conditional section has been terminated
	if {[regexp {^(.*?)]]>(.*)$} $dtd discard t1 t2]} {
	    if {![regexp <.*> $t1]} {
		if {[string length [string trim $t1]]} {
		    uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""]
		}
		if {![llength $state(condSections)]} {
		    uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
		}
		set state(condSections) [lreplace $state(condSections) end end]
		if {![string compare $mode "ignore"]} {
		    set mode {} ;# normal
		}
		set dtd $t2
		set progress 1
	    }
	}

	if {!$progress} {
	    # No parameter entity references were found and 
	    # the text does not contain a well-formed markup declaration
	    # Avoid going into an infinite loop
	    upvar #0 $options(-errorcommand) [list syntaxerror "external entity does not contain well-formed markup declaration"]
	    break
	}
    }

    set state(inInternalDTD) $oldState

    # Check that conditional sections have been closed properly
    if {[llength $state(condSections)] > $startCondSectionDepth} {
	uplevel #0 $options(-errorcommand) [list syntaxerror "[lindex $state(condSections) end] conditional section not closed"]
    }
    if {[llength $state(condSections)] < $startCondSectionDepth} {
	uplevel #0 $options(-errorcommand) [list syntaxerror "too many conditional section closures"]
    }

    return {}
}

# Procedures for handling the various declarative elements in a DTD.
# New elements may be added by creating a procedure of the form
# parse:DTD:_element_

# For each of these procedures, the various regular expressions they use
# are created outside of the proc to avoid overhead at runtime

# sgml::DTD:ELEMENT --
#
#	<!ELEMENT ...> defines an element.
#
#	The content model for the element is stored in the contentmodel array,
#	indexed by the element name.  The content model is parsed into the
#	following list form:
#
#		{}	Content model is EMPTY.
#			Indicated by an empty list.
#		*	Content model is ANY.
#			Indicated by an asterix.
#		{ELEMENT ...}
#			Content model is element-only.
#		{MIXED {element1 element2 ...}}
#			Content model is mixed (PCDATA and elements).
#			The second element of the list contains the 
#			elements that may occur.  #PCDATA is assumed 
#			(ie. the list is normalised).
#
# Arguments:
#	opts	configuration options
#	name	element GI
#	modspec	unparsed content model specification

proc sgml::DTD:ELEMENT {opts name modspec} {
    variable Wsp
    array set options $opts

    upvar #0 $options(elementdecls) elements

    if {$options(-validate) && [info exists elements($name)]} {
	eval $options(-errorcommand) elementdeclared [list "element \"$name\" already declared"]
    } else {
	switch -- $modspec {
	    EMPTY {
	    	set elements($name) {}
		uplevel #0 $options(-elementdeclcommand) $name {{}}
	    }
	    ANY {
	    	set elements($name) *
		uplevel #0 $options(-elementdeclcommand) $name *
	    }
	    default {
		# Don't parse the content model for now,
		# just pass the model to the application
		if {0 && [regexp [format {^\([%s]*#PCDATA[%s]*(\|([^)]+))?[%s]*\)*[%s]*$} $Wsp $Wsp $Wsp $Wsp] discard discard mtoks]} {
		    set cm($name) [list MIXED [split $mtoks |]]
		} elseif {0} {
		    if {[catch {CModelParse $state(state) $value} result]} {
			eval $options(-errorcommand) element [list $result]
		    } else {
			set cm($id) [list ELEMENT $result]
		    }
		} else {
		    set elements($name) $modspec
		    uplevel #0 $options(-elementdeclcommand) $name [list $modspec]
		}
	    }
	}
    }
}

# sgml::CModelParse --
#
#	Parse an element content model (non-mixed).
#	A syntax tree is constructed.
#	A transition table is built next.
#
#	This is going to need alot of work!
#
# Arguments:
#	state	state array variable
#	value	the content model data
#
# Results:
#	A Tcl list representing the content model.

proc sgml::CModelParse {state value} {
    upvar #0 $state var

    # First build syntax tree
    set syntaxTree [CModelMakeSyntaxTree $state $value]

    # Build transition table
    set transitionTable [CModelMakeTransitionTable $state $syntaxTree]

    return [list $syntaxTree $transitionTable]
}

# sgml::CModelMakeSyntaxTree --
#
#	Construct a syntax tree for the regular expression.
#
#	Syntax tree is represented as a Tcl list:
#	rep {:choice|:seq {{rep list1} {rep list2} ...}}
#	where:	rep is repetition character, *, + or ?. {} for no repetition
#		listN is nested expression or Name
#
# Arguments:
#	spec	Element specification
#
# Results:
#	Syntax tree for element spec as nested Tcl list.
#
#	Examples:
#	(memo)
#		{} {:seq {{} memo}}
#	(front, body, back?)
#		{} {:seq {{} front} {{} body} {? back}}
#	(head, (p | list | note)*, div2*)
#		{} {:seq {{} head} {* {:choice {{} p} {{} list} {{} note}}} {* div2}}
#	(p | a | ul)+
#		+ {:choice {{} p} {{} a} {{} ul}}

proc sgml::CModelMakeSyntaxTree {state spec} {
    upvar #0 $state var
    variable Wsp
    variable name

    # Translate the spec into a Tcl list.

    # None of the Tcl special characters are allowed in a content model spec.
    if {[regexp {\$|\[|\]|\{|\}} $spec]} {
	return -code error "illegal characters in specification"
    }

    regsub -all [format {(%s)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $name $Wsp $Wsp] $spec [format {%sCModelSTname %s {\1} {\2} {\3}} \n $state] spec
    regsub -all {\(} $spec "\nCModelSTopenParen $state " spec
    regsub -all [format {\)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $Wsp $Wsp] $spec [format {%sCModelSTcloseParen %s {\1} {\2}} \n $state] spec

    array set var {stack {} state start}
    eval $spec

    # Peel off the outer seq, its redundant
    return [lindex [lindex $var(stack) 1] 0]
}

# sgml::CModelSTname --
#
#	Processes a name in a content model spec.
#
# Arguments:
#	state	state array variable
#	name	name specified
#	rep	repetition operator
#	cs	choice or sequence delimiter
#
# Results:
#	See CModelSTcp.

proc sgml::CModelSTname {state name rep cs args} {
    if {[llength $args]} {
	return -code error "syntax error in specification: \"$args\""
    }

    CModelSTcp $state $name $rep $cs
}

# sgml::CModelSTcp --
#
#	Process a content particle.
#
# Arguments:
#	state	state array variable
#	name	name specified
#	rep	repetition operator
#	cs	choice or sequence delimiter
#
# Results:
#	The content particle is added to the current group.

proc sgml::CModelSTcp {state cp rep cs} {
    upvar #0 $state var

    switch -glob -- [lindex $var(state) end]=$cs {
	start= {
	    set var(state) [lreplace $var(state) end end end]
	    # Add (dummy) grouping, either choice or sequence will do
	    CModelSTcsSet $state ,
	    CModelSTcpAdd $state $cp $rep
	}
	:choice= -
	:seq= {
	    set var(state) [lreplace $var(state) end end end]
	    CModelSTcpAdd $state $cp $rep
	}
	start=| -
	start=, {
	    set var(state) [lreplace $var(state) end end [expr {$cs == "," ? ":seq" : ":choice"}]]
	    CModelSTcsSet $state $cs
	    CModelSTcpAdd $state $cp $rep
	}
	:choice=| -
	:seq=, {
	    CModelSTcpAdd $state $cp $rep
	}
	:choice=, -
	:seq=| {
	    return -code error "syntax error in specification: incorrect delimiter after \"$cp\", should be \"[expr {$cs == "," ? "|" : ","}]\""
	}
	end=* {
	    return -code error "syntax error in specification: no delimiter before \"$cp\""
	}
	default {
	    return -code error "syntax error"
	}
    }
    
}

# sgml::CModelSTcsSet --
#
#	Start a choice or sequence on the stack.
#
# Arguments:
#	state	state array
#	cs	choice oir sequence
#
# Results:
#	state is modified: end element of state is appended.

proc sgml::CModelSTcsSet {state cs} {
    upvar #0 $state var

    set cs [expr {$cs == "," ? ":seq" : ":choice"}]

    if {[llength $var(stack)]} {
	set var(stack) [lreplace $var(stack) end end $cs]
    } else {
	set var(stack) [list $cs {}]
    }
}

# sgml::CModelSTcpAdd --
#
#	Append a content particle to the top of the stack.
#
# Arguments:
#	state	state array
#	cp	content particle
#	rep	repetition
#
# Results:
#	state is modified: end element of state is appended.

proc sgml::CModelSTcpAdd {state cp rep} {
    upvar #0 $state var

    if {[llength $var(stack)]} {
	set top [lindex $var(stack) end]
    	lappend top [list $rep $cp]
	set var(stack) [lreplace $var(stack) end end $top]
    } else {
	set var(stack) [list $rep $cp]
    }
}

# sgml::CModelSTopenParen --
#
#	Processes a '(' in a content model spec.
#
# Arguments:
#	state	state array
#
# Results:
#	Pushes stack in state array.

proc sgml::CModelSTopenParen {state args} {
    upvar #0 $state var

    if {[llength $args]} {
	return -code error "syntax error in specification: \"$args\""
    }

    lappend var(state) start
    lappend var(stack) [list {} {}]
}

# sgml::CModelSTcloseParen --
#
#	Processes a ')' in a content model spec.
#
# Arguments:
#	state	state array
#	rep	repetition
#	cs	choice or sequence delimiter
#
# Results:
#	Stack is popped, and former top of stack is appended to previous element.

proc sgml::CModelSTcloseParen {state rep cs args} {
    upvar #0 $state var

    if {[llength $args]} {
	return -code error "syntax error in specification: \"$args\""
    }

    set cp [lindex $var(stack) end]
    set var(stack) [lreplace $var(stack) end end]
    set var(state) [lreplace $var(state) end end]
    CModelSTcp $state $cp $rep $cs
}

# sgml::CModelMakeTransitionTable --
#
#	Given a content model's syntax tree, constructs
#	the transition table for the regular expression.
#
#	See "Compilers, Principles, Techniques, and Tools",
#	Aho, Sethi and Ullman.  Section 3.9, algorithm 3.5.
#
# Arguments:
#	state	state array variable
#	st	syntax tree
#
# Results:
#	The transition table is returned, as a key/value Tcl list.

proc sgml::CModelMakeTransitionTable {state st} {
    upvar #0 $state var

    # Construct nullable, firstpos and lastpos functions
    array set var {number 0}
    foreach {nullable firstpos lastpos} [	\
	TraverseDepth1st $state $st {
	    # Evaluated for leaf nodes
	    # Compute nullable(n)
	    # Compute firstpos(n)
	    # Compute lastpos(n)
	    set nullable [nullable leaf $rep $name]
	    set firstpos [list {} $var(number)]
	    set lastpos [list {} $var(number)]
	    set var(pos:$var(number)) $name
	} {
	    # Evaluated for nonterminal nodes
	    # Compute nullable, firstpos, lastpos
	    set firstpos [firstpos $cs $firstpos $nullable]
	    set lastpos  [lastpos  $cs $lastpos  $nullable]
	    set nullable [nullable nonterm $rep $cs $nullable]
	}	\
    ] break

    set accepting [incr var(number)]
    set var(pos:$accepting) #

    # var(pos:N) maps from position to symbol.
    # Construct reverse map for convenience.
    # NB. A symbol may appear in more than one position.
    # var is about to be reset, so use different arrays.

    foreach {pos symbol} [array get var pos:*] {
	set pos [lindex [split $pos :] 1]
	set pos2symbol($pos) $symbol
	lappend sym2pos($symbol) $pos
    }

    # Construct the followpos functions
    catch {unset var}
    followpos $state $st $firstpos $lastpos

    # Construct transition table
    # Dstates is [union $marked $unmarked]
    set unmarked [list [lindex $firstpos 1]]
    while {[llength $unmarked]} {
	set T [lindex $unmarked 0]
	lappend marked $T
	set unmarked [lrange $unmarked 1 end]

	# Find which input symbols occur in T
	set symbols {}
	foreach pos $T {
	    if {$pos != $accepting && [lsearch $symbols $pos2symbol($pos)] < 0} {
		lappend symbols $pos2symbol($pos)
	    }
	}
	foreach a $symbols {
	    set U {}
	    foreach pos $sym2pos($a) {
		if {[lsearch $T $pos] >= 0} {
		    # add followpos($pos)
	    	    if {$var($pos) == {}} {
	    	    	lappend U $accepting
	    	    } else {
	    	    	eval lappend U $var($pos)
	    	    }
		}
	    }
	    set U [makeSet $U]
	    if {[llength $U] && [lsearch $marked $U] < 0 && [lsearch $unmarked $U] < 0} {
		lappend unmarked $U
	    }
	    set Dtran($T,$a) $U
	}
	
    }

    return [list [array get Dtran] [array get sym2pos] $accepting]
}

# sgml::followpos --
#
#	Compute the followpos function, using the already computed
#	firstpos and lastpos.
#
# Arguments:
#	state		array variable to store followpos functions
#	st		syntax tree
#	firstpos	firstpos functions for the syntax tree
#	lastpos		lastpos functions
#
# Results:
#	followpos functions for each leaf node, in name/value format

proc sgml::followpos {state st firstpos lastpos} {
    upvar #0 $state var

    switch -- [lindex [lindex $st 1] 0] {
	:seq {
	    for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
	    	followpos $state [lindex [lindex $st 1] $i]			\
			[lindex [lindex $firstpos 0] [expr $i - 1]]	\
			[lindex [lindex $lastpos 0] [expr $i - 1]]
	    	foreach pos [lindex [lindex [lindex $lastpos 0] [expr $i - 1]] 1] {
		    eval lappend var($pos) [lindex [lindex [lindex $firstpos 0] $i] 1]
		    set var($pos) [makeSet $var($pos)]
	    	}
	    }
	}
	:choice {
	    for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
		followpos $state [lindex [lindex $st 1] $i]			\
			[lindex [lindex $firstpos 0] [expr $i - 1]]	\
			[lindex [lindex $lastpos 0] [expr $i - 1]]
	    }
	}
	default {
	    # No action at leaf nodes
	}
    }

    switch -- [lindex $st 0] {
	? {
	    # We having nothing to do here ! Doing the same as
	    # for * effectively converts this qualifier into the other.
	}
	* {
	    foreach pos [lindex $lastpos 1] {
		eval lappend var($pos) [lindex $firstpos 1]
		set var($pos) [makeSet $var($pos)]
	    }
	}
    }

}

# sgml::TraverseDepth1st --
#
#	Perform depth-first traversal of a tree.
#	A new tree is constructed, with each node computed by f.
#
# Arguments:
#	state	state array variable
#	t	The tree to traverse, a Tcl list
#	leaf	Evaluated at a leaf node
#	nonTerm	Evaluated at a nonterminal node
#
# Results:
#	A new tree is returned.

proc sgml::TraverseDepth1st {state t leaf nonTerm} {
    upvar #0 $state var

    set nullable {}
    set firstpos {}
    set lastpos {}

    switch -- [lindex [lindex $t 1] 0] {
	:seq -
	:choice {
	    set rep [lindex $t 0]
	    set cs [lindex [lindex $t 1] 0]

	    foreach child [lrange [lindex $t 1] 1 end] {
		foreach {childNullable childFirstpos childLastpos} \
			[TraverseDepth1st $state $child $leaf $nonTerm] break
		lappend nullable $childNullable
		lappend firstpos $childFirstpos
		lappend lastpos  $childLastpos
	    }

	    eval $nonTerm
	}
	default {
	    incr var(number)
	    set rep [lindex [lindex $t 0] 0]
	    set name [lindex [lindex $t 1] 0]
	    eval $leaf
	}
    }

    return [list $nullable $firstpos $lastpos]
}

# sgml::firstpos --
#
#	Computes the firstpos function for a nonterminal node.
#
# Arguments:
#	cs		node type, choice or sequence
#	firstpos	firstpos functions for the subtree
#	nullable	nullable functions for the subtree
#
# Results:
#	firstpos function for this node is returned.

proc sgml::firstpos {cs firstpos nullable} {
    switch -- $cs {
	:seq {
	    set result [lindex [lindex $firstpos 0] 1]
	    for {set i 0} {$i < [llength $nullable]} {incr i} {
	    	if {[lindex [lindex $nullable $i] 1]} {
	    	    eval lappend result [lindex [lindex $firstpos [expr $i + 1]] 1]
		} else {
		    break
		}
	    }
	}
	:choice {
	    foreach child $firstpos {
		eval lappend result $child
	    }
	}
    }

    return [list $firstpos [makeSet $result]]
}

# sgml::lastpos --
#
#	Computes the lastpos function for a nonterminal node.
#	Same as firstpos, only logic is reversed
#
# Arguments:
#	cs		node type, choice or sequence
#	lastpos		lastpos functions for the subtree
#	nullable	nullable functions forthe subtree
#
# Results:
#	lastpos function for this node is returned.

proc sgml::lastpos {cs lastpos nullable} {
    switch -- $cs {
	:seq {
	    set result [lindex [lindex $lastpos end] 1]
	    for {set i [expr [llength $nullable] - 1]} {$i >= 0} {incr i -1} {
		if {[lindex [lindex $nullable $i] 1]} {
		    eval lappend result [lindex [lindex $lastpos $i] 1]
		} else {
		    break
		}
	    }
	}
	:choice {
	    foreach child $lastpos {
		eval lappend result $child
	    }
	}
    }

    return [list $lastpos [makeSet $result]]
}

# sgml::makeSet --
#
#	Turn a list into a set, ie. remove duplicates.
#
# Arguments:
#	s	a list
#
# Results:
#	A set is returned, which is a list with duplicates removed.

proc sgml::makeSet s {
    foreach r $s {
	if {[llength $r]} {
	    set unique($r) {}
	}
    }
    return [array names unique]
}

# sgml::nullable --
#
#	Compute the nullable function for a node.
#
# Arguments:
#	nodeType	leaf or nonterminal
#	rep		repetition applying to this node
#	name		leaf node: symbol for this node, nonterm node: choice or seq node
#	subtree		nonterm node: nullable functions for the subtree
#
# Results:
#	Returns nullable function for this branch of the tree.

proc sgml::nullable {nodeType rep name {subtree {}}} {
    switch -glob -- $rep:$nodeType {
	:leaf -
	+:leaf {
	    return [list {} 0]
	}
	\\*:leaf -
	\\?:leaf {
	    return [list {} 1]
	}
	\\*:nonterm -
	\\?:nonterm {
	    return [list $subtree 1]
	}
	:nonterm -
	+:nonterm {
	    switch -- $name {
		:choice {
		    set result 0
		    foreach child $subtree {
			set result [expr $result || [lindex $child 1]]
		    }
		}
		:seq {
		    set result 1
		    foreach child $subtree {
			set result [expr $result && [lindex $child 1]]
		    }
		}
	    }
	    return [list $subtree $result]
	}
    }
}

# sgml::DTD:ATTLIST --
#
#	<!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.
		    package require uri
		    set token [uri::geturl [uri::resolve $options(-baseurl) [lindex $value 1]]]

		    set ExtPEnts($name) [lindex [array get $token data] 1]
		    uplevel #0 $options(-parameterentitydeclcommand) [eval list $name [lrange $value 1 2]]
		}
	    }
	}
    }
}

# sgml::EntitySubst --
#
#	Perform entity substitution on an entity replacement text.
#	This differs slightly from other substitution procedures,
#	because only parameter and character entity substitution
#	is performed, not general entities.
#	See XML Rec. section 4.5.
#
# Arguments:
#	opts	configuration options
#	value	Literal entity value
#
# Results:
#	Expanded replacement text

proc sgml::EntitySubst {opts value} {
    array set options $opts

    # Protect Tcl special characters
    regsub -all {([{}\\])} $value {\\\1} value

    # Find entity references
    regsub -all (&#\[0-9\]+|&#x\[0-9a-fA-F\]+|%${::sgml::Name})\; $value "\[EntitySubstValue [list $options(parameterentities)] {\\1}\]" value

    set result [subst $value]

    return $result
}

# sgml::EntitySubstValue --
#
#	Handle a single character or parameter entity substitution
#
# Arguments:
#	PEvar	array variable containing PE declarations
#	ref	character or parameter entity reference
#
# Results:
#	Replacement text

proc sgml::EntitySubstValue {PEvar ref} {
    switch -glob -- $ref {
	&#x* {
	    scan [string range $ref 3 end] %x hex
	    return [format %c $hex]
	}
	&#* {
	    return [format %c [string range $ref 2 end]]
	}
	%* {
	    upvar #0 $PEvar PEs
	    set ref [string range $ref 1 end]
	    if {[info exists PEs($ref)]} {
		return $PEs($ref)
	    } else {
		return -code error "parameter entity \"$ref\" not declared"
	    }
	}
	default {
	    return -code error "internal error - unexpected entity reference"
	}
    }
    return {}
}

# sgml::DTD:NOTATION --
#
#	Process notation declaration
#
# Arguments:
#	opts	configuration options
#	name	notation name
#	value	unparsed notation spec

proc sgml::DTD:NOTATION {opts name value} {
    return {}

    variable notation_exp
    upvar opts state

    if {[regexp $notation_exp $value x scheme data] == 2} {
    } else {
	eval $state(-errorcommand) notationvalue [list "notation value \"$value\" incorrectly specified"]
    }
}

# sgml::ResolveEntity --
#
#	Default entity resolution routine
#
# Arguments:
#	name	name of parent parser
#	base	base URL for relative URLs
#	sysId	system identifier
#	pubId	public identifier

proc sgml::ResolveEntity {name base sysId pubId} {
    variable ParseEventNum

    package require tcllib

    if {[catch {uri::resolve $base $sysId} url]} {
	return -code error "unable to resolve system identifier \"$sysId\""
    }
    if {[catch {uri::geturl $url} token]} {
	return -code error "unable to retrieve external entity \"$url\" for system identifier \"$sysId\""
    }

    upvar #0 $token data

    set parser [uplevel #0 $name entityparser]

    $parser parse $data(data) -dtdsubset external
    #$parser free

    return {}
}
#  browse.tcl ---
#  
#      This file is part of The Coccinella application. 
#      It maintains the current state of all 'jid-types' for each server.
#      In other words, it manages the client's internal state corresponding
#      to 'iq' elements with namespace 'jabber:iq:browse'.
#      
#  Copyright (c) 2001-2004  Mats Bengtsson
#  
#  See the README file for license, bugs etc.
#  
# $Id: browse.tcl,v 1.30 2004/07/30 12:55:54 matben Exp $
# 
#  locals($jid,parent):       the parent of $jid.
#  locals($jid,parents):      list of all parent jid's,
#                             {server conference.server myroom@conference.server}
#  locals($jid,childs):       list of all childs of this jid if any.                             
#  locals($jid,xmllist):      the hierarchical xml list of this $jid.
#  locals($jid,type):         the type/subtype (category/type) of this $jid.
#  locals($type,typelist):    a list of jid's for this type/subtype.
#  locals(alltypes):          a list of all jid types.
#  locals($jid,allusers):     list of all users in room $jid.
#  locals($jid,isbrowsed):    1 if $jid browsed, 0 if not.
#
############################# USAGE ############################################
#
#       Changes to the state of this object should only be made from jabberlib,
#       and never directly by the client!
#       All jid's must be browsed hierarchically, that is, when browsing
#       'myroom@conference.server', 'conference.server' must have already been 
#       browsed, and browsing 'conference.server' requires 'server' to have
#       been browsed.
#
#   NAME
#      browse - an object for the ...
#      
#   SYNOPSIS
#      browse::new jlibname ?-command clientCommand?
#      
#   OPTIONS
#      none
#      
#   INSTANCE COMMANDS
#      browseName clear ?jid?
#      browseName delete
#      browseName get jid
#      browseName getchilds jid
#      browseName getconferenceservers
#      browseName getname jid
#      browseName getnamespaces jid
#      browseName getservicesforns ns
#      browseName getparentjid jid
#      browseName getparents jid
#      browseName gettype jid
#      browseName getalltypes globpattern
#      browseName getalljidfortypes globpattern
#      browseName getusers jid
#      browseName hasnamespace jid namespace
#      browseName isbrowsed jid
#      browseName isroom jid
#      browseName remove jid
#      browseName send_get jid ?-command procName?
#      browseName setjid jid xmllist       (only from jabberlib)
#
#   The 'clientCommand' procedure must have the following form:
#   
#      clientCommand {browseName type jid xmllist args}
#      
#   which is supposed to handle all get/set events which happen async.
#      
#   where 'type' can be 'set' or 'remove'.
#      
############################# CHANGES ##########################################
#
#       030703   removed browseName from browse::browse
#       040408   version 2.0
#       040408   browsename now fully qualified, added browse::new, send_get,
#                removed browse::browse,

package require wrapper

package provide browse 2.0

namespace eval browse {
    
    # Running number.
    variable uid 0
   
    # Globals same for all instances of all rooms.
    variable debug 0
    
    # Options only for internal use. EXPERIMENTAL!
    #     -setbrowsedjid:  default=1, store the browsed jid even if cached already
    variable options
    array set options {
	-setbrowsedjid 1
    }
}	

# browse::new --
# 
#       Creates a new instance of a browse object.
#       
# Arguments:
#       jlibname:     name of existing jabberlib instance
#       args:         -command procName {browsename type jid subiq args}
#                     the command is supposed to handle the async get/set 
#                     events only.
# 
# Results:
#       namespaced instance command

proc browse::new {jlibname args} {
    
    variable uid
    variable browse2jlib

    # Generate unique command token for this browse instance.
    # Fully qualified!
    set browsename [namespace current]::[incr uid]

    Debug 2 "browse::new jlibname=$jlibname, browsename=$browsename"
      
    # Instance specific namespace.
    namespace eval $browsename {
	variable locals
    }
    upvar ${browsename}::locals locals

    foreach {key value} $args {
	switch -- $key {
	    -command {
		set locals(cmd) $value
	    }
	    default {
		return -code error "unrecognized option \"$key\" for browse::new"
	    }
	}
    }
    set locals(confservers) {}
    set browse2jlib($browsename) $jlibname
    
    # Register service.
    $jlibname service register browse $browsename
    
    # Register some standard iq handlers that is handled internally.
    # The get/set events are async events and need to be handled by a -command.
    $jlibname iq_register get jabber:iq:browse  \
      [list [namespace current]::handle_get $browsename]
    $jlibname iq_register set jabber:iq:browse  \
      [list [namespace current]::handle_set $browsename]

    # Make sure we clean up any state if user logouts.
    $jlibname presence_register unavailable  \
      [list [namespace current]::handle_unavailable $browsename]
    
    # Create the actual browser instance procedure.
    proc $browsename {cmd args}   \
      "eval browse::CommandProc {$browsename} \$cmd \$args"
    
    return $browsename
}

# browse::CommandProc --
#
#       Just dispatches the command to the right procedure.
#
# Arguments:
#       browsename:   the instance of this conference browse.
#       cmd:        the method.
#       args:       all args to the cmd method.
#       
# Results:
#       none.

proc browse::CommandProc {browsename cmd args} {
        
    # Which command? Just dispatch the command to the right procedure.
    return [eval {$cmd $browsename} $args]
}

# browse::send_get --
#
#       Sends a get request within the browse namespace.
#
# Arguments:
#       browsename: the instance of this browse.
#       jid:        to jid
#       cmd:        procName {browsename type jid subiq args}      
#       
# Results:
#       none.

proc browse::send_get {browsename jid cmd} {
    
    variable browse2jlib
        
    Debug 2 "browse::send_get jid=$jid, cmd=$cmd"
    
    $browse2jlib($browsename) iq_get "jabber:iq:browse" -to $jid  \
      -command [list [namespace current]::parse_get $browsename $jid $cmd]
}

proc browse::parse_get {browsename jid cmd jlibname type subiq args} {

    upvar ${browsename}::locals locals

    Debug 2 "browse::parse_get jid=$jid, type=$type"

    switch -- $type {
	error {
	    uplevel #0 $cmd [list $browsename $type $jid $subiq] $args
	}
	default {
	    
	    # Set internal state first, then handle callback.
	    setjid $browsename $jid $subiq
	    uplevel #0 $cmd [list $browsename $type $jid $subiq] $args
	}
    }
}

# browse::handle_get --
# 
#       Hook for iq_register get.

proc browse::handle_get {browsename jlibname from subiq args} {
    
    upvar ${browsename}::locals locals

    Debug 2 "browse::handle_get from=$from"
    
    set ishandled 0
    if {[info exists locals(cmd)]} {
	set ishandled \
	  [uplevel #0 $locals(cmd) [list $browsename get $from $subiq] $args]
    }
    return $ishandled
}

# browse::handle_set --
# 
#       Hook for iq_register set.

proc browse::handle_set {browsename jlibname from subiq args} {
    
    upvar ${browsename}::locals locals

    Debug 2 "browse::handle_set from=$from, subiq='$subiq'"

    # Set internal state first, then handle any callback.
    setjid $browsename $from $subiq
    
    set ishandled 0
    if {[info exists locals(cmd)]} {
	set ishandled \
	  [uplevel #0 $locals(cmd) [list $browsename set $from $subiq] $args]
    }
    return $ishandled
}


proc browse::handle_unavailable {browsename jlibname jid type args} {
    
    Debug 2 "browse::handle_unavailable jid=$jid, type=$type"
    
    clear $browsename $jid
}

# browse::getparentjid --
#
#       Returns the logical parent of a jid. 
#       'matben@ayhkdws.se/home' => 'matben@ayhkdws.se' etc.
#       
# Arguments:
#       jid     the three-tier jid
#       
# Results:
#       another jid or empty if failed

proc browse::getparentjid {browsename jid} {
    
    upvar ${browsename}::locals locals

    set jid [jlib::jidmap $jid]
    if {[info exists locals($jid,parent)]} {
	set parJid $locals($jid,parent)
    } else {
	
	# Only to make it failsafe. DANGER!!!
	set parJid [GetParentJidFromJid $browsename $jid]
    }
    return $parJid
}

# This is not good...   DANGER!!!

proc browse::GetParentJidFromJid {browseName jid} {
        
    Debug 3 "GetParentJidFromJid BADBADBADBADBADBAD!!!  jid=$jid"

    set c {[^@/.<>:]+}
    if {[regexp "(${c}@(${c}\.)+${c})/${c}" $jid match parJid junk]} {	
    } elseif {[regexp "${c}@((${c}\.)+${c})" $jid match parJid junk]} {
    } elseif {[regexp "${c}\.((${c}\.)*${c})" $jid match parJid junk]} {
    } else {
	set parJid {}
    }
    return $parJid
}

# browse::get --
#
# Arguments:
#       browsename:   the instance of this conference browse.
#
# Results:
#       Hierarchical xmllist if already browsed or empty if not browsed.

proc browse::get {browsename jid} {
    
    upvar ${browsename}::locals locals
    
    Debug 3 "browse::get  jid=$jid"
    
    set jid [jlib::jidmap $jid]
    if {[info exists locals($jid,xmllist)]} {
	return $locals($jid,xmllist)
    } else {
	return ""
    }
}

proc browse::isbrowsed {browsename jid} {
    
    upvar ${browsename}::locals locals
    
    Debug 3 "browse::isbrowsed  jid=$jid"
    
    set jid [jlib::jidmap $jid]
    if {[info exists locals($jid,isbrowsed)] && ($locals($jid,isbrowsed) == 1)} {
	return 1
    } else {
	return 0
    }
}
    
# browse::remove --
#
#
# Arguments:
#       browsename:   the instance of this browse.
#       jid:          jid to remove.
#
# Results:
#       none.

proc browse::remove {browsename jid} {
    
    upvar ${browsename}::locals locals
    
    Debug 3 "browse::remove  jid=$jid"
    
    set mjid [jlib::jidmap $jid]
    
    unset -nocomplain locals($mjid,parents) locals($mjid,xmllist) \
      locals($mjid,isbrowsed)

    # Evaluate the client callback.
    if {[info exists locals(cmd)]} {
	uplevel #0 $locals(cmd) [list $browsename remove $jid {}]
    }
}
    
# browse::getparents --
#
#
# Arguments:
#       browsename:   the instance of this browse.
#
# Results:
#       List of all parent jid's.

proc browse::getparents {browsename jid} {
    
    upvar ${browsename}::locals locals
    
    Debug 3 "browse::getparents  jid=$jid"

    set jid [jlib::jidmap $jid]    
    if {[info exists locals($jid,parents)]} {
	return $locals($jid,parents)
    } else {
	return ""
    }
}
    
# browse::getchilds --
#
#
# Arguments:
#       browsename:   the instance of this browse.
#
# Results:
#       List of all parent jid's.

proc browse::getchilds {browsename jid} {
    
    upvar ${browsename}::locals locals
    
    Debug 3 "browse::getchilds  jid=$jid"
    
    set jid [jlib::jidmap $jid]
    if {[info exists locals($jid,childs)]} {
	return $locals($jid,childs)
    } else {
	return ""
    }
}
    
# browse::getname --
#
#       Returns the nickname of a jid in conferencing, or the rooms name
#       if jid is a room.
#
# Arguments:
#       browsename:   the instance of this conference browse.
#       
# Results:
#       The nick, room name or empty if undefined.

proc browse::getname {browsename jid} {
    
    upvar ${browsename}::locals locals
    
    Debug 3 "browse::getname  jid=$jid"
    
    set jid [jlib::jidmap $jid]    
    if {[info exists locals($jid,name)]} {
	return $locals($jid,name)
    } else {
	return ""
    }
}
    
# browse::getusers --
#
#       Returns all users of a room jid in conferencing.
#
# Arguments:
#       browsename:   the instance of this conference browse.
#       jid:          must be a room jid: 'roomname@server'.
#       
# Results:
#       The nick name or empty if undefined.

proc browse::getusers {browsename jid} {
    
    upvar ${browsename}::locals locals
    
    Debug 3 "browse::getusers  jid=$jid"
    
    set jid [jlib::jidmap $jid]    
    if {[info exists locals($jid,allusers)]} {
	return $locals($jid,allusers)
    } else {
	return ""
    }
}
    
# browse::getconferenceservers --
#
#

proc browse::getconferenceservers {browsename} {    
    
    upvar ${browsename}::locals locals
    
    return $locals(confservers)
}    
    
# browse::getservicesforns --
#
#       Gets all jid's that support a certain namespace.
#       Only for the browsed services.

proc browse::getservicesforns {browsename ns} {    
    
    upvar ${browsename}::locals locals
    
    if {[info exists locals(ns,$ns)]} {
	return $locals(ns,$ns)
    } else {
	return ""
    }
}

# browse::isroom --
#
#       If 'jid' is a child of a conference server, that is, a room.

proc browse::isroom {browsename jid} {
    
    upvar ${browsename}::locals locals
    
    set jid [jlib::jidmap $jid]    
    set parentJid [getparentjid $browsename $jid]

    # Check if this is in our list of conference servers.
    set ind [lsearch -exact $locals(confservers) $parentJid]
    return [expr ($ind < 0) ? 0 : 1]
}    
    
# browse::gettype --
#
#       Returns the jidType/subType if found.

proc browse::gettype {browsename jid} {    
    
    upvar ${browsename}::locals locals
    
    set jid [jlib::jidmap $jid]    
    if {[info exists locals($jid,type)]} {
	return $locals($jid,type)
    } else {
	return ""
    }
}    

# browse::getalljidfortypes --
#
#       Returns all jids that match the glob pattern typepattern.
#       
# Arguments:
#       browsename:   the instance of this conference browse.
#       typepattern:  a global pattern of jid type/subtype (service/*).
#
# Results:
#       List of jid's matching the type pattern.

proc browse::getalljidfortypes {browsename typepattern} {
    
    upvar ${browsename}::locals locals
    
    set allkeys [array names locals "${typepattern},typelist"]
    set jidlist {}
    
    foreach key $allkeys {
	set locals($key) [lsort -unique $locals($key)]
	set jidlist [concat $jidlist $locals($key)]
    }
    return $jidlist
}    

# browse::getalltypes --
#
#       Returns all types that match the glob pattern typepattern.
#       
# Arguments:
#       browsename:   the instance of this conference browse.
#       typepattern:  a glob pattern of jid type/subtype (service/*).
#
# Results:
#       List of types matching the type pattern.

proc browse::getalltypes {browsename typepattern} {    
    
    upvar ${browsename}::locals locals
    
    set ans {}
    if {[info exists locals(alltypes)]} {
	set locals(alltypes) [lsort -unique $locals(alltypes)]
	foreach type $locals(alltypes) {
	    if {[string match $typepattern $type]} {
		lappend ans $type
	    }
	}
    }
    return $ans
}    

# browse::getnamespaces --
#
#       Returns all namespaces for this jid describing the services available.
#
# Arguments:
#       browsename:   the instance of this conference browse.
#       jid:          .
#       
# Results:
#       List of namespaces or empty if none.

proc browse::getnamespaces {browsename jid} {
    
    upvar ${browsename}::locals locals
    
    Debug 3 "browse::getnamespaces  jid=$jid"

    set jid [jlib::jidmap $jid]    
    if {[info exists locals($jid,ns)]} {
	return $locals($jid,ns)
    } else {
	return ""
    }
}

# browse::hasnamespace --
#
#       Returns 0/1 if jid supports this namespace.
#
# Arguments:
#       browsename:   the instance of this conference browse.
#       jid:          .
#       ns            namespace.
#       
# Results:
#       0/1

proc browse::hasnamespace {browsename jid ns} {
    
    upvar ${browsename}::locals locals
    
    Debug 3 "browse::hasnamespace  jid=$jid, ns=$ns"

    set jid [jlib::jidmap $jid]    
    if {[info exists locals($jid,ns)]} {
	return [expr [lsearch $locals($jid,ns) $ns] < 0 ? 0 : 1]
    } else {
	return 0
    }
}

# browse::setjid --
#
#       Called when receiving a 'set' or 'result' iq element in jabber:iq:browse
#       Shall only be called from jabberlib
#       Sets internal state, and makes callback to client proc. 
#       Could be called with type='remove' attribute.
#       For 'user' elements we need to build a table that maps the
#       'roomname@server/hexname' with the nick name.
#       It also keeps a list of all 'user'«s in a room.
#       
# Arguments:
#       browsename:   the instance of this conference browse.
#       fromJid:      the 'from' attribute which is also the parent of any
#                     childs.
#       subiq:      hierarchical xml list starting with element containing
#                     the xmlns='jabber:iq:browse' attribute.
#                     Any children defines a parent-child relation.
#                     
#                   ???????????
#       args:       -command cmdProc:   replaces the client callback command
#                        in the browse object
#       
# Results:
#       none.

proc browse::setjid {browsename fromJid subiq args} {
    
    upvar ${browsename}::locals locals
    
    Debug 3 "browse::setjid browsename=$browsename, fromJid=$fromJid\n\t\
      subiq='[string range $subiq 0 80]...', args='$args'"

    set theTag [wrapper::gettag $subiq]
    array set attrArr [wrapper::getattrlist $subiq]
    array set argsArr $args
    
    # Seems that the browse component doesn't do STRINGPREP.
    set fromJid [jlib::jidmap $fromJid]
    
    # Root parent empty. A bit unclear what to do with it.
    if {![info exists locals($fromJid,parent)]} {
	
	# This can be a completely new room not seen before.
	# Workoround for bug in 'conference 0.4.1' component. No parent!
        # <iq type='set' to='matben@localhost/xx' 
        #         from='junk@conference.localhost'>
        #     <conference xmlns='jabber:iq:browse' name='Junk' type='public'/>
        # </iq>
	if {[string match *@* $fromJid]} {

	    # Ugly!!!
	    set parentJid [getparentjid $browsename $fromJid]
	    set locals($fromJid,parent) $parentJid
	    if {[info exists locals($parentJid,parents)]} {
		set locals($fromJid,parents)  \
		  [concat $locals($parentJid,parents) $parentJid]
	    } else {
		set locals($fromJid,parents) $parentJid
		set locals($parentJid,parents) {}
	    }
	} else {
	
	    # Else we assume it is a root. Not correct!
	    set locals($fromJid,parent) {}
	    set locals($fromJid,parents) {}
	    set parentJid {}
	}
    }
    
    # Docs say that jid is required attribute but... 
    # <conference> and <service> seem to lack jid.
    # If no jid attribute it is probably(?) assumed to be 'fromJid.
    if {![info exists attrArr(jid)]} {
	set jid $fromJid
	set parentJid $locals($jid,parent)
    } else {
	
	# Must do STRINGPREP when comparing two jids!
	set jid [jlib::jidmap $attrArr(jid)]
	if {$fromJid != $jid} {
	    set parentJid $fromJid
	} else {
	    set parentJid $locals($jid,parent)
	}
    }
    set locals($fromJid,isbrowsed) 1
    set locals($jid,isbrowsed) 1
    
    # Handle the top jid, and follow recursively for any childs.
    setsinglejid $browsename $parentJid $jid $subiq 1
}

# browse::setsinglejid --
#
#       Gets called for each jid in the jabber:iq:browse callback.
#       The recursive helper proc for 'setjid'.
#       
# Arguments:
#       browsename:   the instance of this conference browse.
#       parentJid:    the logical parent of 'jid'
#       jid:          the 'jid' we are setting; if empty it is in attribute list.
#       xmllist:      hierarchical xml list.
#                     Any children defines a parent-child relation.
#       
# Results:
#       none.

proc browse::setsinglejid {browsename parentJid jid xmllist {browsedjid 0}} {

    variable options
    variable browse2jlib
    
    upvar ${browsename}::locals locals
    
    Debug 3 "browse::setsinglejid browsename=$browsename, parentJid=$parentJid, jid=$jid"
    
    set category [wrapper::gettag $xmllist]
    array set attrArr [wrapper::getattrlist $xmllist]

    # Check for any 'category' attribute introduced in the 1.2 rev. of JEP-0011.
    if {[info exists attrArr(category)]} {
    	set category $attrArr(category)
    }
    
    # If the 'jid' is empty we get it from our attributes!
    if {[string length $jid] == 0} {
	set jid $attrArr(jid)
    }
    
    # First, is this a "set" or a "remove" type?
    if {[info exists attrArr(type)] && [string equal $attrArr(type) "remove"]} {
	if {[string equal $category "user"]} {
	    
	    # Be sure to update the room's list of participants.
	    if {[info exists locals($parentJid,allusers)]} {
		set ind [lsearch $locals($parentJid,allusers) $jid]
		if {$ind >= 0} {
		    set locals($parentJid,allusers)   \
		      [lreplace $locals($parentJid,allusers) $ind $ind]
		}
	    }
	}
    } elseif {$options(-setbrowsedjid) || !$browsedjid} {
	
	# Set type.
	set locals($jid,xmllist) $xmllist
	
	# Set up parents for this jid.
	# Root's parent is empty. When not root, store parent(s).
	if {[string length $parentJid] > 0} {
	    set locals($jid,parent) $parentJid
	    set locals($jid,parents)   \
	      [concat $locals($parentJid,parents) $parentJid]
	}
	
	# Add us to parentJid's child list if not there already.
	if {![info exists locals($parentJid,childs)]} {
	    set locals($parentJid,childs) {}
	}
	if {[lsearch -exact $locals($parentJid,childs) $jid] < 0} {
	    lappend locals($parentJid,childs) $jid
	}
	
	if {[info exists attrArr(type)]} {
	    set jidtype $category/$attrArr(type)
	    set locals($jid,type) $jidtype
	    lappend locals($jidtype,typelist) $jid
	    lappend locals(alltypes) $jidtype
	    set locals($jidtype,typelist) \
	    	[lsort -unique $locals($jidtype,typelist)]
	    set locals(alltypes) [lsort -unique $locals(alltypes)]
	}
	
	# Cache additional info depending on the tag.
	switch -exact -- $category {
	    conference {
	    
		# This is either a conference server or one of its rooms.
		if {[string match *@* $jid]} {
		    
		    # This must be a room. Cache its name.
		    if {[info exists attrArr(name)]} {
			set locals($jid,name) $attrArr(name)
		    }
		} else {
		
		    # Cache all conference servers. Don't count the rooms.
		    if {[lsearch -exact $locals(confservers) $jid] < 0} {		    
			lappend locals(confservers) $jid
		    }
		}
	    }
	    user {
	    
		# If with 'user' tag in conferencing, keep internal table that
		# maps the 'room@server/hexname' to nickname.
		if {[info exists attrArr(name)]} {
		    set locals($jid,name) $attrArr(name)
		}
		
		# Keep list of all 'user'«s in a room. The 'parentJid' must
		# be the room's jid here.
		lappend locals($parentJid,allusers) $jid
		set locals($parentJid,allusers)  \
		  [lsort -unique $locals($parentJid,allusers)]
	    }	    
	}
    }
    # End set type.
    
    # Loop through the children if any. Defines a parentship.
    # Only exception is a namespace definition <ns/>.
    foreach child [wrapper::getchildren $xmllist] {
	if {[string equal [wrapper::gettag $child] "ns"]} {
	    
	    # Cache any namespace declarations.
	    set ns [wrapper::getcdata $child]
	    lappend locals($jid,ns) $ns
	    set locals($jid,ns) [lsort -unique $locals($jid,ns)]
	    lappend locals(ns,$ns) $jid
	    set locals(ns,$ns) [lsort -unique $locals(ns,$ns)]
	    
	    # Register any groupchat protocol.
	    # There seems to be a problem here since not all conference
	    # components list <ns>jabber:iq:conference</ns> in their browse
	    # section.
	    if {[string equal $category "conference"]} {
	    
		switch -- $ns {
		    "http://jabber.org/protocol/muc" {
			$browse2jlib($browsename) service registergcprotocol $jid "muc"
		    }
		    "jabber:iq:conference" {
			$browse2jlib($browsename) service registergcprotocol $jid "conference"
		    }
		    "gc-1.0" {
			$browse2jlib($browsename) service registergcprotocol $jid "gc-1.0"
		    }
		}
	    }
	} else {
	    
	    # Now jid is the parent, and the jid to set is an attribute.
	    setsinglejid $browsename $jid {} $child
	}
    }
}

# browse::clear --
#
#       Empties everything cached internally for the specified jid (and all
#       its children ?).
#       Problem since icq.jabber.se child of icq.jabber.se/registered (?!)
#       It must be failsafe in case of missing browse elements.

proc browse::clear {browsename {jid {}}} {
    
    upvar ${browsename}::locals locals
    
    Debug 3 "browse::clear browse::clear $jid"
    if {[string length $jid]} {

	# testing...
	set jid [jlib::jidmap $jid]    
	ClearJidIsbrowsed $browsename $jid
	ClearJid $browsename $jid
    } else {
	ClearAll $browsename
    }
}

proc browse::ClearJid {browsename jid} {
    
    upvar ${browsename}::locals locals

    # Can be problems with this (ICQ)
    if {0 && [info exists locals($jid,childs)]} {
	foreach child $locals($jid,childs) {
	    ClearJid $browsename $child
	}
    }
    
    # Guard against the case where no parent registered.    
    # Keep parents!
    if {[info exists locals($jid,parent)]} {
    	set parent $locals($jid,parent)
    }
    if {[info exists locals($jid,parents)]} {
    	set parents $locals($jid,parents)
    }

    # Remove this specific jid from our internal state.
    array unset locals "$jid,*"
    if {[info exists parent]} {
    	set locals($jid,parent) $parent
    }
    if {[info exists parents]} {
    	set locals($jid,parents) $parents
    }
}

proc browse::ClearJidIsbrowsed {browsename jid} {
    
    upvar ${browsename}::locals locals

    if {[info exists locals($jid,childs)]} {
	foreach child $locals($jid,childs) {
	    ClearJidIsbrowsed $browsename $child
	}
    }
    unset -nocomplain locals($jid,isbrowsed)
}
    
# browse::ClearAll --
#
#       Empties everything cached internally.

proc browse::ClearAll {browsename} {
    
    upvar ${browsename}::locals locals

    # Be sure to keep some entries! Separate array for these?
    if {[info exists locals(cmd)]} {
	set clientCmd $locals(cmd)
    }
    unset locals
    if {[info exists clientCmd]} {
	set locals(cmd) $clientCmd
    }
    set locals(confservers) {}
}

# browse::delete --
#
#       Deletes the complete object.

proc browse::delete {browsename} {
    
    namespace delete $browsename
}

proc browse::Debug {num str} {
    variable debug

    if {$num <= $debug} {
	puts $str
    }
}

#-------------------------------------------------------------------------------

#  muc.tcl --
#  
#      This file is part of the whiteboard application and 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
#  
#  See the README file for license, bugs etc.
#
# $Id: muc.tcl,v 1.20 2005/02/09 14:30:33 matben Exp $
# 
############################# USAGE ############################################
#
#   NAME
#      muc - convenience command library for MUC
#      
#   OPTIONS
#	see below for instance command options
#	
#   INSTANCE COMMANDS
#      mucName allroomsin
#      mucName create roomjid nick callback
#      mucName destroy roomjid ?-command, -reason, alternativejid?
#      mucName enter roomjid nick ?-command, -extras, -password?
#      mucName exit roomjid
#      mucName getaffiliation roomjid affiliation callback
#      mucName getrole roomjid role callback
#      mucName getroom roomjid callback
#      mucName invite roomjid jid ?-reason?
#      mucName isroom jid
#      mucName mynick roomjid
#      mucName participants roomjid
#      mucName setaffiliation roomjid nick affiliation ?-command, -reason?
#      mucName setnick roomjid nick ?-command?
#      mucName setrole roomjid nick role ?-command, -reason?
#      mucName setroom roomjid type ?-command, -form?
#      
############################# CHANGES ##########################################
#
#       0.1         first version
#       0.2         rewritten as a standalone component

package provide muc 0.2

namespace eval jlib::muc {
    
    # Globals same for all instances of this jlib.
    variable debug 0

    # Running number.
    variable uid 0
    
    variable muc
    set muc(affiliationExp) {(owner|admin|member|outcast|none)}
    set muc(roleExp) {(moderator|participant|visitor|none)}
}

# jlib::muc::new --
# 
#       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::new {jlibname args} {
    
    variable uid
    variable muc2jlib

    # Generate unique command token for this browse instance.
    # Fully qualified!
    set mucname [namespace current]::[incr uid]

    Debug 2 "muc::new jlibname=$jlibname, mucname=$mucname"
      
    # Instance specific namespace.
    namespace eval $mucname {
	variable cache
	variable rooms
    }
    upvar ${mucname}::cache cache
    upvar ${mucname}::rooms rooms

    foreach {key value} $args {
	switch -- $key {
	    default {
		return -code error "unrecognized option \"$key\" for muc::new"
	    }
	}
    }
    set muc2jlib($mucname) $jlibname

    # Register service.
    $jlibname service register muc $mucname
        
    # Create the actual muc instance procedure.
    proc $mucname {cmd args}   \
      "eval jlib::muc::CommandProc {$mucname} \$cmd \$args"
    
    return $mucname
}


# jlib::muc::CommandProc --
#
#       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::CommandProc {mucname cmd args} {
    
    # Which sub command? Just dispatch the command to the right procedure.
    return [eval {$cmd $mucname} $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:
#       mucname    name of jabberlib instance.
#       roomjiid
#       nick        nick name
#       args        ?-command callbackProc?
#                   ?-extras list of xmllist?
#                   ?-password str?
#       
# Results:
#       none.

proc jlib::muc::enter {mucname roomjid nick args} {

    variable muc2jlib
    upvar ${mucname}::cache cache
    upvar ${mucname}::rooms rooms
    
    set jlibname $muc2jlib($mucname)
    set xsub {}
    set extras {}
    foreach {name value} $args {
	
	switch -- $name {
	    -command {
		set cache($roomjid,entercb) $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 {xmlns "http://jabber.org/protocol/muc"}]
    $jlibname send_presence -to $jid -xlist [list $xelem] -extras $extras \
      -command [list [namespace current]::parse_enter $mucname $roomjid]
    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.
# 
# Arguments:
#       mucname
#       
#       jlibname 
#       type    presence typ attribute, 'available', 'error', etc.
#       args    -from, -id, -to, -x ...

proc jlib::muc::parse_enter {mucname roomjid jlibname type args} {

    upvar ${mucname}::cache cache

    if {[string equal $type "error"]} {
	unset -nocomplain cache($roomjid,mynick)
    } else {
	set cache($roomjid,inside) 1
    }
    if {[info exists cache($roomjid,entercb)]} {
	set cbproc $cache($roomjid,entercb)
	unset -nocomplain cache($roomjid,entercb)
	uplevel #0 $cbproc $mucname $type $args
    }
}

# jlib::muc::exit --
# 
#       Exit room.

proc jlib::muc::exit {mucname roomjid} {

    variable muc2jlib
    upvar ${mucname}::cache cache

    set jlibname $muc2jlib($mucname)
    set rostername [$jlibname getrostername]
    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)
    $rostername clearpresence "${roomjid}*"
}

# jlib::muc::setnick --
# 
#       Set new nick name for room.

proc jlib::muc::setnick {mucname roomjid nick args} {

    variable muc2jlib
    upvar ${mucname}::cache cache
    
    set jlibname $muc2jlib($mucname)
    set opts {}
    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 {mucname roomjid jid args} {
    
    variable muc2jlib

    set jlibname $muc2jlib($mucname)
    set opts {}
    set children {}
    foreach {name value} $args {
	switch -- $name {
	    -reason {
		lappend children [wrapper::createtag  \
		  [string trimleft $name "-"] -chdata $value]
	    }
	    default {
		return -code error "Unrecognized option \"$name\""
	    }
	}
    }    
    set invite [list \
      [wrapper::createtag "invite" -attrlist [list to $jid] -subtags $children]]
    
    set xelem [wrapper::createtag "x" -subtags $invite  \
      -attrlist {xmlns "http://jabber.org/protocol/muc#user"}]
    $jlibname send_message $roomjid  \
      -xlist [list $xelem]
}

# jlib::muc::setrole --
# 
# 

proc jlib::muc::setrole {mucname roomjid nick role args} {

    variable muc2jlib
    variable muc
    
    if {![regexp $muc(roleExp) $role]} {
	return -code error "Unrecognized role \"$role\""
    }
    set jlibname $muc2jlib($mucname)
    set opts {}
    set subitem {}
    foreach {name value} $args {
	switch -- $name {
	    -command {
		lappend opts -command  \
		  [list [namespace current]::invoke_callback $mucname $value]
	    }
	    -reason {
		set subitem [list [wrapper::createtag "reason" -chdata $value]]
	    }
	    default {
		return -code error "Unrecognized option \"$name\""
	    }
	}
    }
    
    set subelements [list [wrapper::createtag "item" -subtags $subitem \
      -attrlist [list nick $nick role $role]]]
    
    set xmllist [wrapper::createtag "query" \
      -attrlist {xmlns "http://jabber.org/protocol/muc#admin"} \
      -subtags $subelements]
    eval {$jlibname send_iq "set" [list $xmllist] -to $roomjid} $opts
}

# jlib::muc::setaffiliation --
# 
# 

proc jlib::muc::setaffiliation {mucname roomjid nick affiliation args} {

    variable muc2jlib
    variable muc
    
    if {![regexp $muc(affiliationExp) $affiliation]} {
	return -code error "Unrecognized affiliation \"$affiliation\""
    }
    set jlibname $muc2jlib($mucname)
    set opts {}
    set subitem {}
    foreach {name value} $args {
	switch -- $name {
	    -command {
		lappend opts -command  \
		  [list [namespace current]::invoke_callback $mucname $value]
	    }
	    -reason {
		set subitem [list [wrapper::createtag "reason" -chdata $value]]
	    }
	    default {
		return -code error "Unrecognized option \"$name\""
	    }
	}
    }

    switch -- $affiliation {
    	owner {
    	    set xmlns "http://jabber.org/protocol/muc#owner"
    	}
    	default {
    	    set xmlns "http://jabber.org/protocol/muc#admin"
    	}
    }
    
    set subelements [list [wrapper::createtag "item" -subtags $subitem \
      -attrlist [list nick $nick affiliation $affiliation]]]
    
    set xmllist [wrapper::createtag "query" \
      -attrlist [list xmlns $xmlns] -subtags $subelements]
    eval {$jlibname send_iq "set" [list $xmllist] -to $roomjid} $opts
}

# jlib::muc::getrole --
# 
# 

proc jlib::muc::getrole {mucname roomjid role callback} {

    variable muc2jlib
    variable muc
    
    if {![regexp $muc(roleExp) $role]} {
	return -code error "Unrecognized role \"$role\""
    }
    set jlibname $muc2jlib($mucname)
    set subelements [list [wrapper::createtag "item" \
      -attrlist [list role $role]]]
    
    set xmllist [wrapper::createtag "query" -subtags $subelements \
      -attrlist {xmlns "http://jabber.org/protocol/muc#admin"}]
    $jlibname send_iq "get" [list $xmllist] -to $roomjid \
      -command [list [namespace current]::invoke_callback $mucname $callback]
}

# jlib::muc::getaffiliation --
# 
# 

proc jlib::muc::getaffiliation {mucname roomjid affiliation callback} {

    variable muc2jlib
    variable muc
    
    if {![regexp $muc(affiliationExp) $affiliation]} {
	return -code error "Unrecognized role \"$affiliation\""
    }
    set jlibname $muc2jlib($mucname)
    set subelements [list [wrapper::createtag "item" \
      -attrlist [list affiliation $affiliation]]]

    switch -- $affiliation {
    	owner - admin {
    	    set xmlns "http://jabber.org/protocol/muc#owner"
    	}
    	default {
    	    set xmlns "http://jabber.org/protocol/muc#admin"
    	}
    }
    
    set xmllist [wrapper::createtag "query" -subtags $subelements \
      -attrlist [list xmlns $xmlns]]
    $jlibname send_iq "get" [list $xmllist] -to $roomjid \
      -command [list [namespace current]::invoke_callback $mucname $callback]
}

# jlib::muc::create --
# 
#       The first thing to do when creating a room.

proc jlib::muc::create {mucname roomjid nick callback} {

    variable muc2jlib
    upvar ${mucname}::cache cache
    upvar ${mucname}::rooms rooms

    set jlibname $muc2jlib($mucname)
    set jid ${roomjid}/${nick}
    set cache($roomjid,createcb) $callback
    set xelem [wrapper::createtag "x"  \
      -attrlist {xmlns "http://jabber.org/protocol/muc"}]
    $jlibname send_presence -to $jid -xlist [list $xelem]  \
      -command [list [namespace current]::parse_create $mucname $roomjid]
    set cache($roomjid,mynick) $nick
    set rooms($roomjid) 1
    $jlibname service setroomprotocol $roomjid "muc"
}

proc jlib::muc::parse_create {mucname roomjid jlibname type args} {

    variable muc2jlib
    upvar ${mucname}::cache cache

    if {[string equal $type "error"]} {
	unset -nocomplain cache($roomjid,mynick)
    } else {
	set cache($roomjid,inside) 1
    }
    if {[info exists cache($roomjid,createcb)]} {
	set cbproc $cache($roomjid,createcb)
	unset -nocomplain cache($roomjid,createcb)
	uplevel #0 $cbproc $mucname $type $args
    }
}

# jlib::muc::setroom --
# 
#       Sends an iq set element to room. If -form the 'type' argument is
#       omitted.
#       
# Arguments:
#       mucname     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 {mucname roomjid type args} {

    variable muc2jlib

    set jlibname $muc2jlib($mucname)
    set opts {}
    set subelements {}
    foreach {name value} $args {
	switch -- $name {
	    -command {
		lappend opts -command  \
		  [list [namespace current]::invoke_callback $mucname $value]
	    }
	    -form {
		set xelem $value
	    }
	    default {
		return -code error "Unrecognized option \"$name\""
	    }
	}
    }
    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 {xmlns "http://jabber.org/protocol/muc#owner"}]
    eval {$jlibname send_iq "set" [list $xmllist] -to $roomjid} $opts
}

# jlib::muc::destroy --
# 
# 
# Arguments:
#       mucname     name of muc instance.
#       roomjid     the rooms jid.
#       args        -command, -reason, alternativejid.
#       
# Results:
#       None.

proc jlib::muc::destroy {mucname roomjid args} {

    variable muc2jlib

    set jlibname $muc2jlib($mucname)
    set opts {}
    set subelements {}
    foreach {name value} $args {
	switch -- $name {
	    -command {
		lappend opts -command  \
		  [list [namespace current]::invoke_callback $mucname $value]
	    }
	    -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 {xmlns "http://jabber.org/protocol/muc#owner"}]
    eval {$jlibname send_iq "set" [list $xmllist] -to $roomjid} $opts
}

# jlib::muc::getroom --
# 
# 

proc jlib::muc::getroom {mucname roomjid callback} {

    variable muc2jlib

    set jlibname $muc2jlib($mucname)
    set xmllist [wrapper::createtag "query"  \
      -attrlist {xmlns "http://jabber.org/protocol/muc#owner"}]
    $jlibname send_iq "get" [list $xmllist] -to $roomjid  \
      -command [list [namespace current]::invoke_callback $mucname $callback]
}

# jlib::muc::mynick --
# 
#       Returns own nick name for room, or empty if not there.

proc jlib::muc::mynick {mucname roomjid} {

    upvar ${mucname}::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 {mucname} {

    upvar ${mucname}::cache cache
    
    set roomList {}
    foreach key [array names cache "*,inside"] {
	regexp {(.+),inside} $key match room
	lappend roomList $room
    }
    return $roomList
}

proc jlib::muc::isroom {mucname jid} {
    
    upvar ${mucname}::rooms rooms
    
    if {[info exists rooms($jid)]} {
	return 1
    } else {
	return 0
    }
}

# jlib::muc::participants --
#
#

proc jlib::muc::participants {mucname roomjid} {

    variable muc2jlib
    upvar ${mucname}::cache cache
    
    set jlibname $muc2jlib($mucname)
    set rostername [[namespace parent]::getrostername $jlibname]
    set everyone {}

    # The rosters presence elements should give us all info we need.
    foreach userAttr [$rostername getpresence $roomjid -type available] {
	unset -nocomplain attrArr
	array set attrArr $userAttr
	lappend everyone ${roomjid}/$attrArr(-resource)
    }
    return $everyone
}

proc jlib::muc::Debug {num str} {
    variable debug
    if {$num <= $debug} {
	puts $str
    }
}

#-------------------------------------------------------------------------------

# groupchat.tcl--
# 
#       Support for the old gc-1.0 groupchat protocol.
#       
#  Copyright (c) 2002-2005  Mats Bengtsson
#  
# $Id: groupchat.tcl,v 1.1 2005/02/09 14:30:32 matben Exp $
# 
############################# USAGE ############################################
#
#   INSTANCE COMMANDS
#      jlibName groupchat enter room nick
#      jlibName groupchat exit room
#      jlibName groupchat mynick room ?nick?
#      jlibName groupchat status room
#      jlibName groupchat participants room
#      jlibName groupchat allroomsin
#
################################################################################

package provide 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} {
    
    # Which command? Just dispatch the command to the right procedure.
    set ans [eval {[namespace current]::groupchat::${cmd} $jlibname} $args]
    return $ans
}

proc jlib::groupchat::init {jlibname} {

    upvar ${jlibname}::gchat gchat

    set gchat(allroomsin) {}
}

# 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
    
    set room [string tolower $room]
    set jid ${room}/${nick}
    eval {[namespace parent]::send_presence $jlibname -to $jid} $args
    set gchat($room,mynick) $nick
    
    # This is not foolproof since it may not always success.
    lappend gchat(allroomsin) $room
    [namespace parent]::service::setroomprotocol $jlibname $room "gc-1.0"
    set gchat(allroomsin) [lsort -unique $gchat(allroomsin)]
    return ""
}

proc jlib::groupchat::exit {jlibname room} {

    upvar ${jlibname}::gchat gchat
    upvar ${jlibname}::lib lib
    
    set room [string tolower $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}
    [namespace parent]::send_presence $jlibname -to $jid -type "unavailable"
    unset gchat($room,mynick)
    set ind [lsearch -exact $gchat(allroomsin) $room]
    if {$ind >= 0} {
	set gchat(allroomsin) [lreplace $gchat(allroomsin) $ind $ind]
    }
    $lib(rostername) clearpresence "${room}*"
    return ""
}

proc jlib::groupchat::mynick {jlibname room args} {

    upvar ${jlibname}::gchat gchat

    set room [string tolower $room]
    if {[llength $args] == 0} {
	if {[info exists gchat($room,mynick)]} {
	    return $gchat($room,mynick)
	} else {
	    return -code error "Unknown nick name for room \"$room\""
	}
    } elseif {[llength $args] == 1} {
	
	# This should work automatically.
	enter $jlibname $room $args
    } else {
	return -code error "Wrong number of arguments"
    }
}

proc jlib::groupchat::status {jlibname room args} {

    upvar ${jlibname}::gchat gchat

    set room [string tolower $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 {[namespace parent]::send_presence $jlibname -to $jid} $args
}

proc jlib::groupchat::participants {jlibname room} {

    upvar ${jlibname}::agent agent
    upvar ${jlibname}::gchat gchat
    upvar ${jlibname}::lib lib

    set room [string tolower $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 [$lib(rostername) getpresence $room -type available] {
	unset -nocomplain attrArr
	array set attrArr $userAttr
	lappend everyone ${room}/$attrArr(-resource)
    }
    return $everyone
}

proc jlib::groupchat::allroomsin {jlibname} {

    upvar ${jlibname}::gchat gchat

    set gchat(allroomsin) [lsort -unique $gchat(allroomsin)]
    return $gchat(allroomsin)
}

#-------------------------------------------------------------------------------
# stack.tcl --
#
#	Stack implementation for Tcl.
#
# 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$

namespace eval ::struct {}

namespace eval ::struct::stack {
    # The stacks array holds all of the stacks you've made
    variable stacks
    
    # counter is used to give a unique name for unnamed stacks
    variable counter 0

    # Only export one command, the one used to instantiate a new stack
    namespace export stack
}

# ::struct::stack::stack --
#
#	Create a new stack with a given name; if no name is given, use
#	stackX, where X is a number.
#
# Arguments:
#	name	name of the stack; if null, generate one.
#
# Results:
#	name	name of the stack created

proc ::struct::stack::stack {args} {
    variable stacks
    variable counter
    
    switch -exact -- [llength [info level 0]] {
	1 {
	    # Missing name, generate one.
	    incr counter
	    set name "stack${counter}"
	}
	2 {
	    # Standard call. New empty stack.
	    set name [lindex $args 0]
	}
	default {
	    # Error.
	    return -code error \
		    "wrong # args: should be \"stack ?name?\""
	}
    }

    # FIRST, qualify the name.
    if {![string match "::*" $name]} {
        # Get caller's namespace; append :: if not global namespace.
        set ns [uplevel 1 namespace current]
        if {"::" != $ns} {
            append ns "::"
        }

        set name "$ns$name"
    }
    if {[llength [info commands $name]]} {
	return -code error \
		"command \"$name\" already exists, unable to create stack"
    }

    set stacks($name) [list ]

    # Create the command to manipulate the stack
    interp alias {} $name {} ::struct::stack::StackProc $name

    return $name
}

##########################
# Private functions follow

# ::struct::stack::StackProc --
#
#	Command that processes all stack object commands.
#
# Arguments:
#	name	name of the stack object to manipulate.
#	args	command name and args for the command
#
# Results:
#	Varies based on command to perform

proc ::struct::stack::StackProc {name cmd args} {
    # Do minimal args checks here
    if { [llength [info level 0]] == 2 } {
	return -code error "wrong # args: should be \"$name option ?arg arg ...?\""
    }

    # Split the args into command and args components
    set sub _$cmd
    if { [llength [info commands ::struct::stack::$sub]] == 0 } {
	set optlist [lsort [info commands ::struct::stack::_*]]
	set xlist {}
	foreach p $optlist {
	    set p [namespace tail $p]
	    lappend xlist [string range $p 1 end]
	}
	set optlist [linsert [join $xlist ", "] "end-1" "or"]
	return -code error \
		"bad option \"$cmd\": must be $optlist"
    }

    uplevel 1 [linsert $args 0 ::struct::stack::$sub $name]
}

# ::struct::stack::_clear --
#
#	Clear a stack.
#
# Arguments:
#	name	name of the stack object.
#
# Results:
#	None.

proc ::struct::stack::_clear {name} {
    set ::struct::stack::stacks($name) [list ]
    return
}

# ::struct::stack::_destroy --
#
#	Destroy a stack object by removing it's storage space and 
#	eliminating it's proc.
#
# Arguments:
#	name	name of the stack object.
#
# Results:
#	None.

proc ::struct::stack::_destroy {name} {
    unset ::struct::stack::stacks($name)
    interp alias {} $name {}
    return
}

# ::struct::stack::_peek --
#
#	Retrieve the value of an item on the stack without popping it.
#
# Arguments:
#	name	name of the stack object.
#	count	number of items to pop; defaults to 1
#
# Results:
#	items	top count items from the stack; if there are not enough items
#		to fulfill the request, throws an error.

proc ::struct::stack::_peek {name {count 1}} {
    variable stacks
    if { $count < 1 } {
	error "invalid item count $count"
    }

    if { $count > [llength $stacks($name)] } {
	error "insufficient items on stack to fill request"
    }

    if { $count == 1 } {
	# Handle this as a special case, so single item pops aren't listified
	set item [lindex $stacks($name) end]
	return $item
    }

    # Otherwise, return a list of items
    set result [list ]
    for {set i 0} {$i < $count} {incr i} {
	lappend result [lindex $stacks($name) "end-${i}"]
    }
    return $result
}

# ::struct::stack::_pop --
#
#	Pop an item off a stack.
#
# Arguments:
#	name	name of the stack object.
#	count	number of items to pop; defaults to 1
#
# Results:
#	item	top count items from the stack; if the stack is empty, 
#		returns a list of count nulls.

proc ::struct::stack::_pop {name {count 1}} {
    variable stacks
    if { $count > [llength $stacks($name)] } {
	error "insufficient items on stack to fill request"
    } elseif { $count < 1 } {
	error "invalid item count $count"
    }

    if { $count == 1 } {
	# Handle this as a special case, so single item pops aren't listified
	set item [lindex $stacks($name) end]
	set stacks($name) [lreplace $stacks($name) end end]
	return $item
    }

    # Otherwise, return a list of items
    set result [list ]
    for {set i 0} {$i < $count} {incr i} {
	lappend result [lindex $stacks($name) "end-${i}"]
    }

    # Remove these items from the stack
    incr i -1
    set stacks($name) [lreplace $stacks($name) "end-${i}" end]

    return $result
}

# ::struct::stack::_push --
#
#	Push an item onto a stack.
#
# Arguments:
#	name	name of the stack object
#	args	items to push.
#
# Results:
#	None.

proc ::struct::stack::_push {name args} {
    if { [llength $args] == 0 } {
	error "wrong # args: should be \"$name push item ?item ...?\""
    }
    foreach item $args {
	lappend ::struct::stack::stacks($name) $item
    }
}

# ::struct::stack::_rotate --
#
#	Rotate the top count number of items by step number of steps.
#
# Arguments:
#	name	name of the stack object.
#	count	number of items to rotate.
#	steps	number of steps to rotate.
#
# Results:
#	None.

proc ::struct::stack::_rotate {name count steps} {
    variable stacks
    set len [llength $stacks($name)]
    if { $count > $len } {
	error "insufficient items on stack to fill request"
    }

    # Rotation algorithm:
    # do
    #   Find the insertion point in the stack
    #   Move the end item to the insertion point
    # repeat $steps times

    set start [expr {$len - $count}]
    set steps [expr {$steps % $count}]
    for {set i 0} {$i < $steps} {incr i} {
	set item [lindex $stacks($name) end]
	set stacks($name) [lreplace $stacks($name) end end]
	set stacks($name) [linsert $stacks($name) $start $item]
    }
    return
}

# ::struct::stack::_size --
#
#	Return the number of objects on a stack.
#
# Arguments:
#	name	name of the stack object.
#
# Results:
#	count	number of items on the stack.

proc ::struct::stack::_size {name} {
    return [llength $::struct::stack::stacks($name)]
}

# ### ### ### ######### ######### #########
## Ready

namespace eval ::struct {
    # Get 'stack::stack' into the general structure namespace.
    namespace import -force stack::stack
    namespace export stack
}
package provide struct::stack 1.3
stack-1.3.tm {F 7021 7021}# 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 Zveno Pty Ltd
# http://www.zveno.com/
# 
# Zveno makes this software and all associated data and documentation
# ('Software') available free of charge for any purpose.
# Copies may be made of this Software but all of this notice must be included
# on any copy.
# 
# The Software was developed for research purposes and Zveno does not warrant
# that it is error free or fit for any purpose.  Zveno disclaims any
# liability for all claims, expenses, losses, damages and costs any user may
# incur as a result of using, copying or modifying the Software.
#
# $Id: xml__tcl.tcl,v 1.3 2004/09/02 13:59:38 matben Exp $

package provide xml::tcl 99.0

#if {![catch {package require xml::c}]} {
#    return -code error "this package is incompatible with xml::c"
#}

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

	    eval $classinfo(-createentityparsercommand) [list $name $new] $args

	    return $new
	}

	free {
	    eval $classinfo(-deletecommand) [list $name]
	    unset data
	    rename $name {}
	}

	get {
	    eval $classinfo(-getcommand) [list $name] $args
	}

	parse {
	    if {[llength $args] < 1} {
		return -code error "wrong number of arguments, should be $name parse xml ?options?"
	    }
	    eval $classinfo(-parsecommand) [list $name] $args
	}

	reset {
	    eval $classinfo(-deletecommand) [list $name]
	    eval $classinfo(-createcommand) [list $name]
	}

	default {
	    return -code error "unknown method"
	}
    }

    return {}
}

# xml::noop --
#
#	Do nothing utility proc
#
# Arguments:
#	args	whatever
#
# Results:
#	Nothing happens

proc xml::noop args {}
# 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-2001 Zveno Pty Ltd
# http://www.zveno.com/
# 
# Zveno makes this software and all associated data and documentation
# ('Software') available free of charge for any purpose.
# Copies may be made of this Software but all of this notice must be included
# on any copy.
# 
# The Software was developed for research purposes and Zveno does not warrant
# that it is error free or fit for any purpose.  Zveno disclaims any
# liability for all claims, expenses, losses, damages and costs any user may
# incur as a result of using, copying or modifying the Software.
#
# Copyright (c) 1997 Australian National University (ANU).
# 
# ANU makes this software and all associated data and documentation
# ('Software') available free of charge for any purpose. You may make copies
# of the Software but you must include all of this notice on any copy.
# 
# The Software was developed for research purposes and ANU does not warrant
# that it is error free or fit for any purpose.  ANU disclaims any
# liability for all claims, expenses, losses, damages and costs any user may
# incur as a result of using, copying or modifying the Software.
#
# $Id: tclparser-8.1.tcl,v 1.3 2004/09/02 13:59:38 matben Exp $

package require Tcl 8.1

package provide xml::tclparser 99.0

package require xmldefs 2.0

package require sgmlparser 99.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]
}

# xml::tclparser::create --
#
#	Creates XML parser object.
#
# Arguments:
#	name	unique identifier for this instance
#
# Results:
#	The state variable is initialised.

proc xml::tclparser::create name {

    # Initialise state variable
    upvar \#0 [namespace current]::$name parser
    array set parser [list -name $name			\
	-final 1					\
	-validate 0					\
	-statevariable [namespace current]::$name	\
	-baseurl {}					\
	internaldtd {}					\
	entities [namespace current]::Entities$name	\
	extentities [namespace current]::ExtEntities$name	\
	parameterentities [namespace current]::PEntities$name	\
	externalparameterentities [namespace current]::ExtPEntities$name \
	elementdecls [namespace current]::ElDecls$name	\
	attlistdecls [namespace current]::AttlistDecls$name	\
	notationdecls [namespace current]::NotDecls$name	\
	depth 0						\
	leftover {}                                     \
    ]

    # Initialise entities with predefined set
    array set [namespace current]::Entities$name [array get ::sgml::EntityPredef]

    return $name
}

# xml::tclparser::createentityparser --
#
#	Creates XML parser object for an entity.
#
# Arguments:
#	name	name for the new parser
#	parent	name of parent parser
#
# Results:
#	The state variable is initialised.

proc xml::tclparser::createentityparser {parent name} {
    upvar #0 [namespace current]::$parent p

    # Initialise state variable
    upvar \#0 [namespace current]::$name external
    array set external [array get p]

    array set external [list -name $name			\
	-statevariable [namespace current]::$name	\
	internaldtd {}					\
	line 0						\
    ]
    incr external(depth)

    return $name
}

# xml::tclparser::configure --
#
#	Configures a XML parser object.
#
# Arguments:
#	name	unique identifier for this instance
#	args	option name/value pairs
#
# Results:
#	May change values of config options

proc xml::tclparser::configure {name args} {
    upvar \#0 [namespace current]::$name parser

    # BUG: very crude, no checks for illegal args
    # Mats: Should be synced with sgmlparser.tcl
    set options {-elementstartcommand -elementendcommand \
      -characterdatacommand -processinginstructioncommand \
      -externalentitycommand -xmldeclcommand \
      -doctypecommand -commentcommand \
      -entitydeclcommand -unparsedentitydeclcommand \
      -parameterentitydeclcommand -notationdeclcommand \
      -elementdeclcommand -attlistdeclcommand \
      -paramentityparsing -defaultexpandinternalentities \
      -startdoctypedeclcommand -enddoctypedeclcommand \
      -entityreferencecommand -warningcommand \
      -errorcommand -final \
      -validate -baseurl \
      -name -emptyelement \
      -parseattributelistcommand -parseentitydeclcommand \
      -normalize -internaldtd \
      -reportempty -ignorewhitespace \
      -reportempty \
    }
    set usage [join $options ", "]
    regsub -all -- - $options {} options
    set pat ^-([join $options |])$
    foreach {flag value} $args {
	if {[regexp $pat $flag]} {
	    # Validate numbers
	    if {[info exists parser($flag)] && \
		    [string is integer -strict $parser($flag)] && \
		    ![string is integer -strict $value]} {
		return -code error "Bad value for $flag ($value), must be integer"
	    }
	    set parser($flag) $value
	} else {
	    return -code error "Unknown option $flag, can be: $usage"
	}
    }

    return {}
}

# xml::tclparser::parse --
#
#	Parses document instance data
#
# Arguments:
#	name	parser object
#	xml	data
#	args	configuration options
#
# Results:
#	Callbacks are invoked

proc xml::tclparser::parse {name xml args} {

    array set options $args
    upvar \#0 [namespace current]::$name parser
    variable 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 -name] \
	    [array get parser -baseurl] \
	    [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:
#	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 attrs {

    set result {}

    while {[string length [string trim $attrs]]} {
	if {[regexp ($::xml::Name)[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')([::sgml::cl ^<]*?)\\2(.*) $attrs discard attrName delimiter value attrs]} {
	    lappend result $attrName [NormalizeAttValue $value]
	} elseif {[regexp $::xml::Name[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')[::sgml::cl ^<]*\$ $attrs]} {
	    return -code error [list {unterminated attribute value} $result $attrs]
	} else {
	    return -code error "invalid attribute list"
	}
    }

    return $result
}

# xml::tclparser::NormalizeAttValue --
#
#	Perform attribute value normalisation.  This involves:
#	. character references are appended to the value
#	. entity references are recursively processed and replacement value appended
#	. whitespace characters cause a space to be appended
#	. other characters appended as-is
#
#	Because no state is passed in here, it's a bit difficult
#	to pass entity references back into the parser for further
#	replacement.  I'll just punt on the whole thing for now and do
#	basic normalisation - char refs, pre-defined entities and ws.
#
# Arguments:
#	value	unparsed attribute value
#
# Results:
#	Normalised value returned.

proc xml::tclparser::NormalizeAttValue 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 {\1}]} value

    return [subst $value]
}

# xml::tclparser::NormalizeAttValue:DeRef --
#
#	Simplistic handler to normalize attribute values
#
# Arguments:
#	ref	entity reference
#
# Results:
#	Returns character

proc xml::tclparser::NormalizeAttValue:DeRef ref {
    switch -glob -- $ref {
	#x* {
	    scan [string range 2 $ref] %x value
	    return $value
	}
	#* {
	    scan [string range 1 $ref] %d value
	    return $value
	}
	lt -
	gt -
	amp -
	quot -
	apos {
	    array set map {lt < gt > amp & quot \" apos '}
	    return $map($ref)
	}
	default {
	    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} {
}
tclparser-99.0.tm {F 14377 14377} tcl-99.0.tm {F 6542 20919}groupchat-1.0.tm {F 4307 32333} muc-0.2.tm {F 16444 48777} sha1-1.0.3.tm {F 9119 424691} streamerror-1.0.tm {F 5196 174053} cmdline-1.2.3.tm {F 30109 415572} base64-2.3.1.tm {F 31410 456101} sgmlparser-99.0.tm {F 82350 157447} wrapper-1.0.tm {F 46299 385463} struct {D 26 21005} xml-99.0.tm {F 131 168857} sgml-1.8.tm {F 7554 165001} stanzaerror-1.0.tm {F 3755 177808} xml {D 60 60} roster-1.0.tm {F 33402 232265} textutil-0.6.2.tm {F 137495 658150} service-1.0.tm {F 21055 198863} htmlparse-1.1.tm {F 28668 520655} jlib-2.0.tm {F 106899 339164} browse-2.0.tm {F 26320 75097} log-1.2.tm {F 35886 491987} xmldefs-2.0.tm {F 3725 168726}tkchat.tcl {F 235283 894067} modules {D 634 634}trofs010