#!/usr/bin/tclsh




proc printUsage {exitCode} {
    puts stderr "Usage: $::argv0 \[OPTION\]... \[DIRECTORY|CONFIGURATIONFILE\]..."
    puts stderr {  --debug                module errors verbose reporting}
    puts stderr {  -f, --foreground       run in foreground as opposed to daemon mode}
    puts stderr {  -h, --help             display this help and exit}
    puts stderr {  -m, --mailto           send an email to specified address at startup}
    puts stderr {  -p, --poll-files-time  loaded files monitoring poll time in seconds}
    puts stderr {  --pid-file             file containing the daemon process ID}
    puts stderr {  -r                     preferences file name}
    puts stderr {  --version              output version information and exit}
    exit $exitCode
}

proc printVersion {} {
    puts "moomps (a Modular Object Oriented Multi-Purpose Service) version $global::applicationVersion"
}




package provide miscellaneous [lindex {$Revision: 1.13 $} 1]


proc minimum {a b} {return [expr {$a < $b? $a: $b}]}
proc maximum {a b} {return [expr {$a > $b? $a: $b}]}

proc ldelete {listName value} {
    upvar 1 $listName list

    set index [lsearch -exact $list $value]
    if {$index < 0} {
        error "\"$value\" is not in list"
    }
    set list [lreplace $list $index $index]
}

proc static {localName args} {
    set global [uplevel 1 namespace which -command [lindex [info level -1] 0]]:$localName
    uplevel 1 upvar #0 $global $localName
    if {![info exists $global]} {
        switch [llength $args] {
            0 return
            1 {set $global [lindex $args 0]}
            default {error {usage: static name ?value?}}
        }
    }
}

proc formattedTime {seconds} {
    set string {}
    set interval [expr {$seconds / 86400}]
    if {$interval > 0} {
        append string ${interval}d
        set seconds [expr {$seconds % 86400}]
    }
    set interval [expr {$seconds / 3600}]
    if {$interval > 0} {
        append string ${interval}h
        set seconds [expr {$seconds % 3600}]
    }
    set interval [expr {$seconds / 60}]
    if {$interval > 0} {
        append string ${interval}m
        set seconds [expr {$seconds % 60}]
    }
    append string ${seconds}s
    return $string
}



namespace eval global {
    variable withGUI [expr {![catch {package present Tk}]}]
    variable debug 0
    variable 32BitIntegerMinimum -2147483648
    variable 32BitIntegerMaximum 2147483647
    variable 32BitUnsignedIntegerMaximum 4294967295
    variable 64BitIntegerMinimum -9223372036854775808
    variable 64BitIntegerMaximum 9223372036854775807
    variable 64BitUnsignedIntegerMaximum 18446744073709551615
    if {$withGUI} {
        variable applicationName moodss
        variable applicationVersion 19.7
        variable messenger
        variable scroll
        variable canvas
        variable static
        variable windowManager
        variable fileMenuContextHelper
        variable fileMenuContextHelperSaveIndex
        variable fileDatabaseMenu
        variable fileDatabaseMenuStartIndex
        variable fileDatabaseStartButton
        variable fileDatabaseStartButtonTip
        variable saveFile
        variable xWindowManagerInitialOffset 30
        variable yWindowManagerInitialOffset 20
        variable graphNumberOfIntervals 100
        variable graphMinimumY {}
        variable graphXAxisLabelsRotation 90
        variable graphLabelsPositions [list right bottom left top]
        variable graphLabelsPosition right
        variable graphPlotBackground black
        variable graphDisplayGrid 0
        variable viewerHeight 200
        variable viewerWidth 400
        variable canvasWidth 0; variable canvasHeight 0
        variable canvasBackground white
        variable canvasImage
        variable canvasImageFile {}
        variable canvasImagePosition nw
        variable canvasImageItem
        variable pieLabeler peripheral
        variable viewerColors {#7FFFFF #FFFF7F #FF7F7F #7FFF7F #7F7FFF #FFBF00 #BFBFBF #FF7FFF #FFFFFF}
        variable fileDirectory [pwd]
        variable readOnly
        variable showTrace 0
        variable traceGeometry
        variable iconPadding 2
        variable printDialogCommand
        if {[string equal $::tcl_platform(platform) unix]} {
            set printDialogCommand print::printOrSaveCanvas
        } else {
            set printDialogCommand {after idle PrintWindow $global::canvas -margins 0.5,0.5,0.5,0.5 -colordepth 8 -title moodss}
        }
        variable showToolBar 1
        variable fileSaveHelpTip
        variable pagesWidth 65536
        variable pagesTabPosition bottom
        variable traceThresholds 1
        button .temporary
        variable fontFamily [font actual [.temporary cget -font] -family]
        variable fontSize [font actual [.temporary cget -font] -size]
        if {$fontSize < 12} {set fontSize 12}
        destroy .temporary
        variable viewerMessageColor blue
        variable snapDistance; array set snapDistance {window 10 border 10}
        variable currentValueTableRows 1000
        variable cellsLabelModuleHeader 1
        variable fileCloseImage
        variable separatorCut 6
        variable printToFile 0
        variable fileToPrintTo moodss.ps
        variable printCommand {lpr -P%P}
        variable printOrientations {landscape portrait}
        variable printOrientation portrait
        variable printPalettes {color gray monochrome}
        variable printPalette color
        variable printPaperSizes [list            {A3 (297 x 420 millimeters)} {A4 (210 x 297 millimeters)} {executive (7 1/2 x 10 inches)} {legal (8 1/2 x 14 inches)}            {letter (8 1/2 x 11 inches)}        ]
        variable printPaperSize [lindex $printPaperSizes end]
    } else {
        variable applicationName moomps
        variable applicationVersion 4.6
        variable formulasDialog
    }
    variable pollTimes {}
    variable pollTime 0
    variable fromAddress $::tcl_platform(user)
    variable smtpServers 127.0.0.1
    variable mail
    set mail(subject,default) {%A threshold %l message}
    set mail(body,default) "%l: \"%s\" data value is now \"%v\",\nwhich triggered the \"%T\" threshold of \"%t\"."
    variable mailSubject $mail(subject,default)
    variable mailBody $mail(body,default)
    variable logMessage {"%s" = "%v" (triggered "%T" threshold "%t")}
    variable dataTypes {ascii clock dictionary integer real}
    variable numericDataTypes {integer real}
    variable traceNumberOfRows 20
    if {[package vcompare $::tcl_version 8.4] < 0} {
        variable sqliteDefaultFile [file join $::env(HOME) moodss.dat]
    } else {
        variable sqliteDefaultFile [file normalize ~/moodss.dat]
    }
    variable databaseOptions [list -dsn {} -file $sqliteDefaultFile -host {} -password {} -port {} -user {}]
    variable database 0
    variable moompsResourceFile /etc/moomps/rc
    if {![file writable $moompsResourceFile]} {
        set moompsResourceFile {}
    }
    variable passwordOptionExpression {^-.*passw(d|ord)$}
}



proc commaSeparatedString {words} {
    for {set index 0} {$index < ([llength $words] - 1)} {incr index} {
        append string "[lindex $words $index], "
    }
    append string [lindex $words $index]
    return $string
}

proc startGatheringPackageDirectories {} {
    catch {rename source _source}
    proc source {file} {
        if {![string equal [file tail $file] pkgIndex.tcl]} {
            return [uplevel 1 _source [list $file]]
        }
        foreach name [package names] {
            set versions($name) [package versions $name]
        }
        uplevel 1 _source [list $file]
        set directory [file dirname $file]
        foreach name [package names] {
            set available [package versions $name]
            if {[info exists versions($name)]} {
                if {[llength $available] > [llength $versions($name)]} {
                    set ::package(exact,$name) {}
                    if {![info exists ::package(moodss,$name)]} {
                        set ::package(directory,$name) $directory
                        set ::package(version,$name) [lindex $available end]
                    }
                }
            } else {
                set ::package(directory,$name) $directory
                set ::package(version,$name) $available
                if {[string match *moodss* $directory]} {
                    set ::package(moodss,$name) {}
                }
            }
        }
    }
}

proc temporaryFileName {{extension {}} {identifier {}}} {
    if {[string length $identifier] == 0} {
        set identifier [pid]
    }
    switch $::tcl_platform(platform) {
        macintosh {
            error {not implemented yet}
        }
        unix {
            foreach directory {/var/tmp /usr/tmp /tmp} {
                if {[file isdirectory $directory] && [file writable $directory]} break
            }
        }
        windows {
            set directory c:/windows/temp
            catch {set directory $::env(TEMP)}
        }
    }
    set name [file join $directory moodss$identifier]
    if {[string length $extension] > 0} {
        append name .$extension
    }
    return $name
}

proc linesCount {string} {
    return [llength [split $string \n]]
}

proc compareClocks {value1 value2} {
    return [expr {[clock scan $value1 -base 0] - [clock scan $value2 -base 0]}]
}

proc emailAddressError {string} {
    set string [string trim $string]
    if {[string length $string] == 0} {return {blank address}}
    foreach list [mime::parseaddress $string] {
        array set array $list
    }
    return $array(error)
}

proc sendTextEmail {from to subject text} {
    set token [mime::initialize -canonical text/plain -string $text]
    lappend headers -servers [list $global::smtpServers]
    lappend headers -header [list From $from]
    foreach address $to {
        lappend headers -header [list To $address]
    }
    lappend headers -header [list Subject $subject]
    eval smtp::sendmessage $token $headers
}

if {$global::withGUI} {

proc intersect {rectangle1 rectangle2} {
    foreach {left1 top1 right1 bottom1} $rectangle1 {left2 top2 right2 bottom2} $rectangle2 {}
    return [expr {!(($right1 < $left2) || ($left1 > $right2) || ($bottom1 < $top2) || ($top1 > $bottom2))}]
}

proc serialize {document} {
    return [dom::serialize $document -indent 0 -indentspec {2 {{} {}}}]
}

proc nodeFromList {parentNode name values} {
    set node [dom::document createElement $parentNode $name]
    foreach value $values {
        dom::document createTextNode [dom::document createElement $node item] $value
    }
    return $node
}

}

proc listFromNode {parentNode {path {}}} {
    if {[string length $path] > 0} {
        append path /
    }
    append path item
    set values {}
    foreach node [dom::selectNode $parentNode $path] {
        lappend values [dom::node stringValue $node]
    }
    return $values
}

if {$global::withGUI} {

proc busy {set {paths {}} {cursor watch}} {
    static lifo

    if {[llength $paths] == 0} {
        set paths .
        foreach path [winfo children .] {
            if {[string equal [winfo class $path] Toplevel]} {
                lappend paths $path
            }
        }
    }
    if {$set} {
        foreach path $paths {
            if {![info exists lifo($path)]} {
                set lifo($path) [new lifo]
            }
            xifo::in $lifo($path) [$path cget -cursor]
            $path configure -cursor $cursor
        }
        update idletasks
    } else {
        foreach path $paths {
            if {[catch {set stack $lifo($path)}]} continue
            catch {$path configure -cursor [xifo::out $stack]}
            if {[xifo::isEmpty $stack]} {
                delete $stack
                unset lifo($path)
            }
        }
    }
    if {[string equal $::tcl_platform(platform) windows]} update
}

proc centerMessage {path text {background {}} {foreground {}}} {
    set label $path.centeredMessage
    if {[string length $text] == 0} {
        catch {destroy $label}
        set label {}
    } else {
        if {![winfo exists $label]} {
            label $label
        }
        $label configure -text $text -background $background -foreground $foreground
        place $label -relx 0.5 -rely 0.5 -anchor center
    }
    return $label
}

proc 3DBorders {path background} {
    set intensity 65535
    foreach {red green blue} [winfo rgb $path $background] {}
    if {(($red * 0.5 * $red) + ($green * 1.0 * $green) + ($blue * 0.28 * $blue)) < ($intensity * 0.05 * $intensity)} {
        set dark [format {#%04X%04X%04X}            [expr {($intensity + (3 * $red)) / 4}] [expr {($intensity + (3 * $green)) / 4}] [expr {($intensity + (3 * $blue)) / 4}]        ]
    } else {
        set dark [format {#%04X%04X%04X} [expr {(60 * $red) / 100}] [expr {(60 * $green) / 100}] [expr {(60 * $blue) / 100}]]
    }
    if {$green > ($intensity * 0.95)} {
        set light [format {#%04X%04X%04X} [expr {(90 * $red) / 100}] [expr {(90 * $green) / 100}] [expr {(90 * $blue) / 100}]]
    } else {
        set tmp1 [expr {(14 * $red) / 10}]
        if {$tmp1 > $intensity} {set tmp1 $intensity}
        set tmp2 [expr {($intensity + $red) / 2}]
        set lightRed [expr {($tmp1 > $tmp2)? $tmp1: $tmp2}]
        set tmp1 [expr {(14 * $green) / 10}]
        if {$tmp1 > $intensity} {set tmp1 $intensity}
        set tmp2 [expr {($intensity + $green) / 2}]
        set lightGreen [expr {($tmp1 > $tmp2)? $tmp1: $tmp2}]
        set tmp1 [expr {(14 * $blue) / 10}]
        if {$tmp1 > $intensity} {set tmp1 $intensity}
        set tmp2 [expr {($intensity + $blue) / 2}]
        set lightBlue [expr {($tmp1 > $tmp2)? $tmp1: $tmp2}]
        set light [format {#%04X%04X%04X} $lightRed $lightGreen $lightBlue]
    }
    return [list $dark $light]
}

proc setupTextBindings {path} {
    bind $path <Control-x> [bind Text <<Cut>>]
    bind $path <Control-c> [bind Text <<Copy>>]
    bind $path <Control-v> [bind Text <<Paste>>]
}

proc vectors {left top width height} {
    return [list        $left $top $width 0 $left [expr {$top + $height}] $width 0 $left $top 0 $height [expr {$left + $width}] $top 0 $height    ]
}

if {[package vcompare $::tcl_version 8.4] < 0} {

    proc setupGlobalMouseWheelBindings {} {
        set classes [list Text Listbox Table TreeCtrl]
        foreach class $classes {bind $class <MouseWheel> {}}
        if {[string equal $::tcl_platform(platform) unix]} {
            foreach class $classes {
                bind $class <4> {}
                bind $class <5> {}
            }
        }
        bind all <MouseWheel> [list ::tkMouseWheel %W %D %X %Y]
        if {[string equal $::tcl_platform(platform) unix]} {
            bind all <4> [list ::tkMouseWheel %W 120 %X %Y]
            bind all <5> [list ::tkMouseWheel %W -120 %X %Y]
        }
    }
    proc ::tkMouseWheel {fired D X Y} {
        if {[string length [bind [winfo class $fired] <MouseWheel>]] > 0} return
        set w [winfo containing $X $Y]
        if {![winfo exists $w]} {catch {set w [focus]}}
        if {[winfo exists $w]} {
            if {[string equal [winfo class $w] Scrollbar]} {
                catch {tkScrollByUnits $w [string index [$w cget -orient] 0] [expr {-($D / 30)}]}
            } else {
                switch [winfo class $w] {Text - Listbox - Table - TreeCtrl {} default return}
                catch {$w yview scroll [expr {-($D / 120) * 4}] units}
            }
        }
    }

    proc underlineAmpersand {text} {
        set idx [string first "&" $text]
        if {$idx >= 0} {
            set underline $idx
            while {[string match "&" [string index $text [expr {$idx + 1}]]]} {
                set base [expr {$idx + 2}]
                set idx  [string first "&" [string range $text $base end]]
                if {$idx < 0} {
                    break
                } else {
                    set underline [expr {$underline + $idx + 1}]
                    incr idx $base
                }
            }
        }
        if {$idx >= 0} {
            regsub -all -- {&([^&])} $text {\1} text
        }
        return [list $text $idx]
    }

} else {

    proc setupGlobalMouseWheelBindings {} {
        set mw_classes [list Text Listbox Table TreeCtrl]
        foreach class $mw_classes { bind $class <MouseWheel> {} }
        if {[tk windowingsystem] eq "x11"} {
            foreach class $mw_classes {
                bind $class <4> {}
                bind $class <5> {}
            }
        }
        bind all <MouseWheel> [list ::tk::MouseWheel %W %D %X %Y]
        if {[tk windowingsystem] eq "x11"} {
            bind all <4> [list ::tk::MouseWheel %W 120 %X %Y]
            bind all <5> [list ::tk::MouseWheel %W -120 %X %Y]
        }
    }
    proc ::tk::MouseWheel {wFired D X Y} {
        if {[bind [winfo class $wFired] <MouseWheel>] ne ""} { return }
        set w [winfo containing $X $Y]
        if {![winfo exists $w]} { catch {set w [focus]} }
        if {[winfo exists $w]} {
            if {[winfo class $w] eq "Scrollbar"} {
                catch {tk::ScrollByUnits $w                     [string index [$w cget -orient] 0]                     [expr {-($D / 30)}]}
            } else {
                switch [winfo class $w] {Text - Listbox - Table - TreeCtrl {} default return}
                catch {$w yview scroll [expr {-($D / 120) * 4}] units}
            }
        }
    }

    proc underlineAmpersand {text} {
        return [::tk::UnderlineAmpersand $text]
    }

}

proc dragEcho {data format} {
    return $data
}

proc bounds {canvas} {
    foreach {left top right bottom} [$canvas cget -scrollregion] {}
    return [list        $left $top        [expr {$left + [maximum [winfo width $canvas] [expr {$right - $left}]]}]        [expr {$top + [maximum [winfo height $canvas] [expr {$bottom - $top}]]}]    ]
}

proc fenceRectangle {canvas list} {
    foreach {xMinimum yMinimum} [pages::closestPageTopLeftCorner [lindex $list 0]] {}
    foreach {left top right bottom} [bounds $canvas] {}
    set xMaximum [expr {$xMinimum + ($right - $left)}]; set yMaximum [expr {$yMinimum + ($bottom - $top)}]
    foreach {left top right bottom} $list {}
    set x 0; set y 0
    if {$left < $xMinimum} {
        set x [expr {$xMinimum - $left}]
    } elseif {$right > $xMaximum} {
        set x [expr {$xMaximum - $right}]
    }
    if {$top < $yMinimum} {
        set y [expr {$yMinimum - $top}]
    } elseif {$bottom > $yMaximum} {
        set y [expr {$yMaximum - $bottom}]
    }
    return [list $x $y]
}

proc fence {canvas itemOrTag} {
    if {([winfo width $canvas] <= 1) || ([winfo height $canvas] <= 1)} return
    foreach {x y} [fenceRectangle $canvas [$canvas bbox $itemOrTag]] {}
    if {($x != 0) || ($y != 0)} {
        $canvas move $itemOrTag $x $y
    }
}

proc visibleForeground {background {path .}} {
    foreach {red green blue} [winfo rgb $path $background] {}
    if {($red + $green + $blue) >= (32768 * 3)} {
        return black
    } else {
        return white
    }
}


}
startGatheringPackageDirectories



proc parseCommandLineArguments {switches arguments arrayName} {
    upvar 1 $arrayName data

    if {[llength $switches] == 0} {
        return $arguments
    }
    foreach {value flag} $switches {
        if {![string match {[-+]*} $value] || ![string match {[01]} $flag]} {
            error "invalid switches: $switches"
        }
    }
    unset flag
    array set flag $switches

    set index 0
    foreach value $arguments {
        set argument($index) $value
        incr index
    }
    set maximum $index
    for {set index 0} {$index < $maximum} {incr index} {
        set switch $argument($index)
        if {![info exists flag($switch)]} break
        if {[string equal $switch --]} {
            incr index
            break
        }
        if {$flag($switch)} {
            if {[catch {set value $argument([incr index])}] || [string match {[-+]*} $value]} {
                error "no value for switch $switch"
            }
            set data($switch) $value
        } else {
            set data($switch) {}
        }
    }
    return [lrange $arguments $index end]
}

if {[catch    {        set argv [parseCommandLineArguments            {
                --debug 0 -f 0 --foreground 0 -h 0 -he 0 -hel 0 -help 0 --help 0 -m 1 --mailto 1 --pid-file 1
                -p 1 --poll-files-time 1 -r 1 --version 0
            } $argv arguments        ]    } message]} {
    puts stderr $message
    printUsage 1
}

foreach {short long} {-f --foreground -h --help -m --mailto -p --poll-files-time} {
    catch {set arguments($short) $arguments($long)}
}

if {    [info exists arguments(-h)] || [info exists arguments(-he)] || [info exists arguments(-hel)] ||    [info exists arguments(-help)]} {
    printUsage 1
}
set pollFilesTime 60000
if {[info exists arguments(-p)] && [catch {expr {$arguments(-p) * 1000}} pollFilesTime]} {
    printUsage 1
}
if {[info exists arguments(--version)]} {
    printVersion
    exit
}
if {[llength $argv] == 0} {
    printUsage 1
}
set preferencesFile /etc/moomps/rc
if {[info exists arguments(-r)]} {
    set preferencesFile $arguments(-r)
    if {![file readable $preferencesFile]} {
        puts stderr "cannot access preferences file: $preferencesFile"
        exit 1
    }
}
foreach file $argv {
    if {![file readable $file]} {
        puts stderr "cannot access file: $file"
        exit 1
    }
}

set global::debug [info exists arguments(--debug)]

# 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
##################################################
#
# md5.tcl - MD5 in Tcl
# Author: Don Libes <libes@nist.gov>, July 1999
# Version 1.2.0
#
# MD5  defined by RFC 1321, "The MD5 Message-Digest Algorithm"
# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
#
# Most of the comments below come right out of RFC 1321; That's why
# they have such peculiar numbers.  In addition, I have retained
# original syntax, bugs in documentation (yes, really), etc. from the
# RFC.  All remaining bugs are mine.
#
# HMAC implementation by D. J. Hagberg <dhagberg@millibits.com> and
# is based on C code in RFC 2104.
#
# For more info, see: http://expect.nist.gov/md5pure
#
# - Don
#
# Modified by Miguel Sofer to use inlines and simple variables
##################################################

package require Tcl 8.2
namespace eval ::md5 {
}

if {![catch {package require Trf 2.0}] && ![catch {::md5 -- test}]} {
    # Trf is available, so implement the functionality provided here
    # in terms of calls to Trf for speed.

    proc ::md5::md5 {msg} {
	string tolower [::hex -mode encode -- [::md5 -- $msg]]
    }

    # hmac: hash for message authentication

    # MD5 of Trf and MD5 as defined by this package have slightly
    # different results. Trf returns the digest in binary, here we get
    # it as hex-string. In the computation of the HMAC the latter
    # requires back conversion into binary in some places. With Trf we
    # can use omit these.

    proc ::md5::hmac {key text} {
	# if key is longer than 64 bytes, reset it to MD5(key).  If shorter, 
	# pad it out with null (\x00) chars.
	set keyLen [string length $key]
	if {$keyLen > 64} {
	    #old: set key [binary format H32 [md5 $key]]
	    set key [::md5 -- $key]
	    set keyLen [string length $key]
	}
    
	# ensure the key is padded out to 64 chars with nulls.
	set padLen [expr {64 - $keyLen}]
	append key [binary format "a$padLen" {}]

	# Split apart the key into a list of 16 little-endian words
	binary scan $key i16 blocks

	# XOR key with ipad and opad values
	set k_ipad {}
	set k_opad {}
	foreach i $blocks {
	    append k_ipad [binary format i [expr {$i ^ 0x36363636}]]
	    append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]]
	}
    
	# Perform inner md5, appending its results to the outer key
	append k_ipad $text
	#old: append k_opad [binary format H* [md5 $k_ipad]]
	append k_opad [::md5 -- $k_ipad]

	# Perform outer md5
	#old: md5 $k_opad
	string tolower [::hex -mode encode -- [::md5 -- $k_opad]]
    }

} else {
    # Without Trf use the all-tcl implementation by Don Libes.

    # T will be inlined after the definition of md5body

    # test md5
    #
    # This proc is not necessary during runtime and may be omitted if you
    # are simply inserting this file into a production program.
    #
    proc ::md5::test {} {
	foreach {msg expected} {
	    ""
	    "d41d8cd98f00b204e9800998ecf8427e"
	    "a"
	    "0cc175b9c0f1b6a831c399e269772661"
	    "abc"
	    "900150983cd24fb0d6963f7d28e17f72"
	    "message digest"
	    "f96b697d7cb7938d525a2f31aaf161d0"
	    "abcdefghijklmnopqrstuvwxyz"
	    "c3fcd3d76192e4007dfb496cca67e13b"
	    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
	    "d174ab98d277d9f5a5611c2c9f419d9f"
	    "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
	    "57edf4a22be3c955ac49da2e2107b67a"
	} {
	    puts "testing: md5 \"$msg\""
	    set computed [md5 $msg]
	    puts "expected: $expected"
	    puts "computed: $computed"
	    if {0 != [string compare $computed $expected]} {
		puts "FAILED"
	    } else {
		puts "SUCCEEDED"
	    }
	}
    }

    # time md5
    #
    # This proc is not necessary during runtime and may be omitted if you
    # are simply inserting this file into a production program.
    #
    proc ::md5::time {} {
	foreach len {10 50 100 500 1000 5000 10000} {
	    set time [::time {md5 [format %$len.0s ""]} 100]
	    set msec [lindex $time 0]
	    puts "input length $len: [expr {$msec/1000}] milliseconds per interation"
	}
    }

    #
    # We just define the body of md5pure::md5 here; later we
    # regsub to inline a few function calls for speed
    #

    set ::md5::md5body {

	#
	# 3.1 Step 1. Append Padding Bits
	#

	set msgLen [string length $msg]

	set padLen [expr {56 - $msgLen%64}]
	if {$msgLen % 64 > 56} {
	    incr padLen 64
	}

	# pad even if no padding required
	if {$padLen == 0} {
	    incr padLen 64
	}

	# append single 1b followed by 0b's
	append msg [binary format "a$padLen" \200]

	#
	# 3.2 Step 2. Append Length
	#

	# RFC doesn't say whether to use little- or big-endian
	# code demonstrates little-endian
	# This step limits our input to size 2^32b or 2^24B
	append msg [binary format "i1i1" [expr {8*$msgLen}] 0]
	
	#
	# 3.3 Step 3. Initialize MD Buffer
	#

	set A [expr 0x67452301]
	set B [expr 0xefcdab89]
	set C [expr 0x98badcfe]
	set D [expr 0x10325476]

	#
	# 3.4 Step 4. Process Message in 16-Word Blocks
	#

	# process each 16-word block
	# RFC doesn't say whether to use little- or big-endian
	# code says little-endian
	binary scan $msg i* blocks

	# loop over the message taking 16 blocks at a time

	foreach {X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15} $blocks {

	    # Save A as AA, B as BB, C as CC, and D as DD.
	    set AA $A
	    set BB $B
	    set CC $C
	    set DD $D

	    # Round 1.
	    # Let [abcd k s i] denote the operation
	    #      a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s).
	    # [ABCD  0  7  1]  [DABC  1 12  2]  [CDAB  2 17  3]  [BCDA  3 22  4]
	    set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X0  + $T01}]  7]}]
	    set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X1  + $T02}] 12]}]
	    set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X2  + $T03}] 17]}]
	    set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X3  + $T04}] 22]}]
	    # [ABCD  4  7  5]  [DABC  5 12  6]  [CDAB  6 17  7]  [BCDA  7 22  8]
	    set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X4  + $T05}]  7]}]
	    set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X5  + $T06}] 12]}]
	    set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X6  + $T07}] 17]}]
	    set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X7  + $T08}] 22]}]
	    # [ABCD  8  7  9]  [DABC  9 12 10]  [CDAB 10 17 11]  [BCDA 11 22 12]
	    set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X8  + $T09}]  7]}]
	    set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X9  + $T10}] 12]}]
	    set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X10 + $T11}] 17]}]
	    set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X11 + $T12}] 22]}]
	    # [ABCD 12  7 13]  [DABC 13 12 14]  [CDAB 14 17 15]  [BCDA 15 22 16]
	    set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X12 + $T13}]  7]}]
	    set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X13 + $T14}] 12]}]
	    set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X14 + $T15}] 17]}]
	    set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X15 + $T16}] 22]}]

	    # Round 2.
	    # Let [abcd k s i] denote the operation
	    #      a = b + ((a + G(b,c,d) + X[k] + T[i]) <<< s).
	    # Do the following 16 operations.
	    # [ABCD  1  5 17]  [DABC  6  9 18]  [CDAB 11 14 19]  [BCDA  0 20 20]
	    set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X1  + $T17}]  5]}]
	    set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X6  + $T18}]  9]}]
	    set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X11 + $T19}] 14]}]
	    set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X0  + $T20}] 20]}]
	    # [ABCD  5  5 21]  [DABC 10  9 22]  [CDAB 15 14 23]  [BCDA  4 20 24]
	    set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X5  + $T21}]  5]}]
	    set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X10 + $T22}]  9]}]
	    set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X15 + $T23}] 14]}]
	    set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X4  + $T24}] 20]}]
	    # [ABCD  9  5 25]  [DABC 14  9 26]  [CDAB  3 14 27]  [BCDA  8 20 28]
	    set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X9  + $T25}]  5]}]
	    set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X14 + $T26}]  9]}]
	    set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X3  + $T27}] 14]}]
	    set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X8  + $T28}] 20]}]
	    # [ABCD 13  5 29]  [DABC  2  9 30]  [CDAB  7 14 31]  [BCDA 12 20 32]
	    set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X13 + $T29}]  5]}]
	    set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X2  + $T30}]  9]}]
	    set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X7  + $T31}] 14]}]
	    set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X12 + $T32}] 20]}]

	    # Round 3.
	    # Let [abcd k s t] [sic] denote the operation
	    #     a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s).
	    # Do the following 16 operations.
	    # [ABCD  5  4 33]  [DABC  8 11 34]  [CDAB 11 16 35]  [BCDA 14 23 36]
	    set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X5  + $T33}]  4]}]
	    set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X8  + $T34}] 11]}]
	    set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X11 + $T35}] 16]}]
	    set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X14 + $T36}] 23]}]
	    # [ABCD  1  4 37]  [DABC  4 11 38]  [CDAB  7 16 39]  [BCDA 10 23 40]
	    set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X1  + $T37}]  4]}]
	    set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X4  + $T38}] 11]}]
	    set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X7  + $T39}] 16]}]
	    set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X10 + $T40}] 23]}]
	    # [ABCD 13  4 41]  [DABC  0 11 42]  [CDAB  3 16 43]  [BCDA  6 23 44]
	    set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X13 + $T41}]  4]}]
	    set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X0  + $T42}] 11]}]
	    set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X3  + $T43}] 16]}]
	    set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X6  + $T44}] 23]}]
	    # [ABCD  9  4 45]  [DABC 12 11 46]  [CDAB 15 16 47]  [BCDA  2 23 48]
	    set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X9  + $T45}]  4]}]
	    set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X12 + $T46}] 11]}]
	    set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X15 + $T47}] 16]}]
	    set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X2  + $T48}] 23]}]

	    # Round 4.
	    # Let [abcd k s t] [sic] denote the operation
	    #     a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s).
	    # Do the following 16 operations.
	    # [ABCD  0  6 49]  [DABC  7 10 50]  [CDAB 14 15 51]  [BCDA  5 21 52]
	    set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X0  + $T49}]  6]}]
	    set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X7  + $T50}] 10]}]
	    set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X14 + $T51}] 15]}]
	    set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X5  + $T52}] 21]}]
	    # [ABCD 12  6 53]  [DABC  3 10 54]  [CDAB 10 15 55]  [BCDA  1 21 56]
	    set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X12 + $T53}]  6]}]
	    set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X3  + $T54}] 10]}]
	    set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X10 + $T55}] 15]}]
	    set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X1  + $T56}] 21]}]
	    # [ABCD  8  6 57]  [DABC 15 10 58]  [CDAB  6 15 59]  [BCDA 13 21 60]
	    set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X8  + $T57}]  6]}]
	    set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X15 + $T58}] 10]}]
	    set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X6  + $T59}] 15]}]
	    set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X13 + $T60}] 21]}]
	    # [ABCD  4  6 61]  [DABC 11 10 62]  [CDAB  2 15 63]  [BCDA  9 21 64]
	    set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X4  + $T61}]  6]}]
	    set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X11 + $T62}] 10]}]
	    set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X2  + $T63}] 15]}]
	    set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X9  + $T64}] 21]}]

	    # Then perform the following additions. (That is increment each
	    #   of the four registers by the value it had before this block
	    #   was started.)
	    incr A $AA
	    incr B $BB
	    incr C $CC
	    incr D $DD
	}
	# 3.5 Step 5. Output

	# ... begin with the low-order byte of A, and end with the high-order byte
	# of D.

	return [bytes $A][bytes $B][bytes $C][bytes $D]
    }

    #
    # Here we inline/regsub the functions F, G, H, I and <<< 
    #

    namespace eval ::md5 {
	#proc md5pure::F {x y z} {expr {(($x & $y) | ((~$x) & $z))}}
	regsub -all -- {\[ *F +(\$.) +(\$.) +(\$.) *\]} $md5body {((\1 \& \2) | ((~\1) \& \3))} md5body

	#proc md5pure::G {x y z} {expr {(($x & $z) | ($y & (~$z)))}}
	regsub -all -- {\[ *G +(\$.) +(\$.) +(\$.) *\]} $md5body {((\1 \& \3) | (\2 \& (~\3)))} md5body

	#proc md5pure::H {x y z} {expr {$x ^ $y ^ $z}}
	regsub -all -- {\[ *H +(\$.) +(\$.) +(\$.) *\]} $md5body {(\1 ^ \2 ^ \3)} md5body

	#proc md5pure::I {x y z} {expr {$y ^ ($x | (~$z))}}
	regsub -all -- {\[ *I +(\$.) +(\$.) +(\$.) *\]} $md5body {(\2 ^ (\1 | (~\3)))} md5body

	# bitwise left-rotate
	if {0} {
	    proc md5pure::<<< {x i} {
		# This works by bitwise-ORing together right piece and left
		# piece so that the (original) right piece becomes the left
		# piece and vice versa.
		#
		# The (original) right piece is a simple left shift.
		# The (original) left piece should be a simple right shift
		# but Tcl does sign extension on right shifts so we
		# shift it 1 bit, mask off the sign, and finally shift
		# it the rest of the way.
		
		# expr {($x << $i) | ((($x >> 1) & 0x7fffffff) >> (31-$i))}

		#
		# New version, faster when inlining
		# We replace inline (computing at compile time):
		#   R$i -> (32 - $i)
		#   S$i -> (0x7fffffff >> (31-$i))
		#

		expr { ($x << $i) | (($x >> [set R$i]) & [set S$i])}
	    }
	}
	# inline <<<
	regsub -all -- {\[ *<<< +\[ *expr +({[^\}]*})\] +([0-9]+) *\]} $md5body {(([set x [expr \1]] << \2) |  (($x >> R\2) \& S\2))} md5body

	# now replace the R and S
	set map {}
	foreach i { 
	    7 12 17 22
	    5  9 14 20
	    4 11 16 23
	    6 10 15 21 
	} {
	    lappend map R$i [expr {32 - $i}] S$i [expr {0x7fffffff >> (31-$i)}]
	}
	
	# inline the values of T
	foreach 		tName {
	    T01 T02 T03 T04 T05 T06 T07 T08 T09 T10 
	    T11 T12 T13 T14 T15 T16 T17 T18 T19 T20 
	    T21 T22 T23 T24 T25 T26 T27 T28 T29 T30 
	    T31 T32 T33 T34 T35 T36 T37 T38 T39 T40 
	    T41 T42 T43 T44 T45 T46 T47 T48 T49 T50 
	    T51 T52 T53 T54 T55 T56 T57 T58 T59 T60 
	    T61 T62 T63 T64 } 		tVal {
	    0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee
	    0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501
	    0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be
	    0x6b901122 0xfd987193 0xa679438e 0x49b40821

	    0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa
	    0xd62f105d 0x2441453  0xd8a1e681 0xe7d3fbc8
	    0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed
	    0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a

	    0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c
	    0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70
	    0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05
	    0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665

	    0xf4292244 0x432aff97 0xab9423a7 0xfc93a039
	    0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1
	    0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1
	    0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391
	} {
	    lappend map \$$tName $tVal
	}
	set md5body [string map $map $md5body]
	

	# Finally, define the proc
	proc md5 {msg} $md5body

	# unset auxiliary variables
	unset md5body tName tVal map
    }

    proc ::md5::byte0 {i} {expr {0xff & $i}}
    proc ::md5::byte1 {i} {expr {(0xff00 & $i) >> 8}}
    proc ::md5::byte2 {i} {expr {(0xff0000 & $i) >> 16}}
    proc ::md5::byte3 {i} {expr {((0xff000000 & $i) >> 24) & 0xff}}

    proc ::md5::bytes {i} {
	format %0.2x%0.2x%0.2x%0.2x [byte0 $i] [byte1 $i] [byte2 $i] [byte3 $i]
    }

    # hmac: hash for message authentication
    proc ::md5::hmac {key text} {
	# if key is longer than 64 bytes, reset it to MD5(key).  If shorter, 
	# pad it out with null (\x00) chars.
	set keyLen [string length $key]
	if {$keyLen > 64} {
	    set key [binary format H32 [md5 $key]]
	    set keyLen [string length $key]
	}

	# ensure the key is padded out to 64 chars with nulls.
	set padLen [expr {64 - $keyLen}]
	append key [binary format "a$padLen" {}]
	
	# Split apart the key into a list of 16 little-endian words
	binary scan $key i16 blocks

	# XOR key with ipad and opad values
	set k_ipad {}
	set k_opad {}
	foreach i $blocks {
	    append k_ipad [binary format i [expr {$i ^ 0x36363636}]]
	    append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]]
	}
    
	# Perform inner md5, appending its results to the outer key
	append k_ipad $text
	append k_opad [binary format H* [md5 $k_ipad]]

	# Perform outer md5
	md5 $k_opad
    }
}

package provide md5 1.4.3

# mime.tcl - MIME body parts
#
# (c) 1999-2000 Marshall T. Rose
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's
# unpublished package of 1999.
#

# new string features and inline scan are used, requiring 8.3.
package require Tcl 8.3

package provide mime 1.4

if {[catch {package require Trf  2.0}]} {

    # Fall-back to tcl-based procedures of base64 and quoted-printable encoders
    # Warning!
    # These are a fragile emulations of the more general calling sequence
    # that appears to work with this code here.

    package require base64 2.0
    set major [lindex [split [package require md5] .] 0]

    # Create these commands in the mime namespace so that they
    # won't collide with things at the global namespace level

    namespace eval ::mime {
        proc base64 {-mode what -- chunk} {
   	    return [base64::$what $chunk]
        }
        proc quoted-printable {-mode what -- chunk} {
  	    return [mime::qp_$what $chunk]
        }

	if {$::major < 2} {
	    # md5 v1, result is hex string ready for use.
	    proc md5 {-- string} {
		return [md5::md5 $string]
	    }
	} else {
	    # md5 v2, need option to get hex string
	    proc md5 {-- string} {
		return [md5::md5 -hex $string]
	    }
	}
        proc unstack {channel} {
	    # do nothing
	    return
        }
    }

    unset major
}        

#
# state variables:
#
#     canonicalP: input is in its canonical form
#     content: type/subtype
#     params: seralized array of key/value pairs (keys are lower-case)
#     encoding: transfer encoding
#     version: MIME-version
#     header: serialized array of key/value pairs (keys are lower-case)
#     lowerL: list of header keys, lower-case
#     mixedL: list of header keys, mixed-case
#     value: either "file", "parts", or "string"
#
#     file: input file
#     fd: cached file-descriptor, typically for root
#     root: token for top-level part, for (distant) subordinates
#     offset: number of octets from beginning of file/string
#     count: length in octets of (encoded) content
#
#     parts: list of bodies (tokens)
#
#     string: input string
#
#     cid: last child-id assigned
#


namespace eval ::mime {
    variable mime
    array set mime { uid 0 cid 0 }

# 822 lexemes
    variable addrtokenL  [list ";"          ","                                        "<"          ">"                                        ":"          "."                                        "("          ")"                                        "@"          "\""                                       "\["         "\]"                                       "\\"]
    variable addrlexemeL [list LX_SEMICOLON LX_COMMA                                   LX_LBRACKET  LX_RBRACKET                                LX_COLON     LX_DOT                                     LX_LPAREN    LX_RPAREN                                  LX_ATSIGN    LX_QUOTE                                   LX_LSQUARE   LX_RSQUARE                                  LX_QUOTE]

# 2045 lexemes
    variable typetokenL  [list ";"          ","                                        "<"          ">"                                        ":"          "?"                                        "("          ")"                                        "@"          "\""                                       "\["         "\]"                                       "="          "/"                                        "\\"]
    variable typelexemeL [list LX_SEMICOLON LX_COMMA                                   LX_LBRACKET  LX_RBRACKET                                LX_COLON     LX_QUESTION                                LX_LPAREN    LX_RPAREN                                  LX_ATSIGN    LX_QUOTE                                   LX_LSQUARE   LX_RSQUARE                                 LX_EQUALS    LX_SOLIDUS                                 LX_QUOTE]

    set encList [list             ascii US-ASCII             big5 Big5             cp1250 Windows-1250             cp1251 Windows-1251             cp1252 Windows-1252             cp1253 Windows-1253             cp1254 Windows-1254             cp1255 Windows-1255             cp1256 Windows-1256             cp1257 Windows-1257             cp1258 Windows-1258             cp437 IBM437             cp737 ""             cp775 IBM775             cp850 IBM850             cp852 IBM852             cp855 IBM855             cp857 IBM857             cp860 IBM860             cp861 IBM861             cp862 IBM862             cp863 IBM863             cp864 IBM864             cp865 IBM865             cp866 IBM866             cp869 IBM869             cp874 ""             cp932 ""             cp936 GBK             cp949 ""             cp950 ""             dingbats "" 	    ebcdic ""             euc-cn EUC-CN             euc-jp EUC-JP             euc-kr EUC-KR             gb12345 GB12345             gb1988 GB1988             gb2312 GB2312             iso2022 ISO-2022             iso2022-jp ISO-2022-JP             iso2022-kr ISO-2022-KR             iso8859-1 ISO-8859-1             iso8859-2 ISO-8859-2             iso8859-3 ISO-8859-3             iso8859-4 ISO-8859-4             iso8859-5 ISO-8859-5             iso8859-6 ISO-8859-6             iso8859-7 ISO-8859-7             iso8859-8 ISO-8859-8             iso8859-9 ISO-8859-9             iso8859-10 ISO-8859-10             iso8859-13 ISO-8859-13             iso8859-14 ISO-8859-14             iso8859-15 ISO-8859-15             iso8859-16 ISO-8859-16             jis0201 JIS_X0201             jis0208 JIS_C6226-1983             jis0212 JIS_X0212-1990             koi8-r KOI8-R             koi8-u KOI8-U             ksc5601 KS_C_5601-1987             macCentEuro ""             macCroatian ""             macCyrillic ""             macDingbats ""             macGreek ""             macIceland ""             macJapan ""             macRoman ""             macRomania ""             macThai ""             macTurkish ""             macUkraine ""             shiftjis Shift_JIS             symbol ""             tis-620 TIS-620             unicode ""             utf-8 UTF-8]

    variable encodings
    array set encodings $encList
    variable reversemap
    foreach {enc mimeType} $encList {
        if {$mimeType != ""} {
            set reversemap([string tolower $mimeType]) $enc
        }
    } 

    set encAliasList [list             ascii ANSI_X3.4-1968             ascii iso-ir-6             ascii ANSI_X3.4-1986             ascii ISO_646.irv:1991             ascii ASCII             ascii ISO646-US             ascii us             ascii IBM367             ascii cp367             cp437 cp437             cp437 437             cp775 cp775             cp850 cp850             cp850 850             cp852 cp852             cp852 852             cp855 cp855             cp855 855             cp857 cp857             cp857 857             cp860 cp860             cp860 860             cp861 cp861             cp861 861             cp861 cp-is             cp862 cp862             cp862 862             cp863 cp863             cp863 863             cp864 cp864             cp865 cp865             cp865 865             cp866 cp866             cp866 866             cp869 cp869             cp869 869             cp869 cp-gr             cp936 CP936             cp936 MS936             cp936 Windows-936             iso8859-1 ISO_8859-1:1987             iso8859-1 iso-ir-100             iso8859-1 ISO_8859-1             iso8859-1 latin1             iso8859-1 l1             iso8859-1 IBM819             iso8859-1 CP819             iso8859-2 ISO_8859-2:1987             iso8859-2 iso-ir-101             iso8859-2 ISO_8859-2             iso8859-2 latin2             iso8859-2 l2             iso8859-3 ISO_8859-3:1988             iso8859-3 iso-ir-109             iso8859-3 ISO_8859-3             iso8859-3 latin3             iso8859-3 l3             iso8859-4 ISO_8859-4:1988             iso8859-4 iso-ir-110             iso8859-4 ISO_8859-4             iso8859-4 latin4             iso8859-4 l4             iso8859-5 ISO_8859-5:1988             iso8859-5 iso-ir-144             iso8859-5 ISO_8859-5             iso8859-5 cyrillic             iso8859-6 ISO_8859-6:1987             iso8859-6 iso-ir-127             iso8859-6 ISO_8859-6             iso8859-6 ECMA-114             iso8859-6 ASMO-708             iso8859-6 arabic             iso8859-7 ISO_8859-7:1987             iso8859-7 iso-ir-126             iso8859-7 ISO_8859-7             iso8859-7 ELOT_928             iso8859-7 ECMA-118             iso8859-7 greek             iso8859-7 greek8             iso8859-8 ISO_8859-8:1988             iso8859-8 iso-ir-138             iso8859-8 ISO_8859-8             iso8859-8 hebrew             iso8859-9 ISO_8859-9:1989             iso8859-9 iso-ir-148             iso8859-9 ISO_8859-9             iso8859-9 latin5             iso8859-9 l5             iso8859-10 iso-ir-157             iso8859-10 l6             iso8859-10 ISO_8859-10:1992             iso8859-10 latin6             iso8859-14 iso-ir-199             iso8859-14 ISO_8859-14:1998             iso8859-14 ISO_8859-14             iso8859-14 latin8             iso8859-14 iso-celtic             iso8859-14 l8             iso8859-15 ISO_8859-15             iso8859-15 Latin-9             iso8859-16 iso-ir-226             iso8859-16 ISO_8859-16:2001             iso8859-16 ISO_8859-16             iso8859-16 latin10             iso8859-16 l10             jis0201 X0201             jis0208 iso-ir-87             jis0208 x0208             jis0208 JIS_X0208-1983             jis0212 x0212             jis0212 iso-ir-159             ksc5601 iso-ir-149             ksc5601 KS_C_5601-1989             ksc5601 KSC5601             ksc5601 korean             shiftjis MS_Kanji             utf-8 UTF8]

    foreach {enc mimeType} $encAliasList {
        set reversemap([string tolower $mimeType]) $enc
    }

    namespace export initialize finalize getproperty                      getheader setheader                      getbody                      copymessage                      mapencoding                      reversemapencoding                      parseaddress                      parsedatetime                      uniqueID
}

# ::mime::initialize --
#
#	Creates a MIME part, and returnes the MIME token for that part.
#
# Arguments:
#	args   Args can be any one of the following:
#                  ?-canonical type/subtype
#                  ?-param    {key value}?...
#                  ?-encoding value?
#                  ?-header   {key value}?... ?
#                  (-file name | -string value | -parts {token1 ... tokenN})
#
#       If the -canonical option is present, then the body is in
#       canonical (raw) form and is found by consulting either the -file,
#       -string, or -part option. 
#
#       In addition, both the -param and -header options may occur zero
#       or more times to specify "Content-Type" parameters (e.g.,
#       "charset") and header keyword/values (e.g.,
#       "Content-Disposition"), respectively. 
#
#       Also, -encoding, if present, specifies the
#       "Content-Transfer-Encoding" when copying the body.
#
#       If the -canonical option is not present, then the MIME part
#       contained in either the -file or the -string option is parsed,
#       dynamically generating subordinates as appropriate.
#
# Results:
#	An initialized mime token.

proc ::mime::initialize {args} {
    global errorCode errorInfo

    variable mime

    set token [namespace current]::[incr mime(uid)]
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[set code [catch { eval [linsert $args 0 mime::initializeaux $token] }                          result]]} {
        set ecode $errorCode
        set einfo $errorInfo

        catch { mime::finalize $token -subordinates dynamic }

        return -code $code -errorinfo $einfo -errorcode $ecode $result
    }

    return $token
}

# ::mime::initializeaux --
#
#	Configures the MIME token created in mime::initialize based on
#       the arguments that mime::initialize supports.
#
# Arguments:
#       token  The MIME token to configure.
#	args   Args can be any one of the following:
#                  ?-canonical type/subtype
#                  ?-param    {key value}?...
#                  ?-encoding value?
#                  ?-header   {key value}?... ?
#                  (-file name | -string value | -parts {token1 ... tokenN})
#
# Results:
#       Either configures the mime token, or throws an error.

proc ::mime::initializeaux {token args} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set params [set state(params) ""]
    set state(encoding) ""
    set state(version) "1.0"

    set state(header) ""
    set state(lowerL) ""
    set state(mixedL) ""

    set state(cid) 0

    set argc [llength $args]
    for {set argx 0} {$argx < $argc} {incr argx} {
        set option [lindex $args $argx]
        if {[incr argx] >= $argc} {
            error "missing argument to $option"
        }
	set value [lindex $args $argx]

        switch -- $option {
            -canonical {
                set state(content) [string tolower $value]
            }

            -param {
                if {[llength $value] != 2} {
                    error "-param expects a key and a value, not $value"
                }
                set lower [string tolower [set mixed [lindex $value 0]]]
                if {[info exists params($lower)]} {
                    error "the $mixed parameter may be specified at most once"
                }

                set params($lower) [lindex $value 1]
                set state(params) [array get params]
            }

            -encoding {
                switch -- [set state(encoding) [string tolower $value]] {
                    7bit - 8bit - binary - quoted-printable - base64 {
                    }

                    default {
                        error "unknown value for -encoding $state(encoding)"
                    }
                }
            }

            -header {
                if {[llength $value] != 2} {
                    error "-header expects a key and a value, not $value"
                }
                set lower [string tolower [set mixed [lindex $value 0]]]
                if {![string compare $lower content-type]} {
                    error "use -canonical instead of -header $value"
                }
                if {![string compare $lower content-transfer-encoding]} {
                    error "use -encoding instead of -header $value"
                }
                if {(![string compare $lower content-md5])                         || (![string compare $lower mime-version])} {
                    error "don't go there..."
                }
                if {[lsearch -exact $state(lowerL) $lower] < 0} {
                    lappend state(lowerL) $lower
                    lappend state(mixedL) $mixed
                }               

                array set header $state(header)
                lappend header($lower) [lindex $value 1]
                set state(header) [array get header]
            }

            -file {
                set state(file) $value
            }

            -parts {
                set state(parts) $value
            }

            -string {
                set state(string) $value

		set state(lines) [split $value "\n"]
		set state(lines.count) [llength $state(lines)]
		set state(lines.current) 0
            }

            -root {
                # the following are internal options

                set state(root) $value
            }

            -offset {
                set state(offset) $value
            }

            -count {
                set state(count) $value
            }

	    -lineslist { 
		set state(lines) $value 
		set state(lines.count) [llength $state(lines)]
		set state(lines.current) 0
		#state(string) is needed, but will be built when required
		set state(string) ""
	    }

            default {
                error "unknown option $option"
            }
        }
    }

    #We only want one of -file, -parts or -string:
    set valueN 0
    foreach value [list file parts string] {
        if {[info exists state($value)]} {
            set state(value) $value
            incr valueN
        }
    }
    if {$valueN != 1 && ![info exists state(lines)]} {
        error "specify exactly one of -file, -parts, or -string"
    }

    if {[set state(canonicalP) [info exists state(content)]]} {
        switch -- $state(value) {
            file {
                set state(offset) 0
            }

            parts {
                switch -glob -- $state(content) {
                    text/*
                        -
                    image/*
                        -
                    audio/*
                        -
                    video/* {
                        error "-canonical $state(content) and -parts do not mix"
                    }
    
                    default {
                        if {[string compare $state(encoding) ""]} {
                            error "-encoding and -parts do not mix"
                        }
                    }
                }
            }
	    default {# Go ahead}
        }

        if {[lsearch -exact $state(lowerL) content-id] < 0} {
            lappend state(lowerL) content-id
            lappend state(mixedL) Content-ID

            array set header $state(header)
            lappend header(content-id) [uniqueID]
            set state(header) [array get header]
        }

        set state(version) 1.0

        return
    }

    if {[string compare $state(params) ""]} {
        error "-param requires -canonical"
    }
    if {[string compare $state(encoding) ""]} {
        error "-encoding requires -canonical"
    }
    if {[string compare $state(header) ""]} {
        error "-header requires -canonical"
    }
    if {[info exists state(parts)]} {
        error "-parts requires -canonical"
    }

    if {[set fileP [info exists state(file)]]} {
        if {[set openP [info exists state(root)]]} {
	    # FRINK: nocheck
            variable $state(root)
            upvar 0 $state(root) root

            set state(fd) $root(fd)
        } else {
            set state(root) $token
            set state(fd) [open $state(file) { RDONLY }]
            set state(offset) 0
            seek $state(fd) 0 end
            set state(count) [tell $state(fd)]

            fconfigure $state(fd) -translation binary
        }
    }

    set code [catch { mime::parsepart $token } result]
    set ecode $errorCode
    set einfo $errorInfo

    if {$fileP} {
        if {!$openP} {
            unset state(root)
            catch { close $state(fd) }
        }
        unset state(fd)
    }

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::mime::parsepart --
#
#       Parses the MIME headers and attempts to break up the message
#       into its various parts, creating a MIME token for each part.
#
# Arguments:
#       token  The MIME token to parse.
#
# Results:
#       Throws an error if it has problems parsing the MIME token,
#       otherwise it just sets up the appropriate variables.

proc ::mime::parsepart {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[set fileP [info exists state(file)]]} {
        seek $state(fd) [set pos $state(offset)] start
        set last [expr {$state(offset)+$state(count)-1}]
    } else {
        set string $state(string)
    }

    set vline ""
    while {1} {
        set blankP 0
        if {$fileP} {
            if {($pos > $last) || ([set x [gets $state(fd) line]] <= 0)} {
                set blankP 1
            } else {
                incr pos [expr {$x+1}]
            }
        } else {

	    if { $state(lines.current) >= $state(lines.count) } {
		set blankP 1
		set line ""
	    } else {
		set line [lindex $state(lines) $state(lines.current)]
		incr state(lines.current)
		set x [string length $line]
		if { $x == 0 } { set blankP 1 }
	    }

        }

         if {(!$blankP) && ([string last "\r" $line] == [expr {$x-1}])} {
	    
             set line [string range $line 0 [expr {$x-2}]]
             if {$x == 1} {
                 set blankP 1
             }
         }

        if {(!$blankP)                 && (([string first " " $line] == 0)                         || ([string first "\t" $line] == 0))} {
            append vline "\n" $line
            continue
        }      

        if {![string compare $vline ""]} {
            if {$blankP} {
                break
            }

            set vline $line
            continue
        }

        if {([set x [string first ":" $vline]] <= 0)                 || (![string compare                              [set mixed                                   [string trimright                                           [string range                                                   $vline 0 [expr {$x-1}]]]]                             ""])} {
            error "improper line in header: $vline"
        }
        set value [string trim [string range $vline [expr {$x+1}] end]]
        switch -- [set lower [string tolower $mixed]] {
            content-type {
                if {[info exists state(content)]} {
                    error "multiple Content-Type fields starting with $vline"
                }

                if {![catch { set x [parsetype $token $value] }]} {
                    set state(content) [lindex $x 0]
                    set state(params) [lindex $x 1]
                }
            }

            content-md5 {
            }

            content-transfer-encoding {
                if {([string compare $state(encoding) ""])                         && ([string compare $state(encoding)                                     [string tolower $value]])} {
                    error "multiple Content-Transfer-Encoding fields starting with $vline"
                }

                set state(encoding) [string tolower $value]
            }

            mime-version {
                set state(version) $value
            }

            default {
                if {[lsearch -exact $state(lowerL) $lower] < 0} {
                    lappend state(lowerL) $lower
                    lappend state(mixedL) $mixed
                }

                array set header $state(header)
                lappend header($lower) $value
                set state(header) [array get header]
            }
        }

        if {$blankP} {
            break
        }
        set vline $line
    }

    if {![info exists state(content)]} {
        set state(content) text/plain
        set state(params) [list charset us-ascii]
    }

    if {![string match multipart/* $state(content)]} {
        if {$fileP} {
            set x [tell $state(fd)]
            incr state(count) [expr {$state(offset)-$x}]
            set state(offset) $x
        } else {
	    # rebuild string, this is cheap and needed by other functions    
	    set state(string) [join [lrange $state(lines) 					 $state(lines.current) end] "\n"]
        }

        if {[string match message/* $state(content)]} {
	    # FRINK: nocheck
            variable [set child $token-[incr state(cid)]]

            set state(value) parts
            set state(parts) $child
            if {$fileP} {
                mime::initializeaux $child                     -file $state(file) -root $state(root)                     -offset $state(offset) -count $state(count)
            } else {
		mime::initializeaux $child 		    -lineslist [lrange $state(lines) 				    $state(lines.current) end] 
            }
        }

        return
    } 

    set state(value) parts

    set boundary ""
    foreach {k v} $state(params) {
        if {![string compare $k boundary]} {
            set boundary $v
            break
        }
    }
    if {![string compare $boundary ""]} {
        error "boundary parameter is missing in $state(content)"
    }
    if {![string compare [string trim $boundary] ""]} {
        error "boundary parameter is empty in $state(content)"
    }

    if {$fileP} {
        set pos [tell $state(fd)]
    }

    set inP 0
    set moreP 1
    while {$moreP} {
        if {$fileP} {
            if {$pos > $last} {
                 error "termination string missing in $state(content)"
                 set line "--$boundary--"
            } else {
              if {[set x [gets $state(fd) line]] < 0} {
                  error "end-of-file encountered while parsing $state(content)"
              }
           }
            incr pos [expr {$x+1}]
        } else {

	    if { $state(lines.current) >= $state(lines.count) } {
		error "end-of-string encountered while parsing $state(content)"
	    } else {
		set line [lindex $state(lines) $state(lines.current)]
		incr state(lines.current)
		set x [string length $line]
	    }

            set x [string length $line]
        }
        if {[string last "\r" $line] == [expr {$x-1}]} {
            set line [string range $line 0 [expr {$x-2}]]
        }

        if {[string first "--$boundary" $line] != 0} {
             if {$inP && !$fileP} {
 		lappend start $line
             }

             continue
        }

        if {!$inP} {
            if {![string compare $line "--$boundary"]} {
                set inP 1
                if {$fileP} {
                    set start $pos
                } else {
		    set start [list]
                }
            }

            continue
        }

        if {([set moreP [string compare $line "--$boundary--"]])                 && ([string compare $line "--$boundary"])} {
            if {$inP && !$fileP} {
		lappend start $line
            }
            continue
        }
	# FRINK: nocheck
        variable [set child $token-[incr state(cid)]]

        lappend state(parts) $child

        if {$fileP} {
            if {[set count [expr {$pos-($start+$x+3)}]] < 0} {
                set count 0
            }

            mime::initializeaux $child                 -file $state(file) -root $state(root)                 -offset $start -count $count

            seek $state(fd) [set start $pos] start
        } else {
	    mime::initializeaux $child -lineslist $start
            set start ""
        }
    }
}

# ::mime::parsetype --
#
#       Parses the string passed in and identifies the content-type and
#       params strings.
#
# Arguments:
#       token  The MIME token to parse.
#       string The content-type string that should be parsed.
#
# Results:
#       Returns the content and params for the string as a two element
#       tcl list.

proc ::mime::parsetype {token string} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    variable typetokenL
    variable typelexemeL

    set state(input)   $string
    set state(buffer)  ""
    set state(lastC)   LX_END
    set state(comment) ""
    set state(tokenL)  $typetokenL
    set state(lexemeL) $typelexemeL

    set code [catch { mime::parsetypeaux $token $string } result]    
    set ecode $errorCode
    set einfo $errorInfo

    unset state(input)             state(buffer)            state(lastC)             state(comment)           state(tokenL)            state(lexemeL)

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::mime::parsetypeaux --
#
#       A helper function for mime::parsetype.  Parses the specified
#       string looking for the content type and params.
#
# Arguments:
#       token  The MIME token to parse.
#       string The content-type string that should be parsed.
#
# Results:
#       Returns the content and params for the string as a two element
#       tcl list.

proc ::mime::parsetypeaux {token string} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[string compare [parselexeme $token] LX_ATOM]} {
        error [format "expecting type (found %s)" $state(buffer)]
    }
    set type [string tolower $state(buffer)]

    switch -- [parselexeme $token] {
        LX_SOLIDUS {
        }

        LX_END {
            if {[string compare $type message]} {
                error "expecting type/subtype (found $type)"
            }

            return [list message/rfc822 ""]
        }

        default {
            error [format "expecting \"/\" (found %s)" $state(buffer)]
        }
    }

    if {[string compare [parselexeme $token] LX_ATOM]} {
        error [format "expecting subtype (found %s)" $state(buffer)]
    }
    append type [string tolower /$state(buffer)]

    array set params ""
    while {1} {
        switch -- [parselexeme $token] {
            LX_END {
                return [list $type [array get params]]
            }

            LX_SEMICOLON {
            }

            default {
                error [format "expecting \";\" (found %s)" $state(buffer)]
            }
        }

        switch -- [parselexeme $token] {
            LX_END {
                return [list $type [array get params]]
            }

            LX_ATOM {
            }

            default {
                error [format "expecting attribute (found %s)" $state(buffer)]
            }
        }

        set attribute [string tolower $state(buffer)]

        if {[string compare [parselexeme $token] LX_EQUALS]} {
            error [format "expecting \"=\" (found %s)" $state(buffer)]
        }

        switch -- [parselexeme $token] {
            LX_ATOM {
            }

            LX_QSTRING {
                set state(buffer)                     [string range $state(buffer) 1                             [expr {[string length $state(buffer)]-2}]]
            }

            default {
                error [format "expecting value (found %s)" $state(buffer)]
            }
        }
        set params($attribute) $state(buffer)
    }
}

# ::mime::finalize --
#
#   mime::finalize destroys a MIME part.
#
#   If the -subordinates option is present, it specifies which
#   subordinates should also be destroyed. The default value is
#   "dynamic".
#
# Arguments:
#       token  The MIME token to parse.
#       args   Args can be optionally be of the following form:
#              ?-subordinates "all" | "dynamic" | "none"?
#
# Results:
#       Returns an empty string.

proc ::mime::finalize {token args} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options [list -subordinates dynamic]
    array set options $args

    switch -- $options(-subordinates) {
        all {
            if {![string compare $state(value) parts]} {
                foreach part $state(parts) {
                    eval [linsert $args 0 mime::finalize $part]
                }
            }
        }

        dynamic {
            for {set cid $state(cid)} {$cid > 0} {incr cid -1} {
                eval [linsert $args 0 mime::finalize $token-$cid]
            }
        }

        none {
        }

        default {
            error "unknown value for -subordinates $options(-subordinates)"
        }
    }

    foreach name [array names state] {
        unset state($name)
    }
    # FRINK: nocheck
    unset $token
}

# ::mime::getproperty --
#
#   mime::getproperty returns the properties of a MIME part.
#
#   The properties are:
#
#       property    value
#       ========    =====
#       content     the type/subtype describing the content
#       encoding    the "Content-Transfer-Encoding"
#       params      a list of "Content-Type" parameters
#       parts       a list of tokens for the part's subordinates
#       size        the approximate size of the content (unencoded)
#
#   The "parts" property is present only if the MIME part has
#   subordinates.
#
#   If mime::getproperty is invoked with the name of a specific
#   property, then the corresponding value is returned; instead, if
#   -names is specified, a list of all properties is returned;
#   otherwise, a serialized array of properties and values is returned.
#
# Arguments:
#       token      The MIME token to parse.
#       property   One of 'content', 'encoding', 'params', 'parts', and
#                  'size'. Defaults to returning a serialized array of
#                  properties and values.
#
# Results:
#       Returns the properties of a MIME part

proc ::mime::getproperty {token {property ""}} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -- $property {
        "" {
            array set properties [list content  $state(content)                                        encoding $state(encoding)                                        params   $state(params)                                        size     [getsize $token]]
            if {[info exists state(parts)]} {
                set properties(parts) $state(parts)
            }

            return [array get properties]
        }

        -names {
            set names [list content encoding params]
            if {[info exists state(parts)]} {
                lappend names parts
            }

            return $names
        }

        content
            -
        encoding
            -
        params {
            return $state($property)
        }

        parts {
            if {![info exists state(parts)]} {
                error "MIME part is a leaf"
            }

            return $state(parts)
        }

        size {
            return [getsize $token]
        }

        default {
            error "unknown property $property"
        }
    }
}

# ::mime::getsize --
#
#    Determine the size (in bytes) of a MIME part/token
#
# Arguments:
#       token      The MIME token to parse.
#
# Results:
#       Returns the size in bytes of the MIME token.

proc ::mime::getsize {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -- $state(value)/$state(canonicalP) {
        file/0 {
            set size $state(count)
        }

        file/1 {
            return [file size $state(file)]
        }

        parts/0
            -
        parts/1 {
            set size 0
            foreach part $state(parts) {
                incr size [getsize $part]
            }

            return $size
        }

        string/0 {
            set size [string length $state(string)]
        }

        string/1 {
            return [string length $state(string)]
        }
	default {
	    error "Unknown combination \"$state(value)/$state(canonicalP)\""
	}
    }

    if {![string compare $state(encoding) base64]} {
        set size [expr {($size*3+2)/4}]
    }

    return $size
}

# ::mime::getheader --
#
#    mime::getheader returns the header of a MIME part.
#
#    A header consists of zero or more key/value pairs. Each value is a
#    list containing one or more strings.
#
#    If mime::getheader is invoked with the name of a specific key, then
#    a list containing the corresponding value(s) is returned; instead,
#    if -names is specified, a list of all keys is returned; otherwise, a
#    serialized array of keys and values is returned. Note that when a
#    key is specified (e.g., "Subject"), the list returned usually
#    contains exactly one string; however, some keys (e.g., "Received")
#    often occur more than once in the header, accordingly the list
#    returned usually contains more than one string.
#
# Arguments:
#       token      The MIME token to parse.
#       key        Either a key or '-names'.  If it is '-names' a list
#                  of all keys is returned.
#
# Results:
#       Returns the header of a MIME part.

proc ::mime::getheader {token {key ""}} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set header $state(header)
    switch -- $key {
        "" {
            set result ""
            foreach lower $state(lowerL) mixed $state(mixedL) {
                lappend result $mixed $header($lower)
            }
            return $result
        }

        -names {
            return $state(mixedL)
        }

        default {
            set lower [string tolower [set mixed $key]]

            if {![info exists header($lower)]} {
                error "key $mixed not in header"
            }
            return $header($lower)
        }
    }
}

# ::mime::setheader --
#
#    mime::setheader writes, appends to, or deletes the value associated
#    with a key in the header.
#
#    The value for -mode is one of: 
#
#       write: the key/value is either created or overwritten (the
#       default);
#
#       append: a new value is appended for the key (creating it as
#       necessary); or,
#
#       delete: all values associated with the key are removed (the
#       "value" parameter is ignored).
#
#    Regardless, mime::setheader returns the previous value associated
#    with the key.
#
# Arguments:
#       token      The MIME token to parse.
#       key        The name of the key whose value should be set.
#       value      The value for the header key to be set to.
#       args       An optional argument of the form:
#                  ?-mode "write" | "append" | "delete"?
#
# Results:
#       Returns previous value associated with the specified key.

proc ::mime::setheader {token key value args} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options [list -mode write]
    array set options $args

    switch -- [set lower [string tolower $key]] {
        content-md5
            -
        content-type
            -
        content-transfer-encoding
            -
        mime-version {
            error "key $key may not be set"
        }
	default {# Skip key}
    }

    array set header $state(header)
    if {[set x [lsearch -exact $state(lowerL) $lower]] < 0} {
        if {![string compare $options(-mode) delete]} {
            error "key $key not in header"
        }

        lappend state(lowerL) $lower
        lappend state(mixedL) $key

        set result ""
    } else {
        set result $header($lower)
    }
    switch -- $options(-mode) {
        append {
            lappend header($lower) $value
        }

        delete {
            unset header($lower)
            set state(lowerL) [lreplace $state(lowerL) $x $x]
            set state(mixedL) [lreplace $state(mixedL) $x $x]
        }

        write {
            set header($lower) [list $value]
        }

        default {
            error "unknown value for -mode $options(-mode)"
        }
    }

    set state(header) [array get header]

    return $result
}

# ::mime::getbody --
#
#    mime::getbody returns the body of a leaf MIME part in canonical form.
#
#    If the -command option is present, then it is repeatedly invoked
#    with a fragment of the body as this:
#
#        uplevel #0 $callback [list "data" $fragment]
#
#    (The -blocksize option, if present, specifies the maximum size of
#    each fragment passed to the callback.)
#    When the end of the body is reached, the callback is invoked as:
#
#        uplevel #0 $callback "end"
#
#    Alternatively, if an error occurs, the callback is invoked as:
#
#        uplevel #0 $callback [list "error" reason]
#
#    Regardless, the return value of the final invocation of the callback
#    is propagated upwards by mime::getbody.
#
#    If the -command option is absent, then the return value of
#    mime::getbody is a string containing the MIME part's entire body.
#
# Arguments:
#       token      The MIME token to parse.
#       args       Optional arguments of the form:
#                  ?-decode? ?-command callback ?-blocksize octets? ?
#
# Results:
#       Returns a string containing the MIME part's entire body, or
#       if '-command' is specified, the return value of the command
#       is returned.

proc ::mime::getbody {token args} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set decode 0
    if {[set pos [lsearch -exact $args -decode]] >= 0} {
        set decode 1
        set args [lreplace $args $pos $pos]
    }

    array set options [list -command [list mime::getbodyaux $token]                             -blocksize 4096]
    array set options $args
    if {$options(-blocksize) < 1} {
        error "-blocksize expects a positive integer, not $options(-blocksize)"
    }

    set code 0
    set ecode ""
    set einfo ""

    switch -- $state(value)/$state(canonicalP) {
        file/0 {
            set fd [open $state(file) { RDONLY }]

            set code [catch {
                fconfigure $fd -translation binary
                seek $fd [set pos $state(offset)] start
                set last [expr {$state(offset)+$state(count)-1}]

                set fragment ""
                while {$pos <= $last} {
                    if {[set cc [expr {($last-$pos)+1}]]                             > $options(-blocksize)} {
                        set cc $options(-blocksize)
                    }
                    incr pos [set len                                   [string length [set chunk [read $fd $cc]]]]
                    switch -exact -- $state(encoding) {
                        base64
                            -
                        quoted-printable {
                            if {([set x [string last "\n" $chunk]] > 0)                                     && ($x+1 != $len)} {
                                set chunk [string range $chunk 0 $x]
                                seek $fd [incr pos [expr {($x+1)-$len}]] start
                            }
                            set chunk [$state(encoding) -mode decode                                                         -- $chunk]
                        }
			7bit - 8bit - binary - "" {
			    # Bugfix for [#477088]
			    # Go ahead, leave chunk alone
			}
			default {
			    error "Can't handle content encoding \"$state(encoding)\""
			}
                    }
                    append fragment $chunk

                    set cc [expr {$options(-blocksize)-1}]
                    while {[string length $fragment] > $options(-blocksize)} {
                        uplevel #0 $options(-command)                                    [list data                                          [string range $fragment 0 $cc]]

                        set fragment [string range                                              $fragment $options(-blocksize)                                              end]
                    }
                }
                if {[string length $fragment] > 0} {
                    uplevel #0 $options(-command) [list data $fragment]
                }
            } result]
            set ecode $errorCode
            set einfo $errorInfo

            catch { close $fd }
        }

        file/1 {
            set fd [open $state(file) { RDONLY }]

            set code [catch {
                fconfigure $fd -translation binary

                while {[string length                                [set fragment                                     [read $fd $options(-blocksize)]]] > 0} {
                    uplevel #0 $options(-command) [list data $fragment]
                }
            } result]
            set ecode $errorCode
            set einfo $errorInfo

            catch { close $fd }
        }

        parts/0
            -
        parts/1 {
            error "MIME part isn't a leaf"
        }

        string/0
            -
        string/1 {
            switch -- $state(encoding)/$state(canonicalP) {
                base64/0
                    -
                quoted-printable/0 {
                    set fragment [$state(encoding) -mode decode                                                    -- $state(string)]
                }

                default {
		    # Not a bugfix for [#477088], but clarification
		    # This handles no-encoding, 7bit, 8bit, and binary.
                    set fragment $state(string)
                }
            }

            set code [catch {
                set cc [expr {$options(-blocksize)-1}]
                while {[string length $fragment] > $options(-blocksize)} {
                    uplevel #0 $options(-command)                             [list data [string range $fragment 0 $cc]]

                    set fragment [string range $fragment                                          $options(-blocksize) end]
                }
                if {[string length $fragment] > 0} {
                    uplevel #0 $options(-command) [list data $fragment]
                }
            } result]
            set ecode $errorCode
            set einfo $errorInfo
	}
	default {
	    error "Unknown combination \"$state(value)/$state(canonicalP)\""
	}
    }

    set code [catch {
        if {$code} {
            uplevel #0 $options(-command) [list error $result]
        } else {
            uplevel #0 $options(-command) [list end]
        }
    } result]
    set ecode $errorCode
    set einfo $errorInfo    

    if {$code} {
        return -code $code -errorinfo $einfo -errorcode $ecode $result
    }

    if {$decode} {
        array set params [mime::getproperty $token params]

        if {[info exists params(charset)]} {
            set charset $params(charset)
        } else {
            set charset US-ASCII
        }

        set enc [reversemapencoding $charset]
        if {$enc != ""} {
            set result [::encoding convertfrom $enc $result]
        } else {
            return -code error "-decode failed: can't reversemap charset $charset"
        }
    }

    return $result
}

# ::mime::getbodyaux --
#
#    Builds up the body of the message, fragment by fragment.  When
#    the entire message has been retrieved, it is returned.
#
# Arguments:
#       token      The MIME token to parse.
#       reason     One of 'data', 'end', or 'error'.
#       fragment   The section of data data fragment to extract a
#                  string from.
#
# Results:
#       Returns nothing, except when called with the 'end' argument
#       in which case it returns a string that contains all of the
#       data that 'getbodyaux' has been called with.  Will throw an
#       error if it is called with the reason of 'error'.

proc ::mime::getbodyaux {token reason {fragment ""}} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -- $reason {
        data {
            append state(getbody) $fragment
	    return ""
        }

        end {
            if {[info exists state(getbody)]} {
                set result $state(getbody)
                unset state(getbody)
            } else {
                set result ""
            }

            return $result
        }

        error {
            catch { unset state(getbody) }
            error $reason
        }

	default {
	    error "Unknown reason \"$reason\""
	}
    }
}

# ::mime::copymessage --
#
#    mime::copymessage copies the MIME part to the specified channel.
#
#    mime::copymessage operates synchronously, and uses fileevent to
#    allow asynchronous operations to proceed independently.
#
# Arguments:
#       token      The MIME token to parse.
#       channel    The channel to copy the message to.
#
# Results:
#       Returns nothing unless an error is thrown while the message
#       is being written to the channel.

proc ::mime::copymessage {token channel} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set openP [info exists state(fd)]

    set code [catch { mime::copymessageaux $token $channel } result]
    set ecode $errorCode
    set einfo $errorInfo

    if {(!$openP) && ([info exists state(fd)])} {
        if {![info exists state(root)]} {
            catch { close $state(fd) }
        }
        unset state(fd)
    }

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::mime::copymessageaux --
#
#    mime::copymessageaux copies the MIME part to the specified channel.
#
# Arguments:
#       token      The MIME token to parse.
#       channel    The channel to copy the message to.
#
# Results:
#       Returns nothing unless an error is thrown while the message
#       is being written to the channel.

proc ::mime::copymessageaux {token channel} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set header $state(header)

    if {[string compare $state(version) ""]} {
        puts $channel "MIME-Version: $state(version)"
    }
    foreach lower $state(lowerL) mixed $state(mixedL) {
        foreach value $header($lower) {
            puts $channel "$mixed: $value"
        }
    }
    if {(!$state(canonicalP))             && ([string compare [set encoding $state(encoding)] ""])} {
        puts $channel "Content-Transfer-Encoding: $encoding"
    }

    puts -nonewline $channel "Content-Type: $state(content)"
    set boundary ""
    foreach {k v} $state(params) {
        if {![string compare $k boundary]} {
            set boundary $v
        }

        puts -nonewline $channel ";\n              $k=\"$v\""
    }

    set converter ""
    set encoding ""
    if {[string compare $state(value) parts]} {
        puts $channel ""

        if {$state(canonicalP)} {
            if {![string compare [set encoding $state(encoding)] ""]} {
                set encoding [encoding $token]
            }
            if {[string compare $encoding ""]} {
                puts $channel "Content-Transfer-Encoding: $encoding"
            }
            switch -- $encoding {
                base64
                    -
                quoted-printable {
                    set converter $encoding
                }
		7bit - 8bit - binary - "" {
		    # Bugfix for [#477088], also [#539952]
		    # Go ahead
		}
		default {
		    error "Can't handle content encoding \"$encoding\""
		}
            }
        }
    } elseif {([string match multipart/* $state(content)])                     && (![string compare $boundary ""])} {
# we're doing everything in one pass...
        set key [clock seconds]$token[info hostname][array get state]
        set seqno 8
        while {[incr seqno -1] >= 0} {
            set key [md5 -- $key]
        }
        set boundary "----- =_[string trim [base64 -mode encode -- $key]]"

        puts $channel ";\n              boundary=\"$boundary\""
    } else {
        puts $channel ""
    }

    if {[info exists state(error)]} {
        unset state(error)
    }
                
    switch -- $state(value) {
        file {
            set closeP 1
            if {[info exists state(root)]} {
		# FRINK: nocheck
                variable $state(root)
                upvar 0 $state(root) root 

                if {[info exists root(fd)]} {
                    set fd $root(fd)
                    set closeP 0
                } else {
                    set fd [set state(fd)                                 [open $state(file) { RDONLY }]]
                }
                set size $state(count)
            } else {
                set fd [set state(fd) [open $state(file) { RDONLY }]]
		# read until eof
                set size -1
            }
            seek $fd $state(offset) start
            if {$closeP} {
                fconfigure $fd -translation binary
            }

            puts $channel ""

	    while {($size != 0) && (![eof $fd])} {
		if {$size < 0 || $size > 32766} {
		    set X [read $fd 32766]
		} else {
		    set X [read $fd $size]
		}
		if {$size > 0} {
		    set size [expr {$size - [string length $X]}]
		}
		if {[string compare $converter ""]} {
		    puts -nonewline $channel [$converter -mode encode -- $X]
		} else {
		    puts -nonewline $channel $X
		}
	    }

            if {$closeP} {
                catch { close $state(fd) }
                unset state(fd)
            }
        }

        parts {
            if {(![info exists state(root)])                     && ([info exists state(file)])} {
                set state(fd) [open $state(file) { RDONLY }]
                fconfigure $state(fd) -translation binary
            }

            switch -glob -- $state(content) {
                message/* {
                    puts $channel ""
                    foreach part $state(parts) {
                        mime::copymessage $part $channel
                        break
                    }
                }

                default {
                    foreach part $state(parts) {
                        puts $channel "\n--$boundary"
                        mime::copymessage $part $channel
                    }
                    puts $channel "\n--$boundary--"
                }
            }

            if {[info exists state(fd)]} {
                catch { close $state(fd) }
                unset state(fd)
            }
        }

        string {
            if {[catch { fconfigure $channel -buffersize } blocksize]} {
                set blocksize 4096
            } elseif {$blocksize < 512} {
                set blocksize 512
            }
            set blocksize [expr {($blocksize/4)*3}]

	    # [893516]
	    fconfigure $channel -buffersize $blocksize

            puts $channel ""

            if {[string compare $converter ""]} {
                puts $channel [$converter -mode encode -- $state(string)]
            } else {
		puts $channel $state(string)
	    }
        }
	default {
	    error "Unknown value \"$state(value)\""
	}
    }

    flush $channel

    if {[string compare $converter ""]} {
        unstack $channel
    }
    if {[info exists state(error)]} {
        error $state(error)
    }
}

# ::mime::buildmessage --
#
#     The following is a clone of the copymessage code to build up the
#     result in memory, and, unfortunately, without using a memory channel.
#     I considered parameterizing the "puts" calls in copy message, but
#     the need for this procedure may go away, so I'm living with it for
#     the moment.
#
# Arguments:
#       token      The MIME token to parse.
#
# Results:
#       Returns the message that has been built up in memory.

proc ::mime::buildmessage {token} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set openP [info exists state(fd)]

    set code [catch { mime::buildmessageaux $token } result]
    set ecode $errorCode
    set einfo $errorInfo

    if {(!$openP) && ([info exists state(fd)])} {
        if {![info exists state(root)]} {
            catch { close $state(fd) }
        }
        unset state(fd)
    }

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::mime::buildmessageaux --
#
#     The following is a clone of the copymessageaux code to build up the
#     result in memory, and, unfortunately, without using a memory channel.
#     I considered parameterizing the "puts" calls in copy message, but
#     the need for this procedure may go away, so I'm living with it for
#     the moment.
#
# Arguments:
#       token      The MIME token to parse.
#
# Results:
#       Returns the message that has been built up in memory.

proc ::mime::buildmessageaux {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set header $state(header)

    set result ""
    if {[string compare $state(version) ""]} {
        append result "MIME-Version: $state(version)\r\n"
    }
    foreach lower $state(lowerL) mixed $state(mixedL) {
        foreach value $header($lower) {
            append result "$mixed: $value\r\n"
        }
    }
    if {(!$state(canonicalP))             && ([string compare [set encoding $state(encoding)] ""])} {
        append result "Content-Transfer-Encoding: $encoding\r\n"
    }

    append result "Content-Type: $state(content)"
    set boundary ""
    foreach {k v} $state(params) {
        if {![string compare $k boundary]} {
            set boundary $v
        }

        append result ";\r\n              $k=\"$v\""
    }

    set converter ""
    set encoding ""
    if {[string compare $state(value) parts]} {
        append result \r\n

        if {$state(canonicalP)} {
            if {![string compare [set encoding $state(encoding)] ""]} {
                set encoding [encoding $token]
            }
            if {[string compare $encoding ""]} {
                append result "Content-Transfer-Encoding: $encoding\r\n"
            }
            switch -- $encoding {
                base64
                    -
                quoted-printable {
                    set converter $encoding
                }
		7bit - 8bit - binary - "" {
		    # Bugfix for [#477088]
		    # Go ahead
		}
		default {
		    error "Can't handle content encoding \"$encoding\""
		}
            }
        }
    } elseif {([string match multipart/* $state(content)])                     && (![string compare $boundary ""])} {
# we're doing everything in one pass...
        set key [clock seconds]$token[info hostname][array get state]
        set seqno 8
        while {[incr seqno -1] >= 0} {
            set key [md5 -- $key]
        }
        set boundary "----- =_[string trim [base64 -mode encode -- $key]]"

        append result ";\r\n              boundary=\"$boundary\"\r\n"
    } else {
        append result "\r\n"
    }

    if {[info exists state(error)]} {
        unset state(error)
    }
                
    switch -- $state(value) {
        file {
            set closeP 1
            if {[info exists state(root)]} {
		# FRINK: nocheck
                variable $state(root)
                upvar 0 $state(root) root 

                if {[info exists root(fd)]} {
                    set fd $root(fd)
                    set closeP 0
                } else {
                    set fd [set state(fd)                                 [open $state(file) { RDONLY }]]
                }
                set size $state(count)
            } else {
                set fd [set state(fd) [open $state(file) { RDONLY }]]
                set size -1	;# Read until EOF
            }
            seek $fd $state(offset) start
            if {$closeP} {
                fconfigure $fd -translation binary
            }

            append result "\r\n"

	    while {($size != 0) && (![eof $fd])} {
		if {$size < 0 || $size > 32766} {
		    set X [read $fd 32766]
		} else {
		    set X [read $fd $size]
		}
		if {$size > 0} {
		    set size [expr {$size - [string length $X]}]
		}
		if {[string compare $converter ""]} {
		    append result "[$converter -mode encode -- $X]\r\n"
		} else {
		    append result "$X\r\n"
		}
	    }

            if {$closeP} {
                catch { close $state(fd) }
                unset state(fd)
            }
        }

        parts {
            if {(![info exists state(root)])                     && ([info exists state(file)])} {
                set state(fd) [open $state(file) { RDONLY }]
                fconfigure $state(fd) -translation binary
            }

            switch -glob -- $state(content) {
                message/* {
                    append result "\r\n"
                    foreach part $state(parts) {
                        append result [buildmessage $part]
                        break
                    }
                }

                default {
                    foreach part $state(parts) {
                        append result "\r\n--$boundary\r\n"
                        append result [buildmessage $part]
                    }
                    append result "\r\n--$boundary--\r\n"
                }
            }

            if {[info exists state(fd)]} {
                catch { close $state(fd) }
                unset state(fd)
            }
        }

        string {

            append result "\r\n"

	    if {[string compare $converter ""]} {
		append result "[$converter -mode encode -- $state(string)]\r\n"
	    } else {
		append result "$state(string)\r\n"
	    }
        }
	default {
	    error "Unknown value \"$state(value)\""
	}
    }

    if {[info exists state(error)]} {
        error $state(error)
    }
    return $result
}

# ::mime::encoding --
#
#     Determines how a token is encoded.
#
# Arguments:
#       token      The MIME token to parse.
#
# Results:
#       Returns the encoding of the message (the null string, base64,
#       or quoted-printable).

proc ::mime::encoding {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -glob -- $state(content) {
        audio/*
            -
        image/*
            -
        video/* {
            return base64
        }

        message/*
            -
        multipart/* {
            return ""
        }
	default {# Skip}
    }

    set asciiP 1
    set lineP 1
    switch -- $state(value) {
        file {
            set fd [open $state(file) { RDONLY }]
            fconfigure $fd -translation binary

            while {[gets $fd line] >= 0} {
                if {$asciiP} {
                    set asciiP [encodingasciiP $line]
                }
                if {$lineP} {
                    set lineP [encodinglineP $line]
                }
                if {(!$asciiP) && (!$lineP)} {
                    break
                }
            }

            catch { close $fd }
        }

        parts {
            return ""
        }

        string {
            foreach line [split $state(string) "\n"] {
                if {$asciiP} {
                    set asciiP [encodingasciiP $line]
                }
                if {$lineP} {
                    set lineP [encodinglineP $line]
                }
                if {(!$asciiP) && (!$lineP)} {
                    break
                }
            }
        }
	default {
	    error "Unknown value \"$state(value)\""
	}
    }

    switch -glob -- $state(content) {
        text/* {
            if {!$asciiP} {
                foreach {k v} $state(params) {
                    if {![string compare $k charset]} {
                        set v [string tolower $v]
                        if {([string compare $v us-ascii])                                 && (![string match {iso-8859-[1-8]} $v])} {
                            return base64
                        }

                        break
                    }
                }
            }

            if {!$lineP} {
                return quoted-printable
            }
        }

        
        default {
            if {(!$asciiP) || (!$lineP)} {
                return base64
            }
        }
    }

    return ""
}

# ::mime::encodingasciiP --
#
#     Checks if a string is a pure ascii string, or if it has a non-standard
#     form.
#
# Arguments:
#       line    The line to check.
#
# Results:
#       Returns 1 if \r only occurs at the end of lines, and if all
#       characters in the line are between the ASCII codes of 32 and 126.

proc ::mime::encodingasciiP {line} {
    foreach c [split $line ""] {
        switch -- $c {
            " " - "\t" - "\r" - "\n" {
            }

            default {
                binary scan $c c c
                if {($c < 32) || ($c > 126)} {
                    return 0
                }
            }
        }
    }
    if {([set r [string first "\r" $line]] < 0)             || ($r == [expr {[string length $line]-1}])} {
        return 1
    }

    return 0
}

# ::mime::encodinglineP --
#
#     Checks if a string is a line is valid to be processed.
#
# Arguments:
#       line    The line to check.
#
# Results:
#       Returns 1 the line is less than 76 characters long, the line
#       contains more characters than just whitespace, the line does
#       not start with a '.', and the line does not start with 'From '.

proc ::mime::encodinglineP {line} {
    if {([string length $line] > 76)             || ([string compare $line [string trimright $line]])             || ([string first . $line] == 0)             || ([string first "From " $line] == 0)} {
        return 0
    }

    return 1
}

# ::mime::fcopy --
#
#	Appears to be unused.
#
# Arguments:
#
# Results:
# 

proc ::mime::fcopy {token count {error ""}} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[string compare $error ""]} {
        set state(error) $error
    }
    set state(doneP) 1
}

# ::mime::scopy --
#
#	Copy a portion of the contents of a mime token to a channel.
#
# Arguments:
#	token     The token containing the data to copy.
#       channel   The channel to write the data to.
#       offset    The location in the string to start copying
#                 from.
#       len       The amount of data to write.
#       blocksize The block size for the write operation.
#
# Results:
#	The specified portion of the string in the mime token is
#       copied to the specified channel.

proc ::mime::scopy {token channel offset len blocksize} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {$len <= 0} {
        set state(doneP) 1
        fileevent $channel writable ""
        return
    }

    if {[set cc $len] > $blocksize} {
        set cc $blocksize
    }

    if {[catch { puts -nonewline $channel                       [string range $state(string) $offset                               [expr {$offset+$cc-1}]]
                 fileevent $channel writable                            [list mime::scopy $token $channel                                              [incr offset $cc]                                              [incr len -$cc]                                              $blocksize]
               } result]} {
        set state(error) $result
        set state(doneP) 1
        fileevent $channel writable ""
    }
    return
}

# ::mime::qp_encode --
#
#	Tcl version of quote-printable encode
#
# Arguments:
#	string        The string to quote.
#       encoded_word  Boolean value to determine whether or not encoded words
#                     (RFC 2047) should be handled or not. (optional)
#
# Results:
#	The properly quoted string is returned.

proc ::mime::qp_encode {string {encoded_word 0} {no_softbreak 0}} {
    # 8.1+ improved string manipulation routines used.
    # Replace outlying characters, characters that would normally
    # be munged by EBCDIC gateways, and special Tcl characters "[\]{}
    # with =xx sequence

    regsub -all -- 	    {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF]} 	    $string {[format =%02X [scan "\\&" %c]]} string

    # Replace the format commands with their result

    set string [subst -novariable $string]

    # soft/hard newlines and other
    # Funky cases for SMTP compatibility
    set mapChars [list " \n" "=20\n" "\t\n" "=09\n" 	    "\n\.\n" "\n=2E\n" "\nFrom " "\n=46rom "]
    if {$encoded_word} {
	# Special processing for encoded words (RFC 2047)
	lappend mapChars " " "_"
    }
    set string [string map $mapChars $string]

    # Break long lines - ugh

    # Implementation of FR #503336
    if {$no_softbreak} {
	set result $string
    } else {
	set result ""
	foreach line [split $string \n] {
	    while {[string length $line] > 72} {
		set chunk [string range $line 0 72]
		if {[regexp -- (=|=.)$ $chunk dummy end]} {
		    
		    # Don't break in the middle of a code

		    set len [expr {72 - [string length $end]}]
		    set chunk [string range $line 0 $len]
		    incr len
		    set line [string range $line $len end]
		} else {
		    set line [string range $line 73 end]
		}
		append result $chunk=\n
	    }
	    append result $line\n
	}
    }
    
    # Trim off last \n, since the above code has the side-effect
    # of adding an extra \n to the encoded string and return the result.

    set result [string range $result 0 end-1]

    # If the string ends in space or tab, replace with =xx

    set lastChar [string index $result end]
    if {$lastChar==" "} {
	set result [string replace $result end end "=20"]
    } elseif {$lastChar=="\t"} {
	set result [string replace $result end end "=09"]
    }

    return $result
}

# ::mime::qp_decode --
#
#	Tcl version of quote-printable decode
#
# Arguments:
#	string        The quoted-prinatble string to decode.
#       encoded_word  Boolean value to determine whether or not encoded words
#                     (RFC 2047) should be handled or not. (optional)
#
# Results:
#	The decoded string is returned.

proc ::mime::qp_decode {string {encoded_word 0}} {
    # 8.1+ improved string manipulation routines used.
    # Special processing for encoded words (RFC 2047)

    if {$encoded_word} {
	# _ == \x20, even if SPACE occupies a different code position
	set string [string map [list _ \u0020] $string]
    }

    # smash the white-space at the ends of lines since that must've been
    # generated by an MUA.

    regsub -all -- {[ \t]+\n} $string "\n" string
    set string [string trimright $string " \t"]

    # Protect the backslash for later subst and
    # smash soft newlines, has to occur after white-space smash
    # and any encoded word modification.

    set string [string map [list "\\" "\\\\" "=\n" ""] $string]

    # Decode specials

    regsub -all -nocase {=([a-f0-9][a-f0-9])} $string {\\u00\1} string

    # process \u unicode mapped chars

    return [subst -novar -nocommand $string]
}

# ::mime::parseaddress --
#
#       This was originally written circa 1982 in C. we're still using it
#       because it recognizes virtually every buggy address syntax ever
#       generated!
#
#       mime::parseaddress takes a string containing one or more 822-style
#       address specifications and returns a list of serialized arrays, one
#       element for each address specified in the argument.
#
#    Each serialized array contains these properties:
#
#       property    value
#       ========    =====
#       address     local@domain
#       comment     822-style comment
#       domain      the domain part (rhs)
#       error       non-empty on a parse error
#       group       this address begins a group
#       friendly    user-friendly rendering
#       local       the local part (lhs)
#       memberP     this address belongs to a group
#       phrase      the phrase part
#       proper      822-style address specification
#       route       822-style route specification (obsolete)
#
#    Note that one or more of these properties may be empty.
#
# Arguments:
#	string        The address string to parse
#
# Results:
#	Returns a list of serialized arrays, one element for each address
#       specified in the argument.

proc ::mime::parseaddress {string} {
    global errorCode errorInfo

    variable mime

    set token [namespace current]::[incr mime(uid)]
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set code [catch { mime::parseaddressaux $token $string } result]
    set ecode $errorCode
    set einfo $errorInfo

    foreach name [array names state] {
        unset state($name)
    }
    # FRINK: nocheck
    catch { unset $token }

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::mime::parseaddressaux --
#
#       This was originally written circa 1982 in C. we're still using it
#       because it recognizes virtually every buggy address syntax ever
#       generated!
#
#       mime::parseaddressaux does the actually parsing for mime::parseaddress
#
#    Each serialized array contains these properties:
#
#       property    value
#       ========    =====
#       address     local@domain
#       comment     822-style comment
#       domain      the domain part (rhs)
#       error       non-empty on a parse error
#       group       this address begins a group
#       friendly    user-friendly rendering
#       local       the local part (lhs)
#       memberP     this address belongs to a group
#       phrase      the phrase part
#       proper      822-style address specification
#       route       822-style route specification (obsolete)
#
#    Note that one or more of these properties may be empty.
#
# Arguments:
#       token         The MIME token to work from.
#	string        The address string to parse
#
# Results:
#	Returns a list of serialized arrays, one element for each address
#       specified in the argument.

proc ::mime::parseaddressaux {token string} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    variable addrtokenL
    variable addrlexemeL

    set state(input)   $string
    set state(glevel)  0
    set state(buffer)  ""
    set state(lastC)   LX_END
    set state(tokenL)  $addrtokenL
    set state(lexemeL) $addrlexemeL

    set result ""
    while {[addr_next $token]} {
        if {[string compare [set tail $state(domain)] ""]} {
            set tail @$state(domain)
        } else {
            set tail @[info hostname]
        }
        if {[string compare [set address $state(local)] ""]} {
            append address $tail
        }

        if {[string compare $state(phrase) ""]} {
            set state(phrase) [string trim $state(phrase) "\""]
            foreach t $state(tokenL) {
                if {[string first $t $state(phrase)] >= 0} {
                    set state(phrase) \"$state(phrase)\"
                    break
                }
            }

            set proper "$state(phrase) <$address>"
        } else {
            set proper $address
        }

        if {![string compare [set friendly $state(phrase)] ""]} {
            if {[string compare [set note $state(comment)] ""]} {
                if {[string first "(" $note] == 0} {
                    set note [string trimleft [string range $note 1 end]]
                }
                if {[string last ")" $note]                         == [set len [expr {[string length $note]-1}]]} {
                    set note [string range $note 0 [expr {$len-1}]]
                }
                set friendly $note
            }

            if {(![string compare $friendly ""])                     && ([string compare [set mbox $state(local)] ""])} {
                set mbox [string trim $mbox "\""]

                if {[string first "/" $mbox] != 0} {
                    set friendly $mbox
                } elseif {[string compare                                   [set friendly [addr_x400 $mbox PN]]                                   ""]} {
                } elseif {([string compare                                    [set friendly [addr_x400 $mbox S]]                                    ""])                             && ([string compare                                         [set g [addr_x400 $mbox G]]                                         ""])} {
                    set friendly "$g $friendly"
                }

                if {![string compare $friendly ""]} {
                    set friendly $mbox
                }
            }
        }
        set friendly [string trim $friendly "\""]

        lappend result [list address  $address                                     comment  $state(comment)                              domain   $state(domain)                               error    $state(error)                                friendly $friendly                                    group    $state(group)                                local    $state(local)                                memberP  $state(memberP)                              phrase   $state(phrase)                               proper   $proper                                      route    $state(route)]

    }

    unset state(input)             state(glevel)            state(buffer)            state(lastC)             state(tokenL)            state(lexemeL)

    return $result
}

# ::mime::addr_next --
#
#       Locate the next address in a mime token.
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns 1 if there is another address, and 0 if there is not.

proc ::mime::addr_next {token} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    foreach prop {comment domain error group local memberP phrase route} {
        catch { unset state($prop) }
    }

    switch -- [set code [catch { mime::addr_specification $token } result]] {
        0 {
            if {!$result} {
                return 0
            }

            switch -- $state(lastC) {
                LX_COMMA
                    -
                LX_END {
                }
                default {
                    # catch trailing comments...
                    set lookahead $state(input)
                    mime::parselexeme $token
                    set state(input) $lookahead
                }
            }
        }

        7 {
            set state(error) $result

            while {1} {
                switch -- $state(lastC) {
                    LX_COMMA
                        -
                    LX_END {
                        break
                    }

                    default {
                        mime::parselexeme $token
                    }
                }
            }
        }

        default {
            set ecode $errorCode
            set einfo $errorInfo

            return -code $code -errorinfo $einfo -errorcode $ecode $result
        }
    }

    foreach prop {comment domain error group local memberP phrase route} {
        if {![info exists state($prop)]} {
            set state($prop) ""
        }
    }

    return 1
}

# ::mime::addr_specification --
#
#   Uses lookahead parsing to determine whether there is another
#   valid e-mail address or not.  Throws errors if unrecognized
#   or invalid e-mail address syntax is used.
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns 1 if there is another address, and 0 if there is not.

proc ::mime::addr_specification {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set lookahead $state(input)
    switch -- [parselexeme $token] {
        LX_ATOM
            -
        LX_QSTRING {
            set state(phrase) $state(buffer)
        }

        LX_SEMICOLON {
            if {[incr state(glevel) -1] < 0} {
                return -code 7 "extraneous semi-colon"
            }

            catch { unset state(comment) }
            return [addr_specification $token]
        }

        LX_COMMA {
            catch { unset state(comment) }
            return [addr_specification $token]
        }

        LX_END {
            return 0
        }

        LX_LBRACKET {
            return [addr_routeaddr $token]
        }

        LX_ATSIGN {
            set state(input) $lookahead
            return [addr_routeaddr $token 0]
        }

        default {
            return -code 7                    [format "unexpected character at beginning (found %s)"                            $state(buffer)]
        }
    }

    switch -- [parselexeme $token] {
        LX_ATOM
            -
        LX_QSTRING {
            append state(phrase) " " $state(buffer)

            return [addr_phrase $token]
        }

        LX_LBRACKET {
            return [addr_routeaddr $token]
        }

        LX_COLON {
            return [addr_group $token]
        }

        LX_DOT {
            set state(local) "$state(phrase)$state(buffer)"
            unset state(phrase)
            mime::addr_routeaddr $token 0
            mime::addr_end $token
        }

        LX_ATSIGN {
            set state(memberP) $state(glevel)
            set state(local) $state(phrase)
            unset state(phrase)
            mime::addr_domain $token
            mime::addr_end $token
        }

        LX_SEMICOLON
            -
        LX_COMMA
            -
        LX_END {
            set state(memberP) $state(glevel)
            if {(![string compare $state(lastC) LX_SEMICOLON])                     && ([incr state(glevel) -1] < 0)} {
                return -code 7 "extraneous semi-colon"
            }

            set state(local) $state(phrase)
            unset state(phrase)
        }

        default {
            return -code 7 [format "expecting mailbox (found %s)"                                    $state(buffer)]
        }
    }

    return 1
}

# ::mime::addr_routeaddr --
#
#       Parses the domain portion of an e-mail address.  Finds the '@'
#       sign and then calls mime::addr_route to verify the domain.
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns 1 if there is another address, and 0 if there is not.

proc ::mime::addr_routeaddr {token {checkP 1}} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set lookahead $state(input)
    if {![string compare [parselexeme $token] LX_ATSIGN]} {
        mime::addr_route $token
    } else {
        set state(input) $lookahead
    }

    mime::addr_local $token

    switch -- $state(lastC) {
        LX_ATSIGN {
            mime::addr_domain $token
        }

        LX_SEMICOLON
            -
        LX_RBRACKET
            -
        LX_COMMA
            -
        LX_END {
        }

        default {
            return -code 7                    [format "expecting at-sign after local-part (found %s)"                            $state(buffer)]
        }
    }

    if {($checkP) && ([string compare $state(lastC) LX_RBRACKET])} {
        return -code 7 [format "expecting right-bracket (found %s)"                                $state(buffer)]
    }

    return 1
}

# ::mime::addr_route --
#
#    Attempts to parse the portion of the e-mail address after the @.
#    Tries to verify that the domain definition has a valid form.
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_route {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set state(route) @

    while {1} {
        switch -- [parselexeme $token] {
            LX_ATOM
                -
            LX_DLITERAL {
                append state(route) $state(buffer)
            }

            default {
                return -code 7                        [format "expecting sub-route in route-part (found %s)"                                $state(buffer)]
            }
        }

        switch -- [parselexeme $token] {
            LX_COMMA {
                append state(route) $state(buffer)
                while {1} {
                    switch -- [parselexeme $token] {
                        LX_COMMA {
                        }

                        LX_ATSIGN {
                            append state(route) $state(buffer)
                            break
                        }

                        default {
                            return -code 7                                    [format "expecting at-sign in route (found %s)"                                            $state(buffer)]
                        }
                    }
                }
            }

            LX_ATSIGN
                -
            LX_DOT {
                append state(route) $state(buffer)
            }

            LX_COLON {
                append state(route) $state(buffer)
                return
            }

            default {
                return -code 7                        [format "expecting colon to terminate route (found %s)"                                $state(buffer)]
            }
        }
    }
}

# ::mime::addr_domain --
#
#    Attempts to parse the portion of the e-mail address after the @.
#    Tries to verify that the domain definition has a valid form.
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_domain {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    while {1} {
        switch -- [parselexeme $token] {
            LX_ATOM
                -
            LX_DLITERAL {
                append state(domain) $state(buffer)
            }

            default {
                return -code 7                        [format "expecting sub-domain in domain-part (found %s)"                                $state(buffer)]
            }
        }

        switch -- [parselexeme $token] {
            LX_DOT {
                append state(domain) $state(buffer)
            }

            LX_ATSIGN {
                append state(local) % $state(domain)
                unset state(domain)
            }

            default {
                return
            }
        }
    }
}

# ::mime::addr_local --
#
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_local {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set state(memberP) $state(glevel)

    while {1} {
        switch -- [parselexeme $token] {
            LX_ATOM
                -
            LX_QSTRING {
                append state(local) $state(buffer)
            }

            default {
                return -code 7                        [format "expecting mailbox in local-part (found %s)"                                $state(buffer)]
            }
        }

        switch -- [parselexeme $token] {
            LX_DOT {
                append state(local) $state(buffer)
            }

            default {
                return
            }
        }
    }
}

# ::mime::addr_phrase --
#
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns nothing if successful, and throws an error if invalid
#       syntax is found.


proc ::mime::addr_phrase {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    while {1} {
        switch -- [parselexeme $token] {
            LX_ATOM
                -
            LX_QSTRING {
                append state(phrase) " " $state(buffer)
            }

            default {
                break
            }
        }
    }

    switch -- $state(lastC) {
        LX_LBRACKET {
            return [addr_routeaddr $token]
        }

        LX_COLON {
            return [addr_group $token]
        }

        LX_DOT {
            append state(phrase) $state(buffer)
            return [addr_phrase $token]   
        }

        default {
            return -code 7                    [format "found phrase instead of mailbox (%s%s)"                            $state(phrase) $state(buffer)]
        }
    }
}

# ::mime::addr_group --
#
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_group {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[incr state(glevel)] > 1} {
        return -code 7 [format "nested groups not allowed (found %s)"                                $state(phrase)]
    }

    set state(group) $state(phrase)
    unset state(phrase)

    set lookahead $state(input)
    while {1} {
        switch -- [parselexeme $token] {
            LX_SEMICOLON
                -
            LX_END {
                set state(glevel) 0
                return 1
            }

            LX_COMMA {
            }

            default {
                set state(input) $lookahead
                return [addr_specification $token]
            }
        }
    }
}

# ::mime::addr_end --
#
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_end {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -- $state(lastC) {
        LX_SEMICOLON {
            if {[incr state(glevel) -1] < 0} {
                return -code 7 "extraneous semi-colon"
            }
        }

        LX_COMMA
            -
        LX_END {
        }

        default {
            return -code 7 [format "junk after local@domain (found %s)"                                    $state(buffer)]
        }
    }    
}

# ::mime::addr_x400 --
#
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_x400 {mbox key} {
    if {[set x [string first "/$key=" [string toupper $mbox]]] < 0} {
        return ""
    }
    set mbox [string range $mbox [expr {$x+[string length $key]+2}] end]

    if {[set x [string first "/" $mbox]] > 0} {
        set mbox [string range $mbox 0 [expr {$x-1}]]
    }

    return [string trim $mbox "\""]
}

# ::mime::parsedatetime --
#
#    Fortunately the clock command in the Tcl 8.x core does all the heavy 
#    lifting for us (except for timezone calculations).
#
#    mime::parsedatetime takes a string containing an 822-style date-time
#    specification and returns the specified property.
#
#    The list of properties and their ranges are:
#
#       property     range
#       ========     =====
#       hour         0 .. 23
#       lmonth       January, February, ..., December
#       lweekday     Sunday, Monday, ... Saturday
#       mday         1 .. 31
#       min          0 .. 59
#       mon          1 .. 12
#       month        Jan, Feb, ..., Dec
#       proper       822-style date-time specification
#       rclock       elapsed seconds between then and now
#       sec          0 .. 59
#       wday         0 .. 6 (Sun .. Mon)
#       weekday      Sun, Mon, ..., Sat
#       yday         1 .. 366
#       year         1900 ...
#       zone         -720 .. 720 (minutes east of GMT)
#
# Arguments:
#       value       Either a 822-style date-time specification or '-now'
#                   if the current date/time should be used.
#       property    The property (from the list above) to return
#
# Results:
#	Returns the string value of the 'property' for the date/time that was
#       specified in 'value'.

proc ::mime::parsedatetime {value property} {
    if {![string compare $value -now]} {
        set clock [clock seconds]
    } else {
        set clock [clock scan $value]
    }

    switch -- $property {
        hour {
            set value [clock format $clock -format %H]
        }

        lmonth {
            return [clock format $clock -format %B]
        }

        lweekday {
            return [clock format $clock -format %A]
        }

        mday {
            set value [clock format $clock -format %d]
        }

        min {
            set value [clock format $clock -format %M]
        }

        mon {
            set value [clock format $clock -format %m]
        }

        month {
            return [clock format $clock -format %b]
        }

        proper {
            set gmt [clock format $clock -format "%d %b %Y %H:%M:%S"                            -gmt true]
            if {[set diff [expr {($clock-[clock scan $gmt])/60}]] < 0} {
                set s -
                set diff [expr {-($diff)}]
            } else {
                set s +
            }
            set zone [format %s%02d%02d $s [expr {$diff/60}] [expr {$diff%60}]]

            return [clock format $clock                           -format "%a, %d %b %Y %H:%M:%S $zone"]
        }

        rclock {
            if {![string compare $value -now]} {
                return 0
            } else {
                return [expr {[clock seconds]-$clock}]
            }
        }

        sec {
            set value [clock format $clock -format %S]
        }

        wday {
            return [clock format $clock -format %w]
        }

        weekday {
            return [clock format $clock -format %a]
        }

        yday {
            set value [clock format $clock -format %j]
        }

        year {
            set value [clock format $clock -format %Y]
        }

        zone {
	    set value [string trim [string map [list "\t" " "] $value]]
            if {[set x [string last " " $value]] < 0} {
                return 0
            }
            set value [string range $value [expr {$x+1}] end]
            switch -- [set s [string index $value 0]] {
                + - - {
                    if {![string compare $s +]} {
                        set s ""
                    }
                    set value [string trim [string range $value 1 end]]
                    if {([string length $value] != 4)                             || ([scan $value %2d%2d h m] != 2)                             || ($h > 12)                             || ($m > 59)                             || (($h == 12) && ($m > 0))} {
                        error "malformed timezone-specification: $value"
                    }
                    set value $s[expr {$h*60+$m}]
                }

                default {
                    set value [string toupper $value]
                    set z1 [list  UT GMT EST EDT CST CDT MST MDT PST PDT]
                    set z2 [list   0   0  -5  -4  -6  -5  -7  -6  -8  -7]
                    if {[set x [lsearch -exact $z1 $value]] < 0} {
                        error "unrecognized timezone-mnemonic: $value"
                    }
                    set value [expr {[lindex $z2 $x]*60}]
                }
            }
        }

        date2gmt
            -
        date2local
            -
        dst
            -
        sday
            -
        szone
            -
        tzone
            -
        default {
            error "unknown property $property"
        }
    }

    if {![string compare [set value [string trimleft $value 0]] ""]} {
        set value 0
    }
    return $value
}

# ::mime::uniqueID --
#
#    Used to generate a 'globally unique identifier' for the content-id.
#    The id is built from the pid, the current time, the hostname, and
#    a counter that is incremented each time a message is sent.
#
# Arguments:
#
# Results:
#	Returns the a string that contains the globally unique identifier
#       that should be used for the Content-ID of an e-mail message.

proc ::mime::uniqueID {} {
    variable mime

    return "<[pid].[clock seconds].[incr mime(cid)]@[info hostname]>"
}

# ::mime::parselexeme --
#
#    Used to implement a lookahead parser.
#
# Arguments:
#       token    The MIME token to operate on.
#
# Results:
#	Returns the next token found by the parser.

proc ::mime::parselexeme {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set state(input) [string trimleft $state(input)]

    set state(buffer) ""
    if {![string compare $state(input) ""]} {
        set state(buffer) end-of-input
        return [set state(lastC) LX_END]
    }

    set c [string index $state(input) 0]
    set state(input) [string range $state(input) 1 end]

    if {![string compare $c "("]} {
        set noteP 0
        set quoteP 0

        while {1} {
            append state(buffer) $c

            switch -- $c/$quoteP {
                "(/0" {
                    incr noteP
                }

                "\\/0" {
                    set quoteP 1
                }

                ")/0" {
                    if {[incr noteP -1] < 1} {
                        if {[info exists state(comment)]} {
                            append state(comment) " "
                        }
                        append state(comment) $state(buffer)

                        return [parselexeme $token]
                    }
                }

                default {
                    set quoteP 0
                }
            }

            if {![string compare [set c [string index $state(input) 0]] ""]} {
                set state(buffer) "end-of-input during comment"
                return [set state(lastC) LX_ERR]
            }
            set state(input) [string range $state(input) 1 end]
        }
    }

    if {![string compare $c "\""]} {
        set firstP 1
        set quoteP 0

        while {1} {
            append state(buffer) $c

            switch -- $c/$quoteP {
                "\\/0" {
                    set quoteP 1
                }

                "\"/0" {
                    if {!$firstP} {
                        return [set state(lastC) LX_QSTRING]
                    }
                    set firstP 0
                }

                default {
                    set quoteP 0
                }
            }

            if {![string compare [set c [string index $state(input) 0]] ""]} {
                set state(buffer) "end-of-input during quoted-string"
                return [set state(lastC) LX_ERR]
            }
            set state(input) [string range $state(input) 1 end]
        }
    }

    if {![string compare $c "\["]} {
        set quoteP 0

        while {1} {
            append state(buffer) $c

            switch -- $c/$quoteP {
                "\\/0" {
                    set quoteP 1
                }

                "\]/0" {
                    return [set state(lastC) LX_DLITERAL]
                }

                default {
                    set quoteP 0
                }
            }

            if {![string compare [set c [string index $state(input) 0]] ""]} {
                set state(buffer) "end-of-input during domain-literal"
                return [set state(lastC) LX_ERR]
            }
            set state(input) [string range $state(input) 1 end]
        }
    }

    if {[set x [lsearch -exact $state(tokenL) $c]] >= 0} {
        append state(buffer) $c

        return [set state(lastC) [lindex $state(lexemeL) $x]]
    }

    while {1} {
        append state(buffer) $c

        switch -- [set c [string index $state(input) 0]] {
            "" - " " - "\t" - "\n" {
                break
            }

            default {
                if {[lsearch -exact $state(tokenL) $c] >= 0} {
                    break
                }
            }
        }

        set state(input) [string range $state(input) 1 end]
    }

    return [set state(lastC) LX_ATOM]
}

# ::mime::mapencoding --
#
#    mime::mapencodings maps tcl encodings onto the proper names for their
#    MIME charset type.  This is only done for encodings whose charset types
#    were known.  The remaining encodings return "" for now.
#
# Arguments:
#       enc      The tcl encoding to map.
#
# Results:
#	Returns the MIME charset type for the specified tcl encoding, or ""
#       if none is known.

proc ::mime::mapencoding {enc} {

    variable encodings

    if {[info exists encodings($enc)]} {
        return $encodings($enc)
    }
    return ""
}

# ::mime::reversemapencoding --
#
#    mime::reversemapencodings maps MIME charset types onto tcl encoding names.
#    Those that are unknown return "".
#
# Arguments:
#       mimeType  The MIME charset to convert into a tcl encoding type.
#
# Results:
#	Returns the tcl encoding name for the specified mime charset, or ""
#       if none is known.

proc ::mime::reversemapencoding {mimeType} {

    variable reversemap
    
    set lmimeType [string tolower $mimeType]
    if {[info exists reversemap($lmimeType)]} {
        return $reversemap($lmimeType)
    }
    return ""
}

# ::mime::word_encode --
#
#    Word encodes strings as per RFC 2047.
#
# Arguments:
#       charset   The character set to encode the message to.
#       method    The encoding method (base64 or quoted-printable).
#       string    The string to encode.
#
# Results:
#	Returns a word encoded string.

proc ::mime::word_encode {charset method string} {

    variable encodings

    if {![info exists encodings($charset)]} {
	error "unknown charset '$charset'"
    }

    if {$encodings($charset) == ""} {
	error "invalid charset '$charset'"
    }

    if {$method != "base64" && $method != "quoted-printable"} {
	error "unknown method '$method', must be base64 or quoted-printable"
    }

    set result "=?$encodings($charset)?"
    switch -exact -- $method {
	base64 {
	    append result "B?[string trimright [base64 -mode encode -- $string] \n]?="
	}
	quoted-printable {
	    append result "Q?[qp_encode $string 1]?="
	}
	"" {
	    # Go ahead
	}
	default {
	    error "Can't handle content encoding \"$method\""
	}
    }

    return $result
}

# ::mime::word_decode --
#
#    Word decodes strings that have been word encoded as per RFC 2047.
#
# Arguments:
#       encoded   The word encoded string to decode.
#
# Results:
#	Returns the string that has been decoded from the encoded message.

proc ::mime::word_decode {encoded} {

    variable reversemap

    if {[regexp -- {=\?([^?]+)\?(.)\?([^?]*)\?=} $encoded 		- charset method string] != 1} {
	error "malformed word-encoded expression '$encoded'"
    }

    set enc [reversemapencoding $charset]
    if {[string equal "" $enc]} {
	error "unknown charset '$charset'"
    }

    switch -exact -- $method {
	b -
	B {
            set method base64
        }
	q -
	Q {
            set method quoted-printable
        }
	default {
	    error "unknown method '$method', must be B or Q"
        }
    }

    switch -exact -- $method {
	base64 {
	    set result [base64 -mode decode -- $string]
	}
	quoted-printable {
	    set result [qp_decode $string 1]
	}
	"" {
	    # Go ahead
	}
	default {
	    error "Can't handle content encoding \"$method\""
	}
    }

    return [list $enc $method $result]
}

# ::mime::field_decode --
#
#    Word decodes strings that have been word encoded as per RFC 2047
#    and converts the string from UTF to the original encoding/charset.
#
# Arguments:
#       field     The string to decode
#
# Results:
#	Returns the decoded string in its original encoding/charset..

proc ::mime::field_decode {field} {
    # ::mime::field_decode is broken.  Here's a new version.
    # This code is in the public domain.  Don Libes <don@libes.com>

    # Step through a field for mime-encoded words, building a new
    # version with unencoded equivalents.

    # Sorry about the grotesque regexp.  Most of it is sensible.  One
    # notable fudge: the final $ is needed because of an apparent bug
    # in the regexp engine where the preceding .* otherwise becomes
    # non-greedy - perhaps because of the earlier ".*?", sigh.

    while {[regexp {(.*?)(=\?(?:[^?]+)\?(?:.)\?(?:[^?]*)\?=)(.*)$} $field ignore prefix encoded field]} {
	# don't allow whitespace between encoded words per RFC 2047
	if {"" != $prefix} {
	    if {![string is space $prefix]} {
		append result $prefix
	    }
	}

	set decoded [word_decode $encoded]
        foreach {charset - string} $decoded break

	append result [::encoding convertfrom $charset $string]
    }

    append result $field
    return $result
}

# smtp.tcl - SMTP client
#
# (c) 1999-2000 Marshall T. Rose
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package require Tcl 8.3
package require mime 1.4
package provide smtp 1.4

#
# state variables:
#
#    sd: socket to server
#    afterID: afterID associated with ::smtp::timer
#    options: array of user-supplied options
#    readable: semaphore for vwait
#    addrs: number of recipients negotiated
#    error: error during read
#    line: response read from server
#    crP: just put a \r in the data
#    nlP: just put a \n in the data
#    size: number of octets sent in DATA
#


namespace eval ::smtp {
    variable trf 1
    variable smtp
    array set smtp { uid 0 }

    namespace export sendmessage
}

if {[catch {package require Trf  2.0}]} {
    # Trf is not available, but we can live without it as long as the
    # transform and unstack procs are defined.

    # Warning!
    # This is a fragile emulation of the more general calling sequence
    # that appears to work with this code here.

    proc transform {args} {
	upvar state mystate
	set mystate(size) 1
    }
    proc unstack {channel} {
        # do nothing
        return
    }
    set ::smtp::trf 0
}


# ::smtp::sendmessage --
#
#	Sends a mime object (containing a message) to some recipients
#
# Arguments:
#	part  The MIME object containing the message to send
#       args  A list of arguments specifying various options for sending the
#             message:
#             -atleastone  A boolean specifying whether or not to send the
#                          message at all if any of the recipients are 
#                          invalid.  A value of false (as defined by 
#                          ::smtp::boolean) means that ALL recipients must be
#                          valid in order to send the message.  A value of
#                          true means that as long as at least one recipient
#                          is valid, the message will be sent.
#             -debug       A boolean specifying whether or not debugging is
#                          on.  If debugging is enabled, status messages are 
#                          printed to stderr while trying to send mail.
#             -queue       A boolean specifying whether or not the message
#                          being sent should be queued for later delivery.
#             -header      A single RFC 822 header key and value (as a list),
#                          used to specify to whom to send the message 
#                          (To, Cc, Bcc), the "From", etc.
#             -originator  The originator of the message (equivalent to
#                          specifying a From header).
#             -recipients  A string containing recipient e-mail addresses.
#                          NOTE: This option overrides any recipient addresses
#                          specified with -header.
#             -servers     A list of mail servers that could process the
#                          request.
#             -ports       A list of SMTP ports to use for each SMTP server
#                          specified
#             -maxsecs     Maximum number of seconds to allow the SMTP server
#                          to accept the message. If not specified, the default
#                          is 120 seconds.
#             -usetls      A boolean flag. If the server supports it and we
#                          have the package, use TLS to secure the connection.
#             -tlspolicy   A command to call if the TLS negotiation fails for
#                          some reason. Return 'insecure' to continue with
#                          normal SMTP or 'secure' to close the connection and
#                          try another server.
#             -username    These are needed if your SMTP server requires
#             -password    authentication.
#
# Results:
#	Message is sent.  On success, return "".  On failure, throw an
#       exception with an error code and error message.

proc ::smtp::sendmessage {part args} {
    global errorCode errorInfo

    # Here are the meanings of the following boolean variables:
    # aloP -- value of -atleastone option above.
    # debugP -- value of -debug option above.
    # origP -- 1 if -originator option was specified, 0 otherwise.
    # queueP -- value of -queue option above.

    set aloP 0
    set debugP 0
    set origP 0
    set queueP 0
    set maxsecs 120
    set originator ""
    set recipients ""
    set servers [list localhost]
    set ports [list 25]
    set tlsP 1
    set tlspolicy {}
    set username {}
    set password {}

    array set header ""

    # lowerL will contain the list of header keys (converted to lower case) 
    # specified with various -header options.  mixedL is the mixed-case version
    # of the list.
    set lowerL ""
    set mixedL ""

    # Parse options (args).

    if {[expr {[llength $args]%2}]} {
        # Some option didn't get a value.
        error "Each option must have a value!  Invalid option list: $args"
    }
    
    foreach {option value} $args {
        switch -- $option {
            -atleastone {set aloP   [boolean $value]}
            -debug      {set debugP [boolean $value]}
            -queue      {set queueP [boolean $value]}
            -usetls     {set tlsP   [boolean $value]}
            -tlspolicy  {set tlspolicy $value}
	    -maxsecs    {set maxsecs [expr {$value < 0 ? 0 : $value}]}
            -header {
                if {[llength $value] != 2} {
                    error "-header expects a key and a value, not $value"
                }
                set mixed [lindex $value 0]
                set lower [string tolower $mixed]
                set disallowedHdrList                     [list content-type                           content-transfer-encoding                           content-md5                           mime-version]
                if {[lsearch -exact $disallowedHdrList $lower] > -1} {
                    error "Content-Type, Content-Transfer-Encoding,                        Content-MD5, and MIME-Version cannot be user-specified."
                }
                if {[lsearch -exact $lowerL $lower] < 0} {
                    lappend lowerL $lower
                    lappend mixedL $mixed
                }               

                lappend header($lower) [lindex $value 1]
            }

            -originator {
                set originator $value
                if {$originator == ""} {
                    set origP 1
                }
            }

            -recipients {
                set recipients $value
            }

            -servers {
                set servers $value
            }

            -ports {
                set ports $value
            }

            -username { set username $value }
            -password { set password $value }

            default {
                error "unknown option $option"
            }
        }
    }

    if {[lsearch -glob $lowerL resent-*] >= 0} {
        set prefixL resent-
        set prefixM Resent-
    } else {
        set prefixL ""
        set prefixM ""
    }

    # Set a bunch of variables whose value will be the real header to be used
    # in the outbound message (with proper case and prefix).

    foreach mixed {From Sender To cc Dcc Bcc Date Message-ID} {
        set lower [string tolower $mixed]
	# FRINK: nocheck
        set ${lower}L $prefixL$lower
	# FRINK: nocheck
        set ${lower}M $prefixM$mixed
    }

    if {$origP} {
        # -originator was specified with "", so SMTP sender should be marked "".
        set sender ""
    } else {
        # -originator was specified with a value, OR -originator wasn't
        # specified at all.
        
        # If no -originator was provided, get the originator from the "From"
        # header.  If there was no "From" header get it from the username
        # executing the script.

        set who "-originator"
        if {$originator == ""} {
            if {![info exists header($fromL)]} {
                set originator $::tcl_platform(user)
            } else {
                set originator [join $header($fromL) ,]

                # Indicate that we're using the From header for the originator.

                set who $fromM
            }
        }
        
	# If there's no "From" header, create a From header with the value
	# of -originator as the value.

        if {[lsearch -exact $lowerL $fromL] < 0} {
            lappend lowerL $fromL
            lappend mixedL $fromM
            lappend header($fromL) $originator
        }

	# ::mime::parseaddress returns a list whose elements are huge key-value
	# lists with info about the addresses.  In this case, we only want one
	# originator, so we want the length of the main list to be 1.

        set addrs [::mime::parseaddress $originator]
        if {[llength $addrs] > 1} {
            error "too many mailboxes in $who: $originator"
        }
        array set aprops [lindex $addrs 0]
        if {$aprops(error) != ""} {
            error "error in $who: $aprops(error)"
        }

	# sender = validated originator or the value of the From header.

        set sender $aprops(address)

	# If no Sender header has been specified and From is different from
	# originator, then set the sender header to the From.  Otherwise, don't
	# specify a Sender header.
        set from [join $header($fromL) ,]
        if {[lsearch -exact $lowerL $senderL] < 0 &&                 [string compare $originator $from]} {
            if {[info exists aprops]} {
                unset aprops
            }
            array set aprops [lindex [::mime::parseaddress $from] 0]
            if {$aprops(error) != ""} {
                error "error in $fromM: $aprops(error)"
            }
            if {[string compare $aprops(address) $sender]} {
                lappend lowerL $senderL
                lappend mixedL $senderM
                lappend header($senderL) $aprops(address)
            }
        }
    }

    # We're done parsing the arguments.

    if {$recipients != ""} {
        set who -recipients
    } elseif {![info exists header($toL)]} {
        error "need -header \"$toM ...\""
    } else {
        set recipients [join $header($toL) ,]
	# Add Cc values to recipients list
	set who $toM
        if {[info exists header($ccL)]} {
            append recipients ,[join $header($ccL) ,]
            append who /$ccM
        }

        set dccInd [lsearch -exact $lowerL $dccL]
        if {$dccInd >= 0} {
	    # Add Dcc values to recipients list, and get rid of Dcc header
	    # since we don't want to output that.
            append recipients ,[join $header($dccL) ,]
            append who /$dccM

            unset header($dccL)
            set lowerL [lreplace $lowerL $dccInd $dccInd]
            set mixedL [lreplace $mixedL $dccInd $dccInd]
        }
    }

    set brecipients ""
    set bccInd [lsearch -exact $lowerL $bccL]
    if {$bccInd >= 0} {
        set bccP 1

	# Build valid bcc list and remove bcc element of header array (so that
	# bcc info won't be sent with mail).
        foreach addr [::mime::parseaddress [join $header($bccL) ,]] {
            if {[info exists aprops]} {
                unset aprops
            }
            array set aprops $addr
            if {$aprops(error) != ""} {
                error "error in $bccM: $aprops(error)"
            }
            lappend brecipients $aprops(address)
        }

        unset header($bccL)
        set lowerL [lreplace $lowerL $bccInd $bccInd]
        set mixedL [lreplace $mixedL $bccInd $bccInd]
    } else {
        set bccP 0
    }

    # If there are no To headers, add "" to bcc list.  WHY??
    if {[lsearch -exact $lowerL $toL] < 0} {
        lappend lowerL $bccL
        lappend mixedL $bccM
        lappend header($bccL) ""
    }

    # Construct valid recipients list from recipients list.

    set vrecipients ""
    foreach addr [::mime::parseaddress $recipients] {
        if {[info exists aprops]} {
            unset aprops
        }
        array set aprops $addr
        if {$aprops(error) != ""} {
            error "error in $who: $aprops(error)"
        }
        lappend vrecipients $aprops(address)
    }

    # If there's no date header, get the date from the mime message.  Same for
    # the message-id.

    if {([lsearch -exact $lowerL $dateL] < 0)             && ([catch { ::mime::getheader $part $dateL }])} {
        lappend lowerL $dateL
        lappend mixedL $dateM
        lappend header($dateL) [::mime::parsedatetime -now proper]
    }

    if {([lsearch -exact $lowerL ${message-idL}] < 0)             && ([catch { ::mime::getheader $part ${message-idL} }])} {
        lappend lowerL ${message-idL}
        lappend mixedL ${message-idM}
        lappend header(${message-idL}) [::mime::uniqueID]

    }

    # Get all the headers from the MIME object and save them so that they can
    # later be restored.
    set savedH [::mime::getheader $part]

    # Take all the headers defined earlier and add them to the MIME message.
    foreach lower $lowerL mixed $mixedL {
        foreach value $header($lower) {
            ::mime::setheader $part $mixed $value -mode append
        }
    }

    if {![string compare $servers localhost]} {
        set client localhost
    } else {
        set client [info hostname]
    }

    # Create smtp token, which essentially means begin talking to the SMTP
    # server.
    set token [initialize -debug $debugP -client $client 		                -maxsecs $maxsecs -usetls $tlsP                                 -multiple $bccP -queue $queueP                                 -servers $servers -ports $ports                                 -tlspolicy $tlspolicy                                 -username $username -password $password]

    if {![string match "::smtp::*" $token]} {
	# An error occurred and $token contains the error info
	array set respArr $token
	return -code error $respArr(diagnostic)
    }

    set code [catch { sendmessageaux $token $part                                            $sender $vrecipients $aloP }                     result]
    set ecode $errorCode
    set einfo $errorInfo

    # Send the message to bcc recipients as a MIME attachment.

    if {($code == 0) && ($bccP)} {
        set inner [::mime::initialize -canonical message/rfc822                                     -header [list Content-Description                                                   "Original Message"]                                     -parts [list $part]]

        set subject "\[$bccM\]"
        if {[info exists header(subject)]} {
            append subject " " [lindex $header(subject) 0] 
        }

        set outer [::mime::initialize                          -canonical multipart/digest                          -header [list From $originator]                          -header [list Bcc ""]                          -header [list Date                                        [::mime::parsedatetime -now proper]]                          -header [list Subject $subject]                          -header [list Message-ID [::mime::uniqueID]]                          -header [list Content-Description                                        "Blind Carbon Copy"]                          -parts [list $inner]]


        set code [catch { sendmessageaux $token $outer                                                $sender $brecipients                                                $aloP } result2]
        set ecode $errorCode
        set einfo $errorInfo

        if {$code == 0} {
            set result [concat $result $result2]
        } else {
            set result $result2
        }

        catch { ::mime::finalize $inner -subordinates none }
        catch { ::mime::finalize $outer -subordinates none }
    }

    # Determine if there was any error in prior operations and set errorcodes
    # and error messages appropriately.
    
    switch -- $code {
        0 {
            set status orderly
        }

        7 {
            set code 1
            array set response $result
            set result "$response(code): $response(diagnostic)"
            set status abort
        }

        default {
            set status abort
        }
    }

    # Destroy SMTP token 'cause we're done with it.
    
    catch { finalize $token -close $status }

    # Restore provided MIME object to original state (without the SMTP headers).
    
    foreach key [::mime::getheader $part -names] {
        mime::setheader $part $key "" -mode delete
    }
    foreach {key values} $savedH {
        foreach value $values {
            ::mime::setheader $part $key $value -mode append
        }
    }

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::smtp::sendmessageaux --
#
#	Sends a mime object (containing a message) to some recipients using an
#       existing SMTP token.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	part        The MIME object containing the message to send.
#       originator  The e-mail address of the entity sending the message,
#                   usually the From clause.
#       recipients  List of e-mail addresses to whom message will be sent.
#       aloP        Boolean "atleastone" setting; see the -atleastone option
#                   in ::smtp::sendmessage for details.
#
# Results:
#	Message is sent.  On success, return "".  On failure, throw an
#       exception with an error code and error message.

proc ::smtp::sendmessageaux {token part originator recipients aloP} {
    global errorCode errorInfo

    winit $token $part $originator

    set goodP 0
    set badP 0
    set oops ""
    foreach recipient $recipients {
        set code [catch { waddr $token $recipient } result]
        set ecode $errorCode
        set einfo $errorInfo

        switch -- $code {
            0 {
                incr goodP
            }

            7 {
                incr badP

                array set response $result
                lappend oops [list $recipient $response(code)                                    $response(diagnostic)]
            }

            default {
                return -code $code -errorinfo $einfo -errorcode $ecode $result
            }
        }
    }

    if {($goodP) && ((!$badP) || ($aloP))} {
        wtext $token $part
    } else {
        catch { talk $token 300 RSET }
    }

    return $oops
}

# ::smtp::initialize --
#
#	Create an SMTP token and open a connection to the SMTP server.
#
# Arguments:
#       args  A list of arguments specifying various options for sending the
#             message:
#             -debug       A boolean specifying whether or not debugging is
#                          on.  If debugging is enabled, status messages are 
#                          printed to stderr while trying to send mail.
#             -client      Either localhost or the name of the local host.
#             -multiple    Multiple messages will be sent using this token.
#             -queue       A boolean specifying whether or not the message
#                          being sent should be queued for later delivery.
#             -servers     A list of mail servers that could process the
#                          request.
#             -ports       A list of ports on mail servers that could process
#                          the request (one port per server-- defaults to 25).
#             -usetls      A boolean to indicate we will use TLS if possible.
#             -tlspolicy   Command called if TLS setup fails.
#             -username    These provide the authentication information 
#             -password    to be used if needed by the SMTP server.
#
# Results:
#	On success, return an smtp token.  On failure, throw
#       an exception with an error code and error message.

proc ::smtp::initialize {args} {
    global errorCode errorInfo

    variable smtp

    set token [namespace current]::[incr smtp(uid)]
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set state [list afterID "" options "" readable 0]
    array set options [list -debug 0 -client localhost -multiple 1                             -maxsecs 120 -queue 0 -servers localhost                             -ports 25 -usetls 1 -tlspolicy {}                             -username {} -password {}]
    array set options $args
    set state(options) [array get options]

    # Iterate through servers until one accepts a connection (and responds
    # nicely).
   
    set index 0 
    foreach server $options(-servers) {
	set state(readable) 0
        if {[llength $options(-ports)] >= $index} {
            set port [lindex $options(-ports) $index]
        } else {
            set port 25
        }
        if {$options(-debug)} {
            puts stderr "Trying $server..."
            flush stderr
        }

        if {[info exists state(sd)]} {
            unset state(sd)
        }

        if {[set code [catch {
            set state(sd) [socket -async $server $port]
            fconfigure $state(sd) -blocking off -translation binary
            fileevent $state(sd) readable [list ::smtp::readable $token]
        } result]]} {
            set ecode $errorCode
            set einfo $errorInfo

            catch { close $state(sd) }
            continue
        }

        if {[set code [catch { hear $token 600 } result]]} {
            array set response [list code 400 diagnostic $result]
        } else {
            array set response $result
        }
        set ecode $errorCode
        set einfo $errorInfo
        switch -- $response(code) {
            220 {
            }

            421 - default {
                # 421 - Temporary problem on server
                catch {close $state(sd)}
                continue
            }
        }

        set r [initialize_ehlo $token]
        if {$r != {}} {
            return $r
        }
        incr index
    }

    # None of the servers accepted our connection, so close everything up and
    # return an error.
    finalize $token -close drop

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

proc ::smtp::initialize_ehlo {token} {
    global errorCode errorInfo
    upvar einfo einfo
    upvar ecode ecode
    upvar code  code
    
    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    array set options $state(options)

    # Try enhanced SMTP first.

    if {[set code [catch {smtp::talk $token 300 "EHLO $options(-client)"}                        result]]} {
        array set response [list code 400 diagnostic $result args ""]
    } else {
        array set response $result
    }
    set ecode $errorCode
    set einfo $errorInfo
    if {(500 <= $response(code)) && ($response(code) <= 599)} {
        if {[set code [catch { talk $token 300                                    "HELO $options(-client)" }                            result]]} {
            array set response [list code 400 diagnostic $result args ""]
        } else {
            array set response $result
        }
        set ecode $errorCode
        set einfo $errorInfo
    }
    
    if {$response(code) == 250} {
        # Successful response to HELO or EHLO command, so set up queuing
        # and whatnot and return the token.
        
        set state(esmtp) $response(args)

        if {(!$options(-multiple))                 && ([lsearch $response(args) ONEX] >= 0)} {
            catch {smtp::talk $token 300 ONEX}
        }
        if {($options(-queue))                 && ([lsearch $response(args) XQUE] >= 0)} {
            catch {smtp::talk $token 300 QUED}
        }
        
        # Support STARTTLS extension.
        # The state(tls) item is used to see if we have already tried this.
        if {($options(-usetls)) && ![info exists state(tls)]                 && (([lsearch $response(args) STARTTLS] >= 0)
                    || ([lsearch $response(args) TLS] >= 0))} {
            if {![catch {package require tls}]} {
                set state(tls) 0
                if {![catch {smtp::talk $token 300 STARTTLS} resp]} {
                    array set starttls $resp
                    if {$starttls(code) == 220} {
                        fileevent $state(sd) readable {}
                        catch {
                            ::tls::import $state(sd)
                            catch {::tls::handshake $state(sd)} msg
                            set state(tls) 1
                        } 
                        fileevent $state(sd) readable                             [list ::smtp::readable $token]
                        return [initialize_ehlo $token]
                    } else {
                        # Call a TLS client policy proc here
                        #  returns secure close and try another server.
                        #  returns insecure continue on current socket
                        set policy insecure
                        if {$options(-tlspolicy) != {}} {
                            catch {
                                eval $options(-tlspolicy)                                     [list $starttls(code)]                                     [list $starttls(diagnostic)]
                            } policy
                        }
                        if {$policy != "insecure"} {
                            set code error
                            set ecode $starttls(code)
                            set einfo $starttls(diagnostic)
                            catch {close $state(sd)}
                            return {}
                        }
                    }
                }
            }
        }

        # If we have not already tried and the server supports it and we 
        # have a username -- lets try to authenticate.
        #
        if {![info exists state(auth)]
            && [set andx [lsearch -glob $response(args) "AUTH*"]] >= 0 
            && [string length $options(-username)] > 0 } {
            
            # May be AUTH mech or AUTH=mech
            # We want to use the strongest mechanism that has been offered
            # and that we support. If we cannot find a mechanism that 
            # succeeds, we will go ahead and try to carry on unauthenticated.
            # This may still work else we'll get an unauthorised error later.

            set mechs [string range [lindex $response(args) $andx] 5 end]
            foreach mech [list DIGEST-MD5 CRAM-MD5 LOGIN PLAIN] {
                if {[lsearch -exact $mechs $mech] == -1} { continue }
                if {[info command [namespace current]::auth_$mech] != {}} {
                    if {[catch {
                        auth_$mech $token
                    } msg]} {
                        if {$options(-debug)} {
                            puts stderr "AUTH $mech failed: $msg "
                            flush stderr
                        }
                    }
                    if {[info exists state(auth)] && $state(auth)} {
                        if {$state(auth) == 1} {
                            break
                        } else {
                            # After successful AUTH we are supposed to redo
                            # our connection for mechanisms that setup a new
                            # security layer -- these should set state(auth) 
                            # greater than 1
                            fileevent $state(sd) readable                                 [list ::smtp::readable $token]
                            return [initialize_ehlo $token]
                        }
                    }
                }
            }
        }
        
        return $token
    } else {
        # Bad response; close the connection and hope the next server
        # is happier.
        catch {close $state(sd)}
    }
    return {}
}

# ::smtp::auth_LOGIN --
#
#	Perform LOGIN authentication to the SMTP server.
#
# Results:
#	Negiotiates user authentication. If successful returns the result
#       otherwise an error is thrown

proc ::smtp::auth_LOGIN {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    array set options $state(options)
    
    package require base64
    set user [base64::encode $options(-username)]
    set pass [base64::encode $options(-password)]

    set state(auth) 0
    set result [smtp::talk $token 300 "AUTH LOGIN"]
    array set response $result

    if {$response(code) == 334} {
        set result [smtp::talk $token 300 $user]
        array set response $result
    }
    if {$response(code) == 334} {
        set result [smtp::talk $token 300 $pass]
        array set response $result
    }
    if {$response(code) == 235} {
        set state(auth) 1
        return $result
    } else {
        return -code 7 $result
    }
}

# ::smtp::auth_PLAIN
#
# 	Implement PLAIN SASL mechanism (RFC2595).
#
# Results:
#	Negiotiates user authentication. If successful returns the result
#       otherwise an error is thrown

proc ::smtp::auth_PLAIN {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    array set options $state(options)
    
    package require base64
    set id [base64::encode "\x00$options(-username)\x00$options(-password)"]

    set state(auth) 0
    set result [smtp::talk $token 300 "AUTH PLAIN $id"]
    array set response $result
    
    if {$response(code) == 235} {
        set state(auth) 1
        return $result
    } else {
        return -code 7 $result
    }
}

# ::smtp::auth_CRAM-MD5
#
# 	Implement CRAM-MD5 SASL mechanism (RFC2195).
#
# Results:
#	Negiotiates user authentication. If successful returns the result
#       otherwise an error is thrown

proc ::smtp::auth_CRAM-MD5 {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    array set options $state(options)
    
    package require base64
    md5_init

    set state(auth) 0
    set result [smtp::talk $token 300 "AUTH CRAM-MD5"]
    array set response $result

    if {$response(code) == 334} {
        set challenge [base64::decode $response(diagnostic)]
        set reply [hmac_hex $options(-password) $challenge]
        set reply [base64::encode                        "$options(-username) [string tolower $reply]"]
        set result [smtp::talk $token 300 $reply]
        array set response $result
    }

    if {$response(code) == 235} {
        set state(auth) 1
        return $result
    } else {
        return -code 7 $result
    }
}

# ::smtp::auth_DIGEST-MD5
#
# 	Implement DIGEST-MD5 SASL mechanism (RFC2831).
#
# Results:
#	Negiotiates user authentication. If successful returns the result
#       otherwise an error is thrown

proc ::smtp::auth_DIGEST-MD5 {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    array set options $state(options)
    
    package require base64
    md5_init

    set state(auth) 0
    set result [smtp::talk $token 300 "AUTH DIGEST-MD5"]
    array set response $result

    if {$response(code) == 334} {
        set challenge [base64::decode $response(diagnostic)]
        
        # RFC 2831 2.1
        # Char categories as per spec...
        # Build up a regexp for splitting the challenge into key value pairs.
        set sep "\\\]\\\[\\\\()<>@,;:\\\"\\\?=\\\{\\\} \t"
        set tok {0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\-\|\~\!\#\$\%\&\*\+\.\^\_\`}
        set sqot {(?:\'(?:\\.|[^\'\\])*\')}
        set dqot {(?:\"(?:\\.|[^\"\\])*\")}
        array set params [regsub -all "(\[${tok}\]+)=(${dqot}|(?:\[${tok}\]+))(?:\[${sep}\]+|$)" $challenge {\1 \2 }]

        if {![info exists options(noncecount)]} {set options(noncecount) 0}
        set nonce $params(nonce)
        set cnonce [CreateNonce]
        set noncecount [format %08u [incr options(noncecount)]]
        set qop auth
        # If realm not specified - use the servers fqdn
        if {[info exists params(realm)]} {
            set realm $params(realm)
        } else {
            set realm [lindex [fconfigure $state(sd) -peername] 1]
        }
        set uri "smtp/$realm"

        set A1 [md5_bin "$options(-username):$realm:$options(-password)"]
        set A2 "AUTHENTICATE:$uri"
        if {![string equal $qop "auth"]} {
            append A2 :[string repeat 0 32]
        }
        
        set A1h [md5_hex "${A1}:$nonce:$cnonce"]
        set A2h [md5_hex $A2]
        set R  [md5_hex $A1h:$nonce:$noncecount:$cnonce:$qop:$A2h]

        set reply "username=\"$options(-username)\",realm=\"$realm\",nonce=\"$nonce\",nc=\"$noncecount\",cnonce=\"$cnonce\",digest-uri=\"$uri\",response=\"$R\",qop=$qop"
        if {$options(-debug)} {
            puts stderr "<*- $challenge"
            puts stderr "-*> $reply"
            flush stderr
        }

        # The server will provide a base64 encoded string for use with
        # subsequest authentication now. At this time we dont use this value.
        set result [smtp::talk $token 300 [join [base64::encode $reply] {}]]
        array set response $result
        if {$response(code) == 334} {
            #set authresp [base64::decode $response(diagnostic)]
            #if {$options(-debug)} { puts stderr "-*> $authresp" }
            set result [smtp::talk $token 300 {}]
            array set response $result
        }
    }

    if {$response(code) == 235} {
        set state(auth) 1
        return $result
    } else {
        return -code 7 $result
    }
}

proc ::smtp::md5_init {} {
    # Deal with either version of md5. We'd like version 2 but someone
    # may have already loaded version 1.
    set md5major [lindex [split [package require md5] .] 0]
    if {$md5major < 2} {
        # md5 v1, no options, and returns a hex string ready for
        # us.
        proc ::smtp::md5_hex {data} { return [::md5::md5 $data] }
        proc ::smtp::md5_bin {data} { return [binary format H* [::md5::md5 $data]] }
        proc ::smtp::hmac_hex {pass data} { return [::md5::hmac $pass $data] }
    } else {
        # md5 v2 requires -hex to return hash as hex-encoded
        # non-binary string.
        proc ::smtp::md5_hex {data} { return [string tolower [::md5::md5 -hex $data]] }
        proc ::smtp::md5_bin {data} { return [::md5::md5 $data] }
        proc ::smtp::hmac_hex {pass data} { return [::md5::hmac -hex -key $pass $data] }
    }
}

# Get 16 random bytes for a nonce value. If we can use /dev/random, do so
# otherwise we hash some values.
#
proc ::smtp::CreateNonce {} {
    set bytes {}
    if {[file readable /dev/random]} {
        catch {
            set f [open /dev/random r]
            fconfigure $f -translation binary -buffering none
            set bytes [read $f 16]
        }
    }
    if {[string length $bytes] < 1} {
        set bytes [md5_bin [clock seconds]:[pid]:[expr {rand()}]]
    }
    return [binary scan $bytes h* r; set r]
}

# ::smtp::finalize --
#
#	Deletes an SMTP token by closing the connection to the SMTP server,
#       cleanup up various state.
#
# Arguments:
#       token   SMTP token that has an open connection to the SMTP server.
#       args    Optional arguments, where the only useful option is -close,
#               whose valid values are the following:
#               orderly     Normal successful completion.  Close connection and
#                           clear state variables.
#               abort       A connection exists to the SMTP server, but it's in
#                           a weird state and needs to be reset before being
#                           closed.  Then clear state variables.
#               drop        No connection exists, so we just need to clean up
#                           state variables.
#
# Results:
#	SMTP connection is closed and state variables are cleared.  If there's
#       an error while attempting to close the connection to the SMTP server,
#       throw an exception with the error code and error message.

proc ::smtp::finalize {token args} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options [list -close orderly]
    array set options $args

    switch -- $options(-close) {
        orderly {
            set code [catch { talk $token 120 QUIT } result]
        }

        abort {
            set code [catch {
                talk $token 0 RSET
                talk $token 0 QUIT
            } result]
        }

        drop {
            set code 0
            set result ""
        }

        default {
            error "unknown value for -close $options(-close)"
        }
    }
    set ecode $errorCode
    set einfo $errorInfo

    catch { close $state(sd) }

    if {$state(afterID) != ""} {
        catch { after cancel $state(afterID) }
    }

    foreach name [array names state] {
        unset state($name)
    }
    # FRINK: nocheck
    unset $token

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::smtp::winit --
#
#	Send originator info to SMTP server.  This occurs after HELO/EHLO
#       command has completed successfully (in ::smtp::initialize).  This function
#       is called by ::smtp::sendmessageaux.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#       part        MIME token for the message to be sent. May be used for
#                   handling some SMTP extensions.
#       originator  The e-mail address of the entity sending the message,
#                   usually the From clause.
#       mode        SMTP command specifying the mode of communication.  Default
#                   value is MAIL.
#
# Results:
#	Originator info is sent and SMTP server's response is returned.  If an
#       error occurs, throw an exception.

proc ::smtp::winit {token part originator {mode MAIL}} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[lsearch -exact [list MAIL SEND SOML SAML] $mode] < 0} {
        error "unknown origination mode $mode"
    }

    set from "$mode FROM:<$originator>"

    # RFC 1870 -  SMTP Service Extension for Message Size Declaration
    if {[info exists state(esmtp)] 
        && [lsearch -glob $state(esmtp) "SIZE*"] != -1} {
        catch {
            set size [string length [mime::buildmessage $part]]
            append from " SIZE=$size"
        }
    }

    array set response [set result [talk $token 600 $from]]

    if {$response(code) == 250} {
        set state(addrs) 0
        return $result
    } else {
        return -code 7 $result
    }
}

# ::smtp::waddr --
#
#	Send recipient info to SMTP server.  This occurs after originator info
#       is sent (in ::smtp::winit).  This function is called by
#       ::smtp::sendmessageaux. 
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#       recipient   One of the recipients to whom the message should be
#                   delivered.  
#
# Results:
#	Recipient info is sent and SMTP server's response is returned.  If an
#       error occurs, throw an exception.

proc ::smtp::waddr {token recipient} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set result [talk $token 3600 "RCPT TO:<$recipient>"]
    array set response $result

    switch -- $response(code) {
        250 - 251 {
            incr state(addrs)
            return $result
        }

        default {
            return -code 7 $result
        }
    }
}

# ::smtp::wtext --
#
#	Send message to SMTP server.  This occurs after recipient info
#       is sent (in ::smtp::winit).  This function is called by
#       ::smtp::sendmessageaux. 
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	part        The MIME object containing the message to send.
#
# Results:
#	MIME message is sent and SMTP server's response is returned.  If an
#       error occurs, throw an exception.

proc ::smtp::wtext {token part} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    array set options $state(options)

    set result [talk $token 300 DATA]
    array set response $result
    if {$response(code) != 354} {
        return -code 7 $result
    }

    if {[catch { wtextaux $token $part } result]} {
        catch { puts -nonewline $state(sd) "\r\n.\r\n" ; flush $state(sd) }
        return -code 7 [list code 400 diagnostic $result]
    }

    set secs $options(-maxsecs)

    set result [talk $token $secs .]
    array set response $result
    switch -- $response(code) {
        250 - 251 {
            return $result
        }

        default {
            return -code 7 $result
        }
    }
}

# ::smtp::wtextaux --
#
#	Helper function that coordinates writing the MIME message to the socket.
#       In particular, it stacks the channel leading to the SMTP server, sets up
#       some file events, sends the message, unstacks the channel, resets the
#       file events to their original state, and returns.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	part        The MIME object containing the message to send.
#
# Results:
#	Message is sent.  If anything goes wrong, throw an exception.

proc ::smtp::wtextaux {token part} {
    global errorCode errorInfo

    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    # Workaround a bug with stacking channels on top of TLS.
    # FRINK: nocheck
    set trf [set [namespace current]::trf]
    if {[info exists state(tls)] && $state(tls)} {
        set trf 0
    }

    flush $state(sd)
    fileevent $state(sd) readable ""
    if {$trf} {
        transform -attach $state(sd) -command [list ::smtp::wdata $token]
    } else {
        set state(size) 1
    }
    fileevent $state(sd) readable [list ::smtp::readable $token]

    # If trf is not available, get the contents of the message,
    # replace all '.'s that start their own line with '..'s, and
    # then write the mime body out to the filehandle. Do not forget to
    # deal with bare LF's here too (SF bug #499242).

    if {$trf} {
        set code [catch { ::mime::copymessage $part $state(sd) } result]
    } else {
        set code [catch { ::mime::buildmessage $part } result]
        if {$code == 0} {
	    # Detect and transform bare LF's into proper CR/LF
	    # sequences.

	    while {[regsub -all -- {([^\r])\n} $result "\\1\r\n" result]} {}
            regsub -all -- {\n\.}      $result "\n.."   result

            set state(size) [string length $result]
            puts -nonewline $state(sd) $result
            set result ""
	}
    }
    set ecode $errorCode
    set einfo $errorInfo

    flush $state(sd)
    fileevent $state(sd) readable ""
    if {$trf} {
        unstack $state(sd)
    }
    fileevent $state(sd) readable [list ::smtp::readable $token]

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::smtp::wdata --
#
#	This is the custom transform using Trf to do CR/LF translation.  If Trf
#       is not installed on the system, then this function never gets called and
#       no translation occurs.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#       command     Trf provided command for manipulating socket data.
#	buffer      Data to be converted.
#
# Results:
#	buffer is translated, and state(size) is set.  If Trf is not installed
#       on the system, the transform proc defined at the top of this file sets
#       state(size) to 1.  state(size) is used later to determine a timeout
#       value.

proc ::smtp::wdata {token command buffer} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -- $command {
        create/write -
        clear/write  -
        delete/write {
            set state(crP) 0
            set state(nlP) 1
            set state(size) 0
        }

        write {
            set result ""

            foreach c [split $buffer ""] {
                switch -- $c {
                    "." {
                        if {$state(nlP)} {
                            append result .
                        }
                        set state(crP) 0
                        set state(nlP) 0
                    }

                    "\r" {
                        set state(crP) 1
                        set state(nlP) 0
                    }

                    "\n" {
                        if {!$state(crP)} {
                            append result "\r"
                        }
                        set state(crP) 0
                        set state(nlP) 1
                    }

                    default {
                        set state(crP) 0
                        set state(nlP) 0
                    }
                }

                append result $c
            }

            incr state(size) [string length $result]
            return $result
        }

        flush/write {
            set result ""

            if {!$state(nlP)} {
                if {!$state(crP)} {
                    append result "\r"
                }
                append result "\n"
            }

            incr state(size) [string length $result]
            return $result
        }

	create/read -
        delete/read {
	    # Bugfix for [#539952]
        }

	query/ratio {
	    # Indicator for unseekable channel,
	    # for versions of Trf which ask for
	    # this.
	    return {0 0}
	}
	query/maxRead {
	    # No limits on reading bytes from the channel below, for
	    # versions of Trf which ask for this information
	    return -1
	}

	default {
	    # Silently pass all unknown commands.
	    #error "Unknown command \"$command\""
	}
    }

    return ""
}

# ::smtp::talk --
#
#	Sends an SMTP command to a server
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	secs        Timeout after which command should be aborted.
#       command     Command to send to SMTP server.
#
# Results:
#	command is sent and response is returned.  If anything goes wrong, throw
#       an exception.

proc ::smtp::talk {token secs command} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options $state(options)

    if {$options(-debug)} {
        puts stderr "--> $command (wait upto $secs seconds)"
        flush stderr
    }

    if {[catch { puts -nonewline $state(sd) "$command\r\n"
                 flush $state(sd) } result]} {
        return [list code 400 diagnostic $result]
    }

    if {$secs == 0} {
        return ""
    }

    return [hear $token $secs]
}

# ::smtp::hear --
#
#	Listens for SMTP server's response to some prior command.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	secs        Timeout after which we should stop waiting for a response.
#
# Results:
#	Response is returned.

proc ::smtp::hear {token secs} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options $state(options)

    array set response [list args ""]

    set firstP 1
    while {1} {
        if {$secs >= 0} {
	    ## SF [ 836442 ] timeout with large data
	    ## correction, aotto 031105 -
	    if {$secs > 600} {set secs 600}
            set state(afterID) [after [expr {$secs*1000}]                                       [list ::smtp::timer $token]]
        }

        if {!$state(readable)} {
            vwait ${token}(readable)
        }

        # Wait until socket is readable.
        if {$state(readable) !=  -1} {
            catch { after cancel $state(afterID) }
            set state(afterID) ""
        }

        if {$state(readable) < 0} {
            array set response [list code 400 diagnostic $state(error)]
            break
        }
        set state(readable) 0

        if {$options(-debug)} {
            puts stderr "<-- $state(line)"
            flush stderr
        }

        if {[string length $state(line)] < 3} {
            array set response                   [list code 500                         diagnostic "response too short: $state(line)"]
            break
        }

        if {$firstP} {
            set firstP 0

            if {[scan [string range $state(line) 0 2] %d response(code)]                     != 1} {
                array set response                       [list code 500                             diagnostic "unrecognizable code: $state(line)"]
                break
            }

            set response(diagnostic)                 [string trim [string range $state(line) 4 end]]
        } else {
            lappend response(args)                     [string trim [string range $state(line) 4 end]]
        }

        # When status message line ends in -, it means the message is complete.
        
        if {[string compare [string index $state(line) 3] -]} {
            break
        }
    }

    return [array get response]
}

# ::smtp::readable --
#
#	Reads a line of data from SMTP server when the socket is readable.  This
#       is the callback of "fileevent readable".
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#
# Results:
#	state(line) contains the line of data and state(readable) is reset.
#       state(readable) gets the following values:
#       -3  if there's a premature eof,
#       -2  if reading from socket fails.
#       1   if reading from socket was successful

proc ::smtp::readable {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[catch { array set options $state(options) }]} {
        return
    }

    set state(line) ""
    if {[catch { gets $state(sd) state(line) } result]} {
        set state(readable) -2
        set state(error) $result
    } elseif {$result == -1} {
        if {[eof $state(sd)]} {
            set state(readable) -3
            set state(error) "premature end-of-file from server"
        }
    } else {
        # If the line ends in \r, remove the \r.
        if {![string compare [string index $state(line) end] "\r"]} {
            set state(line) [string range $state(line) 0 end-1]
        }
        set state(readable) 1
    }

    if {$state(readable) < 0} {
        if {$options(-debug)} {
            puts stderr "    ... $state(error) ..."
            flush stderr
        }

        catch { fileevent $state(sd) readable "" }
    }
}

# ::smtp::timer --
#
#	Handles timeout condition on any communication with the SMTP server.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#
# Results:
#	Sets state(readable) to -1 and state(error) to an error message.

proc ::smtp::timer {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options $state(options)

    set state(afterID) ""
    set state(readable) -1
    set state(error) "read from server timed out"

    if {$options(-debug)} {
        puts stderr "    ... $state(error) ..."
        flush stderr
    }
}

# ::smtp::boolean --
#
#	Helper function for unifying boolean values to 1 and 0.
#
# Arguments:
#       value   Some kind of value that represents true or false (i.e. 0, 1,
#               false, true, no, yes, off, on).
#
# Results:
#	Return 1 if the value is true, 0 if false.  If the input value is not
#       one of the above, throw an exception.

proc ::smtp::boolean {value} {
    switch -- [string tolower $value] {
        0 - false - no - off {
            return 0
        }

        1 - true - yes - on {
            return 1
        }

        default {
            error "unknown boolean value: $value"
        }
    }
}
package require msgcat
namespace import msgcat::*
if {![info exists arguments(-f)]} {
    package require Tclx
}

lappend auto_path /usr/lib/moodss
if {[info exists package(directory,internationalization)]} {
    package require internationalization
} else {
    lappend auto_path [pwd]
    if {[catch {package require internationalization} message]} {
        puts stderr $message:
        puts stderr            "either moomps is not properly installed or you need to run\nmoomps from its development directory with the -f option"
        exit 1
    }
}
set automaticPath $auto_path

# uri.tcl --
#
#	URI parsing and fetch
#
# Copyright (c) 2000 Zveno Pty Ltd
# Steve Ball, http://www.zveno.com/
# Derived from urls.tcl by Andreas Kupries
#
# TODO:
#	Handle www-url-encoding details
#
# CVS: $Id: uri.tcl,v 1.27 2004/05/03 22:56:25 andreas_kupries Exp $

package require Tcl 8.2

namespace eval ::uri {

    namespace export split join
    namespace export resolve isrelative
    namespace export geturl
    namespace export canonicalize
    namespace export register

    variable file:counter 0

    # extend these variable in the coming namespaces
    variable schemes       {}
    variable schemePattern ""
    variable url           ""
    variable url2part
    array set url2part     {}

    # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # basic regular expressions used in URL syntax.

    namespace eval basic {
	variable	loAlpha		{[a-z]}
	variable	hiAlpha		{[A-Z]}
	variable	digit		{[0-9]}
	variable	alpha		{[a-zA-Z]}
	variable	safe		{[$_.+-]}
	variable	extra		{[!*'(,)]}
	# danger in next pattern, order important for []
	variable	national	{[][|\}\{\^~`]}
	variable	punctuation	{[<>#%"]}	;#" fake emacs hilit
	variable	reserved	{[;/?:@&=]}
	variable	hex		{[0-9A-Fa-f]}
	variable	alphaDigit	{[A-Za-z0-9]}
	variable	alphaDigitMinus	{[A-Za-z0-9-]}

	# next is <national | punctuation>
	variable	unsafe		{[][<>"#%\{\}|\\^~`]} ;#" emacs hilit
	variable	escape		"%${hex}${hex}"

	#	unreserved	= alpha | digit | safe | extra
	#	xchar		= unreserved | reserved | escape

	variable	unreserved	{[a-zA-Z0-9$_.+!*'(,)-]}
	variable	uChar		"(${unreserved}|${escape})"
	variable	xCharN		{[a-zA-Z0-9$_.+!*'(,);/?:@&=-]}
	variable	xChar		"(${xCharN}|${escape})"
	variable	digits		"${digit}+"

	variable	toplabel			"(${alpha}${alphaDigitMinus}*${alphaDigit}|${alpha})"
	variable	domainlabel			"(${alphaDigit}${alphaDigitMinus}*${alphaDigit}|${alphaDigit})"

	variable	hostname			"((${domainlabel}\\.)*${toplabel})"
	variable	hostnumber			"(${digits}\\.${digits}\\.${digits}\\.${digits})"

	variable	host		"(${hostname}|${hostnumber})"

	variable	port		$digits
	variable	hostOrPort	"${host}(:${port})?"

	variable	usrCharN	{[a-zA-Z0-9$_.+!*'(,);?&=-]}
	variable	usrChar		"(${usrCharN}|${escape})"
	variable	user		"${usrChar}*"
	variable	password	$user
	variable	login		"(${user}(:${password})?@)?${hostOrPort}"
    } ;# basic {}
}


# ::uri::register --
#
#	Register a scheme (and aliases) in the package. The command
#	creates a namespace below "::uri" with the same name as the
#	scheme and executes the script declaring the pattern variables
#	for this scheme in the new namespace. At last it updates the
#	uri variables keeping track of overall scheme information.
#
#	The script has to declare at least the variable "schemepart",
#	the pattern for an url of the registered scheme after the
#	scheme declaration. Not declaring this variable is an error.
#
# Arguments:
#	schemeList	Name of the scheme to register, plus aliases
#       script		Script declaring the scheme patterns
#
# Results:
#	None.

proc ::uri::register {schemeList script} {
    variable schemes
    variable schemePattern
    variable url
    variable url2part

    # Check scheme and its aliases for existence.
    foreach scheme $schemeList {
	if {[lsearch -exact $schemes $scheme] >= 0} {
	    return -code error 		    "trying to register scheme (\"$scheme\") which is already known"
	}
    }

    # Get the main scheme
    set scheme  [lindex $schemeList 0]

    if {[catch {namespace eval $scheme $script} msg]} {
	catch {namespace delete $scheme}
	return -code error 	    "error while evaluating scheme script: $msg"
    }

    if {![info exists ${scheme}::schemepart]} {
	namespace delete $scheme
	return -code error 	    "Variable \"schemepart\" is missing."
    }

    # Now we can extend the variables which keep track of the registered schemes.

    eval [linsert $schemeList 0 lappend schemes]
    set schemePattern	"([::join $schemes |]):"

    foreach s schemeList {
	# FRINK: nocheck
	set url2part($s) "${s}:[set ${scheme}::schemepart]"
	# FRINK: nocheck
	append url "(${s}:[set ${scheme}::schemepart])|"
    }
    set url [string trimright $url |]
    return
}

# ::uri::split --
#
#	Splits the given <a url> into its constituents.
#
# Arguments:
#	url	the URL to split
#
# Results:
#	Tcl list containing constituents, suitable for 'array set'.

proc ::uri::split {url {defaultscheme http}} {

    set url [string trim $url]
    set scheme {}

    # RFC 1738:	scheme = 1*[ lowalpha | digit | "+" | "-" | "." ]
    regexp -- {^([a-z0-9+.-][a-z0-9+.-]*):} $url dummy scheme

    if {$scheme == {}} {
	set scheme $defaultscheme
    }

    # ease maintenance: dynamic dispatch, able to handle all schemes
    # added in future!

    if {[::info procs Split[string totitle $scheme]] == {}} {
	error "unknown scheme '$scheme' in '$url'"
    }

    regsub -- "^${scheme}:" $url {} url

    set       parts(scheme) $scheme
    array set parts [Split[string totitle $scheme] $url]

    # should decode all encoded characters!

    return [array get parts]
}

proc ::uri::SplitFtp {url} {
    # @c Splits the given ftp-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    # general syntax:
    # //<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
    #
    # additional rules:
    #
    # <user>:<password> are optional, detectable by presence of @.
    # <password> is optional too.
    #
    # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
    #	<cwd1> "/" ..."/" <cwdN> "/" <name> [";type=" <typecode>]

    upvar \#0 [namespace current]::ftp::typepart ftptype

    array set parts {user {} pwd {} host {} port {} path {} type {}}

    # slash off possible type specification

    if {[regexp -indices -- "${ftptype}$" $url dummy ftype]} {

	set from	[lindex $ftype 0]
	set to		[lindex $ftype 1]

	set parts(type)	[string range   $url $from $to]

	set from	[lindex $dummy 0]
	set url		[string replace $url $from end]
    }

    # Handle user, password, host and port

    if {[string match "//*" $url]} {
	set url [string range $url 2 end]

	array set parts [GetUPHP url]
    }

    set parts(path) [string trimleft $url /]

    return [array get parts]
}

proc ::uri::JoinFtp args {
    array set components {
	user {} pwd {} host {} port {}
	path {} type {}
    }
    array set components $args

    set userPwd {}
    if {[string length $components(user)] || [string length $components(pwd)]} {
	set userPwd $components(user)[expr {[string length $components(pwd)] ? ":$components(pwd)" : {}}]@
    }

    set port {}
    if {[string length $components(port)]} {
	set port :$components(port)
    }

    set type {}
    if {[string length $components(type)]} {
	set type \;type=$components(type)
    }

    return ftp://${userPwd}$components(host)${port}/[string trimleft $components(path) /]$type
}

proc ::uri::SplitHttps {url} {
    uri::SplitHttp $url
}

proc ::uri::SplitHttp {url} {
    # @c Splits the given http-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    # general syntax:
    # //<host>:<port>/<path>?<searchpart>
    #
    #   where <host> and <port> are as described in Section 3.1. If :<port>
    #   is omitted, the port defaults to 80.  No user name or password is
    #   allowed.  <path> is an HTTP selector, and <searchpart> is a query
    #   string. The <path> is optional, as is the <searchpart> and its
    #   preceding "?". If neither <path> nor <searchpart> is present, the "/"
    #   may also be omitted.
    #
    #   Within the <path> and <searchpart> components, "/", ";", "?" are
    #   reserved.  The "/" character may be used within HTTP to designate a
    #   hierarchical structure.
    #
    # path == <cwd1> "/" ..."/" <cwdN> "/" <name> ["#" <fragment>]

    upvar #0 [namespace current]::http::search  search
    upvar #0 [namespace current]::http::segment segment

    array set parts {host {} port {} path {} query {}}

    set searchPattern   "\\?(${search})\$"
    set fragmentPattern "#(${segment})\$"

    # slash off possible query

    if {[regexp -indices -- $searchPattern $url match query]} {
	set from [lindex $query 0]
	set to   [lindex $query 1]

	set parts(query) [string range $url $from $to]

	set url [string replace $url [lindex $match 0] end]
    }

    # slash off possible fragment

    if {[regexp -indices -- $fragmentPattern $url match fragment]} {
	set from [lindex $fragment 0]
	set to   [lindex $fragment 1]

	set parts(fragment) [string range $url $from $to]

	set url [string replace $url [lindex $match 0] end]
    }

    if {[string match "//*" $url]} {
	set url [string range $url 2 end]

	array set parts [GetUPHP url]
    }

    set parts(path) [string trimleft $url /]

    return [array get parts]
}

proc ::uri::JoinHttp {args} {
    eval [linsert $args 0 uri::JoinHttpInner http 80]
}

proc ::uri::JoinHttps {args} {
    eval [linsert $args 0 uri::JoinHttpInner https 443]
}

proc ::uri::JoinHttpInner {scheme defport args} {
    array set components [list 	host {} port $defport path {} query {}     ]
    array set components $args

    set port {}
    if {[string length $components(port)] && $components(port) != $defport} {
	set port :$components(port)
    }

    set query {}
    if {[string length $components(query)]} {
	set query ?$components(query)
    }

    regsub -- {^/} $components(path) {} components(path)

    if { [info exists components(fragment)] && $components(fragment) != "" } {
	set components(fragment) "#$components(fragment)"
    } else {
	set components(fragment) ""
    }

    return $scheme://$components(host)$port/$components(path)$components(fragment)$query
}

proc ::uri::SplitFile {url} {
    # @c Splits the given file-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    upvar #0 [namespace current]::basic::hostname	hostname
    upvar #0 [namespace current]::basic::hostnumber	hostnumber

    if {[string match "//*" $url]} {
	set url [string range $url 2 end]

	set hostPattern "^($hostname|$hostnumber)"
	switch -exact -- $::tcl_platform(platform) {
	    windows {
		# Catch drive letter
		append hostPattern :?
	    }
	    default {
		# Proceed as usual
	    }
	}

	if {[regexp -indices -- $hostPattern $url match host]} {
	    set fh	[lindex $host 0]
	    set th	[lindex $host 1]

	    set parts(host)	[string range $url $fh $th]

	    set  matchEnd   [lindex $match 1]
	    incr matchEnd

	    set url	[string range $url $matchEnd end]
	}
    }

    set parts(path) $url

    return [array get parts]
}

proc ::uri::JoinFile args {
    array set components {
	host {} port {} path {}
    }
    array set components $args

    switch -exact -- $::tcl_platform(platform) {
	windows {
	    if {[string length $components(host)]} {
		return file://$components(host):$components(path)
	    } else {
		return file://$components(path)
	    }
	}
	default {
	    return file://$components(host)$components(path)
	}
    }
}

proc ::uri::SplitMailto {url} {
    # @c Splits the given mailto-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    if {[string match "*@*" $url]} {
	set url [::split $url @]
	return [list user [lindex $url 0] host [lindex $url 1]]
    } else {
	return [list user $url]
    }
}

proc ::uri::JoinMailto args {
    array set components {
	user {} host {}
    }
    array set components $args

    return mailto:$components(user)@$components(host)
}

proc ::uri::SplitNews {url} {
    if { [string first @ $url] >= 0 } {
	return [list message-id $url]
    } else {
	return [list newsgroup-name $url]
    }
}

proc ::uri::JoinNews args {
    array set components {
	message-id {} newsgroup-name {}
    }
    array set components $args
    return news:$components(message-id)$components(newsgroup-name)
}

proc ::uri::GetUPHP {urlvar} {
    # @c Parse user, password host and port out of the url stored in
    # @c variable <a urlvar>.
    # @d Side effect: The extracted information is removed from the given url.
    # @r List containing the extracted information in a format suitable for
    # @r 'array set'.
    # @a urlvar: Name of the variable containing the url to parse.

    upvar \#0 [namespace current]::basic::user		user
    upvar \#0 [namespace current]::basic::password	password
    upvar \#0 [namespace current]::basic::hostname	hostname
    upvar \#0 [namespace current]::basic::hostnumber	hostnumber
    upvar \#0 [namespace current]::basic::port		port

    upvar $urlvar url

    array set parts {user {} pwd {} host {} port {}}

    # syntax
    # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
    # "//" already cut off by caller

    set upPattern "^(${user})(:(${password}))?@"

    if {[regexp -indices -- $upPattern $url match theUser c d thePassword]} {
	set fu	[lindex $theUser 0]
	set tu	[lindex $theUser 1]

	set fp	[lindex $thePassword 0]
	set tp	[lindex $thePassword 1]

	set parts(user)	[string range $url $fu $tu]
	set parts(pwd)	[string range $url $fp $tp]

	set  matchEnd   [lindex $match 1]
	incr matchEnd

	set url	[string range $url $matchEnd end]
    }

    set hpPattern "^($hostname|$hostnumber)(:($port))?"

    if {[regexp -indices -- $hpPattern $url match theHost c d e f g h thePort]} {
	set fh	[lindex $theHost 0]
	set th	[lindex $theHost 1]

	set fp	[lindex $thePort 0]
	set tp	[lindex $thePort 1]

	set parts(host)	[string range $url $fh $th]
	set parts(port)	[string range $url $fp $tp]

	set  matchEnd   [lindex $match 1]
	incr matchEnd

	set url	[string range $url $matchEnd end]
    }

    return [array get parts]
}

proc ::uri::GetHostPort {urlvar} {
    # @c Parse host and port out of the url stored in variable <a urlvar>.
    # @d Side effect: The extracted information is removed from the given url.
    # @r List containing the extracted information in a format suitable for
    # @r 'array set'.
    # @a urlvar: Name of the variable containing the url to parse.

    upvar #0 [namespace current]::basic::hostname	hostname
    upvar #0 [namespace current]::basic::hostnumber	hostnumber
    upvar #0 [namespace current]::basic::port		port

    upvar $urlvar url

    set pattern "^(${hostname}|${hostnumber})(:(${port}))?"

    if {[regexp -indices -- $pattern $url match host c d e f g h thePort]} {
	set fromHost	[lindex $host 0]
	set toHost	[lindex $host 1]

	set fromPort	[lindex $thePort 0]
	set toPort	[lindex $thePort 1]

	set parts(host)	[string range $url $fromHost $toHost]
	set parts(port)	[string range $url $fromPort $toPort]

	set  matchEnd   [lindex $match 1]
	incr matchEnd

	set url [string range $url $matchEnd end]
    }

    return [array get parts]
}

# ::uri::resolve --
#
#	Resolve an arbitrary URL, given a base URL
#
# Arguments:
#	base	base URL (absolute)
#	url	arbitrary URL
#
# Results:
#	Returns a URL

proc ::uri::resolve {base url} {
    if {[string length $url]} {
	if {[isrelative $url]} {

	    array set baseparts [split $base]

	    switch -- $baseparts(scheme) {
		http -
		https -
		ftp -
		file {
		    array set relparts [split $url]
		    if { [string match /* $url] } {
			catch { set baseparts(path) $relparts(path) }
		    } elseif { [string match */ $baseparts(path)] } {
			set baseparts(path) "$baseparts(path)$relparts(path)"
		    } else {
			if { [string length $relparts(path)] > 0 } {
			    set path [lreplace [::split $baseparts(path) /] end end]
			    set baseparts(path) "[::join $path /]/$relparts(path)"
			}
		    }
		    catch { set baseparts(query) $relparts(query) }
		    catch { set baseparts(fragment) $relparts(fragment) }
            return [eval [linsert [array get baseparts] 0 join]]
		}
		default {
		    return -code error "unable to resolve relative URL \"$url\""
		}
	    }

	} else {
	    return $url
	}
    } else {
	return $base
    }
}

# ::uri::isrelative --
#
#	Determines whether a URL is absolute or relative
#
# Arguments:
#	url	URL to check
#
# Results:
#	Returns 1 if the URL is relative, 0 otherwise

proc ::uri::isrelative url {
    return [expr {![regexp -- {^[a-z0-9+-.][a-z0-9+-.]*:} $url]}]
}

# ::uri::geturl --
#
#	Fetch the data from an arbitrary URL.
#
#	This package provides a handler for the file:
#	scheme, since this conflicts with the file command.
#
# Arguments:
#	url	address of data resource
#	args	configuration options
#
# Results:
#	Depends on scheme

proc ::uri::geturl {url args} {
    array set urlparts [split $url]

    switch -- $urlparts(scheme) {
	file {
        return [eval [linsert $args 0 file_geturl $url]]
	}
	default {
	    # Load a geturl package for the scheme first and only if
	    # that fails the scheme package itself. This prevents
	    # cyclic dependencies between packages.
	    if {[catch {package require $urlparts(scheme)::geturl}]} {
		package require $urlparts(scheme)
	    }
        return [eval [linsert $args 0 $urlparts(scheme)::geturl $url]]
	}
    }
}

# ::uri::file_geturl --
#
#	geturl implementation for file: scheme
#
# TODO:
#	This is an initial, basic implementation.
#	Eventually want to support all options for geturl.
#
# Arguments:
#	url	URL to fetch
#	args	configuration options
#
# Results:
#	Returns data from file

proc ::uri::file_geturl {url args} {
    variable file:counter

    set var [namespace current]::file[incr file:counter]
    upvar #0 $var state
    array set state {data {}}

    array set parts [split $url]

    set ch [open $parts(path)]
    # Could determine text/binary from file extension,
    # except on Macintosh
    # fconfigure $ch -translation binary
    set state(data) [read $ch]
    close $ch

    return $var
}

# ::uri::join --
#
#	Format a URL
#
# Arguments:
#	args	components, key-value format
#
# Results:
#	A URL

proc ::uri::join args {
    array set components $args

    return [eval [linsert $args 0 Join[string totitle $components(scheme)]]]
}

# ::uri::canonicalize --
#
#	Canonicalize a URL
#
# Acknowledgements:
#	Andreas Kupries <andreas_kupries@users.sourceforge.net>
#
# Arguments:
#	uri	URI (which contains a path component)
#
# Results:
#	The canonical form of the URI

proc ::uri::canonicalize uri {

    # Make uri canonical with respect to dots (path changing commands)
    #
    # Remove single dots (.)  => pwd not changing
    # Remove double dots (..) => gobble previous segment of path
    #
    # Fixes for this command:
    #
    # * Ignore any url which cannot be split into components by this
    #   module. Just assume that such urls do not have a path to
    #   canonicalize.
    #
    # * Ignore any url which could be split into components, but does
    #   not have a path component.
    #
    # In the text above 'ignore' means
    # 'return the url unchanged to the caller'.

    if {[catch {array set u [uri::split $uri]}]} {
	return $uri
    }
    if {![info exists u(path)]} {
	return $uri
    }

    set uri $u(path)

    # Remove leading "./" "../" "/.." (and "/../")
    regsub -all -- {^(\./)+}    $uri {}  uri
    regsub -all -- {^/(\.\./)+} $uri {/} uri
    regsub -all -- {^(\.\./)+}  $uri {}  uri

    # Remove inner /./ and /../
    while {[regsub -all -- {/\./}         $uri {/} uri]} {}
    while {[regsub -all -- {/[^/]+/\.\./} $uri {/} uri]} {}
    while {[regsub -all -- {^[^/]+/\.\./} $uri {}  uri]} {}
    # Munge trailing /..
    while {[regsub -all -- {/[^/]+/\.\.} $uri {/} uri]} {}
    if { $uri == ".." } { set uri "/" }

    set u(path) $uri
    set uri [eval [linsert [array get u] 0 uri::join]]

    return $uri
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# regular expressions covering various url schemes

# Currently known URL schemes:
#
# (RFC 1738)
# ------------------------------------------------
# scheme	basic syntax of scheme specific part
# ------------------------------------------------
# ftp		//<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
#
# http		//<host>:<port>/<path>?<searchpart>
#
# gopher	//<host>:<port>/<gophertype><selector>
#				<gophertype><selector>%09<search>
#		<gophertype><selector>%09<search>%09<gopher+_string>
#
# mailto	<rfc822-addr-spec>
# news		<newsgroup-name>
#		<message-id>
# nntp		//<host>:<port>/<newsgroup-name>/<article-number>
# telnet	//<user>:<password>@<host>:<port>/
# wais		//<host>:<port>/<database>
#		//<host>:<port>/<database>?<search>
#		//<host>:<port>/<database>/<wtype>/<wpath>
# file		//<host>/<path>
# prospero	//<host>:<port>/<hsoname>;<field>=<value>
# ------------------------------------------------
#
# (RFC 2111)
# ------------------------------------------------
# scheme	basic syntax of scheme specific part
# ------------------------------------------------
# mid	message-id
#		message-id/content-id
# cid	content-id
# ------------------------------------------------

# FTP
uri::register ftp {
    variable escape [set [namespace parent [namespace current]]::basic::escape]
    variable login  [set [namespace parent [namespace current]]::basic::login]

    variable	charN	{[a-zA-Z0-9$_.+!*'(,)?:@&=-]}
    variable	char	"(${charN}|${escape})"
    variable	segment	"${char}*"
    variable	path	"${segment}(/${segment})*"

    variable	type		{[AaDdIi]}
    variable	typepart	";type=(${type})"
    variable	schemepart			    "//${login}(/${path}(${typepart})?)?"

    variable	url		"ftp:${schemepart}"
}

# FILE
uri::register file {
    variable	host [set [namespace parent [namespace current]]::basic::host]
    variable	path [set [namespace parent [namespace current]]::ftp::path]

    variable	schemepart	"//(${host}|localhost)?/${path}"
    variable	url		"file:${schemepart}"
}

# HTTP
uri::register http {
    variable	escape         [set [namespace parent [namespace current]]::basic::escape]
    variable	hostOrPort	        [set [namespace parent [namespace current]]::basic::hostOrPort]

    variable	charN		{[a-zA-Z0-9$_.+!*'(,);:@&=-]}
    variable	char		"($charN|${escape})"
    variable	segment		"${char}*"

    variable	path		"${segment}(/${segment})*"
    variable	search		$segment
    variable	schemepart		    "//${hostOrPort}(/${path}(\\?${search})?)?"

    variable	url		"http:${schemepart}"
}

# GOPHER
uri::register gopher {
    variable	xChar         [set [namespace parent [namespace current]]::basic::xChar]
    variable	hostOrPort         [set [namespace parent [namespace current]]::basic::hostOrPort]
    variable	search         [set [namespace parent [namespace current]]::http::search]

    variable	type		$xChar
    variable	selector	"$xChar*"
    variable	string		$selector
    variable	schemepart		    "//${hostOrPort}(/(${type}(${selector}(%09${search}(%09${string})?)?)?)?)?"
    variable	url		"gopher:${schemepart}"
}

# MAILTO
uri::register mailto {
    variable xChar [set [namespace parent [namespace current]]::basic::xChar]
    variable host  [set [namespace parent [namespace current]]::basic::host]

    variable schemepart	"$xChar+(@${host})?"
    variable url	"mailto:${schemepart}"
}

# NEWS
uri::register news {
    variable escape [set [namespace parent [namespace current]]::basic::escape]
    variable alpha  [set [namespace parent [namespace current]]::basic::alpha]
    variable host   [set [namespace parent [namespace current]]::basic::host]

    variable	aCharN		{[a-zA-Z0-9$_.+!*'(,);/?:&=-]}
    variable	aChar		"($aCharN|${escape})"
    variable	gChar		{[a-zA-Z0-9$_.+-]}
    variable	newsgroup-name	"${alpha}${gChar}*"
    variable	message-id	"${aChar}+@${host}"
    variable	schemepart	"\\*|${newsgroup-name}|${message-id}"
    variable	url		"news:${schemepart}"
}

# WAIS
uri::register wais {
    variable	uChar         [set [namespace parent [namespace current]]::basic::xChar]
    variable	hostOrPort         [set [namespace parent [namespace current]]::basic::hostOrPort]
    variable	search         [set [namespace parent [namespace current]]::http::search]

    variable	db		"${uChar}*"
    variable	type		"${uChar}*"
    variable	path		"${uChar}*"

    variable	database	"//${hostOrPort}/${db}"
    variable	index		"//${hostOrPort}/${db}\\?${search}"
    variable	doc		"//${hostOrPort}/${db}/${type}/${path}"

    #variable	schemepart	"${doc}|${index}|${database}"

    variable	schemepart 	    "//${hostOrPort}/${db}((\\?${search})|(/${type}/${path}))?"

    variable	url		"wais:${schemepart}"
}

# PROSPERO
uri::register prospero {
    variable	escape         [set [namespace parent [namespace current]]::basic::escape]
    variable	hostOrPort         [set [namespace parent [namespace current]]::basic::hostOrPort]
    variable	path         [set [namespace parent [namespace current]]::ftp::path]

    variable	charN		{[a-zA-Z0-9$_.+!*'(,)?:@&-]}
    variable	char		"(${charN}|$escape)"

    variable	fieldname	"${char}*"
    variable	fieldvalue	"${char}*"
    variable	fieldspec	";${fieldname}=${fieldvalue}"

    variable	schemepart	"//${hostOrPort}/${path}(${fieldspec})*"
    variable	url		"prospero:$schemepart"
}

package provide uri 1.1.4
package provide xml 2.6
package provide dom 2.6
package provide dom::tcl 2.6
package provide dom::tclgeneric 2.6
namespace eval ::xml {}
# 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.6 2002/08/30 07:52:16 balls Exp $

package require Tcl 8.1

package provide sgml 1.9

namespace eval sgml {

    # Convenience routine
    proc cl x {
	return "\[$x\]"
    }

    # Define various regular expressions

    # Character classes
    variable Char \t\n\r\ -\uD7FF\uE000-\uFFFD\u10000-\u10FFFF
    variable BaseChar \u0041-\u005A\u0061-\u007A\u00C0-\u00D6\u00D8-\u00F6\u00F8-\u00FF\u0100-\u0131\u0134-\u013E\u0141-\u0148\u014A-\u017E\u0180-\u01C3\u01CD-\u01F0\u01F4-\u01F5\u01FA-\u0217\u0250-\u02A8\u02BB-\u02C1\u0386\u0388-\u038A\u038C\u038E-\u03A1\u03A3-\u03CE\u03D0-\u03D6\u03DA\u03DC\u03DE\u03E0\u03E2-\u03F3\u0401-\u040C\u040E-\u044F\u0451-\u045C\u045E-\u0481\u0490-\u04C4\u04C7-\u04C8\u04CB-\u04CC\u04D0-\u04EB\u04EE-\u04F5\u04F8-\u04F9\u0531-\u0556\u0559\u0561-\u0586\u05D0-\u05EA\u05F0-\u05F2\u0621-\u063A\u0641-\u064A\u0671-\u06B7\u06BA-\u06BE\u06C0-\u06CE\u06D0-\u06D3\u06D5\u06E5-\u06E6\u0905-\u0939\u093D\u0958-\u0961\u0985-\u098C\u098F-\u0990\u0993-\u09A8\u09AA-\u09B0\u09B2\u09B6-\u09B9\u09DC-\u09DD\u09DF-\u09E1\u09F0-\u09F1\u0A05-\u0A0A\u0A0F-\u0A10\u0A13-\u0A28\u0A2A-\u0A30\u0A32-\u0A33\u0A35-\u0A36\u0A38-\u0A39\u0A59-\u0A5C\u0A5E\u0A72-\u0A74\u0A85-\u0A8B\u0A8D\u0A8F-\u0A91\u0A93-\u0AA8\u0AAA-\u0AB0\u0AB2-\u0AB3\u0AB5-\u0AB9\u0ABD\u0AE0\u0B05-\u0B0C\u0B0F-\u0B10\u0B13-\u0B28\u0B2A-\u0B30\u0B32-\u0B33\u0B36-\u0B39\u0B3D\u0B5C-\u0B5D\u0B5F-\u0B61\u0B85-\u0B8A\u0B8E-\u0B90\u0B92-\u0B95\u0B99-\u0B9A\u0B9C\u0B9E-\u0B9F\u0BA3-\u0BA4\u0BA8-\u0BAA\u0BAE-\u0BB5\u0BB7-\u0BB9\u0C05-\u0C0C\u0C0E-\u0C10\u0C12-\u0C28\u0C2A-\u0C33\u0C35-\u0C39\u0C60-\u0C61\u0C85-\u0C8C\u0C8E-\u0C90\u0C92-\u0CA8\u0CAA-\u0CB3\u0CB5-\u0CB9\u0CDE\u0CE0-\u0CE1\u0D05-\u0D0C\u0D0E-\u0D10\u0D12-\u0D28\u0D2A-\u0D39\u0D60-\u0D61\u0E01-\u0E2E\u0E30\u0E32-\u0E33\u0E40-\u0E45\u0E81-\u0E82\u0E84\u0E87-\u0E88\u0E8A\u0E8D\u0E94-\u0E97\u0E99-\u0E9F\u0EA1-\u0EA3\u0EA5\u0EA7\u0EAA-\u0EAB\u0EAD-\u0EAE\u0EB0\u0EB2-\u0EB3\u0EBD\u0EC0-\u0EC4\u0F40-\u0F47\u0F49-\u0F69\u10A0-\u10C5\u10D0-\u10F6\u1100\u1102-\u1103\u1105-\u1107\u1109\u110B-\u110C\u110E-\u1112\u113C\u113E\u1140\u114C\u114E\u1150\u1154-\u1155\u1159\u115F-\u1161\u1163\u1165\u1167\u1169\u116D-\u116E\u1172-\u1173\u1175\u119E\u11A8\u11AB\u11AE-\u11AF\u11B7-\u11B8\u11BA\u11BC-\u11C2\u11EB\u11F0\u11F9\u1E00-\u1E9B\u1EA0-\u1EF9\u1F00-\u1F15\u1F18-\u1F1D\u1F20-\u1F45\u1F48-\u1F4D\u1F50-\u1F57\u1F59\u1F5B\u1F5D\u1F5F-\u1F7D\u1F80-\u1FB4\u1FB6-\u1FBC\u1FBE\u1FC2-\u1FC4\u1FC6-\u1FCC\u1FD0-\u1FD3\u1FD6-\u1FDB\u1FE0-\u1FEC\u1FF2-\u1FF4\u1FF6-\u1FFC\u2126\u212A-\u212B\u212E\u2180-\u2182\u3041-\u3094\u30A1-\u30FA\u3105-\u312C\uAC00-\uD7A3  
    variable Ideographic \u4E00-\u9FA5\u3007\u3021-\u3029
    variable CombiningChar \u0300-\u0345\u0360-\u0361\u0483-\u0486\u0591-\u05A1\u05A3-\u05B9\u05BB-\u05BD\u05BF\u05C1-\u05C2\u05C4\u064B-\u0652\u0670\u06D6-\u06DC\u06DD-\u06DF\u06E0-\u06E4\u06E7-\u06E8\u06EA-\u06ED\u0901-\u0903\u093C\u093E-\u094C\u094D\u0951-\u0954\u0962-\u0963\u0981-\u0983\u09BC\u09BE\u09BF\u09C0-\u09C4\u09C7-\u09C8\u09CB-\u09CD\u09D7\u09E2-\u09E3\u0A02\u0A3C\u0A3E\u0A3F\u0A40-\u0A42\u0A47-\u0A48\u0A4B-\u0A4D\u0A70-\u0A71\u0A81-\u0A83\u0ABC\u0ABE-\u0AC5\u0AC7-\u0AC9\u0ACB-\u0ACD\u0B01-\u0B03\u0B3C\u0B3E-\u0B43\u0B47-\u0B48\u0B4B-\u0B4D\u0B56-\u0B57\u0B82-\u0B83\u0BBE-\u0BC2\u0BC6-\u0BC8\u0BCA-\u0BCD\u0BD7\u0C01-\u0C03\u0C3E-\u0C44\u0C46-\u0C48\u0C4A-\u0C4D\u0C55-\u0C56\u0C82-\u0C83\u0CBE-\u0CC4\u0CC6-\u0CC8\u0CCA-\u0CCD\u0CD5-\u0CD6\u0D02-\u0D03\u0D3E-\u0D43\u0D46-\u0D48\u0D4A-\u0D4D\u0D57\u0E31\u0E34-\u0E3A\u0E47-\u0E4E\u0EB1\u0EB4-\u0EB9\u0EBB-\u0EBC\u0EC8-\u0ECD\u0F18-\u0F19\u0F35\u0F37\u0F39\u0F3E\u0F3F\u0F71-\u0F84\u0F86-\u0F8B\u0F90-\u0F95\u0F97\u0F99-\u0FAD\u0FB1-\u0FB7\u0FB9\u20D0-\u20DC\u20E1\u302A-\u302F\u3099\u309A
    variable Digit \u0030-\u0039\u0660-\u0669\u06F0-\u06F9\u0966-\u096F\u09E6-\u09EF\u0A66-\u0A6F\u0AE6-\u0AEF\u0B66-\u0B6F\u0BE7-\u0BEF\u0C66-\u0C6F\u0CE6-\u0CEF\u0D66-\u0D6F\u0E50-\u0E59\u0ED0-\u0ED9\u0F20-\u0F29
    variable Extender \u00B7\u02D0\u02D1\u0387\u0640\u0E46\u0EC6\u3005\u3031-\u3035\u309D-\u309E\u30FC-\u30FE
    variable Letter $BaseChar|$Ideographic

    # white space
    variable Wsp " \t\r\n"
    variable noWsp [cl ^$Wsp]

    # Various XML names
    variable NameChar \[-$Letter$Digit._:$CombiningChar$Extender\]
    variable Name \[_:$BaseChar$Ideographic\]$NameChar*
    variable Names ${Name}(?:$Wsp$Name)*
    variable Nmtoken $NameChar+
    variable Nmtokens ${Nmtoken}(?:$Wsp$Nmtoken)*

    # table of predefined entities for XML

    variable EntityPredef
    array set EntityPredef {
	lt <   gt >   amp &   quot \"   apos '
    }

}

# These regular expressions are defined here once for better performance

namespace eval sgml {
    variable Wsp

    # Watch out for case-sensitivity

    set attlist_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#REQUIRED|#IMPLIED)
    set attlist_enum_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*\\(([cl ^)]*)\\)[cl $Wsp]*("([cl ^")]*)")? ;# "
    set attlist_fixed_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#FIXED)[cl $Wsp]*([cl ^$Wsp]+)

    set param_entity_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^"$Wsp]*)[cl $Wsp]*"([cl ^"]*)"

    set notation_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(.*)

}

### Utility procedures

# sgml::noop --
#
#	A do-nothing proc
#
# Arguments:
#	args	arguments
#
# Results:
#	Nothing.

proc sgml::noop args {
    return 0
}

# sgml::identity --
#
#	Identity function.
#
# Arguments:
#	a	arbitrary argument
#
# Results:
#	$a

proc sgml::identity a {
    return $a
}

# sgml::Error --
#
#	Throw an error
#
# Arguments:
#	args	arguments
#
# Results:
#	Error return condition.

proc sgml::Error args {
    uplevel return -code error [list $args]
}

### Following procedures are based on html_library

# sgml::zapWhite --
#
#	Convert multiple white space into a single space.
#
# Arguments:
#	data	plain text
#
# Results:
#	As above

proc sgml::zapWhite data {
    regsub -all "\[ \t\r\n\]+" $data { } data
    return $data
}

proc sgml::Boolean value {
    regsub {1|true|yes|on} $value 1 value
    regsub {0|false|no|off} $value 0 value
    return $value
}

# 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-2003 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.13 2003/02/25 04:09:22 balls Exp $

package require Tcl 8.1

package provide xmldefs 2.6

package require sgml 1.8

namespace eval xml {

    namespace export qnamesplit

    # Convenience routine
    proc cl x {
	return "\[$x\]"
    }

    # Define various regular expressions

    # Characters
    variable Char $::sgml::Char

    # white space
    variable Wsp " \t\r\n"
    variable allWsp [cl $Wsp]*
    variable noWsp [cl ^$Wsp]

    # Various XML names and tokens

    variable NameChar $::sgml::NameChar
    variable Name $::sgml::Name
    variable Names $::sgml::Names
    variable Nmtoken $::sgml::Nmtoken
    variable Nmtokens $::sgml::Nmtokens

    # XML Namespaces names

    # NCName ::= Name - ':'
    variable NCName $::sgml::Name
    regsub -all : $NCName {} NCName
    variable QName (${NCName}:)?$NCName		;# (Prefix ':')? LocalPart

    # The definition of the Namespace URI for XML Namespaces themselves.
    # The prefix 'xml' is automatically bound to this URI.
    variable xmlnsNS http://www.w3.org/XML/1998/namespace

    # table of predefined entities

    variable EntityPredef
    array set EntityPredef {
	lt <   gt >   amp &   quot \"   apos '
    }

    # Expressions for pulling things apart
    variable tokExpr <(/?)([::xml::cl ^$::xml::Wsp>/]+)([::xml::cl $::xml::Wsp]*[::xml::cl ^>]*)>
    variable substExpr "\}\n{\\2} {\\1} {\\3} \{"

}

###
###	Exported procedures
###

# xml::qnamesplit --
#
#	Split a QName into its constituent parts:
#	the XML Namespace prefix and the Local-name
#
# Arguments:
#	qname	XML Qualified Name (see XML Namespaces [6])
#
# Results:
#	Returns prefix and local-name as a Tcl list.
#	Error condition returned if the prefix or local-name
#	are not valid NCNames (XML Name)

proc xml::qnamesplit qname {
    variable NCName
    variable Name

    set prefix {}
    set localname $qname
    if {[regexp : $qname]} {
	if {![regexp ^($NCName)?:($NCName)\$ $qname discard prefix localname]} {
	    return -code error "name \"$qname\" is not a valid QName"
	}
    } elseif {![regexp ^$Name\$ $qname]} {
	return -code error "name \"$qname\" is not a valid Name"
    }

    return [list $prefix $localname]
}

###
###	General utility procedures
###

# xml::noop --
#
# A do-nothing proc

proc xml::noop args {}

### Following procedures are based on html_library

# xml::zapWhite --
#
#	Convert multiple white space into a single space.
#
# Arguments:
#	data	plain text
#
# Results:
#	As above

proc xml::zapWhite data {
    regsub -all "\[ \t\r\n\]+" $data { } data
    return $data
}

# sgmlparser.tcl --
#
#	This file provides the generic part of a parser for SGML-based
#	languages, namely HTML and XML.
#
#	NB.  It is a misnomer.  There is no support for parsing
#	arbitrary SGML as such.
#
#	See sgml.tcl for variable definitions.
#
# Copyright (c) 1998-2003 Zveno Pty Ltd
# http://www.zveno.com/
#
# 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.30 2003/02/25 04:09:20 balls Exp $

package require sgml 1.9

package require uri 1.1

package provide sgmlparser 1.0

namespace eval sgml {
    namespace export tokenise parseEvent

    namespace export parseDTD

    # NB. Most namespace variables are defined in sgml-8.[01].tcl
    # to account for differences between versions of Tcl.
    # This especially includes the regular expressions used.

    variable ParseEventNum
    if {![info exists ParseEventNum]} {
	set ParseEventNum 0
    }
    variable ParseDTDnum
    if {![info exists ParseDTDNum]} {
	set ParseDTDNum 0
    }

    variable declExpr [cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*)
    variable EntityExpr [cl $::sgml::Wsp]*(%[cl $::sgml::Wsp])?[cl $::sgml::Wsp]*($::sgml::Name)[cl $::sgml::Wsp]+(.*)

    #variable MarkupDeclExpr <([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*)>
    #variable MarkupDeclSub "} {\\1} {\\2} {\\3} {"
    variable MarkupDeclExpr <[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^>]*)>
    variable MarkupDeclSub "\} {\\1} {\\2} \{"

    variable ExternalEntityExpr ^(PUBLIC|SYSTEM)[cl $::sgml::Wsp]+("|')(.*?)\\2([cl $::sgml::Wsp]+("|')(.*?)\\2)?([cl $::sgml::Wsp]+NDATA[cl $::sgml::Wsp]+($::xml::Name))?\$

    variable StdOptions
    array set StdOptions [list 	-elementstartcommand		[namespace current]::noop		-elementendcommand		[namespace current]::noop		-characterdatacommand		[namespace current]::noop		-processinginstructioncommand	[namespace current]::noop		-externalentitycommand		{}					-xmldeclcommand			[namespace current]::noop		-doctypecommand			[namespace current]::noop		-commentcommand			[namespace current]::noop		-entitydeclcommand		[namespace current]::noop		-unparsedentitydeclcommand	[namespace current]::noop		-parameterentitydeclcommand	[namespace current]::noop		-notationdeclcommand		[namespace current]::noop		-elementdeclcommand		[namespace current]::noop		-attlistdeclcommand		[namespace current]::noop		-paramentityparsing		1					-defaultexpandinternalentities	1					-startdoctypedeclcommand	[namespace current]::noop		-enddoctypedeclcommand		[namespace current]::noop		-entityreferencecommand		{}					-warningcommand			[namespace current]::noop		-errorcommand			[namespace current]::Error		-final				1					-validate			0					-baseurl			{}					-name				{}					-emptyelement			[namespace current]::EmptyElement		-parseattributelistcommand	[namespace current]::noop		-parseentitydeclcommand		[namespace current]::noop		-normalize			1					-internaldtd			{}					-reportempty			0					-ignorewhitespace		0				    ]
}

# sgml::tokenise --
#
#	Transform the given HTML/XML text into a Tcl list.
#
# Arguments:
#	sgml		text to tokenize
#	elemExpr	RE to recognise tags
#	elemSub		transform for matched tags
#	args		options
#
# Valid Options:
#       -internaldtdvariable
#	-final		boolean		True if no more data is to be supplied
#	-statevariable	varName		Name of a variable used to store info
#
# Results:
#	Returns a Tcl list representing the document.

proc sgml::tokenise {sgml elemExpr elemSub args} {
    array set options {-final 1}
    array set options $args
    set options(-final) [Boolean $options(-final)]

    # If the data is not final then there must be a variable to store
    # unused data.
    if {!$options(-final) && ![info exists options(-statevariable)]} {
	return -code error {option "-statevariable" required if not final}
    }

    # Pre-process stage
    #
    # Extract the internal DTD subset, if any

    catch {upvar #0 $options(-internaldtdvariable) dtd}
    if {[regexp {<!DOCTYPE[^[<]+\[([^]]+)\]} $sgml discard dtd]} {
	regsub {(<!DOCTYPE[^[<]+)(\[[^]]+\])} $sgml {\1\&xml:intdtd;} sgml
    }

    # Protect Tcl special characters
    regsub -all {([{}\\])} $sgml {\\\1} sgml

    # Do the translation

    if {[info exists options(-statevariable)]} {
	# Mats: Several rewrites here to handle -final 0 option.
	# If any cached unparsed xml (state(leftover)), prepend it.
	upvar #0 $options(-statevariable) state
	if {[string length $state(leftover)]} {
	    regsub -all $elemExpr $state(leftover)$sgml $elemSub sgml
	    set state(leftover) {}
	} else {
	    regsub -all $elemExpr $sgml $elemSub sgml
	}
	set sgml "{} {} {} \{$sgml\}"

	# Performance note (Tcl 8.0):
	#	Use of lindex, lreplace will cause parsing to list object

	# This RE only fixes chopped inside tags, not chopped text.
	if {[regexp {^([^<]*)(<[^>]*$)} [lindex $sgml end] x text rest]} {
	    set sgml [lreplace $sgml end end $text]
	    # Mats: unmatched stuff means that it is chopped off. Cache it for next round.
	    set state(leftover) $rest
	}

	# Patch from bug report #596959, Marshall Rose
	if {[string compare [lindex $sgml 4] ""]} {
	    set sgml [linsert $sgml 0 {} {} {} {} {}]
	}

    } else {

	# Performance note (Tcl 8.0):
	#	In this case, no conversion to list object is performed

	# Mats: This fails if not -final and $sgml is chopped off right in a tag.	
	regsub -all $elemExpr $sgml $elemSub sgml
	set sgml "{} {} {} \{$sgml\}"
    }

    return $sgml

}

# sgml::parseEvent --
#
#	Produces an event stream for a XML/HTML document,
#	given the Tcl list format returned by tokenise.
#
#	This procedure checks that the document is well-formed,
#	and throws an error if the document is found to be not
#	well formed.  Warnings are passed via the -warningcommand script.
#
#	The procedure only check for well-formedness,
#	no DTD is required.  However, facilities are provided for entity expansion.
#
# Arguments:
#	sgml		Instance data, as a Tcl list.
#	args		option/value pairs
#
# Valid Options:
#	-final			Indicates end of document data
#	-validate		Boolean to enable validation
#	-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
#	-ignorewhitespace	whether to automatically strip whitespace
#
# Results:
#	The various callback scripts are invoked.
#	Returns empty string.
#
# BUGS:
#	If command options are set to empty string then they should not be invoked.

proc sgml::parseEvent {sgml args} {
    variable Wsp
    variable noWsp
    variable Nmtoken
    variable Name
    variable ParseEventNum
    variable StdOptions

    array set options [array get StdOptions]
    catch {array set options $args}

    # Mats:
    # If the data is not final then there must be a variable to persistently store the parse state.
    if {!$options(-final) && ![info exists options(-statevariable)]} {
	return -code error {option "-statevariable" required if not final}
    }
    
    foreach {opt value} [array get options *command] {
	if {[string compare $opt "-externalentitycommand"] && ![string length $value]} {
	    set options($opt) [namespace current]::noop
	}
    }

    if {![info exists options(-statevariable)]} {
	set options(-statevariable) [namespace current]::ParseEvent[incr ParseEventNum]
    }
    if {![info exists options(entities)]} {
	set options(entities) [namespace current]::Entities$ParseEventNum
	array set $options(entities) [array get [namespace current]::EntityPredef]
    }
    if {![info exists options(extentities)]} {
	set options(extentities) [namespace current]::ExtEntities$ParseEventNum
    }
    if {![info exists options(parameterentities)]} {
	set options(parameterentities) [namespace current]::ParamEntities$ParseEventNum
    }
    if {![info exists options(externalparameterentities)]} {
	set options(externalparameterentities) [namespace current]::ExtParamEntities$ParseEventNum
    }
    if {![info exists options(elementdecls)]} {
	set options(elementdecls) [namespace current]::ElementDecls$ParseEventNum
    }
    if {![info exists options(attlistdecls)]} {
	set options(attlistdecls) [namespace current]::AttListDecls$ParseEventNum
    }
    if {![info exists options(notationdecls)]} {
	set options(notationdecls) [namespace current]::NotationDecls$ParseEventNum
    }
    if {![info exists options(namespaces)]} {
	set options(namespaces) [namespace current]::Namespaces$ParseEventNum
    }

    # 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)
		    PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$cdata1]
		    set text [subst -novariable -nocommand $text]
		    set tag {}
		    unset state(cdata)
		    set state(mode) normal
		} elseif {[regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $param discard cdata1]} {
		    # end of CDATA (in attributes)
		    PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$tag$cdata1]
		    set text [subst -novariable -nocommand $text]
		    set tag {}
		    set param {}
		    unset state(cdata)
		    set state(mode) normal
		} elseif {[regexp (.*)\]\][cl $Wsp]*>(.*) $text discard cdata1 text]} {
		    # end of CDATA (in text)
		    PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$tag$param>$cdata1]
		    set text [subst -novariable -nocommand $text]
		    set tag {}
		    set param {}
		    set close {}
		    unset state(cdata)
		    set state(mode) normal
		} else {
		    # CDATA continues
		    append state(cdata) [subst -nocommand -novariable <$close$tag$param>$text]
		    continue
		}
	    }
	    continue {
		# We're skipping elements looking for the close tag
		switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close {
		    0,* {
			continue
		    }
		    *,0, {
			if {![string compare $tag $state(continue:tag)]} {
			    set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]
			    if {![string length $empty]} {
				incr state(continue:level)
			    }
			}
			continue
		    }
		    *,0,/ {
			if {![string compare $tag $state(continue:tag)]} {
			    incr state(continue:level) -1
			}
			if {!$state(continue:level)} {
			    unset state(continue:tag)
			    unset state(continue:level)
			    set state(mode) {}
			}
		    }
		    default {
			continue
		    }
		}
	    }
	    default {
		# The trailing slash on empty elements can't be automatically separated out
		# in the RE, so we must do it here.
		regexp (.*)(/)[cl $Wsp]*$ $param discard param empty
	    }
	}

	# default: normal mode

	# Bug: if the attribute list has a right angle bracket then the empty
	# element marker will not be seen

	set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]

	switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close,$empty {

	    0,0,, {
		# Ignore empty tag - dealt with non-normal mode above
	    }
	    *,0,, {

		# Start tag for an element.

		# Check if the internal DTD entity is in an attribute value
		regsub -all &xml:intdtd\; $param \[$options(-internaldtd)\] param

		set code [catch {ParseEvent:ElementOpen $tag $param [array get options]} msg]
		set state(haveDocElement) 1
		switch $code {
		    0 {# OK}
		    3 {
			# break
			return {}
		    }
		    4 {
			# continue
			# Remember this tag and look for its close
			set state(continue:tag) $tag
			set state(continue:level) 1
			set state(mode) continue
			continue
		    }
		    default {
			return -code $code -errorinfo $::errorInfo $msg
		    }
		}

	    }

	    *,0,/, {

		# End tag for an element.

		set code [catch {ParseEvent:ElementClose $tag [array get options]} msg]
		switch $code {
		    0 {# OK}
		    3 {
			# break
			return {}
		    }
		    4 {
			# continue
			# skip sibling nodes
			set state(continue:tag) [lindex $state(stack) end]
			set state(continue:level) 1
			set state(mode) continue
			continue
		    }
		    default {
			return -code $code -errorinfo $::errorInfo $msg
		    }
		}

	    }

	    *,0,,/ {

		# Empty element

		# The trailing slash sneaks through into the param variable
		regsub -all /[cl $::sgml::Wsp]*\$ $param {} param

		set code [catch {ParseEvent:ElementOpen $tag $param [array get options] -empty 1} msg]
		set state(haveDocElement) 1
		switch $code {
		    0 {# OK}
		    3 {
			# break
			return {}
		    }
		    4 {
			# continue
			# Pretty useless since it closes straightaway
		    }
		    default {
			return -code $code -errorinfo $::errorInfo $msg
		    }
		}
		set code [catch {ParseEvent:ElementClose $tag [array get options] -empty 1} msg]
		switch $code {
		    0 {# OK}
		    3 {
			# break
			return {}
		    }
		    4 {
			# continue
			# skip sibling nodes
			set state(continue:tag) [lindex $state(stack) end]
			set state(continue:level) 1
			set state(mode) continue
			continue
		    }
		    default {
			return -code $code -errorinfo $::errorInfo $msg
		    }
		}

	    }

	    *,1,* {
		# Processing instructions or XML declaration
		switch -glob -- $tag {

		    {\?xml} {
			# XML Declaration
			if {$state(haveXMLDecl)} {
			    uplevel #0 $options(-errorcommand) [list illegalcharacter "unexpected characters \"<$tag\" around line $state(line)"]
			} elseif {![regexp {\?$} $param]} {
			    uplevel #0 $options(-errorcommand) [list missingcharacters "XML Declaration missing characters \"?>\" around line $state(line)"]
			} else {

			    # We can do the parsing in one step with Tcl 8.1 RE's
			    # This has the benefit of performing better WF checking

			    set adv_re [format {^[%s]*version[%s]*=[%s]*("|')(-+|[a-zA-Z0-9_.:]+)\1([%s]+encoding[%s]*=[%s]*("|')([A-Za-z][-A-Za-z0-9._]*)\4)?([%s]*standalone[%s]*=[%s]*("|')(yes|no)\7)?[%s]*\?$} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp]

			    if {[catch {regexp $adv_re $param discard delimiter version discard delimiter encoding discard delimiter standalone} matches]} {
				# Otherwise we must fallback to 8.0.
				# This won't detect certain well-formedness errors

				# Get the version number
				if {[regexp [format {[%s]*version[%s]*=[%s]*"(-+|[a-zA-Z0-9_.:]+)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard version] || [regexp [format {[%s]*version[%s]*=[%s]*'(-+|[a-zA-Z0-9_.:]+)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard version]} {
				    if {[string compare $version "1.0"]} {
					# Should we support future versions?
					# At least 1.X?
					uplevel #0 $options(-errorcommand) [list versionincompatibility "document XML version \"$version\" is incompatible with XML version 1.0"]
				    }
				} else {
				    uplevel #0 $options(-errorcommand) [list missingversion "XML Declaration missing version information around line $state(line)"]
				}

				# Get the encoding declaration
				set encoding {}
				regexp [format {[%s]*encoding[%s]*=[%s]*"([A-Za-z]([A-Za-z0-9._]|-)*)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard encoding
				regexp [format {[%s]*encoding[%s]*=[%s]*'([A-Za-z]([A-Za-z0-9._]|-)*)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard encoding

				# Get the standalone declaration
				set standalone {}
				regexp [format {[%s]*standalone[%s]*=[%s]*"(yes|no)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard standalone
				regexp [format {[%s]*standalone[%s]*=[%s]*'(yes|no)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard standalone

				# Invoke the callback
				uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone]

			    } elseif {$matches == 0} {
				uplevel #0 $options(-errorcommand) [list illformeddeclaration "XML Declaration not well-formed around line $state(line)"]
			    } else {

				# Invoke the callback
				uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone]

			    }

			}

		    }

		    {\?*} {
			# Processing instruction
			set tag [string range $tag 1 end]
			if {[regsub {\?$} $tag {} tag]} {
			    if {[string length [string trim $param]]} {
				uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$param\" in processing instruction around line $state(line)"]
			    }
			} elseif {![regexp ^$Name\$ $tag]} {
			    uplevel #0 $options(-errorcommand) [list illegalcharacter "illegal character in processing instruction target \"$tag\""]
			} elseif {[regexp {^[xX][mM][lL]$} $tag]} {
			    uplevel #0 $options(-errorcommand) [list illegalcharacters "characters \"xml\" not permitted in processing instruction target \"$tag\""]
			} elseif {![regsub {\?$} $param {} param]} {
			    uplevel #0 $options(-errorcommand) [list missingquestion "PI: expected '?' character around line $state(line)"]
			}
			set code [catch {uplevel #0 $options(-processinginstructioncommand) [list $tag [string trimleft $param]]} msg]
			switch $code {
			    0 {# OK}
			    3 {
				# break
				return {}
			    }
			    4 {
				# continue
				# skip sibling nodes
				set state(continue:tag) [lindex $state(stack) end]
				set state(continue:level) 1
				set state(mode) continue
				continue
			    }
			    default {
				return -code $code -errorinfo $::errorInfo $msg
			    }
			}
		    }

		    !DOCTYPE {
			# External entity reference
			# This should move into xml.tcl
			# Parse the params supplied.  Looking for Name, ExternalID and MarkupDecl
			set matched [regexp ^[cl $Wsp]*($Name)[cl $Wsp]*(.*) $param x state(doc_name) param]
			set state(doc_name) [Normalize $state(doc_name) $options(-normalize)]
			set externalID {}
			set pubidlit {}
			set systemlit {}
			set externalID {}
			if {[regexp -nocase ^[cl $Wsp]*(SYSTEM|PUBLIC)(.*) $param x id param]} {
			    switch [string toupper $id] {
				SYSTEM {
				    if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
					set externalID [list SYSTEM $systemlit] ;# "
				    } else {
					uplevel #0 $options(-errorcommand) {syntaxerror {syntax error: SYSTEM identifier not followed by literal}}
				    }
				}
				PUBLIC {
				    if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x pubidlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x pubidlit param]} {
					if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
					    set externalID [list PUBLIC $pubidlit $systemlit]
					} else {
					    uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: PUBLIC identifier not followed by system literal around line $state(line)"]
					}
				    } else {
					uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: PUBLIC identifier not followed by literal around line $state(line)"]
				    }
				}
			    }
			    if {[regexp -nocase ^[cl $Wsp]+NDATA[cl $Wsp]+($Name)(.*) $param x notation param]} {
				lappend externalID $notation
			    }
			}

			set state(inDTD) 1

			ParseEvent:DocTypeDecl [array get options] $state(doc_name) $pubidlit $systemlit $options(-internaldtd)

			set state(inDTD) 0

		    }

		    !--* {

			# Start of a comment
			# See if it ends in the same tag, otherwise change the
			# parsing mode

			regexp {!--(.*)} $tag discard comm1
			if {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $comm1 discard comm1_1]} {
			    # processed comment (end in tag)
			    uplevel #0 $options(-commentcommand) [list $comm1_1]
			} elseif {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $param discard comm2]} {
			    # processed comment (end in attributes)
			    uplevel #0 $options(-commentcommand) [list $comm1$comm2]
			} elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm2 text]} {
			    # processed comment (end in text)
			    uplevel #0 $options(-commentcommand) [list $comm1$param$empty>$comm2]
			} else {
			    # start of comment
			    set state(mode) comment
			    set state(commentdata) "$comm1$param$empty>$text"
			    continue
			}
		    }

		    {!\[CDATA\[*} {

			regexp {!\[CDATA\[(.*)} $tag discard cdata1
			if {[regexp {(.*)]]$} $cdata1 discard cdata2]} {
			    # processed CDATA (end in tag)
			    PCDATA [array get options] [subst -novariable -nocommand $cdata2]
			    set text [subst -novariable -nocommand $text]
			} elseif {[regexp {(.*)]]$} $param discard cdata2]} {
			    # processed CDATA (end in attribute)
			    # Backslashes in param are quoted at this stage
			    PCDATA [array get options] $cdata1[subst -novariable -nocommand $cdata2]
			    set text [subst -novariable -nocommand $text]
			} elseif {[regexp {(.*)]]>(.*)} $text discard cdata2 text]} {
			    # processed CDATA (end in text)
			    # Backslashes in param and text are quoted at this stage
			    PCDATA [array get options] $cdata1[subst -novariable -nocommand $param]$empty>[subst -novariable -nocommand $cdata2]
			    set text [subst -novariable -nocommand $text]
			} else {
			    # start CDATA
			    set state(cdata) "$cdata1$param>$text"
			    set state(mode) cdata
			    continue
			}

		    }

		    !ELEMENT -
		    !ATTLIST -
		    !ENTITY -
		    !NOTATION {
			uplevel #0 $options(-errorcommand) [list illegaldeclaration "[string range $tag 1 end] declaration not expected in document instance around line $state(line)"]
		    }

		    default {
			uplevel #0 $options(-errorcommand) [list unknowninstruction "unknown processing instruction \"<$tag>\" around line $state(line)"]
		    }
		}
	    }
	    *,1,* -
	    *,0,/,/ {
		# Syntax error
	    	uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: closed/empty tag: tag $tag param $param empty $empty close $close around line $state(line)"]
	    }
	}

	# Process character data

	if {$state(haveDocElement) && [llength $state(stack)]} {

	    # Check if the internal DTD entity is in the text
	    regsub -all &xml:intdtd\; $text \[$options(-internaldtd)\] text

	    # Look for entity references
	    if {([array size entities] || 		    [string length $options(-entityreferencecommand)]) && 		    $options(-defaultexpandinternalentities) && 		    [regexp {&[^;]+;} $text]} {

		# protect Tcl specials
		# NB. braces and backslashes may already be protected
		regsub -all {\\({|}|\\)} $text {\1} text
		regsub -all {([][$\\{}])} $text {\\\1} text

		# Mark entity references
		regsub -all {&([^;]+);} $text [format {%s; %s {\1} ; %s %s} \}\} [namespace code [list Entity [array get options] $options(-entityreferencecommand) [namespace code [list PCDATA [array get options]]] $options(entities)]] [namespace code [list DeProtect [namespace code [list PCDATA [array get options]]]]] \{\{] text
		set text "uplevel #0 [namespace code [list DeProtect1 [namespace code [list PCDATA [array get options]]]]] {{$text}}"
		eval $text
	    } else {

		# Restore protected special characters
		regsub -all {\\([][{}\\])} $text {\1} text
		PCDATA [array get options] $text
	    }
	} elseif {[string length [string trim $text]]} {
	    uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\" in document prolog around line $state(line)"]
	}

    }

    # If this is the end of the document, close all open containers
    if {$options(-final) && [llength $state(stack)]} {
	eval $options(-errorcommand) [list unclosedelement "element [lindex $state(stack) end] remains unclosed around line $state(line)"]
    }

    return {}
}

# sgml::DeProtect --
#
#	Invoke given command after removing protecting backslashes
#	from given text.
#
# Arguments:
#	cmd	Command to invoke
#	text	Text to deprotect
#
# Results:
#	Depends on command

proc sgml::DeProtect1 {cmd text} {
    if {[string compare {} $text]} {
	regsub -all {\\([]$[{}\\])} $text {\1} text
	uplevel #0 $cmd [list $text]
    }
}
proc sgml::DeProtect {cmd text} {
    set text [lindex $text 0]
    if {[string compare {} $text]} {
	regsub -all {\\([]$[{}\\])} $text {\1} text
	uplevel #0 $cmd [list $text]
    }
}

# sgml::ParserDelete --
#
#	Free all memory associated with parser
#
# Arguments:
#	var	global state array
#
# Results:
#	Variables unset

proc sgml::ParserDelete var {
    upvar #0 $var state

    if {![info exists state]} {
	return -code error "unknown parser"
    }

    catch {unset $state(entities)}
    catch {unset $state(parameterentities)}
    catch {unset $state(elementdecls)}
    catch {unset $state(attlistdecls)}
    catch {unset $state(notationdecls)}
    catch {unset $state(namespaces)}

    unset state

    return {}
}

# sgml::ParseEvent:ElementOpen --
#
#	Start of an element.
#
# Arguments:
#	tag	Element name
#	attr	Attribute list
#	opts	Options
#	args	further configuration options
#
# Options:
#	-empty boolean
#		indicates whether the element was an empty element
#
# Results:
#	Modify state and invoke callback

proc sgml::ParseEvent:ElementOpen {tag attr opts args} {
    variable Name
    variable Wsp

    array set options $opts
    upvar #0 $options(-statevariable) state
    array set cfg {-empty 0}
    array set cfg $args
    set handleEmpty 0

    if {$options(-normalize)} {
	set tag [string toupper $tag]
    }

    # Update state
    lappend state(stack) $tag

    # Parse attribute list into a key-value representation
    if {[string compare $options(-parseattributelistcommand) {}]} {
	if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $opts $attr]} attr]} {
	    if {[string compare [lindex $attr 0] "unterminated attribute value"]} {
		uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
		set attr {}
	    } else {

		# It is most likely that a ">" character was in an attribute value.
		# This manifests itself by ">" appearing in the element's text.
		# In this case the callback should return a three element list;
		# the message "unterminated attribute value", the attribute list it
		# did manage to parse and the remainder of the attribute list.

		foreach {msg attlist brokenattr} $attr break

		upvar text elemText
		if {[string first > $elemText] >= 0} {

		    # Now piece the attribute list back together
		    regexp [cl $Wsp]*($Name)[cl $Wsp]*=[cl $Wsp]*("|')(.*) $brokenattr discard attname delimiter attvalue
		    regexp (.*)>([cl ^>]*)\$ $elemText discard remattlist elemText
		    regexp ([cl ^$delimiter]*)${delimiter}(.*) $remattlist discard remattvalue remattlist

		    # Gotcha: watch out for empty element syntax
		    if {[string match */ [string trimright $remattlist]]} {
			set remattlist [string range $remattlist 0 end-1]
			set handleEmpty 1
			set cfg(-empty) 1
		    }

		    append attvalue >$remattvalue
		    lappend attlist $attname $attvalue

		    # Complete parsing the attribute list
		    if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $options(-statevariable) $remattlist]} attr]} {
			uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
			set attr {}
			set attlist {}
		    } else {
			eval lappend attlist $attr
		    }

		    set attr $attlist

		} else {
		    uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
		    set attr {}
		}
	    }
	}
    }

    set empty {}
    if {$cfg(-empty) && $options(-reportempty)} {
	set empty {-empty 1}
    }

    # Check for namespace declarations
    upvar #0 $options(namespaces) namespaces
    set nsdecls {}
    if {[llength $attr]} {
	array set attrlist $attr
	foreach {attrName attrValue} [array get attrlist xmlns*] {
	    unset attrlist($attrName)
	    set colon [set prefix {}]
	    if {[regexp {^xmlns(:(.+))?$} $attrName discard colon prefix]} {
		switch -glob [string length $colon],[string length $prefix] {
		    0,0 {
			# default NS declaration
			lappend state(defaultNSURI) $attrValue
			lappend state(defaultNS) [llength $state(stack)]
			lappend nsdecls $attrValue {}
		    }
		    0,* {
			# Huh?
		    }
		    *,0 {
			# Error
			uplevel #0 $state(-warningcommand) "no prefix specified for namespace URI \"$attrValue\" in element \"$tag\""
		    }
		    default {
			set namespaces($prefix,[llength $state(stack)]) $attrValue
			lappend nsdecls $attrValue $prefix
		    }
		}
	    }
	}
	if {[llength $nsdecls]} {
	    set nsdecls [list -namespacedecls $nsdecls]
	}
	set attr [array get attrlist]
    }

    # Check whether this element has an expanded name
    set ns {}
    if {[regexp {([^:]+):(.*)$} $tag discard prefix tag]} {
	set nsspec [lsort -dictionary -decreasing [array names namespaces $prefix,*]]
	if {[llength $nsspec]} {
	    set nsuri $namespaces([lindex $nsspec 0])
	    set ns [list -namespace $nsuri]
	} else {
	    uplevel #0 $options(-errorcommand) [list namespaceundeclared "no namespace declared for prefix \"$prefix\" in element $tag"]
	}
    } elseif {[llength $state(defaultNSURI)]} {
	set ns [list -namespace [lindex $state(defaultNSURI) end]]
    }

    # Invoke callback
    set code [catch {uplevel #0 $options(-elementstartcommand) [list $tag $attr] $empty $ns $nsdecls} msg]

    # Sometimes empty elements must be handled here (see above)
    if {$code == 0 && $handleEmpty} {
	ParseEvent:ElementClose $tag $opts -empty 1
    }

    return -code $code -errorinfo $::errorInfo $msg
}

# sgml::ParseEvent:ElementClose --
#
#	End of an element.
#
# Arguments:
#	tag	Element name
#	opts	Options
#	args	further configuration options
#
# Options:
#	-empty boolean
#		indicates whether the element as an empty element
#
# Results:
#	Modify state and invoke callback

proc sgml::ParseEvent:ElementClose {tag opts args} {
    array set options $opts
    upvar #0 $options(-statevariable) state
    array set cfg {-empty 0}
    array set cfg $args

    # WF check
    if {[string compare $tag [lindex $state(stack) end]]} {
	uplevel #0 $options(-errorcommand) [list illegalendtag "end tag \"$tag\" does not match open element \"[lindex $state(stack) end]\" around line $state(line)"]
	return
    }

    # Check whether this element has an expanded name
    upvar #0 $options(namespaces) namespaces
    set ns {}
    if {[regexp {([^:]+):(.*)$} $tag discard prefix tag]} {
	set nsuri $namespaces([lindex [lsort -dictionary -decreasing [array names namespaces $prefix,*]] 0])
	set ns [list -namespace $nsuri]
    } elseif {[llength $state(defaultNSURI)]} {
	set ns [list -namespace [lindex $state(defaultNSURI) end]]
    }

    # Pop namespace stacks, if any
    if {[llength $state(defaultNS)]} {
	if {[llength $state(stack)] == [lindex $state(defaultNS) end]} {
	    set state(defaultNS) [lreplace $state(defaultNS) end end]
	}
    }
    foreach nsspec [array names namespaces *,[llength $state(stack)]] {
	unset namespaces($nsspec)
    }

    # Update state
    set state(stack) [lreplace $state(stack) end end]

    set empty {}
    if {$cfg(-empty) && $options(-reportempty)} {
	set empty {-empty 1}
    }

    # Invoke callback
    # Mats: Shall be same as sgml::ParseEvent:ElementOpen to handle exceptions in callback.
    set code [catch {uplevel #0 $options(-elementendcommand) [list $tag] $empty $ns} msg]
    return -code $code -errorinfo $::errorInfo $msg
}

# sgml::PCDATA --
#
#	Process PCDATA before passing to application
#
# Arguments:
#	opts	options
#	pcdata	Character data to be processed
#
# Results:
#	Checks that characters are legal,
#	checks -ignorewhitespace setting.

proc sgml::PCDATA {opts pcdata} {
    array set options $opts

    if {$options(-ignorewhitespace) && 	    ![string length [string trim $pcdata]]} {
	return {}
    }

    if {![regexp ^[cl $::sgml::Char]*\$ $pcdata]} {
	upvar \#0 $options(-statevariable) state
	uplevel \#0 $options(-errorcommand) [list illegalcharacters "illegal, non-Unicode characters found in text \"$pcdata\" around line $state(line)"]
    }

    uplevel \#0 $options(-characterdatacommand) [list $pcdata]
}

# sgml::Normalize --
#
#	Perform name normalization if required
#
# Arguments:
#	name	name to normalize
#	req	normalization required
#
# Results:
#	Name returned as upper-case if normalization required

proc sgml::Normalize {name req} {
    if {$req} {
	return [string toupper $name]
    } else {
	return $name
    }
}

# sgml::Entity --
#
#	Resolve XML entity references (syntax: &xxx;).
#
# Arguments:
#	opts		options
#	entityrefcmd	application callback for entity references
#	pcdatacmd	application callback for character data
#	entities	name of array containing entity definitions.
#	ref		entity reference (the "xxx" bit)
#
# Results:
#	Returns substitution text for given entity.

proc sgml::Entity {opts entityrefcmd pcdatacmd entities ref} {
    array set options $opts
    upvar #0 $options(-statevariable) state

    if {![string length $entities]} {
	set entities [namespace current]::EntityPredef
    }

    switch -glob -- $ref {
	%* {
	    # Parameter entity - not recognised outside of a DTD
	}
	#x* {
	    # Character entity - hex
	    if {[catch {format %c [scan [string range $ref 2 end] %x tmp; set tmp]} char]} {
		return -code error "malformed character entity \"$ref\""
	    }
	    uplevel #0 $pcdatacmd [list $char]

	    return {}

	}
	#* {
	    # Character entity - decimal
	    if {[catch {format %c [scan [string range $ref 1 end] %d tmp; set tmp]} char]} {
		return -code error "malformed character entity \"$ref\""
	    }
	    uplevel #0 $pcdatacmd [list $char]

	    return {}

	}
	default {
	    # General entity
	    upvar #0 $entities map
	    if {[info exists map($ref)]} {

		if {![regexp {<|&} $map($ref)]} {

		    # Simple text replacement - optimise
		    uplevel #0 $pcdatacmd [list $map($ref)]

		    return {}

		}

		# Otherwise an additional round of parsing is required.
		# This only applies to XML, since HTML doesn't have general entities

		# Must parse the replacement text for start & end tags, etc
		# This text must be self-contained: balanced closing tags, and so on

		set tokenised [tokenise $map($ref) $::xml::tokExpr $::xml::substExpr]
		set options(-final) 0
		eval parseEvent [list $tokenised] [array get options]

		return {}

	    } elseif {[string compare $entityrefcmd "::sgml::noop"]} {

		set result [uplevel #0 $entityrefcmd [list $ref]]

		if {[string length $result]} {
		    uplevel #0 $pcdatacmd [list $result]
		}

		return {}

	    } else {

		# Reconstitute entity reference

		uplevel #0 $options(-errorcommand) [list illegalentity "undefined entity reference \"$ref\""]

		return {}

	    }
	}
    }

    # If all else fails leave the entity reference untouched
    uplevel #0 $pcdatacmd [list &$ref\;]

    return {}
}

####################################
#
# DTD parser for SGML (XML).
#
# This DTD actually only handles XML DTDs.  Other language's
# DTD's, such as HTML, must be written in terms of a XML DTD.
#
####################################

# sgml::ParseEvent:DocTypeDecl --
#
#	Entry point for DTD parsing
#
# Arguments:
#	opts	configuration options
#	docEl	document element name
#	pubId	public identifier
#	sysId	system identifier (a URI)
#	intSSet	internal DTD subset

proc sgml::ParseEvent:DocTypeDecl {opts docEl pubId sysId intSSet} {
    array set options {}
    array set options $opts

    set code [catch {uplevel #0 $options(-doctypecommand) [list $docEl $pubId $sysId $intSSet]} err]
    switch $code {
	3 {
	    # break
	    return {}
	}
	0 -
	4 {
	    # continue
	}
	default {
	    return -code $code $err
	}
    }

    # Otherwise we'll parse the DTD and report it piecemeal

    # The internal DTD subset is processed first (XML 2.8)
    # During this stage, parameter entities are only allowed
    # between markup declarations

    ParseDTD:Internal [array get options] $intSSet

    # The external DTD subset is processed last (XML 2.8)
    # During this stage, parameter entities may occur anywhere

    # We must resolve the external identifier to obtain the
    # DTD data.  The application may supply its own resolver.

    if {[string length $pubId] || [string length $sysId]} {
	uplevel #0 $options(-externalentitycommand) [list $options(-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) [list elementdeclared "element \"$name\" already declared"]
    } else {
	switch -- $modspec {
	    EMPTY {
	    	set elements($name) {}
		uplevel #0 $options(-elementdeclcommand) $name {{}}
	    }
	    ANY {
	    	set elements($name) *
		uplevel #0 $options(-elementdeclcommand) $name *
	    }
	    default {
		# Don't parse the content model for now,
		# just pass the model to the application
		if {0 && [regexp [format {^\([%s]*#PCDATA[%s]*(\|([^)]+))?[%s]*\)*[%s]*$} $Wsp $Wsp $Wsp $Wsp] discard discard mtoks]} {
		    set cm($name) [list MIXED [split $mtoks |]]
		} elseif {0} {
		    if {[catch {CModelParse $state(state) $value} result]} {
			eval $options(-errorcommand) [list element? $result]
		    } else {
			set cm($id) [list ELEMENT $result]
		    }
		} else {
		    set elements($name) $modspec
		    uplevel #0 $options(-elementdeclcommand) $name [list $modspec]
		}
	    }
	}
    }
}

# sgml::CModelParse --
#
#	Parse an element content model (non-mixed).
#	A syntax tree is constructed.
#	A transition table is built next.
#
#	This is going to need alot of work!
#
# Arguments:
#	state	state array variable
#	value	the content model data
#
# Results:
#	A Tcl list representing the content model.

proc sgml::CModelParse {state value} {
    upvar #0 $state var

    # First build syntax tree
    set syntaxTree [CModelMakeSyntaxTree $state $value]

    # Build transition table
    set transitionTable [CModelMakeTransitionTable $state $syntaxTree]

    return [list $syntaxTree $transitionTable]
}

# sgml::CModelMakeSyntaxTree --
#
#	Construct a syntax tree for the regular expression.
#
#	Syntax tree is represented as a Tcl list:
#	rep {:choice|:seq {{rep list1} {rep list2} ...}}
#	where:	rep is repetition character, *, + or ?. {} for no repetition
#		listN is nested expression or Name
#
# Arguments:
#	spec	Element specification
#
# Results:
#	Syntax tree for element spec as nested Tcl list.
#
#	Examples:
#	(memo)
#		{} {:seq {{} memo}}
#	(front, body, back?)
#		{} {:seq {{} front} {{} body} {? back}}
#	(head, (p | list | note)*, div2*)
#		{} {:seq {{} head} {* {:choice {{} p} {{} list} {{} note}}} {* div2}}
#	(p | a | ul)+
#		+ {:choice {{} p} {{} a} {{} ul}}

proc sgml::CModelMakeSyntaxTree {state spec} {
    upvar #0 $state var
    variable Wsp
    variable name

    # Translate the spec into a Tcl list.

    # None of the Tcl special characters are allowed in a content model spec.
    if {[regexp {\$|\[|\]|\{|\}} $spec]} {
	return -code error "illegal characters in specification"
    }

    regsub -all [format {(%s)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $name $Wsp $Wsp] $spec [format {%sCModelSTname %s {\1} {\2} {\3}} \n $state] spec
    regsub -all {\(} $spec "\nCModelSTopenParen $state " spec
    regsub -all [format {\)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $Wsp $Wsp] $spec [format {%sCModelSTcloseParen %s {\1} {\2}} \n $state] spec

    array set var {stack {} state start}
    eval $spec

    # Peel off the outer seq, its redundant
    return [lindex [lindex $var(stack) 1] 0]
}

# sgml::CModelSTname --
#
#	Processes a name in a content model spec.
#
# Arguments:
#	state	state array variable
#	name	name specified
#	rep	repetition operator
#	cs	choice or sequence delimiter
#
# Results:
#	See CModelSTcp.

proc sgml::CModelSTname {state name rep cs args} {
    if {[llength $args]} {
	return -code error "syntax error in specification: \"$args\""
    }

    CModelSTcp $state $name $rep $cs
}

# sgml::CModelSTcp --
#
#	Process a content particle.
#
# Arguments:
#	state	state array variable
#	name	name specified
#	rep	repetition operator
#	cs	choice or sequence delimiter
#
# Results:
#	The content particle is added to the current group.

proc sgml::CModelSTcp {state cp rep cs} {
    upvar #0 $state var

    switch -glob -- [lindex $var(state) end]=$cs {
	start= {
	    set var(state) [lreplace $var(state) end end end]
	    # Add (dummy) grouping, either choice or sequence will do
	    CModelSTcsSet $state ,
	    CModelSTcpAdd $state $cp $rep
	}
	:choice= -
	:seq= {
	    set var(state) [lreplace $var(state) end end end]
	    CModelSTcpAdd $state $cp $rep
	}
	start=| -
	start=, {
	    set var(state) [lreplace $var(state) end end [expr {$cs == "," ? ":seq" : ":choice"}]]
	    CModelSTcsSet $state $cs
	    CModelSTcpAdd $state $cp $rep
	}
	:choice=| -
	:seq=, {
	    CModelSTcpAdd $state $cp $rep
	}
	:choice=, -
	:seq=| {
	    return -code error "syntax error in specification: incorrect delimiter after \"$cp\", should be \"[expr {$cs == "," ? "|" : ","}]\""
	}
	end=* {
	    return -code error "syntax error in specification: no delimiter before \"$cp\""
	}
	default {
	    return -code error "syntax error"
	}
    }
    
}

# sgml::CModelSTcsSet --
#
#	Start a choice or sequence on the stack.
#
# Arguments:
#	state	state array
#	cs	choice oir sequence
#
# Results:
#	state is modified: end element of state is appended.

proc sgml::CModelSTcsSet {state cs} {
    upvar #0 $state var

    set cs [expr {$cs == "," ? ":seq" : ":choice"}]

    if {[llength $var(stack)]} {
	set var(stack) [lreplace $var(stack) end end $cs]
    } else {
	set var(stack) [list $cs {}]
    }
}

# sgml::CModelSTcpAdd --
#
#	Append a content particle to the top of the stack.
#
# Arguments:
#	state	state array
#	cp	content particle
#	rep	repetition
#
# Results:
#	state is modified: end element of state is appended.

proc sgml::CModelSTcpAdd {state cp rep} {
    upvar #0 $state var

    if {[llength $var(stack)]} {
	set top [lindex $var(stack) end]
    	lappend top [list $rep $cp]
	set var(stack) [lreplace $var(stack) end end $top]
    } else {
	set var(stack) [list $rep $cp]
    }
}

# sgml::CModelSTopenParen --
#
#	Processes a '(' in a content model spec.
#
# Arguments:
#	state	state array
#
# Results:
#	Pushes stack in state array.

proc sgml::CModelSTopenParen {state args} {
    upvar #0 $state var

    if {[llength $args]} {
	return -code error "syntax error in specification: \"$args\""
    }

    lappend var(state) start
    lappend var(stack) [list {} {}]
}

# sgml::CModelSTcloseParen --
#
#	Processes a ')' in a content model spec.
#
# Arguments:
#	state	state array
#	rep	repetition
#	cs	choice or sequence delimiter
#
# Results:
#	Stack is popped, and former top of stack is appended to previous element.

proc sgml::CModelSTcloseParen {state rep cs args} {
    upvar #0 $state var

    if {[llength $args]} {
	return -code error "syntax error in specification: \"$args\""
    }

    set cp [lindex $var(stack) end]
    set var(stack) [lreplace $var(stack) end end]
    set var(state) [lreplace $var(state) end end]
    CModelSTcp $state $cp $rep $cs
}

# sgml::CModelMakeTransitionTable --
#
#	Given a content model's syntax tree, constructs
#	the transition table for the regular expression.
#
#	See "Compilers, Principles, Techniques, and Tools",
#	Aho, Sethi and Ullman.  Section 3.9, algorithm 3.5.
#
# Arguments:
#	state	state array variable
#	st	syntax tree
#
# Results:
#	The transition table is returned, as a key/value Tcl list.

proc sgml::CModelMakeTransitionTable {state st} {
    upvar #0 $state var

    # Construct nullable, firstpos and lastpos functions
    array set var {number 0}
    foreach {nullable firstpos lastpos} [		TraverseDepth1st $state $st {
	    # Evaluated for leaf nodes
	    # Compute nullable(n)
	    # Compute firstpos(n)
	    # Compute lastpos(n)
	    set nullable [nullable leaf $rep $name]
	    set firstpos [list {} $var(number)]
	    set lastpos [list {} $var(number)]
	    set var(pos:$var(number)) $name
	} {
	    # Evaluated for nonterminal nodes
	    # Compute nullable, firstpos, lastpos
	    set firstpos [firstpos $cs $firstpos $nullable]
	    set lastpos  [lastpos  $cs $lastpos  $nullable]
	    set nullable [nullable nonterm $rep $cs $nullable]
	}	    ] break

    set accepting [incr var(number)]
    set var(pos:$accepting) #

    # var(pos:N) maps from position to symbol.
    # Construct reverse map for convenience.
    # NB. A symbol may appear in more than one position.
    # var is about to be reset, so use different arrays.

    foreach {pos symbol} [array get var pos:*] {
	set pos [lindex [split $pos :] 1]
	set pos2symbol($pos) $symbol
	lappend sym2pos($symbol) $pos
    }

    # Construct the followpos functions
    catch {unset var}
    followpos $state $st $firstpos $lastpos

    # Construct transition table
    # Dstates is [union $marked $unmarked]
    set unmarked [list [lindex $firstpos 1]]
    while {[llength $unmarked]} {
	set T [lindex $unmarked 0]
	lappend marked $T
	set unmarked [lrange $unmarked 1 end]

	# Find which input symbols occur in T
	set symbols {}
	foreach pos $T {
	    if {$pos != $accepting && [lsearch $symbols $pos2symbol($pos)] < 0} {
		lappend symbols $pos2symbol($pos)
	    }
	}
	foreach a $symbols {
	    set U {}
	    foreach pos $sym2pos($a) {
		if {[lsearch $T $pos] >= 0} {
		    # add followpos($pos)
	    	    if {$var($pos) == {}} {
	    	    	lappend U $accepting
	    	    } else {
	    	    	eval lappend U $var($pos)
	    	    }
		}
	    }
	    set U [makeSet $U]
	    if {[llength $U] && [lsearch $marked $U] < 0 && [lsearch $unmarked $U] < 0} {
		lappend unmarked $U
	    }
	    set Dtran($T,$a) $U
	}
	
    }

    return [list [array get Dtran] [array get sym2pos] $accepting]
}

# sgml::followpos --
#
#	Compute the followpos function, using the already computed
#	firstpos and lastpos.
#
# Arguments:
#	state		array variable to store followpos functions
#	st		syntax tree
#	firstpos	firstpos functions for the syntax tree
#	lastpos		lastpos functions
#
# Results:
#	followpos functions for each leaf node, in name/value format

proc sgml::followpos {state st firstpos lastpos} {
    upvar #0 $state var

    switch -- [lindex [lindex $st 1] 0] {
	:seq {
	    for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
	    	followpos $state [lindex [lindex $st 1] $i]						[lindex [lindex $firstpos 0] [expr $i - 1]]				[lindex [lindex $lastpos 0] [expr $i - 1]]
	    	foreach pos [lindex [lindex [lindex $lastpos 0] [expr $i - 1]] 1] {
		    eval lappend var($pos) [lindex [lindex [lindex $firstpos 0] $i] 1]
		    set var($pos) [makeSet $var($pos)]
	    	}
	    }
	}
	:choice {
	    for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
		followpos $state [lindex [lindex $st 1] $i]						[lindex [lindex $firstpos 0] [expr $i - 1]]				[lindex [lindex $lastpos 0] [expr $i - 1]]
	    }
	}
	default {
	    # No action at leaf nodes
	}
    }

    switch -- [lindex $st 0] {
	? {
	    # We having nothing to do here ! Doing the same as
	    # for * effectively converts this qualifier into the other.
	}
	* {
	    foreach pos [lindex $lastpos 1] {
		eval lappend var($pos) [lindex $firstpos 1]
		set var($pos) [makeSet $var($pos)]
	    }
	}
    }

}

# sgml::TraverseDepth1st --
#
#	Perform depth-first traversal of a tree.
#	A new tree is constructed, with each node computed by f.
#
# Arguments:
#	state	state array variable
#	t	The tree to traverse, a Tcl list
#	leaf	Evaluated at a leaf node
#	nonTerm	Evaluated at a nonterminal node
#
# Results:
#	A new tree is returned.

proc sgml::TraverseDepth1st {state t leaf nonTerm} {
    upvar #0 $state var

    set nullable {}
    set firstpos {}
    set lastpos {}

    switch -- [lindex [lindex $t 1] 0] {
	:seq -
	:choice {
	    set rep [lindex $t 0]
	    set cs [lindex [lindex $t 1] 0]

	    foreach child [lrange [lindex $t 1] 1 end] {
		foreach {childNullable childFirstpos childLastpos} 			[TraverseDepth1st $state $child $leaf $nonTerm] break
		lappend nullable $childNullable
		lappend firstpos $childFirstpos
		lappend lastpos  $childLastpos
	    }

	    eval $nonTerm
	}
	default {
	    incr var(number)
	    set rep [lindex [lindex $t 0] 0]
	    set name [lindex [lindex $t 1] 0]
	    eval $leaf
	}
    }

    return [list $nullable $firstpos $lastpos]
}

# sgml::firstpos --
#
#	Computes the firstpos function for a nonterminal node.
#
# Arguments:
#	cs		node type, choice or sequence
#	firstpos	firstpos functions for the subtree
#	nullable	nullable functions for the subtree
#
# Results:
#	firstpos function for this node is returned.

proc sgml::firstpos {cs firstpos nullable} {
    switch -- $cs {
	:seq {
	    set result [lindex [lindex $firstpos 0] 1]
	    for {set i 0} {$i < [llength $nullable]} {incr i} {
	    	if {[lindex [lindex $nullable $i] 1]} {
	    	    eval lappend result [lindex [lindex $firstpos [expr $i + 1]] 1]
		} else {
		    break
		}
	    }
	}
	:choice {
	    foreach child $firstpos {
		eval lappend result $child
	    }
	}
    }

    return [list $firstpos [makeSet $result]]
}

# sgml::lastpos --
#
#	Computes the lastpos function for a nonterminal node.
#	Same as firstpos, only logic is reversed
#
# Arguments:
#	cs		node type, choice or sequence
#	lastpos		lastpos functions for the subtree
#	nullable	nullable functions forthe subtree
#
# Results:
#	lastpos function for this node is returned.

proc sgml::lastpos {cs lastpos nullable} {
    switch -- $cs {
	:seq {
	    set result [lindex [lindex $lastpos end] 1]
	    for {set i [expr [llength $nullable] - 1]} {$i >= 0} {incr i -1} {
		if {[lindex [lindex $nullable $i] 1]} {
		    eval lappend result [lindex [lindex $lastpos $i] 1]
		} else {
		    break
		}
	    }
	}
	:choice {
	    foreach child $lastpos {
		eval lappend result $child
	    }
	}
    }

    return [list $lastpos [makeSet $result]]
}

# sgml::makeSet --
#
#	Turn a list into a set, ie. remove duplicates.
#
# Arguments:
#	s	a list
#
# Results:
#	A set is returned, which is a list with duplicates removed.

proc sgml::makeSet s {
    foreach r $s {
	if {[llength $r]} {
	    set unique($r) {}
	}
    }
    return [array names unique]
}

# sgml::nullable --
#
#	Compute the nullable function for a node.
#
# Arguments:
#	nodeType	leaf or nonterminal
#	rep		repetition applying to this node
#	name		leaf node: symbol for this node, nonterm node: choice or seq node
#	subtree		nonterm node: nullable functions for the subtree
#
# Results:
#	Returns nullable function for this branch of the tree.

proc sgml::nullable {nodeType rep name {subtree {}}} {
    switch -glob -- $rep:$nodeType {
	:leaf -
	+:leaf {
	    return [list {} 0]
	}
	\\*:leaf -
	\\?:leaf {
	    return [list {} 1]
	}
	\\*:nonterm -
	\\?:nonterm {
	    return [list $subtree 1]
	}
	:nonterm -
	+:nonterm {
	    switch -- $name {
		:choice {
		    set result 0
		    foreach child $subtree {
			set result [expr $result || [lindex $child 1]]
		    }
		}
		:seq {
		    set result 1
		    foreach child $subtree {
			set result [expr $result && [lindex $child 1]]
		    }
		}
	    }
	    return [list $subtree $result]
	}
    }
}

# sgml::DTD:ATTLIST --
#
#	<!ATTLIST ...> defines an attribute list.
#
# Arguments:
#	opts	configuration opions
#	name	Element GI
#	attspec	unparsed attribute definitions
#
# Results:
#	Attribute list variables are modified.

proc sgml::DTD:ATTLIST {opts name attspec} {
    variable attlist_exp
    variable attlist_enum_exp
    variable attlist_fixed_exp

    array set options $opts

    # Parse the attribute list.  If it were regular, could just use foreach,
    # but some attributes may have values.
    regsub -all {([][$\\])} $attspec {\\\1} attspec
    regsub -all $attlist_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {} \{" attspec
    regsub -all $attlist_enum_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {} {\\4} \{" attspec
    regsub -all $attlist_fixed_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {\\4} \{" attspec

    eval "noop \{$attspec\}"

    return {}
}

# sgml::DTDAttribute --
#
#	Parse definition of a single attribute.
#
# Arguments:
#	callback	attribute defn callback
#	name	element name
#	var	array variable
#	att	attribute name
#	type	type of this attribute
#	default	default value of the attribute
#	value	other information
#	text	other text (should be empty)
#
# Results:
#	Attribute defn added to array, unless it already exists

proc sgml::DTDAttribute args {
    # BUG: Some problems with parameter passing - deal with it later
    foreach {callback name var att type default value text} $args break

    upvar #0 $var atts

    if {[string length [string trim $text]]} {
	return -code error "unexpected text \"$text\" in attribute definition"
    }

    # What about overridden attribute defns?
    # A non-validating app may want to know about them
    # (eg. an editor)
    if {![info exists atts($name/$att)]} {
	set atts($name/$att) [list $type $default $value]
	uplevel #0 $callback [list $name $att $type $default $value]
    }

    return {}
}

# sgml::DTD:ENTITY --
#
#	<!ENTITY ...> declaration.
#
#	Callbacks:
#	-entitydeclcommand for general entity declaration
#	-unparsedentitydeclcommand for unparsed external entity declaration
#	-parameterentitydeclcommand for parameter entity declaration
#
# Arguments:
#	opts	configuration options
#	name	name of entity being defined
#	param	whether a parameter entity is being defined
#	value	unparsed replacement text
#
# Results:
#	Modifies the caller's entities array variable

proc sgml::DTD:ENTITY {opts name param value} {

    array set options $opts

    if {[string compare % $param]} {
	# Entity declaration - general or external
	upvar #0 $options(entities) ents
	upvar #0 $options(extentities) externals

	if {[info exists ents($name)] || [info exists externals($name)]} {
	    eval $options(-warningcommand) entity [list "entity \"$name\" already declared"]
	} else {
	    if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} {
		return -code error "unable to parse entity declaration due to \"$value\""
	    }
	    switch -glob [lindex $value 0],[lindex $value 3] {
		internal, {
		    set ents($name) [EntitySubst [array get options] [lindex $value 1]]
		    uplevel #0 $options(-entitydeclcommand) [list $name $ents($name)]
		}
		internal,* {
		    return -code error "unexpected NDATA declaration"
		}
		external, {
		    set externals($name) [lrange $value 1 2]
		    uplevel #0 $options(-entitydeclcommand) [eval list $name [lrange $value 1 2]]
		}
		external,* {
		    set externals($name) [lrange $value 1 3]
		    uplevel #0 $options(-unparsedentitydeclcommand) [eval list $name [lrange $value 1 3]]
		}
		default {
		    return -code error "internal error: unexpected parser state"
		}
	    }
	}
    } else {
	# Parameter entity declaration
	upvar #0 $options(parameterentities) PEnts
	upvar #0 $options(externalparameterentities) ExtPEnts

	if {[info exists PEnts($name)] || [info exists ExtPEnts($name)]} {
	    eval $options(-warningcommand) parameterentity [list "parameter entity \"$name\" already declared"]
	} else {
	    if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} {
		return -code error "unable to parse parameter entity declaration due to \"$value\""
	    }
	    if {[string length [lindex $value 3]]} {
		return -code error "NDATA illegal in parameter entity declaration"
	    }
	    switch [lindex $value 0] {
		internal {
		    # Substitute character references and PEs (XML: 4.5)
		    set value [EntitySubst [array get options] [lindex $value 1]]

		    set PEnts($name) $value
		    uplevel #0 $options(-parameterentitydeclcommand) [list $name $value]
		}
		external -
		default {
		    # Get the replacement text now.
		    # Could wait until the first reference, but easier
		    # to just do it now.

		    set token [uri::geturl [uri::resolve $options(-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) [list notationvalue "notation value \"$value\" incorrectly specified"]
    }
}

# sgml::ResolveEntity --
#
#	Default entity resolution routine
#
# Arguments:
#	name	name of parent parser
#	base	base URL for relative URLs
#	sysId	system identifier
#	pubId	public identifier

proc sgml::ResolveEntity {name base sysId pubId} {
    variable ParseEventNum

    if {[catch {uri::resolve $base $sysId} url]} {
	return -code error "unable to resolve system identifier \"$sysId\""
    }
    if {[catch {uri::geturl $url} token]} {
	return -code error "unable to retrieve external entity \"$url\" for system identifier \"$sysId\""
    }

    upvar #0 $token data

    set parser [uplevel #0 $name entityparser]

    $parser parse $data(body) -dtdsubset external
    #$parser free

    return {}
}
# 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-2003 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.12 2003/02/25 04:09:22 balls Exp $

package provide xml::tcl 2.6

#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
	    uplevel 1 [list rename $name {}]
	}

	get {
	    eval $classinfo(-getcommand) [list $name] $args
	}

	parse {
	    if {[llength $args] < 1} {
		return -code error "wrong number of arguments, should be $name parse xml ?options?"
	    }
	    eval $classinfo(-parsecommand) [list $name] $args
	}

	reset {
	    eval $classinfo(-resetcommand) [list $name]
	}

	default {
	    return -code error "unknown method"
	}
    }

    return {}
}

# xml::noop --
#
#	Do nothing utility proc
#
# Arguments:
#	args	whatever
#
# Results:
#	Nothing happens

proc xml::noop args {}
# tclparser-8.1.tcl --
#
#	This file provides a Tcl implementation of a XML parser.
#	This file supports Tcl 8.1.
#
#	See xml-8.[01].tcl for definitions of character sets and
#	regular expressions.
#
# Copyright (c) 1998-2003 Zveno Pty Ltd
# http://www.zveno.com/
# 
# 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.23 2003/02/25 04:09:21 balls Exp $

package require Tcl 8.1

package provide xml::tclparser 2.6

package require xmldefs 2.6

package require sgmlparser 1.0

namespace eval xml::tclparser {

    namespace export create createexternal externalentity parse configure get delete

    # Tokenising expressions

    variable tokExpr $::xml::tokExpr
    variable substExpr $::xml::substExpr

    # Register this parser class

    ::xml::parserclass create tcl 	    -createcommand [namespace code create] 	    -createentityparsercommand [namespace code createentityparser] 	    -parsecommand [namespace code parse] 	    -configurecommand [namespace code configure] 	    -deletecommand [namespace code delete] 	    -resetcommand [namespace code reset]
}

# xml::tclparser::create --
#
#	Creates XML parser object.
#
# Arguments:
#	name	unique identifier for this instance
#
# Results:
#	The state variable is initialised.

proc xml::tclparser::create name {

    # Initialise state variable
    upvar \#0 [namespace current]::$name parser
    array set parser [list -name $name				-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       -defaultcommand -unknownencodingcommand -notstandalonecommand       -startcdatasectioncommand -endcdatasectioncommand       -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 -ignorewhitespace] 	    [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:
#	opts	parser options
#	attrs	attribute string given in a tag
#
# Results:
#	Returns a Tcl list representing the name-value pairs in the 
#	attribute string
#
#	A ">" occurring in the attribute list causes problems when parsing
#	the XML.  This manifests itself by an unterminated attribute value
#	and a ">" appearing the element text.
#	In this case return a three element list;
#	the message "unterminated attribute value", the attribute list it
#	did manage to parse and the remainder of the attribute list.

proc xml::tclparser::ParseAttrs {opts attrs} {

    set result {}

    while {[string length [string trim $attrs]]} {
	if {[regexp [::sgml::cl $::xml::Wsp]*($::xml::Name)[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')([::sgml::cl ^<]*?)\\2(.*) $attrs discard attrName delimiter value attrs]} {
	    lappend result $attrName [NormalizeAttValue $opts $value]
	} elseif {[regexp [::sgml::cl $::xml::Wsp]*$::xml::Name[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')[::sgml::cl ^<]*\$ $attrs]} {
	    return -code error [list {unterminated attribute value} $result $attrs]
	} else {
	    return -code error "invalid attribute list"
	}
    }

    return $result
}

# xml::tclparser::NormalizeAttValue --
#
#	Perform attribute value normalisation.  This involves:
#	. character references are appended to the value
#	. entity references are recursively processed and replacement value appended
#	. whitespace characters cause a space to be appended
#	. other characters appended as-is
#
# Arguments:
#	opts	parser options
#	value	unparsed attribute value
#
# Results:
#	Normalised value returned.

proc xml::tclparser::NormalizeAttValue {opts value} {

    # sgmlparser already has backslashes protected
    # Protect Tcl specials
    regsub -all {([][$])} $value {\\\1} value

    # Deal with white space
    regsub -all "\[$::xml::Wsp\]" $value { } value

    # Find entity refs
    regsub -all {&([^;]+);} $value {[NormalizeAttValue:DeRef $opts {\1}]} value

    return [subst $value]
}

# xml::tclparser::NormalizeAttValue:DeRef --
#
#	Handler to normalize attribute values
#
# Arguments:
#	opts	parser options
#	ref	entity reference
#
# Results:
#	Returns character

proc xml::tclparser::NormalizeAttValue:DeRef {opts ref} {

    switch -glob -- $ref {
	#x* {
	    scan [string range $ref 2 end] %x value
	    set char [format %c $value]
	    # Check that the char is legal for XML
	    if {[regexp [format {^[%s]$} $::xml::Char] $char]} {
		return $char
	    } else {
		return -code error "illegal character"
	    }
	}
	#* {
	    scan [string range $ref 1 end] %d value
	    set char [format %c $value]
	    # Check that the char is legal for XML
	    if {[regexp [format {^[%s]$} $::xml::Char] $char]} {
		return $char
	    } else {
		return -code error "illegal character"
	    }
	}
	lt -
	gt -
	amp -
	quot -
	apos {
	    array set map {lt < gt > amp & quot \" apos '}
	    return $map($ref)
	}
	default {
	    # A general entity.  Must resolve to a text value - no element structure.

	    array set options $opts
	    upvar #0 $options(entities) map

	    if {[info exists map($ref)]} {

		if {[regexp < $map($ref)]} {
		    return -code error "illegal character \"<\" in attribute value"
		}

		if {![regexp & $map($ref)]} {
		    # Simple text replacement
		    return $map($ref)
		}

		# There are entity references in the replacement text.
		# Can't use child entity parser since must catch element structures

		return [NormalizeAttValue $opts $map($ref)]

	    } elseif {[string compare $options(-entityreferencecommand) "::sgml::noop"]} {

		set result [uplevel #0 $options(-entityreferencecommand) [list $ref]]

		return $result

	    } else {
		return -code error "unable to resolve entity reference \"$ref\""
	    }
	}
    }
}

# xml::tclparser::ParseEntity --
#
#	Parse general entity declaration
#
# Arguments:
#	data	text to parse
#
# Results:
#	Tcl list containing entity declaration

proc xml::tclparser::ParseEntity data {
    set data [string trim $data]
    if {[regexp $::sgml::ExternalEntityExpr $data discard type delimiter1 id1 discard delimiter2 id2 optNDATA ndata]} {
	switch $type {
	    PUBLIC {
		return [list external $id2 $id1 $ndata]
	    }
	    SYSTEM {
		return [list external $id1 {} $ndata]
	    }
	}
    } elseif {[regexp {^("|')(.*?)\1$} $data discard delimiter value]} {
	return [list internal $value]
    } else {
	return -code error "badly formed entity declaration"
    }
}

# xml::tclparser::delete --
#
#	Destroy parser data
#
# Arguments:
#	name	parser object
#
# Results:
#	Parser data structure destroyed

proc xml::tclparser::delete name {
    upvar \#0 [namespace current]::$name parser
    catch {::sgml::ParserDelete $parser(-statevariable)}
    catch {unset parser}
    return {}
}

# xml::tclparser::get --
#
#	Retrieve additional information from the parser
#
# Arguments:
#	name	parser object
#	method	info to retrieve
#	args	additional arguments for method
#
# Results:
#	Depends on method

proc xml::tclparser::get {name method args} {
    upvar #0 [namespace current]::$name parser

    switch -- $method {

	elementdecl {
	    switch [llength $args] {

		0 {
		    # Return all element declarations
		    upvar #0 $parser(elementdecls) elements
		    return [array get elements]
		}

		1 {
		    # Return specific element declaration
		    upvar #0 $parser(elementdecls) elements
		    if {[info exists elements([lindex $args 0])]} {
			return [array get elements [lindex $args 0]]
		    } else {
			return -code error "element \"[lindex $args 0]\" not declared"
		    }
		}

		default {
		    return -code error "wrong number of arguments: should be \"elementdecl ?element?\""
		}
	    }
	}

	attlist {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments: should be \"get attlist element\""
	    }

	    upvar #0 $parser(attlistdecls)

	    return {}
	}

	entitydecl {
	}

	parameterentitydecl {
	}

	notationdecl {
	}

	default {
	    return -code error "unknown method \"$method\""
	}
    }

    return {}
}

# xml::tclparser::ExternalEntity --
#
#	Resolve and parse external entity
#
# Arguments:
#	name	parser object
#	base	base URL
#	sys	system identifier
#	pub	public identifier
#
# Results:
#	External entity is fetched and parsed

proc xml::tclparser::ExternalEntity {name base sys pub} {
}

# xml::tclparser:: --
#
#	Reset a parser instance, ready to parse another document
#
# Arguments:
#	name	parser object
#
# Results:
#	Variables unset

proc xml::tclparser::reset {name} {
    upvar \#0 [namespace current]::$name parser

    # Has this parser object been properly initialised?
    if {![info exists parser] || 	    ![info exists parser(-name)]} {
	return [create $name]
    }

    array set parser {
	-final 1
	depth 0
	leftover {}
    }

    foreach var {Entities ExtEntities PEntities ExtPEntities ElDecls AttlistDecls NotDecls} {
	catch {unset [namespace current]::${var}$name}
    }

    # Initialise entities with predefined set
    array set [namespace current]::Entities$name [array get ::sgml::EntityPredef]

    return {}
}
# xpath.tcl --
#
#	Provides an XPath parser for Tcl,
#	plus various support procedures
#
# Copyright (c) 2000-2002 Zveno Pty Ltd
#
# $Id: xpath.tcl,v 1.7 2002/06/14 12:16:23 balls Exp $

package provide xpath 1.0

# We need the XML package for definition of Names
package require xml

namespace eval xpath {
    namespace export split join createnode

    variable axes {
	ancestor
	ancestor-or-self
	attribute
	child
	descendant
	descendant-or-self
	following
	following-sibling
	namespace
	parent
	preceding
	preceding-sibling
	self
    }

    variable nodeTypes {
	comment
	text
	processing-instruction
	node
    }

    # NB. QName has parens for prefix

    variable nodetestExpr ^(${::xml::QName})${::xml::allWsp}(\\(${::xml::allWsp}(("|')(.*?)\\5)?${::xml::allWsp}\\))?${::xml::allWsp}(.*)

    variable nodetestExpr2 ((($::xml::QName)${::xml::allWsp}(\\(${::xml::allWsp}(("|')(.*?)\\7)?${::xml::allWsp}\\))?)|${::xml::allWsp}(\\*))${::xml::allWsp}(.*)
}

# xpath::split --
#
#	Parse an XPath location path
#
# Arguments:
#	locpath	location path
#
# Results:
#	A Tcl list representing the location path.
#	The list has the form: {{axis node-test {predicate predicate ...}} ...}
#	Where each list item is a location step.

proc xpath::split locpath {
    set leftover {}

    set result [InnerSplit $locpath leftover]

    if {[string length [string trim $leftover]]} {
	return -code error "unexpected text \"$leftover\""
    }

    return $result
}

proc xpath::InnerSplit {locpath leftoverVar} {
    upvar $leftoverVar leftover

    variable axes
    variable nodetestExpr
    variable nodetestExpr2

    # First determine whether we have an absolute location path
    if {[regexp {^/(.*)} $locpath discard locpath]} {
	set path {{}}
    } else {
	set path {}
    }

    while {[string length [string trimleft $locpath]]} {
	if {[regexp {^\.\.(.*)} $locpath discard locpath]} {
	    # .. abbreviation
	    set axis parent
	    set nodetest *
	} elseif {[regexp {^/(.*)} $locpath discard locpath]} {
	    # // abbreviation
	    set axis descendant-or-self
	    if {[regexp ^$nodetestExpr2 [string trimleft $locpath] discard discard discard nodetest discard typetest discard discard literal wildcard locpath]} {
		set nodetest [ResolveWildcard $nodetest $typetest $wildcard $literal]
	    } else {
		set leftover $locpath
		return $path
	    }
	} elseif {[regexp ^\\.${::xml::allWsp}(.*) $locpath discard locpath]} {
	    # . abbreviation
	    set axis self
	    set nodetest *
	} elseif {[regexp ^@($::xml::QName)${::xml::allWsp}=${::xml::allWsp}"(\[^"\])"(.*) $locpath discard attrName discard attrValue locpath]} {
	    # @ abbreviation
	    set axis attribute
	    set nodetest $attrName
	} elseif {[regexp ^@($::xml::QName)${::xml::allWsp}=${::xml::allWsp}'(\[^'\])'(.*) $locpath discard attrName discard attrValue locpath]} {
	    # @ abbreviation
	    set axis attribute
	    set nodetest $attrName
	} elseif {[regexp ^@($::xml::QName)(.*) $locpath discard attrName discard2 locpath]} {
	    # @ abbreviation
	    set axis attribute
	    set nodetest $attrName
	} elseif {[regexp ^((${::xml::QName})${::xml::allWsp}::${::xml::allWsp})?\\*(.*) $locpath discard discard axis discard locpath]} {
	    # wildcard specified
	    set nodetest *
	    if {![string length $axis]} {
		set axis child
	    }
	} elseif {[regexp ^((${::xml::QName})${::xml::allWsp}::${::xml::allWsp})?$nodetestExpr2 $locpath discard discard axis discard discard discard nodetest discard typetest discard discard literal wildcard locpath]} {
	    # nodetest, with or without axis
	    if {![string length $axis]} {
		set axis child
	    }
	    set nodetest [ResolveWildcard $nodetest $typetest $wildcard $literal]
	} else {
	    set leftover $locpath
	    return $path
	}

	# ParsePredicates
	set predicates {}
	set locpath [string trimleft $locpath]
	while {[regexp {^\[(.*)} $locpath discard locpath]} {
	    if {[regexp {^([0-9]+)(\].*)} [string trim $locpath] discard posn locpath]} {
		set predicate [list = {function position {}} [list number $posn]]
	    } else {
		set leftover2 {}
		set predicate [ParseExpr $locpath leftover2]
		set locpath $leftover2
		unset leftover2
	    }

	    if {[regexp {^\](.*)} [string trimleft $locpath] discard locpath]} {
		lappend predicates $predicate
	    } else {
		return -code error "unexpected text in predicate \"$locpath\""
	    }
	}

	set axis [string trim $axis]
	set nodetest [string trim $nodetest]

	# This step completed
	if {[lsearch $axes $axis] < 0} {
	    return -code error "invalid axis \"$axis\""
	}
	lappend path [list $axis $nodetest $predicates]

	# Move to next step

	if {[string length $locpath] && ![regexp ^/(.*) $locpath discard locpath]} {
            set leftover $locpath
	    return $path
	}

    }

    return $path
}

# xpath::ParseExpr --
#
#	Parse one expression in a predicate
#
# Arguments:
#	locpath	location path to parse
#	leftoverVar	Name of variable in which to store remaining path
#
# Results:
#	Returns parsed expression as a Tcl list

proc xpath::ParseExpr {locpath leftoverVar} {
    upvar $leftoverVar leftover
    variable nodeTypes

    set expr {}
    set mode expr
    set stack {}

    while {[string index [string trimleft $locpath] 0] != "\]"} {
	set locpath [string trimleft $locpath]
	switch $mode {
	    expr {
		# We're looking for a term
		if {[regexp ^-(.*) $locpath discard locpath]} {
		    # UnaryExpr
		    lappend stack "-"
		} elseif {[regexp ^\\\$({$::xml::QName})(.*) $locpath discard varname discard locpath]} {
		    # VariableReference
		    lappend stack [list varRef $varname]
		    set mode term
		} elseif {[regexp {^\((.*)} $locpath discard locpath]} {
		    # Start grouping
		    set leftover2 {}
		    lappend stack [list group [ParseExpr $locpath leftover2]]
		    set locpath $leftover2
		    unset leftover2

		    if {[regexp {^\)(.*)} [string trimleft $locpath] discard locpath]} {
			set mode term
		    } else {
			return -code error "unexpected text \"$locpath\", expected \")\""
		    }

		} elseif {[regexp {^"([^"]*)"(.*)} $locpath discard literal locpath]} {
		    # Literal (" delimited)
		    lappend stack [list literal $literal]
		    set mode term
		} elseif {[regexp {^'([^']*)'(.*)} $locpath discard literal locpath]} {
		    # Literal (' delimited)
		    lappend stack [list literal $literal]
		    set mode term
		} elseif {[regexp {^([0-9]+(\.[0-9]+)?)(.*)} $locpath discard number discard locpath]} {
		    # Number
		    lappend stack [list number $number]
		    set mode term
		} elseif {[regexp {^(\.[0-9]+)(.*)} $locpath discard number locpath]} {
		    # Number
		    lappend stack [list number $number]
		    set mode term
		} elseif {[regexp ^(${::xml::QName})\\(${::xml::allWsp}(.*) $locpath discard functionName discard locpath]} {
		    # Function call start or abbreviated node-type test

		    if {[lsearch $nodeTypes $functionName] >= 0} {
			# Looking like a node-type test
			if {[regexp ^\\)${::xml::allWsp}(.*) $locpath discard locpath]} {
			    lappend stack [list path [list child [list $functionName ()] {}]]
			    set mode term
			} else {
			    return -code error "invalid node-type test \"$functionName\""
			}
		    } else {
			if {[regexp ^\\)${::xml::allWsp}(.*) $locpath discard locpath]} {
			    set parameters {}
			} else {
			    set leftover2 {}
			    set parameters [ParseExpr $locpath leftover2]
			    set locpath $leftover2
			    unset leftover2
			    while {[regexp {^,(.*)} $locpath discard locpath]} {
				set leftover2 {}
				lappend parameters [ParseExpr $locpath leftover2]
				set locpath $leftover2
				unset leftover2
			    }

			    if {![regexp ^\\)${::xml::allWsp}(.*) [string trimleft $locpath] discard locpath]} {
				return -code error "unexpected text \"locpath\" - expected \")\""
			    }
		        }

			lappend stack [list function $functionName $parameters]
			set mode term
		    }

		} else {
		    # LocationPath
		    set leftover2 {}
		    lappend stack [list path [InnerSplit $locpath leftover2]]
		    set locpath $leftover2
		    unset leftover2
		    set mode term
		}
	    }
	    term {
		# We're looking for an expression operator
		if {[regexp ^-(.*) $locpath discard locpath]} {
		    # UnaryExpr
		    set stack [linsert $stack 0 expr "-"]
		    set mode expr
		} elseif {[regexp ^(and|or|\\=|!\\=|<|>|<\\=|>\\=|\\||\\+|\\-|\\*|div|mod)(.*) $locpath discard exprtype locpath]} {
		    # AndExpr, OrExpr, EqualityExpr, RelationalExpr or UnionExpr
		    set stack [linsert $stack 0 $exprtype]
		    set mode expr
		} else {
		    return -code error "unexpected text \"$locpath\", expecting operator"
		}
	    }
	    default {
		# Should never be here!
		return -code error "internal error"
	    }
	}
    }

    set leftover $locpath
    return $stack
}

# xpath::ResolveWildcard --

proc xpath::ResolveWildcard {nodetest typetest wildcard literal} {
    variable nodeTypes

    switch -glob -- [string length $nodetest],[string length $typetest],[string length $wildcard],[string length $literal] {
	0,0,0,* {
	    return -code error "bad location step (nothing parsed)"
	}
	0,0,* {
	    # Name wildcard specified
	    return *
	}
	*,0,0,* {
	    # Element type test - nothing to do
	    return $nodetest
	}
	*,0,*,* {
	    # Internal error?
	    return -code error "bad location step (found both nodetest and wildcard)"
	}
	*,*,0,0 {
	    # Node type test
	    if {[lsearch $nodeTypes $nodetest] < 0} {
		return -code error "unknown node type \"$typetest\""
	    }
	    return [list $nodetest $typetest]
	}
	*,*,0,* {
	    # Node type test
	    if {[lsearch $nodeTypes $nodetest] < 0} {
		return -code error "unknown node type \"$typetest\""
	    }
	    return [list $nodetest $literal]
	}
	default {
	    # Internal error?
	    return -code error "bad location step"
	}
    }
}

# xpath::join --
#
#	Reconstitute an XPath location path from a
#	Tcl list representation.
#
# Arguments:
#	spath	split path
#
# Results:
#	Returns an Xpath location path

proc xpath::join spath {
    return -code error "not yet implemented"
}

namespace eval ::dom {variable strictDOM 0}
# dom.tcl --
#
#	This file implements the Tcl language binding for the DOM -
#	the Document Object Model.  Support for the core specification
#	is given here.  Layered support for specific languages, 
#	such as HTML, will be in separate modules.
#
# Copyright (c) 1998-2003 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.
#
# $Id: domimpl.tcl,v 1.18 2003/03/09 11:12:49 balls Exp $

# We need the xml package, so that we get Name defined

package require xml 2.6

# NB. DOM generic layer should be loaded before sourceing this script.
if {[catch {package require dom::generic 2.6}]} {
    package require dom::tclgeneric 2.6
}

package provide dom::tcl 2.6

namespace eval dom::tcl {
    namespace export DOMImplementation
    namespace export hasFeature createDocument create createDocumentType
    namespace export createNode destroy isNode parse selectNode serialize
    namespace export trim

    namespace export document documentFragment node
    namespace export element textNode attribute
    namespace export processingInstruction
    namespace export event

}

# Define generic constants here, since this package
# is always loaded.

namespace eval dom {
    # DOM Level 2 Event defaults
    variable bubbles
    array set bubbles {
	DOMFocusIn 1
	DOMFocusOut 1
	DOMActivate 1
	click 1
	mousedown 1
	mouseup 1
	mouseover 1
	mousemove 1
	mouseout 1
	DOMSubtreeModified 1
	DOMNodeInserted 1
	DOMNodeRemoved 1
	DOMNodeInsertedIntoDocument 0
	DOMNodeRemovedFromDocument 0
	DOMAttrModified 1
	DOMAttrRemoved 1
	DOMCharacterDataModified 1
    }
    variable cancelable
    array set cancelable {
	DOMFocusIn 0
	DOMFocusOut 0
	DOMActivate 1
	click 1
	mousedown 1
	mouseup 1
	mouseover 1
	mousemove 0
	mouseout 1
	DOMSubtreeModified 0
	DOMNodeInserted 0
	DOMNodeRemoved 0
	DOMNodeInsertedIntoDocument 0
	DOMNodeRemovedFromDocument 0
	DOMAttrModified 0
	DOMAttrRemoved 0
	DOMCharacterDataModified 0
    }
}

# Data structure
#
# Documents are stored in an array within the dom namespace.
# Each element of the array is indexed by a unique identifier.
# Each element of the array is a key-value list with at least
# the following fields:
#	id docArray
#	node:parentNode node:childNodes node:nodeType
# Nodes of a particular type may have additional fields defined.
# Note that these fields in many circumstances are configuration options
# for a node type.
#
# "Live" data objects are stored as a separate Tcl variable.
# Lists, such as child node lists, are Tcl list variables (ie scalar)
# and keyed-value lists, such as attribute lists, are Tcl array
# variables.  The accessor function returns the variable name,
# which the application should treat as a read-only object.
#
# A token is a FQ array element reference for a node.

# dom::tcl::DOMImplementation --
#
#	Implementation-dependent functions.
#	Most importantly, this command provides a function to
#	create a document instance.
#
# Arguments:
#	method	method to invoke
#	token	token for node
#	args	arguments for method
#
# Results:
#	Depends on method used.

namespace eval dom::tcl {
    variable DOMImplementationOptions {}
    variable DOMImplementationCounter 0
}

proc dom::tcl::DOMImplementation {method args} {
    variable DOMImplementationOptions
    variable DOMImplementationCounter

    switch -- $method {

	hasFeature {

	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    # Later on, could use Tcl package facility
	    if {[regexp {create|destroy|parse|query|serialize|trim|Events|UIEvents|isNode} [lindex $args 0]]} {
		if {![string compare [lindex $args 1] "1.0"]} {
		    return 1
		} else {
		    return 0
		}
	    } else {
		return 0
	    }

	}

	createDocument {
	    # createDocument introduced in DOM Level 2

	    if {[llength $args] != 3} {
		return -code error "wrong # arguments: should be DOMImplementation nsURI name doctype"
	    }

	    set doc [DOMImplementation create]

	    document createElementNS $doc [lindex $args 0] [lindex $args 1]

	    if {[string length [lindex $args 2]]} {
		document configure -doctype [lindex $args 2]
	    }

	    return $doc
	}

	create {

	    # Non-standard method (see createDocument)
	    # Bootstrap a document instance

	    switch [llength $args] {
		0 {
		    # Allocate unique document array name
	    	    set name [namespace current]::document[incr DOMImplementationCounter]
		}
		1 {
		    # Use array name provided.  Should check that it is safe.
		    set name [lindex $args 0]
		    catch {unset $name}
		}
		default {
		    return -code error "wrong number of arguments"
		}
	    }

	    set varPrefix ${name}var
	    set arrayPrefix ${name}arr

	    array set $name [list counter 1 		node1 [list id node1 docArray $name					node:nodeType documentFragment					node:parentNode {}						node:nodeName #document						node:nodeValue {}						node:childNodes ${varPrefix}1					documentFragment:masterDoc node1				document:implementation [namespace current]::DOMImplementation					document:xmldecl {version 1.0}					document:documentElement {}					document:doctype {}					]]

	    # Initialise child node list
	    set ${varPrefix}1 {}

	    # Return the new toplevel node
	    return ${name}(node1)

	}

	createDocumentType {
	    # Introduced in DOM Level 2

	    # Patch from c.l.t., Richard Calmbach (rc@hnc.com )

	    if {[llength $args] != 5} {
		return -code error "wrong number of arguments, should be: DOMImplementation createDocumentType token name publicid systemid internaldtd"
	    }

	    return [CreateDocType [lindex $args 0] [lindex $args 1] [lrange $args 2 3] [lindex $args 4]]
	}

	createNode {
	    # Non-standard method
	    # Creates node(s) in the given document given an XPath expression

	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    package require xpath

	    return [XPath:CreateNode [lindex $args 0] [lindex $args 1]]
	}

	destroy {

	    # Free all memory associated with a node

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }
	    array set node [set [lindex $args 0]]

	    switch $node(node:nodeType) {

		document -
		documentFragment {

		    if {[string length $node(node:parentNode)]} {
			unset $node(node:childNodes)

			# Dispatch events
			event postMutationEvent $node(node:parentNode) DOMSubtreeModified

			return {}
		    }

		    # else this is the root document node,
		    # and we can optimize the cleanup.
		    # No need to dispatch events.

		    # Patch from Gerald Lester

		    ##
		    ## First release all the associated variables
		    ##
		    upvar #0 $node(docArray) docArray
		    for {set i 0} {$i <= $docArray(counter)} {incr i} {
			catch {unset $node(docArray)var$i}
			catch {unset $node(docArray)arr$i}
			catch {unset $node(docArray)search$i}
		    }
             
		    ##
		    ## Then release the main document array
		    ##
		    if {[catch {unset $node(docArray)}]} {
			return -code error "unable to destroy document"
		    }

		}

		element {
		    # First make sure the node is removed from the tree
		    if {[string length $node(node:parentNode)]} {
			node removeChild $node(node:parentNode) [lindex $args 0]
		    }
		    unset $node(node:childNodes)
		    unset $node(element:attributeList)
		    unset [lindex $args 0]

		    # Don't dispatch events here -
		    # already done by removeChild
		}

		event {
		    unset [lindex $args 0]
		}

		default {
		    # First make sure the node is removed from the tree
		    if {[string length $node(node:parentNode)]} {
			node removeChild $node(node:parentNode) [lindex $args 0]
		    }
		    unset [lindex $args 0]

		    # Dispatch events
		    event postMutationEvent $node(node:parentNode) DOMSubtreeModified

		}

	    }

	    return {}

	}

	isNode {
	    # isNode - non-standard method
	    # Sometimes it is useful to check if an arbitrary string
	    # refers to a DOM node

	    if {![info exists [lindex $args 0]]} {
		return 0
	    } elseif {[catch {array set node [set [lindex $args 0]]}]} {
		return 0
	    } elseif {[info exists node(node:nodeType)]} {
		return 1
	    } else {
		return 0
	    }
	}

	parse {

	    # This implementation uses TclXML version 2.0.
	    # TclXML can choose the best installed parser.

	    if {[llength $args] < 1} {
		return -code error "wrong number of arguments"
	    }

	    array set opts {-parser {} -progresscommand {} -chunksize 8196}
	    if {[catch {array set opts [lrange $args 1 end]}]} {
		return -code error "bad configuration options"
	    }

	    # Create a state array for this parse session
	    set state [namespace current]::parse[incr DOMImplementationCounter]
	    array set $state [array get opts -*]
	    array set $state [list progCounter 0]
	    set errorCleanup {}

	    if {[string length $opts(-parser)]} {
		set parserOpt [list -parser $opts(-parser)]
	    } else {
		set parserOpt {}
	    }
	    if {[catch {package require xml} version]} {
		eval $errorCleanup
		return -code error "unable to load XML parsing package"
	    }
	    set parser [eval xml::parser $parserOpt]

	    $parser configure 		-elementstartcommand [namespace code [list ParseElementStart $state]]			-elementendcommand [namespace code [list ParseElementEnd $state]]			-characterdatacommand [namespace code [list ParseCharacterData $state]] 		-processinginstructioncommand [namespace code [list ParseProcessingInstruction $state]] 		-commentcommand [namespace code [list ParseComment $state]] 		-entityreferencecommand [namespace code [list ParseEntityReference $state]] 		-xmldeclcommand [namespace code [list ParseXMLDeclaration $state]] 		-doctypecommand [namespace code [list ParseDocType $state]] 		-final 1

	    # Create top-level document
	    array set $state [list docNode [DOMImplementation create]]
	    array set $state [list current [lindex [array get $state docNode] 1]]

	    # Parse data
	    # Bug in TclExpat - doesn't handle non-final inputs
	    if {0 && [string length $opts(-progresscommand)]} {
		$parser configure -final false
		while {[string length [lindex $args 0]]} {
		    $parser parse [string range [lindex $args 0] 0 $opts(-chunksize)]
		    set args [lreplace $args 0 0 			[string range [lindex $args 0] $opts(-chunksize) end]]
		    uplevel #0 $opts(-progresscommand)
		}
		$parser configure -final true
	    } elseif {[catch {$parser parse [lindex $args 0]} err]} {
		catch {rename $parser {}}
		catch {unset $state}
		puts stderr $::errorInfo
		return -code error $err
	    }

	    # Free data structures which are no longer required
	    $parser free
	    catch {rename $parser {}}

	    set doc [lindex [array get $state docNode] 1]
	    unset $state
	    return $doc

	}

	query {
	    # Either: query token string
	    # or: query token ?-tagname string? ?-attrname string? ?-attrvalue string? ?-text string? ?-comment string? ?-pitarget string? ?-pidata string?

	    switch [llength $args] {
		0 -
		1 {
		    return -code error "wrong number of arguments"
		}

		2 {
		    # The query applies to the entire document
		    return [Query [lindex $args 0] -tagname [lindex $args 1] 			-attrname [lindex $args 1] -attrvalue [lindex $args 1] 			-text [lindex $args 1] -comment [lindex $args 1] 			-pitarget [lindex $args 1] -pidata [lindex $args 1]]
		}

		default {
		    # Configuration options have been specified to constrain the search
		    if {[llength [lrange $args 1 end]] % 2} {
			return -code error "no value given for option \"[lindex $args end]\""
		    }
		    set startnode [lindex $args 0]
		    foreach {opt value} [lrange $args 1 end] {
			switch -- $opt {
			    -tagname - -attrname - -attrvalue - -text - 
			    -comment - -pitarget - -pidata {}
			    default {
				return -code error "unknown query option \"$opt\""
			    }
			}
		    }

		    return [eval Query [list $startnode] [lrange $args 1 end]]

		}

	    }

	}

	selectNode {
	    # Non-standard method
	    # Returns nodeset in the given document matching an XPath expression

	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    package require xpath

	    return [XPath:SelectNode [lindex $args 0] [lindex $args 1]]
	}

	serialize {

	    if {[llength $args] < 1} {
		return -code error "wrong number of arguments"
	    }

	    array set node [set [lindex $args 0]]
	    return [eval [list Serialize:$node(node:nodeType)] $args]

	}

	trim {

	    # Removes textNodes that only contain white space

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    Trim [lindex $args 0]

	    # Dispatch DOMSubtreeModified event once here?

	    return {}

	}

	default {
	    return -code error "unknown method \"$method\""
	}

    }

    return {}
}

namespace eval dom::tcl {
    foreach method {hasFeature createDocument create createDocumentType createNode destroy isNode parse selectNode serialize trim} {
	proc $method args "eval [namespace current]::DOMImplementation $method \$args"
    }
}

# dom::tcl::document --
#
#	Functions for a document node.
#
# Arguments:
#	method	method to invoke
#	token	token for node
#	args	arguments for method
#
# Results:
#	Depends on method used.

namespace eval dom::tcl {
    variable documentOptionsRO doctype|implementation|documentElement
    variable documentOptionsRW actualEncoding|encoding|standalone|version
}

proc dom::tcl::document {method token args} {
    variable documentOptionsRO
    variable documentOptionsRW

    array set node [set $token]

    set result {}

    switch -- $method {
	cget {
	    if {[llength $args] != 1} {
		return -code error "too many arguments"
	    }
	    if {[regexp [format {^-(%s)$} $documentOptionsRO] [lindex $args 0] discard option]} {
		return $node(document:$option)
	    } elseif {[regexp [format {^-(%s)$} $documentOptionsRW] [lindex $args 0] discard option]} {
		switch -- $option {
		    encoding -
		    version -
		    standalone {
			array set xmldecl $node(document:xmldecl)
			return $xmldecl($option)
		    }
		    default {
			return $node(document:$option)
		    }
		}
	    } else {
		return -code error "unknown option \"[lindex $args 0]\""
	    }
	}
	configure {
	    if {[llength $args] == 1} {
		return [document cget $token [lindex $args 0]]
	    } elseif {[expr [llength $args] % 2]} {
		return -code error "no value specified for option \"[lindex $args end]\""
	    } else {
		foreach {option value} $args {
		    if {[regexp [format {^-(%s)$} $documentOptionsRW] $option discard opt]} {
			switch -- $opt {
			    encoding {
				catch {unset xmldecl}
				array set xmldecl $node(document:xmldecl)
				set xmldecl(encoding) $value
				set node(document:xmldecl) [array get xmldecl]
			    }
			    standalone {
				if {[string is boolean]} {
				    catch {unset xmldecl}
				    array set xmldecl $node(document:xmldecl)
				    if {[string is true $value]} {
					set xmldecl(standalone) yes
				    } else {
					set xmldecl(standalone) no
				    }
				    set node(document:xmldecl) [array get xmldecl]
				} else {
				    return -code error "unsupported value for option \"$option\" - must be boolean"
				}
			    }
			    version {
				if {$value == "1.0"} {
				    catch {unset xmldecl}
				    array set xmldecl $node(document:xmldecl)
				    set xmldecl(version) $value
				    set node(document:xmldecl) [array get xmldecl]
				} else {
				    return -code error "unsupported value for option \"$option\""
				}
			    }
			    default {
				set node(document:$opt) $value
			    }
			}
		    } elseif {[regexp [format {^-(%s)$} $documentOptionsRO] $option discard opt]} {
			return -code error "attribute \"$option\" is read-only"
		    } else {
			return -code error "unknown option \"$option\""
		    }
		}
	    }

	    set $token [array get node]

	}

	createElement {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    # Check that the element name is kosher
	    if {![regexp ^$::xml::Name\$ [lindex $args 0]]} {
		return -code error "invalid element name \"[lindex $args 0]\""
	    }

	    # Invoke internal factory function
	    set result [CreateElement $token [lindex $args 0] {}]

	}
	createDocumentFragment {
	    if {[llength $args]} {
		return -code error "wrong number of arguments"
	    }

	    set result [CreateGeneric $token node:nodeType documentFragment node:nodeName #document-fragment node:nodeValue {}]
	}
	createTextNode {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    set result [CreateTextNode $token [lindex $args 0]]
	}
	createComment {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    set result [CreateGeneric $token node:nodeType comment node:nodeName #comment node:nodeValue [lindex $args 0]]
	}
	createCDATASection {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    set result [CreateTextNode $token [lindex $args 0]]
	    node configure $result -cdatasection 1
	}
	createProcessingInstruction {
	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    set result [CreateGeneric $token node:nodeType processingInstruction 		    node:nodeName [lindex $args 0] node:nodeValue [lindex $args 1]]
	}
	createAttribute {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    # Check that the attribute name is kosher
	    if {![regexp ^$::xml::Name\$ [lindex $args 0]]} {
		return -code error "invalid attribute name \"[lindex $args 0]\""
	    }

	    set result [CreateGeneric $token node:nodeType attribute node:nodeName [lindex $args 0]]
	}
	createEntity {
	    set result [CreateGeneric $token node:nodeType entity]
	}
	createEntityReference {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }
	    set result [CreateGeneric $token node:nodeType entityReference node:nodeName [lindex $args 0]]
	}

	createDocTypeDecl {
	    # This is not a standard DOM 1.0 method
	    # Deprecated - see DOMImplementation createDocumentType

	    if {[llength $args] < 1 || [llength $args] > 5} {
		return -code error "wrong number of arguments"
	    }

	    foreach {name extid dtd entities notations} $args break
	    set result [CreateDocType $token $name $extid]
	    document configure $token -doctype $result
	    documenttype configure $result -internalsubset $dtd
	    documenttype configure $result -entities $entities
	    documenttype configure $result -notations $notations
	}

	importNode {
	    # Introduced in DOM Level 2

	    return -code error "not yet implemented"
	}

	createElementNS {
	    # Introduced in DOM Level 2

	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments, should be: createElementNS nsuri qualname"
	    }

	    # Check that the qualified name is kosher
	    if {[catch {foreach {prefix localname} [::xml::qnamesplit [lindex $args 1]]  break} err]} {
		return -code error "invalid qualified name \"[lindex $args 1]\" due to \"$err\""
	    }

	    # Invoke internal factory function
	    set result [CreateElement $token [lindex $args 1] {} -prefix $prefix -namespace [lindex $args 0] -localname $localname]
	}

	createAttributeNS {
	    # Introduced in DOM Level 2

	    return -code error "not yet implemented"
	}

	getElementsByTagNameNS {
	    # Introduced in DOM Level 2

	    return -code error "not yet implemented"
	}

	getElementsById {
	    # Introduced in DOM Level 2

	    return -code error "not yet implemented"
	}

	createEvent {
	    # Introduced in DOM Level 2

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    set result [CreateEvent $token [lindex $args 0]]

	}

	getElementsByTagName {
	    if {[llength $args] < 1} {
		return -code error "wrong number of arguments"
	    }

	    return [eval Element:GetByTagName [list $token [lindex $args 0]] 		    [lrange $args 1 end]]
	}

	default {
	    return -code error "unknown method \"$method\""
	}

    }

    # Dispatch events

    # Node insertion events are generated here instead of the
    # internal factory procedures.  This is because the factory
    # procedures are meant to be mean-and-lean during the parsing
    # phase, and dispatching events at that time would be an
    # excessive overhead.  The factory methods here are pretty
    # heavyweight anyway.

    if {[string match create* $method] && [string compare $method "createEvent"]} {

	event postMutationEvent $result DOMNodeInserted -relatedNode $token
	event postMutationEvent $result DOMNodeInsertedIntoDocument
	event postMutationEvent $token DOMSubtreeModified

    }

    return $result
}

###	Factory methods
###
### These are lean-and-mean for fastest possible tree building

# dom::tcl::CreateElement --
#
#	Append an element to the given (parent) node (if any)
#
# Arguments:
#	token	parent node
#	name	element name (no checking performed here)
#	aList	attribute list
#	args	configuration options
#
# Results:
#	New node created, parent optionally modified

proc dom::tcl::CreateElement {token name aList args} {
    array set opts $args

    if {[string length $token]} {
	array set parent [set $token]
	upvar #0 $parent(docArray) docArray
	set docArrayName $parent(docArray)
    } else {
	upvar #0 $opts(-docarray) docArray
	set docArrayName $opts(-docarray)
    }

    set id node[incr docArray(counter)]
    set child ${docArrayName}($id)

    # Create the new node
    # NB. normally we'd use Node:create here,
    # but inline it instead for performance
    set docArray($id) [list id $id docArray $docArrayName 	    node:parentNode $token			    node:childNodes ${docArrayName}var$docArray(counter)		    node:nodeType element			    node:nodeName $name				    node:namespaceURI {}			    node:prefix {}				    node:localName $name			    node:nodeValue {}				    element:attributeList ${docArrayName}arr$docArray(counter) 	    element:attributeNodes {}		    ]

    catch {lappend docArray($id) node:namespaceURI $opts(-namespace)}
    catch {lappend docArray($id) node:localName $opts(-localname)}
    catch {lappend docArray($id) node:prefix $opts(-prefix)}

    # Initialise associated variables
    set ${docArrayName}var$docArray(counter) {}
    array set ${docArrayName}arr$docArray(counter) $aList
    catch {
	foreach {ns nsAttrList} $opts(-namespaceattributelists) {
	    foreach {attrName attrValue} $nsAttrList {
		array set ${docArrayName}arr$docArray(counter) [list $ns^$attrName $attrValue]
	    }
	}
    }

    # Update parent record

    # Does this element qualify as the document element?
    # If so, then has a document element already been set?

    if {[string length $token]} {

	if {![string compare $parent(node:nodeType) documentFragment]} {
	    if {$parent(id) == $parent(documentFragment:masterDoc)} {
		if {[info exists parent(document:documentElement)] && 		    [string length $parent(document:documentElement)]} {
		    unset docArray($id)
		    return -code error "document element already exists"
		} else {

		    # Check against document type decl
		    if {[string length $parent(document:doctype)]} {
			array set doctypedecl [set $parent(document:doctype)]
			if {[string compare $name $doctypedecl(doctype:name)]} {
			    return -code error "mismatch between root element type in document type declaration \"$doctypedecl(doctype:name)\" and root element \"$name\""
			}

		    } else {
			# Synthesize document type declaration
			CreateDocType $token $name {} {}
			# Resynchronise parent record
			array set parent [set $token]
		    }

		    set parent(document:documentElement) $child
		    set $token [array get parent]
		}
	    }
	}

	lappend $parent(node:childNodes) $child

    }

    return $child
}

# dom::tcl::CreateTextNode --
#
#	Append a textNode node to the given (parent) node (if any).
#
#	This factory function can also be performed by
#	CreateGeneric, but text nodes are created so often
#	that this specific factory procedure speeds things up.
#
# Arguments:
#	token	parent node
#	text	initial text
#	args	additional configuration options
#
# Results:
#	New node created, parent optionally modified

proc dom::tcl::CreateTextNode {token text args} {
    if {[string length $token]} {
	array set parent [set $token]
	upvar #0 $parent(docArray) docArray
	set docArrayName $parent(docArray)
    } else {
	array set opts $args
	upvar #0 $opts(-docarray) docArray
	set docArrayName $opts(-docarray)
    }

    set id node[incr docArray(counter)]
    set child ${docArrayName}($id)

    # Create the new node
    # NB. normally we'd use Node:create here,
    # but inline it instead for performance

    # Text nodes never have children, so don't create a variable

    set docArray($id) [list id $id docArray $docArrayName 	    node:parentNode $token			    node:childNodes {}				    node:nodeType textNode			    node:nodeValue $text			    node:nodeName #text				    node:cdatasection 0			    ]

    if {[string length $token]} {
	# Update parent record
	lappend $parent(node:childNodes) $child
	set $token [array get parent]
    }

    return $child
}

# dom::tcl::CreateGeneric --
#
#	This is a template used for type-specific factory procedures
#
# Arguments:
#	token	parent node
#	args	optional values
#
# Results:
#	New node created, parent modified

proc dom::tcl::CreateGeneric {token args} {
    if {[string length $token]} {
	array set parent [set $token]
	upvar #0 $parent(docArray) docArray
	set docArrayName $parent(docArray)
    } else {
	array set opts $args
	upvar #0 $opts(-docarray) docArray
	set docArrayName $opts(-docarray)
	array set tmp [array get opts]
	foreach opt [array names tmp -*] {
	    unset tmp($opt)
	}
	set args [array get tmp]
    }

    set id node[incr docArray(counter)]
    set child ${docArrayName}($id)

    # Create the new node
    # NB. normally we'd use Node:create here,
    # but inline it instead for performance
    set docArray($id) [eval list [list id $id docArray $docArrayName		    node:parentNode $token						    node:childNodes ${docArrayName}var$docArray(counter)]		    $args
    ]
    set ${docArrayName}var$docArray(counter) {}

    catch {unset opts}
    array set opts $args
    switch -glob -- [string length $token],$opts(node:nodeType) {
	0,* -
	*,attribute -
	*,namespace {
	    # These type of nodes are not children of their parent
	}

	default {
	    # Update parent record
	    lappend $parent(node:childNodes) $child
	    set $token [array get parent]
	}
    }

    return $child
}

### Specials

# dom::tcl::CreateDocType --
#
#	Create a Document Type Declaration node.
#
# Arguments:
#	token	node id for the document node
#	name	root element type
#	extid	external entity id
#	dtd	internal DTD subset
#
# Results:
#	Returns node id of the newly created node.

proc dom::tcl::CreateDocType {token name {extid {}} {dtd {}} {entities {}} {notations {}}} {
    array set doc [set $token]
    upvar #0 $doc(docArray) docArray

    set id node[incr docArray(counter)]
    set child $doc(docArray)($id)

    if {[llength $dtd] == 1 && [string length [lindex $dtd 0]] == 0} {
	set dtd {}
    }

    set docArray($id) [list 	    id $id docArray $doc(docArray) 	    node:parentNode $token 	    node:childNodes {} 	    node:nodeType docType 	    node:nodeName {} 	    node:nodeValue {} 	    doctype:name $name 	    doctype:entities {} 	    doctype:notations {} 	    doctype:externalid $extid 	    doctype:internaldtd $dtd     ]
    # NB. externalid and internaldtd are not standard DOM 1.0 attributes

    # Update parent

    set doc(document:doctype) $child

    # BUG: The doc type is NOT a child of the document node.
    # This behaviour has been removed.
    ##Add this node to the parent's child list
    ## This must come before the document element,
    ## so this implementation may be buggy
    #lappend $doc(node:childNodes) $child

    set $token [array get doc]

    return $child
}

# dom::tcl::node --
#
#	Functions for a general node.
#
#	Implements EventTarget Interface - introduced in DOM Level 2
#
# Arguments:
#	method	method to invoke
#	token	token for node
#	args	arguments for method
#
# Results:
#	Depends on method used.

namespace eval dom::tcl {
    variable nodeOptionsRO nodeType|parentNode|childNodes|firstChild|lastChild|previousSibling|nextSibling|attributes|namespaceURI|prefix|localName|ownerDocument
    variable nodeOptionsRW nodeValue|cdatasection

    # Allowing nodeName to be rw is not standard DOM.
    # A validating implementation would have to be very careful
    # in allowing this feature
    if {$::dom::strictDOM} {
	append nodeOptionsRO |nodeName
    } else {
	append nodeOptionsRW |nodeName
    }
}
# NB. cdatasection is not a standard DOM option

proc dom::tcl::node {method token args} {
    variable nodeOptionsRO
    variable nodeOptionsRW

    if {[catch {array set node [set $token]}]} {
	return -code error "token not found"
    }

    set result {}

    switch -glob -- $method {
	cg* {
	    # cget

	    # Some read-only configuration options are computed
	    if {[llength $args] != 1} {
		return -code error "too many arguments"
	    }
	    if {[regexp [format {^-(%s)$} $nodeOptionsRO] [lindex $args 0] discard option]} {
		switch $option {
		    nodeName {
			set result $node(node:nodeName)
			switch $node(node:nodeType) {
			    textNode {
				catch {set result [expr {$node(node:cdatasection) ? "#cdata-section" : $node(node:nodeName)}]}
			    }
			    default {
			    }
			}
		    }
		    childNodes {
			# How are we going to handle documentElement?
			set result $node(node:childNodes)
		    }
		    firstChild {
			upvar #0 $node(node:childNodes) children
			switch $node(node:nodeType) {
			    documentFragment {
				set result [lindex $children 0]
				catch {set result $node(document:documentElement)}
			    }
			    default {
				set result [lindex $children 0]
			    }
			}
		    }
		    lastChild {
			upvar #0 $node(node:childNodes) children
			switch $node(node:nodeType) {
			    documentFragment {
				set result [lindex $children end]
				catch {set result $node(document:documentElement)}
			    }
			    default {
				set result [lindex $children end]
			    }
			}
		    }
		    previousSibling {
			# BUG: must take documentElement into account
			# Find the parent node
			array set parent [set $node(node:parentNode)]
			upvar #0 $parent(node:childNodes) children
			set idx [lsearch $children $token]
			if {$idx >= 0} {
			    set sib [lindex $children [incr idx -1]]
			    if {[llength $sib]} {
				set result $sib
			    } else {
				set result {}
			    }
			} else {
			    set result {}
			}
		    }
		    nextSibling {
			# BUG: must take documentElement into account
			# Find the parent node
			array set parent [set $node(node:parentNode)]
			upvar #0 $parent(node:childNodes) children
			set idx [lsearch $children $token]
			if {$idx >= 0} {
			    set sib [lindex $children [incr idx]]
			    if {[llength $sib]} {
				set result $sib
			    } else {
				set result {}
			    }
			} else {
			    set result {}
			}
		    }
		    attributes {
			if {[string compare $node(node:nodeType) element]} {
			    set result {}
			} else {
			    set result $node(element:attributeList)
			}
		    }
		    ownerDocument {
			if {[string compare $node(node:parentNode) {}]} {
			    return $node(docArray)(node1)
			} else {
			    return $token
			}
		    }
		    default {
			return [GetField node(node:$option)]
		    }
		}
	    } elseif {[regexp [format {^-(%s)$} $nodeOptionsRW] [lindex $args 0] discard option]} {
		return [GetField node(node:$option)]
	    } else {
		return -code error "unknown option \"[lindex $args 0]\""
	    }
	}
	co* {
	    # configure

	    if {[llength $args] == 1} {
		return [node cget $token [lindex $args 0]]
	    } elseif {[expr [llength $args] % 2]} {
		return -code error "wrong \# args: should be \"::dom::node configure node option\""
	    } else {
		foreach {option value} $args {
		    if {[regexp [format {^-(%s)$} $nodeOptionsRW] $option discard opt]} {

			switch $opt,$node(node:nodeType) {
			    nodeValue,textNode -
			    nodeValue,processingInstruction {
				# Dispatch event
				set evid [CreateEvent $token DOMCharacterDataModified]
				event initMutationEvent $evid DOMCharacterDataModified 1 0 {} $node(node:nodeValue) $value {}
				set node(node:nodeValue) $value
				node dispatchEvent $token $evid
				DOMImplementation destroy $evid
			    }
			    default {
				set node(node:$opt) $value
			    }
			}

		    } elseif {[regexp [format {^-(%s)$} $nodeOptionsRO] $option discard opt]} {
			return -code error "attribute \"$option\" is read-only"
		    } else {
			return -code error "unknown option \"$option\""
		    }
		}
	    }
	}

	in* {

	    # insertBefore

	    # Previous and next sibling relationships are OK, 
	    # because they are dynamically determined

	    if {[llength $args] < 1 || [llength $args] > 2} {
		return -code error "wrong number of arguments"
	    }

	    array set newChild [set [lindex $args 0]]
	    if {[string compare $newChild(docArray) $node(docArray)]} {
		return -code error "new node must be in the same document"
	    }

	    switch [llength $args] {
		1 {
		    # Append as the last node
		    if {[string length $newChild(node:parentNode)]} {
			node removeChild $newChild(node:parentNode) [lindex $args 0]
		    }
		    lappend $node(node:childNodes) [lindex $args 0]
		    set newChild(node:parentNode) $token
		}
		2 {

		    array set refChild [set [lindex $args 1]]
		    if {[string compare $refChild(docArray) $newChild(docArray)]} {
			return -code error "nodes must be in the same document"
		    }
		    set idx [lsearch [set $node(node:childNodes)] [lindex $args 1]]
		    if {$idx < 0} {
			return -code error "no such reference child"
		    } else {

			# Remove from previous parent
			if {[string length $newChild(node:parentNode)]} {
			    node removeChild $newChild(node:parentNode) [lindex $args 0]
			}

			# Insert into new node
			set $node(node:childNodes) 				[linsert [set $node(node:childNodes)] $idx [lindex $args 0]]
			set newChild(node:parentNode) $token
		    }
		}
	    }
	    set [lindex $args 0] [array get newChild]

	    event postMutationEvent [lindex $args 0] DOMNodeInserted -relatedNode $token
	    FireNodeInsertedEvents [lindex $args 0]
	    event postMutationEvent $token DOMSubtreeModified

	}

	rep* {

	    # replaceChild

	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    array set newChild [set [lindex $args 0]]
	    array set oldChild [set [lindex $args 1]]

	    # Find where to insert new child
	    set idx [lsearch [set $node(node:childNodes)] [lindex $args 1]]
	    if {$idx < 0} {
		return -code error "no such old child"
	    }

	    # Remove new child from current parent
	    if {[string length $newChild(node:parentNode)]} {
		node removeChild $newChild(node:parentNode) [lindex $args 0]
	    }

	    set $node(node:childNodes) 		[lreplace [set $node(node:childNodes)] $idx $idx [lindex $args 0]]
	    set newChild(node:parentNode) $token

	    # Update old child to reflect lack of parentage
	    set oldChild(node:parentNode) {}

	    set [lindex $args 1] [array get oldChild]
	    set [lindex $args 0] [array get newChild]

	    set result [lindex $args 0]

	    event postMutationEvent [lindex $args 0] DOMNodeInserted -relatedNode $token
	    FireNodeInsertedEvents [lindex $args 0]
	    event postMutationEvent $token DOMSubtreeModified

	}

	rem* {

	    # removeChild

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }
	    array set oldChild [set [lindex $args 0]]
	    if {$oldChild(docArray) != $node(docArray)} {
		return -code error "node \"[lindex $args 0]\" is not a child"
	    }

	    # Remove the child from the parent
	    upvar #0 $node(node:childNodes) myChildren
	    if {[set idx [lsearch $myChildren [lindex $args 0]]] < 0} {
		return -code error "node \"[lindex $args 0]\" is not a child"
	    }
	    set myChildren [lreplace $myChildren $idx $idx]

	    # Update the child to reflect lack of parentage
	    set oldChild(node:parentNode) {}
	    set [lindex $args 0] [array get oldChild]

	    set result [lindex $args 0]

	    # Event propagation has a problem here:
	    # Nodes that until recently were ancestors may
	    # want to capture the event, but we've just removed
	    # the parentage information.  They get a DOMSubtreeModified
	    # instead.
	    event postMutationEvent [lindex $args 0] DOMNodeRemoved -relatedNode $token
	    FireNodeRemovedEvents [lindex $args 0]
	    event postMutationEvent $token DOMSubtreeModified

	}

	ap* {

	    # appendChild

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    # Add to new parent
	    node insertBefore $token [lindex $args 0]

	}

	hasChildNodes {
	    set result [Min 1 [llength [set $node(node:childNodes)]]]
	}

	isSameNode {
	    # Introduced in DOM Level 3
	    switch [llength $args] {
		1 {
		    return [expr {$token == [lindex $args 0]}]
		}
		default {
		    return -code error "wrong # arguments: should be dom::node isSameNode token ref"
		}
	    }
	}

	cl* {
	    # cloneNode

	    # May need to pay closer attention to generation of events here

	    set deep 0
	    switch [llength $args] {
		0 {
		}
		1 {
		    set deep [Boolean [lindex $args 0]]
		}
		default {
		    return -code error "too many arguments"
		}
	    }

	    switch $node(node:nodeType) {
		element {
		    set result [CreateElement {} $node(node:nodeName) [array get $node(element:attributeList)] -docarray $node(docArray)]
		    if {$deep} {
			foreach child [set $node(node:childNodes)] {
			    node appendChild $result [node cloneNode $child]
			}
		    }
		}
		textNode {
		    set result [CreateTextNode {} $node(node:nodeValue) -docarray $node(docArray)]
		}
		document -
		documentFragment -
		default {
		    set result [CreateGeneric {} node:nodeType $node(node:nodeType) -docarray $node(docArray)]
		    if {$deep} {
			foreach child [set $node(node:childNodes)] {
			    node appendChild $result [node cloneNode $child]
			}
		    }
		}
	    }

	}

	ch* {
	    # children -- non-standard method

	    # If this is a textNode, then catch the error
	    set result {}
	    catch {set result [set $node(node:childNodes)]}

	}

	par* {
	    # parent -- non-standard method

	    return $node(node:parentNode)

	}

	pat* {
	    # path -- non-standard method

	    for {
		set ancestor $token
		set result {}
		catch {unset ancNode}
		array set ancNode [set $ancestor]
	    } {[string length $ancNode(node:parentNode)]} {
		set ancestor $ancNode(node:parentNode)
		catch {unset ancNode}
		array set ancNode [set $ancestor]
	    } {
		set result [linsert $result 0 $ancestor]
	    }
	    # The last node is the document node
	    set result [linsert $result 0 $ancestor]

	}

	createNode {
	    # createNode -- non-standard method

	    # Creates node(s) in this document given an XPath expression.
	    # Relative location paths have this node as their initial context.

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    package require xpath

	    return [XPath:CreateNode $token [lindex $args 0]]
	}

	selectNode {
	    # selectNode -- non-standard method

	    # Returns nodeset in this document matching an XPath expression.
	    # Relative location paths have this node as their initial context.

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    package require xpath

	    return [XPath:SelectNode $token [lindex $args 0]]
	}

	stringValue {
	    # stringValue -- non-standard method
	    # Returns string value of a node, as defined by XPath Rec.

	    switch $node(node:nodeType) {
		document -
		documentFragment -
		element {
		    set value {}
		    foreach child [set $node(node:childNodes)] {
			switch [node cget $child -nodeType] {
			    element -
			    textNode {
				append value [node stringValue $child]
			    }
			    default {
				# Other nodes are not considered
			    }
			}
		    }
		    return $value
		}
		attribute -
		textNode -
		processingInstruction -
		comment {
		    return $node(node:nodeValue)
		}
		default {
		    return {}
		}
	    }

	}

	addEv* {
	    # addEventListener -- introduced in DOM Level 2

	    if {[llength $args] < 2} {
		return -code error "wrong number of arguments"
	    }

	    set type [string tolower [lindex $args 0]]
	    set listener [lindex $args 1]
	    array set opts {-usecapture 0}
	    array set opts [lrange $args 2 end]
	    set opts(-usecapture) [Boolean $opts(-usecapture)]
	    set listenerType [expr {$opts(-usecapture) ? "capturer" : "listener"}]

	    if {![info exists node(event:$type:$listenerType)] || 		 [lsearch $node(event:$type:$listenerType) $listener] < 0} {
		lappend node(event:$type:$listenerType) $listener
	    }
	    # else avoid registering same listener twice

	}

	removeEv* {
	    # removeEventListener -- introduced in DOM Level 2

	    if {[llength $args] < 2} {
		return -code error "wrong number of arguments"
	    }

	    set type [string tolower [lindex $args 0]]
	    set listener [lindex $args 1]
	    array set opts {-usecapture 0}
	    array set opts [lrange $args 2 end]
	    set opts(-usecapture) [Boolean $opts(-usecapture)]
	    set listenerType [expr {$opts(-usecapture) ? "capturer" : "listener"}]

	    set idx [lsearch $node(event:$type:$listenerType) $listener]
	    if {$idx >= 0} {
		set node(event:$type:$listenerType) [lreplace $node(event:$type:$listenerType) $idx $idx]
	    }

	}

	disp* {
	    # dispatchEvent -- introduced in DOM Level 2

	    # This is where the fun happens!
	    # Check to see if there one or more event listener,
	    # if so trigger the listener(s).
	    # Then pass the event up to the ancestor.
	    # This may be modified by event capturing and bubbling.

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    set eventId [lindex $args 0]
	    array set event [set $eventId]
	    set type $event(type)

	    if {![string length $event(eventPhase)]} {

		# This is the initial dispatch of the event.
		# First trigger any capturing event listeners
		# Starting from the root, proceed downward

		set event(eventPhase) capturing_phase
		set event(target) $token
		set $eventId [array get event]

		# DOM L2 specifies that the ancestors are determined
		# at the moment of event dispatch, so using a static
		# list is the correct thing to do

		foreach ancestor [lreplace [node path $token] end end] {
		    array get event [set $eventId]
		    set event(currentNode) $ancestor
		    set $eventId [array get event]

		    catch {unset ancNode}
		    array set ancNode [set $ancestor]

		    if {[info exists ancNode(event:$type:capturer)]} {
			foreach capturer $ancNode(event:$type:capturer) {
			    if {[catch {uplevel #0 $capturer [list $eventId]} capturerError]} {
				bgerror "error in capturer \"$capturerError\""
			    }
			}

			# A listener may stop propagation,
			# but we check here to let all of the
			# listeners at that level complete

			array set event [set $eventId]
			if {$event(cancelable) && $event(stopPropagation)} {
			    break
			}
		    }
		}

		# Prepare for next phase
		set event(eventPhase) at_target

	    }

	    set event(currentNode) $token
	    set $eventId [array get event]

	    if {[info exists node(event:$type:listener)]} {
		foreach listener $node(event:$type:listener) {
		    if {[catch {uplevel #0 $listener [list $eventId]} listenerError]} {
			bgerror "error in listener \"$listenerError\""
		    }
		}
	    }

	    array set event [set $eventId]
	    set event(eventPhase) bubbling_phase
	    set $eventId [array get event]

	    # Now propagate the event
	    if {$event(cancelable) && $event(stopPropagation)} {
		# Event has been cancelled
	    } elseif {[llength $node(node:parentNode)]} {
		# Go ahead and propagate
		node dispatchEvent $node(node:parentNode) $eventId
	    }

	    set event(dispatched) 1
	    set $eventId [array get event]

	}

	default {
	    return -code error "unknown method \"$method\""
	}

    }

    set $token [array get node]

    return $result
}

# dom::tcl::Node:create --
#
#	Generic node creation.
#	See also CreateElement, CreateTextNode, CreateGeneric.
#
# Arguments:
#	pVar	array in caller which contains parent details
#	args	configuration options
#
# Results:
#	New child node created.

proc dom::tcl::Node:create {pVar args} {
    upvar $pVar parent

    array set opts {-name {} -value {}}
    array set opts $args

    upvar #0 $parent(docArray) docArray

    # Create new node
    if {![info exists opts(-id)]} {
	set opts(-id) node[incr docArray(counter)]
    }
    set docArray($opts(-id)) [list id $opts(-id) 	    docArray $parent(docArray)			    node:parentNode $opts(-parent)		    node:childNodes $parent(docArray)var$docArray(counter)		    node:nodeType $opts(-type)			    node:nodeName $opts(-name)			    node:nodeValue $opts(-value)		    element:attributeList $parent(docArray)arr$docArray(counter)     ]
    set $parent(docArray)var$docArray(counter) {}
    array set $parent(docArray)arr$docArray(counter) {}

    # Update parent node
    if {![info exists parent(document:documentElement)]} {
	lappend parent(node:childNodes) [list [lindex $opts(-parent) 0] $opts(-id)]
    }

    return $parent(docArray)($opts(-id))

}

# dom::tcl::Node:set --
#
#	Generic node update
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	Node modified.

proc dom::tcl::Node:set {token args} {
    upvar $token node

    foreach {key value} $args {
	set node($key) $value
    }

    set $token [array get node]

    return {}
}

# dom::tcl::FireNodeInsertedEvents --
#
#	Recursively descend the tree triggering DOMNodeInserted
#	events as we go.
#
# Arguments:
#	nodeid	Node ID
#
# Results:
#	DOM L2 DOMNodeInserted events posted

proc dom::tcl::FireNodeInsertedEvents nodeid {
    event postMutationEvent $nodeid DOMNodeInsertedIntoDocument
    foreach child [node children $nodeid] {
	FireNodeInsertedEvents $child
    }

    return {}
}

# dom::tcl::FireNodeRemovedEvents --
#
#	Recursively descend the tree triggering DOMNodeRemoved
#	events as we go.
#
# Arguments:
#	nodeid	Node ID
#
# Results:
#	DOM L2 DOMNodeRemoved events posted

proc dom::tcl::FireNodeRemovedEvents nodeid {
    event postMutationEvent $nodeid DOMNodeRemovedFromDocument
    foreach child [node children $nodeid] {
	FireNodeRemovedEvents $child
    }

    return {}
}

# dom::tcl::element --
#
#	Functions for an element.
#
# Arguments:
#	method	method to invoke
#	token	token for node
#	args	arguments for method
#
# Results:
#	Depends on method used.

namespace eval dom::tcl {
    variable elementOptionsRO tagName|empty
    variable elementOptionsRW {}
}

proc dom::tcl::element {method token args} {
    variable elementOptionsRO
    variable elementOptionsRW

    array set node [set $token]

    if {[string compare $node(node:nodeType) "element"]} {
	return -code error "not an element type node"
    }
    set result {}

    switch -- $method {

	cget {
	    # Some read-only configuration options are computed
	    if {[llength $args] != 1} {
		return -code error "too many arguments"
	    }
	    if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} {
		switch $option {
		    tagName {
			set result [lindex $node(node:nodeName) 0]
		    }
		    empty {
			if {![info exists node(element:empty)]} {
			    return 0
			} else {
			    return $node(element:empty)
			}
		    }
		    default {
			return $node(node:$option)
		    }
		}
	    } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} {
		return $node(node:$option)
	    } else {
		return -code error "unknown option \"[lindex $args 0]\""
	    }
	}
	configure {
	    if {[llength $args] == 1} {
		return [document cget $token [lindex $args 0]]
	    } elseif {[expr [llength $args] % 2]} {
		return -code error "no value specified for option \"[lindex $args end]\""
	    } else {
		foreach {option value} $args {
		    if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} {
			return -code error "attribute \"$option\" is read-only"
		    } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} {
			return -code error "not implemented"
		    } else {
			return -code error "unknown option \"$option\""
		    }
		}
	    }
	}

	getAttribute {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    set result {}

	    upvar #0 $node(element:attributeList) attrList
	    catch {set result $attrList([lindex $args 0])}

	    return $result

	}

	setAttribute {
	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    # Check that the attribute name is kosher
	    if {![regexp ^$::xml::Name\$ [lindex $args 0]]} {
		return -code error "invalid attribute name \"[lindex $args 0]\""
	    }

	    upvar #0 $node(element:attributeList) attrList
	    set evid [CreateEvent $token DOMAttrModified]
	    set oldValue {}
	    catch {set oldValue $attrList([lindex $args 0])}
	    event initMutationEvent $evid DOMAttrModified 1 0 $token $oldValue [lindex $args 1] [lindex $args 0]
	    set result [set attrList([lindex $args 0]) [lindex $args 1]]
	    node dispatchEvent $token $evid
	    DOMImplementation destroy $evid

	}

	removeAttribute {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    upvar #0 $node(element:attributeList) attrList
	    catch {unset attrList([lindex $args 0])}

	    event postMutationEvent $token DOMAttrRemoved -attrName [lindex $args 0]

	}

	getAttributeNS {
	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    set result {}
	    upvar #0 $node(element:attributeList) attrList
	    catch {set result $attrList([lindex $args 0]^[lindex $args 1])}

	    return $result

	}

	setAttributeNS {
	    if {[llength $args] != 3} {
		return -code error "wrong number of arguments"
	    }

	    # Check that the attribute name is kosher
	    if {![regexp ^$::xml::QName\$ [lindex $args 1] discard prefix localName]} {
		return -code error "invalid qualified attribute name \"[lindex $args 1]\""
	    }

	    # BUG: At the moment the prefix is ignored

	    upvar #0 $node(element:attributeList) attrList
	    set evid [CreateEvent $token DOMAttrModified]
	    set oldValue {}
	    catch {set oldValue $attrList([lindex $args 0]^$localName)}
	    event initMutationEvent $evid DOMAttrModified 1 0 $token $oldValue [lindex $args 2] [lindex $args 0]^localName
	    set result [set attrList([lindex $args 0]^$localName) [lindex $args 2]]
	    node dispatchEvent $token $evid
	    DOMImplementation destroy $evid

	}

	removeAttributeNS {
	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    upvar #0 $node(element:attributeList) attrList
	    catch {unset attrList([lindex $args 0]^[lindex $args 1])}

	    event postMutationEvent $token DOMAttrRemoved -attrName [lindex $args 0]^[lindex $args 1]

	}

	getAttributeNode {
	    array set tmp [array get $node(element:attributeList)]
	    if {![info exists tmp([lindex $args 0])]} {
		return {}
	    }

	    # Synthesize an attribute node if one doesn't already exist
	    array set attrNodes $node(element:attributeNodes)
	    if {[catch {set result $attrNodes([lindex $args 0])}]} {
		set result [CreateGeneric $token node:nodeType attribute node:nodeName [lindex $args 0] node:nodeValue $tmp([lindex $args 0])]
		lappend node(element:attributeNodes) [lindex $args 0] $result
	    }
	}

	setAttributeNode -
	removeAttributeNode -
	getAttributeNodeNS -
	setAttributeNodeNS -
	removeAttributeNodeNS {
	    return -code error "not yet implemented"
	}

	getElementsByTagName {
	    if {[llength $args] < 1} {
		return -code error "wrong number of arguments"
	    }

	    return [eval Element:GetByTagName [list $token [lindex $args 0]] 		    [lrange $args 1 end]]
	}

	normalize {
	    if {[llength $args]} {
		return -code error "wrong number of arguments"
	    }

	    Element:Normalize node [set $node(node:childNodes)]
	}

	default {
	    return -code error "unknown method \"$method\""
	}

    }

    set $token [array get node]

    return $result
}

# dom::tcl::Element:GetByTagName --
#
#	Search for (child) elements
#
#	This used to be non-recursive, but then I read the DOM spec
#	properly and discovered that it should recurse.  The -deep
#	option allows for backward-compatibility, and defaults to the
#	DOM-specified value of true.
#
# Arguments:
#	token	parent node
#	name	element type to search for
#	args	configuration options
#
# Results:
#	The name of the variable containing the list of matching node tokens

proc dom::tcl::Element:GetByTagName {token name args} {
    array set node [set $token]
    upvar \#0 $node(docArray) docArray

    array set cfg {-deep 1}
    array set cfg $args
    set cfg(-deep) [Boolean $cfg(-deep)]

    # Guard against arbitrary glob characters
    # Checking that name is a legal XML Name does this
    # However, '*' is permitted
    if {![regexp ^$::xml::Name\$ $name] && [string compare $name "*"]} {
	return -code error "invalid element name"
    }

    # Allocate variable name for this search
    set searchVar $node(docArray)search[incr docArray(counter)]
    upvar \#0 $searchVar search

    # Make list live by interposing on variable reads
    # I don't think we need to interpose on unsets,
    # and writing to this variable by the application is
    # not permitted.

    trace variable $searchVar w [namespace code Element:GetByTagName:Error]

    if {[string compare $node(node:nodeType) "documentFragment"]} {
	trace variable $searchVar r [namespace code [list Element:GetByTagName:Search [set $node(node:childNodes)] $name $cfg(-deep)]]
    } elseif {[llength $node(document:documentElement)]} {
	# Document Element must exist and must be an element type node
	trace variable $searchVar r [namespace code [list Element:GetByTagName:Search $node(document:documentElement) $name $cfg(-deep)]]
    }

    return $searchVar
}

# dom::tcl::Element:GetByTagName:Search --
#
#	Search for elements.  This does the real work.
#	Because this procedure is invoked everytime
#	the variable is read, it returns the live list.
#
# Arguments:
#	tokens	nodes to search (inclusive)
#	name	element type to search for
#	deep	whether to search recursively
#	name1	#	name2	 > appended by trace command
#	op	/
#
# Results:
#	List of matching node tokens

proc dom::tcl::Element:GetByTagName:Search {tokens name deep name1 name2 op} {
    set result {}

    foreach tok $tokens {
	catch {unset nodeInfo}
	array set nodeInfo [set $tok]
	switch -- $nodeInfo(node:nodeType) {
	    element {
		if {[string match $name [GetField nodeInfo(node:nodeName)]]} {
		    lappend result $tok
		}
		if {$deep} {
		    set childResult [Element:GetByTagName:Search [set $nodeInfo(node:childNodes)] $name $deep {} {} {}]
		    if {[llength $childResult]} {
			eval lappend result $childResult
		    }
		}
	    }
	}
    }

    if {[string length $name1]} {
	set $name1 $result
	return {}
    } else {
	return $result
    }
}

# dom::tcl::Element:GetByTagName:Error --
#
#	Complain about the application writing to a variable
#	that this package maintains.
#
# Arguments:
#	name1	#	name2	 > appended by trace command
#	op	/
#
# Results:
#	Error code returned.

proc dom::tcl::Element:GetByTagName:Error {name1 name2 op} {
    return -code error "dom: Read-only variable"
}

# dom::tcl::Element:Normalize --
#
#	Normalize the text nodes
#
# Arguments:
#	pVar	parent array variable in caller
#	nodes	list of node tokens
#
# Results:
#	Adjacent text nodes are coalesced

proc dom::tcl::Element:Normalize {pVar nodes} {
    upvar $pVar parent

    set textNode {}

    foreach n $nodes {
	array set child [set $n]
	set cleanup {}

	switch $child(node:nodeType) {
	    textNode {
		if {[llength $textNode]} {

		    # Coalesce into previous node
		    set evid [CreateEvent $n DOMCharacterDataModified]
		    event initMutationEvent $evid DOMCharacterDataModified 1 0 {} $text(node:nodeValue) $text(node:nodeValue)$child(node:nodeValue) {}
		    append text(node:nodeValue) $child(node:nodeValue)
		    node dispatchEvent $n $evid
		    DOMImplementation destroy $evid

		    # Remove this child
		    upvar #0 $parent(node:childNodes) childNodes
		    set idx [lsearch $childNodes $n]
		    set childNodes [lreplace $childNodes $idx $idx]
		    unset $n
		    set cleanup [list event postMutationEvent [node parent $n] DOMSubtreeModified]
		    event postMutationEvent $n DOMNodeRemoved

		    set $textNode [array get text]
		} else {
		    set textNode $n
		    catch {unset text}
		    array set text [array get child]
		}
	    }
	    element -
	    document -
	    documentFragment {
		set textNode {}
		Element:Normalize child [set $child(node:childNodes)]
	    }
	    default {
		set textNode {}
	    }
	}

	eval $cleanup
    }

    return {}
}

# dom::tcl::processinginstruction --
#
#	Functions for a processing intruction.
#
# Arguments:
#	method	method to invoke
#	token	token for node
#	args	arguments for method
#
# Results:
#	Depends on method used.

namespace eval dom::tcl {
    variable piOptionsRO target
    variable piOptionsRW data
}

proc dom::tcl::processinginstruction {method token args} {
    variable piOptionsRO
    variable piOptionsRW

    array set node [set $token]

    set result {}

    switch -- $method {

	cget {
	    # Some read-only configuration options are computed
	    if {[llength $args] != 1} {
		return -code error "too many arguments"
	    }
	    if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} {
		switch $option {
		    target {
			set result [lindex $node(node:nodeName) 0]
		    }
		    default {
			return $node(node:$option)
		    }
		}
	    } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} {
		switch $option {
		    data {
			return $node(node:nodeValue)
		    }
		    default {
			return $node(node:$option)
		    }
		}
	    } else {
		return -code error "unknown option \"[lindex $args 0]\""
	    }
	}
	configure {
	    if {[llength $args] == 1} {
		return [document cget $token [lindex $args 0]]
	    } elseif {[expr [llength $args] % 2]} {
		return -code error "no value specified for option \"[lindex $args end]\""
	    } else {
		foreach {option value} $args {
		    if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} {
			return -code error "attribute \"$option\" is read-only"
		    } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} {
			switch $opt {
			    data {
				set evid [CreateEvent $token DOMCharacterDataModified]
				event initMutationEvent $evid DOMCharacterModified 1 0 {} $node(node:nodeValue) $value {}
				set node(node:nodeValue) $value
				node dispatchEvent $token $evid
				DOMImplementation destroy $evid
			    }
			    default {
				set node(node:$opt) $value
			    }
			}
		    } else {
			return -code error "unknown option \"$option\""
		    }
		}
	    }
	}

	default {
	    return -code error "unknown method \"$method\""
	}

    }

    set $token [array get node]

    return $result
}

#################################################
#
# DOM Level 2 Interfaces
#
#################################################

# dom::tcl::event --
#
#	Implements Event Interface
#
#	Subclassed Interfaces are also defined here,
#	such as UIEvents.
#
# Arguments:
#	method	method to invoke
#	token	token for event
#	args	arguments for method
#
# Results:
#	Depends on method used.

namespace eval dom::tcl {
    variable eventOptionsRO type|target|currentNode|eventPhase|bubbles|cancelable|timeStamp|detail|view|screenX|screenY|clientX|clientY|ctrlKey|shiftKey|altKey|metaKey|button|relatedNode|prevValue|newValue|attrName
    variable eventOptionsRW {}

    # Issue: should the attributes belonging to the subclassed Interface
    # be separated out?

    variable uieventOptionsRO detail|view
    variable uieventOptionsRW {}

    variable mouseeventOptionsRO screenX|screenY|clientX|clientY|ctrlKey|shiftKey|altKey|metaKey|button|relatedNode
    variable mouseeventOptionsRW {}

    variable mutationeventOptionsRO relatedNode|prevValue|newValue|attrName
    variable mutationeventOptionsRW {}
}

proc dom::tcl::event {method token args} {
    variable eventOptionsRO
    variable eventOptionsRW

    array set event [set $token]

    set result {}

    switch -glob -- $method {

	cg* {
	    # cget

	    if {[llength $args] != 1} {
		return -code error "too many arguments"
	    }
	    if {[regexp [format {^-(%s)$} $eventOptionsRO] [lindex $args 0] discard option]} {
		return $event($option)
	    } elseif {[regexp [format {^-(%s)$} $eventOptionsRW] [lindex $args 0] discard option]} {
		return $event($option)
	    } else {
		return -code error "unknown option \"[lindex $args 0]\""
	    }
	}

	co* {
	    # configure

	    if {[llength $args] == 1} {
		return [event cget $token [lindex $args 0]]
	    } elseif {[expr [llength $args] % 2]} {
		return -code error "no value specified for option \"[lindex $args end]\""
	    } else {
		foreach {option value} $args {
		    if {[regexp [format {^-(%s)$} $eventOptionsRW] $option discard opt]} {
			set event($opt) $value
		    } elseif {[regexp [format {^-(%s)$} $eventOptionsRO] $option discard opt]} {
			return -code error "attribute \"$option\" is read-only"
		    } else {
			return -code error "unknown option \"$option\""
		    }
		}
	    }

	    set $token [array get event]

	}

	st* {
	    # stopPropagation

	    set event(stopPropagation) 1
	    set $token [array get event]

	}

	pr* {
	    # preventDefault

	    set event(preventDefault) 1
	    set $token [array get event]

	}

	initE* {
	    # initEvent

	    if {[llength $args] != 3} {
		return -code error "wrong number of arguments"
	    }

	    if {$event(dispatched)} {
		return -code error "event has been dispatched"
	    }

	    foreach {event(type) event(bubbles) event(cancelable)} $args break
	    set event(type) [string tolower $event(type)]

	    set $token [array get event]

	}

	initU* {
	    # initUIEvent

	    if {[llength $args] < 4 || [llength $args] > 5} {
		return -code error "wrong number of arguments"
	    }

	    if {$event(dispatched)} {
		return -code error "event has been dispatched"
	    }

	    set event(detail) 0
	    foreach {event(type) event(bubbles) event(cancelable) event(view) event(detail)} $args break
	    set event(type) [string tolower $event(type)]

	    set $token [array get event]

	}

	initMo* {
	    # initMouseEvent

	    if {[llength $args] != 15} {
		return -code error "wrong number of arguments"
	    }

	    if {$event(dispatched)} {
		return -code error "event has been dispatched"
	    }

	    set event(detail) 1
	    foreach {event(type) event(bubbles) event(cancelable) event(view) event(detail) event(screenX) event(screenY) event(clientX) event(clientY) event(ctrlKey) event(altKey) event(shiftKey) event(metaKey) event(button) event(relatedNode)} $args break
	    set event(type) [string tolower $event(type)]

	    set $token [array get event]

	}

	initMu* {
	    # initMutationEvent

	    if {[llength $args] != 7} {
		return -code error "wrong number of arguments"
	    }

	    if {$event(dispatched)} {
		return -code error "event has been dispatched"
	    }

	    foreach {event(type) event(bubbles) event(cancelable) event(relatedNode) event(prevValue) event(newValue) event(attrName)} $args break
	    set event(type) [string tolower $event(type)]

	    set $token [array get event]

	}

	postUI* {
	    # postUIEvent, non-standard convenience method

	    set evType [lindex $args 0]
	    array set evOpts [list 		    -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType)			    -view {}					    -detail {}				    ]
	    array set evOpts [lrange $args 1 end]

	    set evid [CreateEvent $token $evType]
	    event initUIEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-view) $evOpts(-detail)
	    node dispatchEvent $token $evid
	    DOMImplementation destroy $evid

	}

	postMo* {
	    # postMouseEvent, non-standard convenience method

	    set evType [lindex $args 0]
	    array set evOpts [list 		    -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType)			    -view {}					    -detail {}					    -screenX {}					    -screenY {}					    -clientX {}					    -clientY {}					    -ctrlKey {}					    -altKey {}					    -shiftKey {}				    -metaKey {}					    -button {}					    -relatedNode {}			    ]
	    array set evOpts [lrange $args 1 end]

	    set evid [CreateEvent $token $evType]
	    event initMouseEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-view) $evOpts(-detail) $evOpts(-screenX) $evOpts(-screenY) $evOpts(-clientX) $evOpts(-clientY) $evOpts(-ctrlKey) $evOpts(-altKey) $evOpts(-shiftKey) $evOpts(-metaKey) $evOpts(-button) $evOpts(-relatedNode)
	    node dispatchEvent $token $evid
	    DOMImplementation destroy $evid

	}

	postMu* {
	    # postMutationEvent, non-standard convenience method

	    set evType [lindex $args 0]
	    array set evOpts [list 		    -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType)			    -relatedNode {}					    -prevValue {} -newValue {}				    -attrName {}				    ]
	    array set evOpts [lrange $args 1 end]

	    set evid [CreateEvent $token $evType]
	    event initMutationEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-relatedNode) $evOpts(-prevValue) $evOpts(-newValue) $evOpts(-attrName)
	    node dispatchEvent $token $evid
	    DOMImplementation destroy $evid

	}

	default {
	    return -code error "unknown method \"$method\""
	}
    }

    return $result
}

# dom::tcl::CreateEvent --
#
#	Create an event object
#
# Arguments:
#	token	parent node
#	type	event type
#	args	configuration options
#
# Results:
#	Returns event token

proc dom::tcl::CreateEvent {token type args} {
    if {[string length $token]} {
	array set parent [set $token]
	upvar #0 $parent(docArray) docArray
	set docArrayName $parent(docArray)
    } else {
	array set opts $args
	upvar #0 $opts(-docarray) docArray
	set docArrayName $opts(-docarray)
    }

    set id event[incr docArray(counter)]
    set child ${docArrayName}($id)

    # Create the event
    set docArray($id) [list id $id docArray $docArrayName 	    node:nodeType event		    type $type			    cancelable 1		    stopPropagation 0		    preventDefault 0		    dispatched 0		    bubbles 1			    eventPhase {}		    timeStamp [clock clicks -milliseconds]		    ]

    return $child
}

#################################################
#
# Serialisation
#
#################################################

# dom::tcl::Serialize:documentFragment --
#
#	Produce text for documentFragment.
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:documentFragment {token args} {
    array set node [set $token]

    if {[string compare "node1" $node(documentFragment:masterDoc)]} {
	return [eval [list Serialize:node $token] $args]
    } else {
	if {[string compare {} [GetField node(document:documentElement)]]} {
	    return [eval Serialize:document [list $token] $args]
	} else {
	    return -code error "document has no document element"
	}
    }

}

# dom::tcl::Serialize:document --
#
#	Produce text for document.
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:document {token args} {
    array set node [set $token]
    array set opts {
	-showxmldecl 1
	-showdoctypedecl 1
    }
    array set opts $args

    if {![info exists node(document:documentElement)]} {
	return -code error "document has no document element"
    } elseif {![string length node(document:doctype)]} {
	return -code error "no document type declaration given"
    } else {

	array set doctype [set $node(document:doctype)]

	# Bug fix: can't use Serialize:attributeList for XML declaration,
	# since attributes must occur in a given order (XML 2.8 [23])

	set result {}

	if {$opts(-showxmldecl)} {
	    append result <?xml[Serialize:XMLDecl version $node(document:xmldecl)][Serialize:XMLDecl encoding $node(document:xmldecl)][Serialize:XMLDecl standalone $node(document:xmldecl)]?>\n
	}
	if {$opts(-showdoctypedecl)} {
	    # Is document element in an XML Namespace?
	    # If so then include prefix in doctype decl
	    foreach {prefix localName} [::xml::qnamesplit $doctype(doctype:name)] break
	    if {![string length $prefix]} {
		# The prefix may not have been allocated yet
		array set docel [set $node(document:documentElement)]
		if {[info exists docel(node:namespaceURI)] && 			[string length $docel(node:namespaceURI)]} {
		    set declPrefix [GetNamespacePrefix $node(document:documentElement) $docel(node:namespaceURI)]
		    set docelName $declPrefix:$doctype(doctype:name)
		} else {
		    set docelName $doctype(doctype:name)
		}
	    } else {
		set docelName $doctype(doctype:name)
	    }
	    # Applied patch by Marco Gonnelli, bug #590914
	    append result <!DOCTYPE\ $docelName[Serialize:ExternalID $doctype(doctype:externalid)][expr {[string length $doctype(doctype:internaldtd)] ? " \[[string trim $doctype(doctype:internaldtd) \{\} ]\]" : {}}]>\n
	}

	# BUG #525505: Want to serialize all children including the
	# document element.

	foreach child [set $node(node:childNodes)] {
	    append result [eval Serialize:[node cget $child -nodeType] [list $child] $args]
	}

	return $result
    }

}

# dom::tcl::Serialize:ExternalID --
#
#	Returned appropriately quoted external identifiers
#
# Arguments:
#	id	external indentifiers
#
# Results:
#	text

proc dom::tcl::Serialize:ExternalID id {
    set publicid {}
    set systemid {}
    foreach {publicid systemid} $id break

    switch -glob -- [string length $publicid],[string length $systemid] {
	0,0 {
	    return {}
	}
	0,* {
	    return " SYSTEM \"$systemid\""
	}
	*,* {
	    # Patch from c.l.t., Richard Calmbach (rc@hnc.com )
	    return " PUBLIC \"$publicid\" \"$systemid\""
	}
    }

    return {}
}

# dom::tcl::Serialize:XMLDecl --
#
#	Produce text for XML Declaration attribute.
#	Order is determine by document serialisation procedure.
#
# Arguments:
#	attr	required attribute
#	attList	attribute list
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:XMLDecl {attr attrList} {
    array set data $attrList
    if {![info exists data($attr)]} {
	return {}
    } elseif {[string length $data($attr)]} {
	return " $attr='$data($attr)'"
    } else {
	return {}
    }
}

# dom::tcl::Serialize:node --
#
#	Produce text for an arbitrary node.
#	This simply serializes the child nodes of the node.
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:node {token args} {
    array set node [set $token]
    array set opts $args

    if {[info exists opts(-indent)]} {
	# NB. 0|1 cannot be used as booleans - mention this in docn
	if {[regexp {^false|no|off$} $opts(-indent)]} {
	    # No action required
	} elseif {[regexp {^true|yes|on$} $opts(-indent)]} {
	    set opts(-indent) 1
	} else {
	    incr opts(-indent)
	}
    }

    set result {}
    foreach childToken [set $node(node:childNodes)] {
	catch {unset child}
	array set child [set $childToken]
	append result [eval [list Serialize:$child(node:nodeType) $childToken] [array get opts]]
    }

    return $result
}

# dom::tcl::Serialize:element --
#
#	Produce text for an element.
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:element {token args} {
    array set node [set $token]
    array set opts {-newline {}}
    array set opts $args

    set result {}
    set newline {}
    if {[lsearch $opts(-newline) $node(node:nodeName)] >= 0} {
	append result \n
	set newline \n
    }
    append result [eval Serialize:Indent [array get opts]]
    switch [info exists node(node:namespaceURI)],[info exists node(node:prefix)] {

	1,1 {
	    # XML Namespace is in scope, prefix supplied
	    if {[string length $node(node:prefix)]} {
		# Make sure that there's a declaration for this XML Namespace
		set declPrefix [GetNamespacePrefix $token $node(node:namespaceURI) -prefix $node(node:prefix)]
		# ASSERTION: $declPrefix == $node(node:prefix)
		set nsPrefix $node(node:prefix):
	    } elseif {[string length $node(node:namespaceURI)]} {
		set nsPrefix [GetNamespacePrefix $token $node(node:namespaceURI)]:
	    } else {
		set nsPrefix {}
	    }
	}

	1,0 {
	    # XML Namespace is in scope, no prefix
	    set nsPrefix [GetNamespacePrefix $token $node(node:namespaceURI)]:
	    if {![string compare $nsPrefix :]} {
		set nsPrefix {}
	    }
	}

	0,1 {
	    # Internal error
	    set nsPrefix {}
	}

	0,0 -
	default {
	    # No XML Namespace is in scope
	    set nsPrefix {}
	}
    }
    append result <$nsPrefix$node(node:localName)

    append result [Serialize:attributeList [array get $node(element:attributeList)]]

    if {![llength [set $node(node:childNodes)]]} {

	append result />$newline

    } else {

	append result >$newline

	# Do the children
	if {[hasmixedcontent $token]} {
	    set opts(-indent) no
	}
	append result [eval Serialize:node [list $token] [array get opts]]

	append result [eval Serialize:Indent [array get opts]]
	append result "$newline</$nsPrefix$node(node:localName)>$newline"

    }

    return $result
}

# dom::tcl::GetNamespacePrefix --
#
#	Determine the XML Namespace prefix for a Namespace URI
#
# Arguments:
#	token	node token
#	nsuri	XML Namespace URI
#	args	configuration options
#
# Results:
#	Returns prefix.
#	May add prefix information to node

proc dom::tcl::GetNamespacePrefix {token nsuri args} {
    array set options $args
    array set node [set $token]

    GetNamespaceDecl $token $nsuri declNode prefix

    if {[llength $declNode]} {
	# A declaration was found for this Namespace URI
	return $prefix
    } else {
	# No declaration found.  Allocate a prefix
	# and add XML Namespace declaration
	set prefix {}
	catch {set prefix $options(-prefix)}
	if {![string compare $prefix {}]} {
	    upvar \#0 $node(docArray) docArray
	    set prefix ns[incr docArray(counter)]
	}
	set node(node:prefix) $prefix
	upvar \#0 $node(element:attributeList) attrs
	set attrs(${::dom::xmlnsURI}^$prefix) $nsuri

	return $prefix
    }
}

# dom::tcl::GetNamespaceDecl --
#
#	Find the XML Namespace declaration.
#
# Arguments:
#	token	node token
#	nsuri	XML Namespace URI
#	nodeVar	Variable name for declaration
#	prefVar Variable for prefix
#
# Results:
#	If the declaration is found returns node and prefix

proc dom::tcl::GetNamespaceDecl {token nsuri nodeVar prefVar} {
    upvar $nodeVar declNode
    upvar $prefVar prefix

    array set nodeinfo [set $token]
    while {[string length $nodeinfo(node:parentNode)]} {

	# Check this node's XML Namespace declarations
	catch {unset attrs}
	array set attrs [array get $nodeinfo(element:attributeList)]
	foreach {nsdecl decluri} [array get attrs ${::dom::xmlnsURI}^*] {
	    if {![string compare $decluri $nsuri]} {
		regexp [format {%s\^(.*)} $::dom::xmlnsURI] $nsdecl dummy prefix
		set declNode $token
		return
	    }
	}

	# Move up to parent
	set token $nodeinfo(node:parentNode)
	array set nodeinfo [set $token]
    }

    # Got to Document node and didn't find XML NS decl
    set prefix {}
    set declNode {}
}

# dom::tcl::Serialize:textNode --
#
#	Produce text for a text node.  This procedure may
#	return a CDATA section where appropriate.
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:textNode {token args} {
    array set node [set $token]

    if {$node(node:cdatasection)} {
	return [Serialize:CDATASection $node(node:nodeValue)]
    } elseif {[Serialize:ExceedsThreshold $node(node:nodeValue)]} {
	return [Serialize:CDATASection $node(node:nodeValue)]
    } else {
	return [Encode $node(node:nodeValue)]
    }
}

# dom::tcl::Serialize:ExceedsThreshold --
#
#	Applies heuristic(s) to determine whether a text node
#	should be formatted as a CDATA section.
#
# Arguments:
#	text	node text
#
# Results:
#	Boolean.

proc dom::tcl::Serialize:ExceedsThreshold {text} {
    return [expr {[regsub -all {[<>&]} $text {} discard] > $::dom::maxSpecials}]
}

# dom::tcl::Serialize:CDATASection --
#
#	Formats a CDATA section.
#
# Arguments:
#	text	node text
#
# Results:
#	XML text.

proc dom::tcl::Serialize:CDATASection {text} {
    set result {}
    while {[regexp {(.*)]]>(.*)} $text discard text trailing]} {
	set result \]\]&gt\;<!\[CDATA\[$trailing\]\]>$result
    }
    return <!\[CDATA\[$text\]\]>$result
}

# dom::tcl::Serialize:processingInstruction --
#
#	Produce text for a PI node.
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:processingInstruction {token args} {
    array set node [set $token]

    return "[eval Serialize:Indent $args]<?$node(node:nodeName)[expr {$node(node:nodeValue) == "" ? "" : " $node(node:nodeValue)"}]?>"
}

# dom::tcl::Serialize:comment --
#
#	Produce text for a comment node.
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:comment {token args} {
    array set node [set $token]

    return [eval Serialize:Indent $args]<!--$node(node:nodeValue)-->
}

# dom::tcl::Serialize:entityReference --
#
#	Produce text for an entity reference.
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:entityReference {token args} {
    array set node [set $token]

    return &$node(node:nodeName)\;
}

# dom::tcl::Encode --
#
#	Encode special characters
#
# Arguments:
#	value	text value
#
# Results:
#	XML format text.

proc dom::tcl::Encode value {
    array set Entity {
	$ $
	< &lt;
	> &gt;
	& &amp;
	\" &quot;
	' &apos;
    }

    regsub -all {([$<>&"'])} $value {$Entity(\1)} value

    return [subst -nocommand -nobackslash $value]
}

# dom::tcl::Serialize:attributeList --
#
#	Produce text for an attribute list.
#
# Arguments:
#	l	name/value paired list
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:attributeList {l} {

    set result {}
    foreach {name value} $l {

	if {[regexp {^([^^]+)\^(.*)$} $name discard nsuri prefix]} {
	    if {[string compare $nsuri $::dom::xmlnsURI]} {
		# Need the node token to resolve the Namespace URI
		append result { } ?:$prefix =
	    } else {
		# A Namespace declaration
		append result { } xmlns:$prefix =
	    }
	} else {
	    append result { } $name =
	}

	# Handle special characters
	regsub -all & $value {\&amp;} value
	regsub -all < $value {\&lt;} value
	regsub -all > $value {\&gt;} value

	if {![string match *\"* $value]} {
	    append result \"$value\"
	} elseif {![string match *'* $value]} {
	    append result '$value'
	} else {
	    regsub -all \" $value {\&quot;} value
	    append result \"$value\"
	}

    }

    return $result
}

# dom::tcl::Serialize:Indent --
#
#	Calculate the indentation required, if any
#
# Arguments:
#	args	configuration options, which may specify -indent
#
# Results:
#	May return white space

proc dom::tcl::Serialize:Indent args {
    array set opts [list -indentspec $::dom::indentspec]
    array set opts $args

    if {![info exists opts(-indent)] || 	    [regexp {^false|no|off$} $opts(-indent)]} {
	return {}
    }

    if {[regexp {^true|yes|on$} $opts(-indent)]} {
	# Default indent level is 0
	return \n
    }

    if {!$opts(-indent)} {
	return \n
    }

    set ws [format \n%\ [expr $opts(-indent) * [lindex $opts(-indentspec) 0]]s { }]
    regsub -all [lindex [lindex $opts(-indentspec) 1] 0] $ws [lindex [lindex $opts(-indentspec) 1] 1] ws

    return $ws

}

#################################################
#
# Parsing
#
#################################################

# dom::tcl::ParseElementStart --
#
#	Push a new element onto the stack.
#
# Arguments:
#	stateVar	global state array variable
#	name		element name
#	attrList	attribute list
#	args		configuration options
#
# Results:
#	An element is created within the currently open element.

proc dom::tcl::ParseElementStart {stateVar name attrList args} {

    upvar #0 $stateVar state
    array set opts $args

    # Push namespace declarations
    # We need to be able to map namespaceURI's back to prefixes
    set nsattrlists {}
    catch {
	foreach {namespaceURI prefix} $opts(-namespacedecls) {
	    lappend state(NS:$namespaceURI) $prefix

	    # Also, synthesize namespace declaration attributes
	    # TclXML is a little too clever when it parses them away!

	    lappend nsattrlists $prefix $namespaceURI
	}
	lappend opts(-namespaceattributelists) $::dom::xmlnsURI $nsattrlists

    }

    set nsarg {}
    catch {
	lappend nsarg -namespace $opts(-namespace)
	lappend nsarg -localname $name
	lappend nsarg -prefix [lindex $state(NS:$opts(-namespace)) end]
    }

    lappend state(current) 	[eval CreateElement [list [lindex $state(current) end] $name $attrList] $nsarg [array get opts -namespaceattributelists]]

    if {[info exists opts(-empty)] && $opts(-empty)} {
	# Flag this node as being an empty element
	array set node [set [lindex $state(current) end]]
	set node(element:empty) 1
	set [lindex $state(current) end] [array get node]
    }

    # Temporary: implement -progresscommand here, because of broken parser
    if {[string length $state(-progresscommand)]} {
	if {!([incr state(progCounter)] % $state(-chunksize))} {
	    uplevel #0 $state(-progresscommand)
	}
    }
}

# dom::tcl::ParseElementEnd --
#
#	Pop an element from the stack.
#
# Arguments:
#	stateVar	global state array variable
#	name		element name
#	args		configuration options
#
# Results:
#	Currently open element is closed.

proc dom::tcl::ParseElementEnd {stateVar name args} {
    upvar #0 $stateVar state

    set state(current) [lreplace $state(current) end end]
}

# dom::tcl::ParseCharacterData --
#
#	Add a textNode to the currently open element.
#
# Arguments:
#	stateVar	global state array variable
#	data		character data
#
# Results:
#	A textNode is created.

proc dom::tcl::ParseCharacterData {stateVar data} {
    upvar #0 $stateVar state

    CreateTextNode [lindex $state(current) end] $data
}

# dom::tcl::ParseProcessingInstruction --
#
#	Add a PI to the currently open element.
#
# Arguments:
#	stateVar	global state array variable
#	name		PI name
#	target		PI target
#
# Results:
#	A processingInstruction node is created.

proc dom::tcl::ParseProcessingInstruction {stateVar name target} {
    upvar #0 $stateVar state

    CreateGeneric [lindex $state(current) end] node:nodeType processingInstruction node:nodeName $name node:nodeValue $target
}

# dom::tcl::ParseXMLDeclaration --
#
#	Add information from the XML Declaration to the document.
#
# Arguments:
#	stateVar	global state array variable
#	version		version identifier
#	encoding	character encoding
#	standalone	standalone document declaration
#
# Results:
#	Document node modified.

proc dom::tcl::ParseXMLDeclaration {stateVar version encoding standalone} {
    upvar #0 $stateVar state

    array set node [set $state(docNode)]
    array set xmldecl $node(document:xmldecl)

    array set xmldecl [list version $version		    standalone $standalone			    encoding $encoding			    ]

    set node(document:xmldecl) [array get xmldecl]
    set $state(docNode) [array get node]

    return {}
}

# dom::tcl::ParseDocType --
#
#	Add a Document Type Declaration node to the document.
#
# Arguments:
#	stateVar	global state array variable
#	root		root element type
#	publit		public identifier literal
#	systemlist	system identifier literal
#	dtd		internal DTD subset
#
# Results:
#	DocType node added

proc dom::tcl::ParseDocType {stateVar root {publit {}} {systemlit {}} {dtd {}} args} {
    upvar #0 $stateVar state

    CreateDocType $state(docNode) $root [list $publit $systemlit] $dtd {} {}
    # Last two are entities and notaions (as namedNodeMap's)

    return {}
}

# dom::tcl::ParseComment --
#
#	Parse comment
#
# Arguments:
#	stateVar	state array
#	data		comment data
#
# Results:
#	Comment node added to DOM tree

proc dom::tcl::ParseComment {stateVar data} {
    upvar #0 $stateVar state

    CreateGeneric [lindex $state(current) end] node:nodeType comment node:nodeValue $data

    return {}
}

# dom::tcl::ParseEntityReference --
#
#	Parse an entity reference
#
# Arguments:
#	stateVar	state variable
#	ref		entity
#
# Results:
#	Entity reference node added to DOM tree

proc dom::tcl::ParseEntityReference {stateVar ref} {
    upvar #0 $stateVar state

    CreateGeneric [lindex $state(current) end] node:nodeType entityReference node:nodeName $ref

    return {}
}

#################################################
#
# Trim white space
#
#################################################

# dom::tcl::Trim --
#
#	Remove textNodes that only contain white space
#
# Arguments:
#	nodeid	node to trim
#
# Results:
#	textNode nodes may be removed (from descendants)

proc dom::tcl::Trim nodeid {
    array set node [set $nodeid]

    switch $node(node:nodeType) {

	textNode {
	    if {![string length [string trim $node(node:nodeValue)]]} {
		node removeChild $node(node:parentNode) $nodeid
	    }
	}

	default {
	    # Some nodes have no child list.  Reported by Jim Hollister <jhollister@objectspace.com>
	    set children {}
	    catch {set children [set $node(node:childNodes)]}
	    foreach child $children {
		Trim $child
	    }
	}

    }

    return {}
}

#################################################
#
# Query function
#
#################################################

# dom::tcl::Query --
#
#	Search DOM.
#
# DEPRECATED: This is obsoleted by XPath.
#
# Arguments:
#	token	node to search
#	args	query options
#
# Results:
#	If query is found, return the node ID of the containing node.
#	Otherwise, return empty string

proc dom::tcl::Query {token args} {
    array set node [set $token]
    array set query $args

    set found 0
    switch $node(node:nodeType) {
	document -
	documentFragment {
	    foreach child [set $node(node:childNodes)] {
		if {[llength [set result [eval Query [list $child] $args]]]} {
		    return $result
		}
	    }
	}
	element {
	    catch {set found [expr ![string compare $node(node:nodeName) $query(-tagname)]]}
	    if {$found} {
		return $token
	    }
	    if {![catch {array set attributes [set $node(element:attributeList)]}]} {
		catch {set found [expr [lsearch [array names attributes] $query(-attrname)] >= 0]}
		catch {set found [expr $found || [lsearch [array get attributes] $query(-attrvalue)] >= 0]}
	    }

	    if {$found} {
		return $token
	    }

	    foreach child [set $node(node:childNodes)] {
		if {[llength [set result [eval Query [list $child] $args]]]} {
		    return $result
		}
	    }

	}
	textNode -
	comment {
	    catch {
		set querytext [expr {$node(node:nodeType) == "textNode" ? $query(-text) : $query(-comment)}]
		set found [expr [string match $node(node:nodeValue) $querytext] >= 0]
	    }

	    if {$found} {
		return $token
	    }
	}
	processingInstruction {
	    catch {set found [expr ![string compare $node(node:nodeName) $query(-pitarget)]]}
	    catch {set found [expr $found || ![string compare $node(node:nodeValue) $query(-pidata)]]}

	    if {$found} {
		return $token
	    }
	}
    }

    if {$found} {
	return $token
    }

    return {}
}

#################################################
#
# XPath support
#
#################################################

# dom::tcl::XPath:CreateNode --
#
#	Given an XPath expression, create the node
#	referred to by the expression.  Nodes required
#	as steps of the path are created if they do
#	not exist.
#
# Arguments:
#	node	context node
#	path	location path
#
# Results:
#	Node(s) created in the DOM tree.
#	Returns token for deepest node in the expression.

proc dom::tcl::XPath:CreateNode {node path} {

    set root [::dom::node cget $node -ownerDocument]

    set spath [::xpath::split $path]

    if {[llength $spath] <= 1} {
	# / - do nothing
	return $root
    }

    if {![llength [lindex $spath 0]]} {
	# Absolute location path
	set context $root
	set spath [lrange $spath 1 end]
	set contexttype document
    } else {
	set context $node
	set contexttype [::dom::node cget $node -nodeType]
    }

    foreach step $spath {

	# Sanity check on path
	switch $contexttype {
	    document -
	    documentFragment -
	    element {}
	    default {
		return -code error "node type \"$contexttype\" have no children"
	    }
	}

	switch [lindex $step 0] {

	    child {
		if {[llength [lindex $step 1]] > 1} {
		    foreach {nodetype discard} [lindex $step 1] break

		    switch -- $nodetype {
			text {
			    set posn [CreateNode:FindPosition [lindex $step 2]]

			    set count 0
			    set targetNode {}
			    foreach child [::dom::node children $context] {
				switch [::dom::node cget $child -nodeType] {
				    textNode {
					incr count
					if {$count == $posn} {
					    set targetNode $child
					    break
					}
				    }
				    default {}
				}
			    }

			    if {[string length $targetNode]} {
				set context $targetNode
			    } else {
				# Creating sequential textNodes doesn't make sense
				set context [::dom::document createTextNode $context {}]
			    }
			    set contexttype textNode
			}
			default {
			    return -code error "node type test \"${nodetype}()\" not supported"
			}
		    }
		} else {
		    # Find the child element
		    set posn [CreateNode:FindPosition [lindex $step 2]]

		    set count 0
		    set targetNode {}
		    foreach child [::dom::node children $context] {
			switch [node cget $child -nodeType] {
			    element {
				if {![string compare [lindex $step 1] [::dom::node cget $child -nodeName]]} {
				    incr count
				    if {$count == $posn} {
					set targetNode $child
					break
				    }
				}
			    }
			    default {}
			}
		    }

		    if {[string length $targetNode]} {
			set context $targetNode
		    } else {
			# Didn't find it so create required elements
			while {$count < $posn} {
			    set child [::dom::document createElement $context [lindex $step 1]]
			    incr count
			}
			set context $child
		    }
		    set contexttype element

		}
	    }

	    default {
		return -code error "axis \"[lindex $step 0]\" is not supported"
	    }
	}
    }

    return $context
}

# dom::tcl::CreateNode:FindPosition --

proc dom::tcl::CreateNode:FindPosition predicates {
    switch [llength $predicates] {
	0 {
	    return 1
	}
	1 {
	    # Fall-through
	}
	default {
	    return -code error "multiple predicates not supported"
	}
    }
    set predicate [lindex $predicates 0]

    switch -- [lindex [lindex $predicate 0] 0] {
	function {
	    switch -- [lindex [lindex $predicate 0] 1] {
		position {
		    if {[lindex $predicate 1] == "="} {
			if {[string compare [lindex [lindex $predicate 2] 0] "number"]} {
			    return -code error "operand must be a number"
			} else {
			    set posn [lindex [lindex $predicate 2] 1]
			}
		    } else {
			return -code error "operator must be \"=\""
		    }
		}
		default {
		    return -code error "predicate function \"[lindex [lindex $predicate 0] 1]\" not supported"
		}
	    }
	}
	default {
	    return -code error "predicate must be position() function"
	}
    }

    return $posn
}

# dom::tcl::XPath:SelectNode --
#
#	Match nodes with an XPath location path
#
# Arguments:
#	ctxt	context - Tcl list
#	path	location path
#
# Results:
#	Returns Tcl list of matching nodes

proc dom::tcl::XPath:SelectNode {ctxt path} {

    if {![llength $ctxt]} {
	return {}
    }

    set spath [xpath::split $path]

    if {[string length [node parent [lindex $ctxt 0]]]} {
	array set nodearr [set [lindex $ctxt 0]]
	set root $nodearr(docArray)(node1)
    } else {
	set root [lindex $ctxt 0]
    }

    if {[llength $spath] == 0} {
	return $root
    }
    if {[llength $spath] == 1 && [llength [lindex $spath 0]] == 0} {
	return $root
    }

    if {![llength [lindex $spath 0]]} {
	set ctxt $root
	set spath [lrange $spath 1 end]
    }

    return [XPath:SelectNode:Rel $ctxt $spath]
}

# dom::tcl::XPath:SelectNode:Rel --
#
#	Match nodes with an XPath location path
#
# Arguments:
#	ctxt	context - Tcl list
#	path	split location path
#
# Results:
#	Returns Tcl list of matching nodes

proc dom::tcl::XPath:SelectNode:Rel {ctxt spath} {
    if {![llength $spath]} {
	return $ctxt
    }

    set step [lindex $spath 0]
    set result {}
    switch [lindex $step 0] {

	child {
	    # All children are candidates
	    set children {}
	    foreach node [XPath:SN:GetElementTypeNodes $ctxt] {
		eval lappend children [node children $node]
	    }

	    # Now apply node test to each child
	    foreach node $children {
		if {[XPath:SN:ApplyNodeTest $node [lindex $step 1]]} {
		    lappend result $node
		}
	    }

	}

	descendant-or-self {
	    foreach node $ctxt {
		if {[XPath:SN:ApplyNodeTest $node [lindex $step 1]]} {
		    lappend result $node
		}
		eval lappend result [XPath:SN:DescendAndTest [node children $node] [lindex $step 1]]
	    }
	}

	descendant {
	    foreach node $ctxt {
		eval lappend result [XPath:SN:DescendAndTest [node children $node] [lindex $step 1]]
	    }
	}

	attribute {
	    if {[string compare [lindex $step 1] "*"]} {
		foreach node $ctxt {
		    set attrNode [element getAttributeNode $node [lindex $step 1]]
		    if {[llength $attrNode]} {
			lappend result $attrNode
		    }
		}
	    } else {
		# All attributes are returned
		foreach node $ctxt {
		    foreach attrName [array names [node cget $node -attributes]] {
			set attrNode [element getAttributeNode $node $attrName]
			if {[llength $attrNode]} {
			    lappend result $attrNode
			}
		    }
		}
	    }
	}

	default {
	    return -code error "axis \"[lindex $step 0]\" is not supported"
	}
    }

    # Now apply predicates
    set result [XPath:ApplyPredicates $result [lindex $step 2]]

    # Apply the next location step
    return [XPath:SelectNode:Rel $result [lrange $spath 1 end]]
}

# dom::tcl::XPath:SN:GetElementTypeNodes --
#
#	Reduce nodeset to those nodes of element type
#
# Arguments:
#	nodeset	set of nodes
#
# Results:
#	Returns nodeset in which all nodes are element type

proc dom::tcl::XPath:SN:GetElementTypeNodes nodeset {
    set result {}
    foreach node $nodeset {
	switch [node cget $node -nodeType] {
	    documentFragment -
	    element {
		lappend result $node
	    }
	    default {}
	}
    }
    return $result
}

# dom::tcl::XPath:SN:ApplyNodeTest --
#
#	Apply the node test to a node
#
# Arguments:
#	node	DOM node to test
#	test	node test
#
# Results:
#	1 if node passes, 0 otherwise

proc dom::tcl::XPath:SN:ApplyNodeTest {node test} {
    if {[llength $test] > 1} {
	foreach {name typetest} $test break
	# Node type test
	switch -glob -- $name,[node cget $node -nodeType] {
	    node,* {
		return 1
	    }
	    text,textNode -
	    comment,comment -
	    processing-instruction,processingInstruction {
		return 1
	    }
	    text,* -
	    comment,* -
	    processing-instruction,* {
		return 0
	    }
	    default {
		return -code error "illegal node type test \"[lindex $step 1]\""
	    }
	}
    } else {
	# Node name test
	switch -glob -- $test,[node cget $node -nodeType],[node cget $node -nodeName] 		\\*,element,* {
	    return 1
	} 		\\*,* {
	    return 0
	} 		*,element,$test {
	    return 1
	}
    }

    return 0
}

# dom::tcl::XPath:SN:DescendAndTest --
#
#	Descend the element hierarchy,
#	apply the node test as we go
#
# Arguments:
#	nodeset	nodes to be tested and descended
#	test	node test
#
# Results:
#	Returned nodeset of nodes which pass the test

proc dom::tcl::XPath:SN:DescendAndTest {nodeset test} {
    set result {}

    foreach node $nodeset {
	if {[XPath:SN:ApplyNodeTest $node $test]} {
	    lappend result $node
	}
	switch [node cget $node -nodeType] {
	    documentFragment -
	    element {
		eval lappend result [XPath:SN:DescendAndTest [node children $node] $test]
	    }
	}
    }

    return $result
}

# dom::tcl::XPath:ApplyPredicates --
#
#	Filter a nodeset with predicates
#
# Arguments:
#	ctxt	current context nodeset
#	preds	list of predicates
#
# Results:
#	Returns new (possibly reduced) context nodeset

proc dom::tcl::XPath:ApplyPredicates {ctxt preds} {

    set result {}
    foreach node $ctxt {
	set passed 1
	foreach predicate $preds {
	    if {![XPath:ApplyPredicate $node $predicate]} {
		set passed 0
		break
	    }
	}
	if {$passed} {
	    lappend result $node
	}
    }

    return $result
}

# dom::tcl::XPath:ApplyPredicate --
#
#	Filter a node with a single predicate
#
# Arguments:
#	node	current context node
#	pred	predicate
#
# Results:
#	Returns boolean

proc dom::tcl::XPath:ApplyPredicate {node pred} {

    switch -- [lindex $pred 0] {
	= -
	!= -
	>= -
	<= -
	> -
	> {

	    if {[llength $pred] != 3} {
		return -code error "malformed expression"
	    }

	    set operand1 [XPath:Pred:ResolveExpr $node [lindex $pred 1]]
	    set operand2 [XPath:Pred:ResolveExpr $node [lindex $pred 2]]

	    # Convert operands to the correct type, if necessary
	    switch -glob [lindex $operand1 0],[lindex $operand2 0] {
		literal,literal {
		    return [XPath:Pred:CompareLiterals [lindex $pred 0] [lindex $operand1 1] [lindex $operand2 1]]
		}

		number,number -
		literal,number -
		number,literal {
		    # Compare as numbers
		    return [XPath:Pred:CompareNumbers [lindex $pred 0] [lindex $operand1 1] [lindex $operand2 1]]
		}

		boolean,boolean {
		    # Compare as booleans
		    return -code error "boolean comparison not yet implemented"
		}

		node,node {
		    # Nodeset comparison
		    return -code error "nodeset comparison not yet implemented"
		}

		node,* {
		    set value {}
		    if {[llength [lindex $operand1 1]]} {
			set value [node stringValue [lindex [lindex $operand1 1] 0]]
		    }
		    return [XPath:Pred:CompareLiterals [lindex $pred 0] $value [lindex $operand2 1]]
		}
		*,node {
		    set value {}
		    if {[llength [lindex $operand2 1]]} {
			set value [node stringValue [lindex [lindex $operand2 1] 0]]
		    }
		    return [XPath:Pred:CompareLiterals [lindex $pred 0] $value [lindex $operand1 1]]
		}

		default {
		    return -code error "can't compare [lindex $operand1 0] to [lindex $operand2 0]"
		}
	    }
	}

	function {
	    return -code error "invalid predicate"
	}
	number -
	literal {
	    return -code error "invalid predicate"
	}

	path {
	    set nodeset [XPath:SelectNode:Rel $node [lindex $pred 1]]
	    return [expr {[llength $nodeset] > 0 ? 1 : 0}]
	}

    }

    return 1
}

# dom::tcl::XPath:Pred:Compare --

proc dom::tcl::XPath:Pred:CompareLiterals {op operand1 operand2} {
    set result [string compare $operand1 $operand2]

    # The obvious:
    #return [expr {$result $opMap($op) 0}]
    # doesn't compile
    
    switch $op {
	= {
	    return [expr {$result == 0}]
	}
	!= {
	    return [expr {$result != 0}]
	}
	<= {
	    return [expr {$result <= 0}]
	}
	>= {
	    return [expr {$result >= 0}]
	}
	< {
	    return [expr {$result < 0}]
	}
	> {
	    return [expr {$result > 0}]
	}
    }
    return -code error "internal error"
}

# dom::tcl::XPath:Pred:ResolveExpr --

proc dom::tcl::XPath:Pred:ResolveExpr {node expr} {

    switch [lindex $expr 0] {
	path {
	    return [list node [XPath:SelectNode:Rel $node [lindex $expr 1]]]
	}

	function -
	group {
	    return -code error "[lindex $expr 0] not yet implemented"
	}
	literal -
	number -
	boolean {
	    return $expr
	}

	default {
	    return -code error "internal error"
	}
    }

    return {}
}

#################################################
#
# Miscellaneous
#
#################################################

# dom::tcl::hasmixedcontent --
#
#	Determine whether an element contains mixed content
#
# Arguments:
#	token	dom node
#
# Results:
#	Returns 1 if element contains mixed content,
#	0 otherwise

proc dom::tcl::hasmixedcontent token {
    array set node [set $token]

    if {[string compare $node(node:nodeType) "element"]} {
	# Really undefined
	return 0
    }

    foreach child [set $node(node:childNodes)] {
	catch {unset childnode}
	array set childnode [set $child]
	if {![string compare $childnode(node:nodeType) "textNode"]} {
	    return 1
	}
    }

    return 0
}

# dom::tcl::prefix2namespaceURI --
#
#	Given an XML Namespace prefix, find the corresponding Namespace URI
#
# Arguments:
#	node	DOM Node
#	prefix	XML Namespace prefix
#
# Results:
#	Returns URI

proc dom::tcl::prefix2namespaceURI {node prefix} {

    # Search this node and its ancestors for the appropriate
    # XML Namespace declaration

    set parent [dom::node parent $node]
    set nsuri [dom::element getAttributeNS $node $::dom::xmlnsURI $prefix]
    if {[string length $parent] && ![string length $nsuri]} {
	set nsuri [dom::element getAttributeNS $parent $::dom::xmlnsURI $prefix]
	set parent [dom::node parent $parent]
    }

    if {[string length $nsuri]} {
	return $nsuri
    } else {
	return -code error "unable to find namespace URI for prefix \"$prefix\""
    }

}

# dom::tcl::namespaceURI2prefix --
#
#	Given an XML Namespace URI, find the corresponding prefix
#
# Arguments:
#	node	DOM Node
#	nsuri	XML Namespace URI
#
# Results:
#	Returns prefix

proc dom::tcl::namespaceURI2prefix {node nsuri} {

    # Search this node and its ancestors for the desired
    # XML Namespace declaration

    set found 0
    set prefix {}
    set parent [dom::node parent $node]
    while {[string length $parent]} {
	catch {unset nodeinfo}
	array set nodeinfo [set $node]
	catch {unset attrs}
	array set attrs [array get $nodeinfo(element:attributeList)]
	foreach {nsdecl declNSuri} [array get attrs ${::dom::xmlnsURI}^*] {
	    if {![string compare $declNSuri $nsuri]} {
		set found 1
		set prefix [lindex [split $nsdecl ^] 1]
		break
	    }
	}
	if {$found} {
	    break
	}
	set node $parent
	set parent [dom::node parent $node]
    }

    if {$found} {
	return $prefix
    } else {
	return -code error "unable to find prefix for namespace URI \"$nsuri\""
    }

}

# dom::tcl::GetField --
#
#	Return a value, or empty string if not defined
#
# Arguments:
#	var	name of variable to return
#
# Results:
#	Returns the value, or empty string if variable is not defined.

proc dom::tcl::GetField var {
    upvar $var v
    if {[info exists v]} {
	return $v
    } else {
	return {}
    }
}

# dom::tcl::Min --
#
#	Return the minimum of two numeric values
#
# Arguments:
#	a	a value
#	b	another value
#
# Results:
#	Returns the value which is lower than the other.

proc dom::tcl::Min {a b} {
    return [expr {$a < $b ? $a : $b}]
}

# dom::tcl::Max --
#
#	Return the maximum of two numeric values
#
# Arguments:
#	a	a value
#	b	another value
#
# Results:
#	Returns the value which is greater than the other.

proc dom::tcl::Max {a b} {
    return [expr {$a > $b ? $a : $b}]
}

# dom::tcl::Boolean --
#
#	Return a boolean value
#
# Arguments:
#	b	value
#
# Results:
#	Returns 0 or 1

proc dom::tcl::Boolean b {
    regsub -nocase {^(true|yes|1|on)$} $b 1 b
    regsub -nocase {^(false|no|0|off)$} $b 0 b
    return $b
}

# dom.tcl --
#
#	This file sets up the generic API for TclDOM.
#	It is used when the Tcl-only version of TclDOM
#	is loaded.
#
#	The actual pure-Tcl DOM implementation has moved
#	to domimpl.tcl
#
# Copyright (c) 2002-2003 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.
#
# $Id: dom.tcl,v 1.19 2003/03/09 11:12:49 balls Exp $

package provide dom::tclgeneric 2.6

namespace eval dom {
    namespace export DOMImplementation
    namespace export document documentFragment node
    namespace export element textNode attribute
    namespace export processingInstruction
    namespace export event

    variable maxSpecials
    if {![info exists maxSpecials]} {
	set maxSpecials 10
    }

    variable strictDOM 0

    # Default -indentspec value
    #	spaces-per-indent-level {collapse-re collapse-value}
    variable indentspec [list 2 [list {        } \t]]

    # The Namespace URI for XML Namespace declarations
    variable xmlnsURI http://www.w3.org/2000/xmlns/

}

package require dom::tcl 2.6

foreach p {DOMImplementation hasFeature createDocument create createDocumentType createNode destroy isNode parse selectNode serialize trim document documentFragment node element textNode attribute processingInstruction event} {

    proc dom::$p args "return \[eval tcl::$p \$args\]"

}

# dommap.tcl --
#
#	Apply a mapping function to a DOM structure
#
# Copyright (c) 1998-2003 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.
#
# $Id: dommap.tcl,v 1.4 2003/03/09 11:12:49 balls Exp $

package provide dommap 1.0

# We need the DOM
package require dom 2.6

namespace eval dommap {
    namespace export map
}

# dommap::apply --
#
#	Apply a function to a DOM document.
#
#	The callback command is invoked with the node ID of the
#	matching DOM node as its argument.  The command may return
#	an error, continue or break code to alter the processing
#	of further nodes.
#
#	Filter functions may be applied to match particular
#	nodes.  Valid functions include:
#
#	-nodeType regexp
#	-nodeName regexp
#	-nodeValue regexp
#	-attribute {regexp regexp}
#
#	If a filter is specified then the node must match for the
#	callback command to be invoked.  If a filter is not specified
#	then all nodes match that filter.
#
# Arguments:
#	node	DOM document node
#	cmd	callback command
#	args	configuration options
#
# Results:
#	Depends on callback command

proc dommap::apply {node cmd args} {
    array set opts $args

    # Does this node match?
    set match 1
    catch {set match [expr $match && [regexp $opts(-nodeType) [::dom::node cget $node -nodeType]]]}
    catch {set match [expr $match && [regexp $opts(-nodeName) [::dom::node cget $node -nodeName]]]}
    catch {set match [expr $match && [regexp $opts(-nodeValue) [::dom::node cget $node -nodeValue]]]}
    if {$match && ![string compare [::dom::node cget $node -nodeType] element]} {
	set match 0
	foreach {attrName attrValue} [array get [::dom::node cget $node -attributes]] {
	    set match 1
	    catch {set match [expr $match && [regexp [lindex $opts(-attribute) 0] $attrName]]}
	    catch {set match [expr $match && [regexp [lindex $opts(-attribute) 1] $attrValue]]}
	    if {$match} break
	}
    }
    if {$match && [set code [catch {eval $cmd [list $node]} msg]]} {
	switch $code {
	    0 {}
	    3 {
		return -code break
	    }
	    4 {
		return -code continue
	    }
	    default {
		return -code error $msg
	    }
	}
    }

    # Process children
    foreach child [::dom::node children $node] {
	switch [catch {eval apply [list $child] [list $cmd] $args} msg] {
	    0 {
		# No action required
	    }
	    3 {
		# break
		return -code break
	    }
	    4 {
		# continue - skip processing of siblings
		return
	    }
	    1 -
	    2 -
	    default {
		# propagate the error message
		return -code error $msg
	    }
	}
    }

    return {}
}




namespace eval preferences {

    variable rcFileName ~/.moodssrc

    proc read "{rcFileName $rcFileName}" {
        if {![file readable $rcFileName]} {
            return {}
        }
        set file [::open $rcFileName]
        set line [gets $file]
        seek $file 0
        set list {}
        if {![string match -nocase {<\?xml version=*} $line]} {
            while {[gets $file line] >= 0} {
                if {[string match #* $line]} continue
                foreach {name value} $line {
                    set name [namespace tail $name]
                    variable $name $value
                    lappend list $name $value
                }
            }
        } elseif {[catch {set root [dom::parse [::read $file]]} message]} {
            puts stderr "file $rcFileName is not a valid moodss preferences file:\n$message"
            exit 1
        } else {
            set document [dom::element cget [dom::document cget $root -documentElement] -tagName]
            switch $document {
                moodssPreferences - moompsPreferences {
                    foreach node [dom::selectNode $root /$document/*] {
                        set name [dom::node cget $node -nodeName]
                        switch $name {
                            database {
                                set name databaseOptions
                                set value {}
                                foreach {option data} [array get [dom::node cget $node -attributes]] {
                                    lappend value -$option $data
                                }
                            }
                            moodss {
                                set name moodssVersion
                                set value [dom::element getAttribute $node version]
                            }
                            viewerColors - smtpServers {
                                set value [listFromNode $node]
                            }
                            default {
                                set value [dom::node stringValue $node]
                            }
                        }
                        variable $name $value
                        lappend list $name $value
                    }
                }
                default {
                    error "cannot handle $document type"
                }
            }
        }
        close $file
        return $list
    }

if {$global::withGUI} {

    proc create {file} {
        if {[catch {
            close [open $file w]
            file attributes $file -permissions rw-------
        } message]} {
            tk_messageBox -title moodss -type ok -default ok -icon error -message $message
        }
    }

    proc save {variables} {
        variable rcFileName

        set unix [string equal $::tcl_platform(platform) unix]
        if {$unix && ![file exists $rcFileName]} {
            create $rcFileName
        }
        if {[catch {::open $rcFileName w} file]} {
            tk_messageBox -title moodss -type ok -default ok -icon error -message $file
            return
        }
        lifoLabel::push $global::messenger [mc {saving preferences...}]
        ::update idletasks
        set document [dom::create]
        set root [dom::document createElement $document moodssPreferences]
        dom::document createTextNode [dom::document createElement $root version] $global::applicationVersion
        set seconds [clock seconds]
        set date [clock format $seconds -format %D]; set time [clock format $seconds -format %T]
        dom::document createTextNode [dom::document createElement $root date] $date
        dom::document createTextNode [dom::document createElement $root time] $time
        foreach name $variables {
            switch $name {version - date - time - showToolBar - databaseOptions - viewerColors - smtpServers continue}
            dom::document createTextNode [dom::document createElement $root $name] [set ::preferences::$name]
        }
        nodeFromList $root viewerColors $::preferences::viewerColors
        nodeFromList $root smtpServers $::preferences::smtpServers
        set node [dom::document createElement $root database]
        foreach {switch value} $::preferences::databaseOptions {
            dom::element setAttribute $node [string trimleft $switch -] $value
        }
        dom::document createTextNode [dom::document createElement $root showToolBar] $global::showToolBar
        dom::document configure $document -encoding [fconfigure $file -encoding]
        set data [serialize $document]
        dom::destroy $root
        puts $file $data
        close $file
        if {            $unix && ([string length $global::moompsResourceFile] > 0) &&            ([file writable $global::moompsResourceFile] || ![file exists $global::moompsResourceFile])        } {
            if {$unix && ![file exists $global::moompsResourceFile]} {
                create $global::moompsResourceFile
            }
            set file [::open $global::moompsResourceFile w]
            set document [dom::create]
            set root [dom::document createElement $document moompsPreferences]
            set node [dom::document createElement $root moodss]
            dom::element setAttribute $node version $global::applicationVersion
            dom::document createTextNode [dom::document createElement $root date] $date
            dom::document createTextNode [dom::document createElement $root time] $time
            dom::document createTextNode [dom::document createElement $root fromAddress] $::preferences::fromAddress
            nodeFromList $root smtpServers $::preferences::smtpServers
            set node [dom::document createElement $root database]
            foreach {switch value} $::preferences::databaseOptions {
                dom::element setAttribute $node [string trimleft $switch -] $value
            }
            dom::document configure $document -encoding [fconfigure $file -encoding]
            set data [serialize $document]
            dom::destroy $root
            puts $file $data
            close $file
        }
        lifoLabel::pop $global::messenger
    }

    proc update {} {
        array set data [read]
        save [array names data]
    }

}

}



namespace eval configuration {

if {$global::withGUI} {

    variable container
    variable interface
    variable hierarchy
    variable configure
    if {[string equal $::tcl_platform(platform) unix]} {
        set hierarchy {
            application application.size application.colors application.background application.fonts application.printing
                application.pages application.database application.trace
            viewers viewers.colors viewers.graphs viewers.pies viewers.tables viewers.cells
            thresholds thresholds.email thresholds.trace
            daemon
        }
        set prefer    {1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1}
        set configure {1 1 0 1 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0}
    } else {
        set hierarchy {
            application application.size application.colors application.background application.pages application.database
                application.trace
            viewers viewers.colors viewers.graphs viewers.pies viewers.tables viewers.cells
            thresholds thresholds.email thresholds.trace
        }
        set prefer    {1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1}
        set configure {1 1 0 1 0 0 0 1 1 1 1 1 1 0 0 0}
    }

    variable closedIcon [image create photo -data {
        R0lGODlhEAANAPIAAAAAAH9/f7+/v///AP///wAAAAAAAAAAACH+JEZpbGUgd3JpdHRlbiBieSBBZG9iZSBQaG90b3Nob3CoIDUuMAAsAAAAABAADQAAAzNI
        Gsz6kAQxqAjxzcpvc1KWBUDYnRQZWmilYi37EmztlrAt43R8mzrO60P8lAiApHK5TAAAOw==
    }]
    variable openedIcon [image create photo -data {
        R0lGODlhEAANAPIAAAAAAH9/f7+/v///////AAAAAAAAAAAAACH+JEZpbGUgd3JpdHRlbiBieSBBZG9iZSBQaG90b3Nob3CoIDUuMAAsAAAAABAADQAAAzk4
        Gsz6cIQ44xqCZCGbk4MmclAAgNs4ml7rEaxVAkKc3gTAnBO+sbyQT6M7gVQpk9HlAhgHzqhUmgAAOw==
    }]
    variable leafIcon [image create photo -data {
        R0lGODlhDAANAIQAALi8uJiYmPgA+PDw8LC0sGhoaPj4+Pj8+FhYWPD08ODg4IiIiOjs6NDQ0Ojo6Njc2ODk4NjY2NDU0LCwsMjMyKisqMDAwLi4uKioqKCg
        oGhsaAAAAAAAAAAAAAAAAAAAACH5BAEAAAIALAAAAAAMAA0AAAVUIBCM5CicwaCuBFGggyEbB1G/6UzbNZLPh0Bh6IsBEwrCoihLOBmKBqHoTAwYDsUDQLUy
        IIqIZJryZsWNCfUKeUgalIovTLEALoQKJoPQIP6AgQghADs=
    }]
    variable minusIcon [image create photo -data {
        R0lGODlhCQAJAKEAAL+/v////wAAAP///ywAAAAACQAJAAACEYSPoRvG614DQVg7ZZbxoQ8UADs=
    }]
    variable plusIcon [image create photo -data {
        R0lGODlhCQAJAKEAAL+/v////wAAAP///ywAAAAACQAJAAACFISPoRu2spyCyol7G3hxz850CFIAADs=
    }]

}

    proc load {arrayList} {
        foreach {name value} $arrayList {
            set ::global::$name $value
        }
    }

if {$global::withGUI} {

    proc edit {preferencesMode} {
        variable hierarchy
        variable prefer
        variable configure
        variable container
        variable interface
        variable tree
        variable preferences
        variable dialog
        variable entryIcons
        variable leafIcon
        variable minusIcon
        variable plusIcon

        set preferences $preferencesMode
        set objects {}
        set title {moodss: }
        if {$preferences} {
            append title [mc Preferences]
        } else {
            append title [mc {Dashboard configuration}]
        }
        set dialog [new dialogBox .grabber            -buttons hoc -default o -title $title -x [winfo pointerx .] -y [winfo pointery .] -enterreturn 0            -command configuration::done -helpcommand configuration::help -deletecommand {grab release .grabber} -die 0        ]
        grab .grabber
        lappend objects [linkedHelpWidgetTip $composite::($dialog,help,path)]
        set frame [frame $widget::($dialog,path).frame]
        set tree [Tree $frame.tree            -dragenabled 0 -dropenabled 0 -linestipple gray50 -deltay [expr {[font metrics $font::(mediumBold) -linespace] + 4}]            -background $widget::option(listbox,background) -selectbackground $widget::option(listbox,selectbackground)            -closecmd {configuration::stateChange 0} -opencmd {configuration::stateChange 1} -selectcommand configuration::open            -crossopenimage $minusIcon -crosscloseimage $plusIcon        ]
        $tree bindText <Control-Button-1> {}; $tree bindImage <Control-Button-1> {}
        set container [frame $frame.container -borderwidth 1 -relief sunken]
        set message [createMessage $container.message]
        if {$preferences} {
            $message configure -text [format [mc {Preferences for the user: %s}] $::tcl_platform(user)]
        } else {
            $message configure -text [mc {Current configuration of the dashboard}]
        }
        pack $message -fill both -expand 1
        catch {unset interface(current)}
        foreach entry $hierarchy forPreferences $prefer forConfiguration $configure {
            if {($preferences && !$forPreferences) || (!$preferences && !$forConfiguration)} continue
            foreach {parent child} [split $entry .] {}
            if {[string length $child] == 0} {
                set node                    [$tree insert end root #auto -text [mc $parent] -font $font::(mediumBold) -image $configuration::closedIcon]
                set parentNode $node
            } else {
                set node                    [$tree insert end $parentNode #auto -text [mc $child] -font $font::(mediumBold) -image $configuration::leafIcon]
            }
            regsub -all {\.} $entry :: interface($node,class)
            $interface($node,class)::initialize
        }
        pack $tree -side left -fill y -padx 2
        pack $container -fill both -expand 1 -padx 2
        dialogBox::display $dialog $frame
        wm geometry $widget::($dialog,path) 600x300
        bind $frame <Destroy> "delete $objects"
    }

    proc open {tree node} {
        variable container
        variable interface

        if {[info exists interface(current)]} {
            if {$node == $interface(current)} return
            if {![$interface($interface(current),class)::check]} {
                $tree selection set $interface(current)
                bell
                return
            }
        }
        eval destroy [winfo children $container]
        set frame [frame $container.frame]
        pack $frame -fill both -expand 1
        $interface($node,class)::edit $frame
        set interface(current) $node
    }

    proc done {} {
        variable interface
        variable preferences
        variable variables
        variable dialog

        if {[info exists interface(current)] && ![$interface($interface(current),class)::check]} return
        foreach name [array names interface *,class] {
            $interface($name)::apply
        }
        if {$preferences} {
            preferences::save $variables(1)
        }
        delete $dialog
    }

    proc help {} {
        variable interface
        variable preferences

        if {[info exists interface(current)]} {
            $interface($interface(current),class)::help
        } elseif {$preferences} {
            generalHelpWindow #core.preferences
        } else {
            generalHelpWindow #core.configuration
        }
    }

    proc createMessage {path args} {
        message $path -width [winfo screenwidth .] -font $font::(mediumNormal) -justify center
        eval $path configure $args
        return $path
    }

    proc initialize {name} {
        variable preferences

        if {$preferences} {
            if {![info exists ::preferences::$name]} {
                set ::preferences::$name [set ::global::$name]
            }
            return [set ::preferences::$name]
        } else {
            return [set ::global::$name]
        }
    }

    proc apply {name value {immediately 0}} {
        variable preferences

        if {$preferences} {
            set namespaces ::preferences
            if {$immediately} {lappend namespaces ::global}
        } else {
            set namespaces ::global
        }
        foreach namespace $namespaces {
            if {![info exists ${namespace}::$name] || ![string equal $value [set ${namespace}::$name]]} {
                set ${namespace}::$name $value
            }
        }
    }

    proc variables {preferences} {
        variable variables

        return $variables($preferences)
    }

    proc stateChange {opened node} {
        variable tree
        variable closedIcon
        variable openedIcon

        if {$opened} {
            $tree itemconfigure $node -image $openedIcon
        } else {
            $tree itemconfigure $node -image $closedIcon
        }
    }


    namespace eval application {

        proc initialize {} {}

        proc edit {parentPath} {
            set message [configuration::createMessage $parentPath.message -text [mc {Application configuration}]]
            pack $message -fill both -expand 1
        }

        proc check {} {
            return 1
        }

        proc apply {} {}

        proc variables {} {return {}}

        proc help {} {
            generalHelpWindow #configuration.application
        }

        namespace eval size {

            proc variables {} {
                return {canvasHeight canvasWidth}
            }

            proc initialize {} {
                variable height [configuration::initialize canvasHeight]
                variable width [configuration::initialize canvasWidth]
                variable automatic [expr {($width == 0) && ($height == 0)}]
                variable defaultMessage [mc {Canvas size (in pixels):}]
            }

            proc edit {parentPath} {
                variable height
                variable width
                variable message
                variable automatic
                variable entries
                variable defaultMessage

                set message [configuration::createMessage $parentPath.message -text $defaultMessage]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                set button [checkbutton $parentPath.automatic                    -text [mc {automatic scaling}] -command configuration::application::size::update                    -variable configuration::application::size::automatic                ]
                grid $button -row 1 -column 0 -columnspan 100 -pady 10
                set values {640 800 1024 1280 1600}
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    set widthEntry [new spinEntry $parentPath -width 4 -list $values]
                    spinEntry::set $widthEntry $width
                    grid $widget::($widthEntry,path) -row 2 -column 2
                    set path $composite::($widthEntry,entry,path)
                    set entries $widthEntry
                } else {
                    set path [spinbox $parentPath.widthEntry -width 4 -values $values]
                    $path set $width
                    grid $path -row 2 -column 2
                    set entries $path
                }
                $path configure -textvariable configuration::application::size::width
                setupEntryValidation $path {{checkMaximumLength 4 %P} {check31BitUnsignedInteger %P}}
                grid [label $parentPath.width -text [mc width:]] -row 2 -column 1 -padx 2
                grid columnconfigure $parentPath 3 -weight 1
                set values {400 480 600 768 1024 1280}
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    set heightEntry [new spinEntry $parentPath -width 4 -list $values]
                    spinEntry::set $heightEntry $height
                    grid $widget::($heightEntry,path) -row 2 -column 5
                    set path $composite::($heightEntry,entry,path)
                    lappend entries $heightEntry
                } else {
                    set path [spinbox $parentPath.heightEntry -width 4 -values $values]
                    $path set $height
                    grid $path -row 2 -column 5
                    lappend entries $path
                }
                $path configure -textvariable configuration::application::size::height
                setupEntryValidation $path {{checkMaximumLength 4 %P} {check31BitUnsignedInteger %P}}
                grid [label $parentPath.height -text [mc height:]] -row 2 -column 4 -padx 2
                grid columnconfigure $parentPath 6 -weight 1
                if {!$configuration::preferences} {
                    grid [button $parentPath.apply -text [mc Apply] -command configuration::application::size::apply]                        -row 3 -column 0 -columnspan 100
                }
                grid rowconfigure $parentPath 3 -weight 1
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    bind $message <Destroy> "delete $widthEntry $heightEntry"
                }
                update
            }

            proc update {} {
                variable automatic
                variable entries

                if {$automatic} {set state disabled} else {set state normal}
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    foreach entry $entries {
                        composite::configure $entry -state $state
                    }
                } else {
                    foreach entry $entries {
                        $entry configure -state $state
                    }
                }
            }

            proc check {} {
                variable height
                variable width
                variable message
                variable automatic
                variable defaultMessage

                if {!$automatic} {
                    if {([string length $width] == 0) || ($width == 0)} {
                        set error [mc {please set width}]
                    } elseif {([string length $height] == 0) || ($height == 0)} {
                        set error [mc {please set height}]
                    } elseif {[info exists message]} {
                        $message configure -font $font::(mediumNormal) -text $defaultMessage
                    }
                }
                if {[info exists error]} {
                    $message configure -font $font::(mediumBold) -text $error
                    return 0
                } else {
                    return 1
                }
            }

            proc apply {} {
                variable height
                variable width
                variable automatic

                if {![check]} return
                if {$automatic} {
                    set width 0; set height 0
                }
                configuration::apply canvasHeight $height
                configuration::apply canvasWidth $width
                if {!$configuration::preferences} {
                    pages::updateScrollRegion $global::canvas
                }
            }

            proc help {} {
                generalHelpWindow #configuration.application.size
            }

        }

        namespace eval colors {

            proc variables {} {
                return canvasBackground
            }

            proc initialize {} {
                variable background [configuration::initialize canvasBackground]
            }

            proc edit {parentPath} {
                variable background
                variable colorViewer

                set message [configuration::createMessage $parentPath.message -text [mc {Dashboard background color:}]]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                set colorViewer [button $parentPath.choose                    -text [mc Choose]... -command "configuration::application::colors::choose $parentPath"                ]
                updateColorViewer
                grid $colorViewer -row 1 -column 1
                grid columnconfigure $parentPath 1 -weight 1
                grid columnconfigure $parentPath 2 -weight 1
                grid rowconfigure $parentPath 2 -weight 1
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable background

                if {![check]} return
                configuration::apply canvasBackground $background
            }

            proc updateColorViewer {} {
                variable colorViewer
                variable background

                $colorViewer configure -background $background -foreground [visibleForeground $background]
            }

            proc choose {parentPath} {
                variable background

                set choice [tk_chooseColor -initialcolor $background -title [mc {Choose color:}] -parent $parentPath]
                if {[string length $choice] > 0} {
                    set background $choice
                    updateColorViewer
                }
            }

            proc help {} {
                generalHelpWindow #configuration.application.colors
            }

        }

        namespace eval background {

            proc variables {} {
                return [list canvasBackground canvasImageFile canvasImagePosition]
            }

            proc initialize {} {
                variable backgrounds
                variable images
                variable positions

                set data [pages::data]
                if {[llength $data] == 0} {
                    set backgrounds [list [configuration::initialize canvasBackground]]
                    set images [list [configuration::initialize canvasImageFile]]
                    set positions [list [configuration::initialize canvasImagePosition]]
                } else {
                    set backgrounds {}
                    set images {}
                    set positions {}
                    foreach {page label raised} $data {
                        lappend backgrounds [composite::cget $page -background]
                        lappend images [composite::cget $page -imagefile]
                        lappend positions [composite::cget $page -imageposition]
                    }
                }
            }

            proc edit {parentPath} {
                variable choosers
                variable backgrounds
                variable images
                variable positions
                variable book

                set message [configuration::createMessage $parentPath.message -text [mc {Dashboard background colors and images:}]]
                grid $message -row 0 -column 0
                foreach {left top right bottom} [bounds $global::canvas] {}
                set size [list [expr {$right - $left}] [expr {$bottom - $top}]]
                set data [pages::data]
                if {[llength $data] == 0} {
                    set file [lindex $images 0]
                    set chooser [new backgroundChooser $parentPath                        -font $font::(mediumNormal) -color [lindex $backgrounds 0] -targetsize $size                        -imagefile $file -useimage [expr {[string length $file] > 0}] -position [lindex $positions 0]                    ]
                    grid $widget::($chooser,path) -sticky nsew -row 1 -column 0
                    set choosers [list $chooser]
                } else {
                    set book [NoteBook $parentPath.book                        -background [$parentPath cget -background] -borderwidth 1 -internalborderwidth 0                        -font $font::(mediumNormal) -side $global::pagesTabPosition                    ]
                    set choosers {}
                    set first 1
                    foreach {index label raised} $data background $backgrounds file $images position $positions {
                        $book insert end $index
                        $book itemconfigure $index -text $label
                        set chooser [new backgroundChooser [$book getframe $index]                            -font $font::(mediumNormal) -color $background -targetsize $size                            -imagefile $file -useimage [expr {[string length $file] > 0}] -position $position                        ]
                        pack $widget::($chooser,path)
                        lappend choosers $chooser
                        if {$first} {
                            $book raise $index
                            set first 0
                        }
                        if {$raised} {$book raise $index}
                    }
                    grid $book -sticky nsew -row 1 -column 0
                    bind $message <Destroy> "destroy $book"
                }
                bind $message <Destroy> "+ delete $choosers; unset configuration::application::background::choosers"
                grid [button $parentPath.apply -text [mc Apply] -command configuration::application::background::apply]                    -row 2 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1
                grid rowconfigure $parentPath 2 -weight 1
            }

            proc check {} {
                variable backgrounds
                variable choosers
                variable images
                variable positions
                variable book

                if {[info exists choosers]} {
                    set backgrounds {}
                    set images {}
                    set positions {}
                    foreach chooser $choosers {
                        backgroundChooser::applyFileEntry $chooser
                        lappend backgrounds [composite::cget $chooser -color]
                        if {[composite::cget $chooser -useimage]} {
                            lappend images [composite::cget $chooser -imagefile]
                        } else {
                            lappend images {}
                        }
                        lappend positions [composite::cget $chooser -position]
                    }
                }
                return 1
            }

            proc apply {} {
                variable backgrounds
                variable images
                variable positions

                if {![check]} return
                set data [pages::data]
                if {[llength $data] == 0} {
                    set background [lindex $backgrounds 0]
                    set file [lindex $images 0]
                    set position [lindex $positions 0]
                    $global::canvas configure -background $background
                    updateCanvasImage $file
                    if {[string length $file] > 0} {
                        updateCanvasImagePosition $global::canvasImageItem $position
                    }
                    configuration::apply canvasBackground $background
                    configuration::apply canvasImageFile $file
                    configuration::apply canvasImagePosition $position
                } else {
                    configuration::apply canvasBackground $global::canvasBackground
                    foreach {page label raised} $data background $backgrounds file $images position $positions {
                        composite::configure $page -background $background -imagefile $file -imageposition $position
                    }
                }
                updateCanvasImagesPosition
                pages::updateScrollRegion $global::canvas
            }

            proc help {} {
                generalHelpWindow #configuration.application.background
            }

        }

        namespace eval fonts {

            proc variables {} {
                return {fontFamily fontSize}
            }

            proc initialize {} {
                variable family [configuration::initialize fontFamily]
                variable size [configuration::initialize fontSize]
            }

            proc edit {parentPath} {
                variable family
                variable size
                variable label

                grid rowconfigure $parentPath 0 -weight 1
                grid rowconfigure $parentPath 3 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 5 -weight 1
                set message [configuration::createMessage $parentPath.message                    -text [mc "Global font:\n(restart application for changes to take effect)"]
                ]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid [label $parentPath.family -text [mc Family:]] -row 1 -column 1 -padx 2
                set entry [new comboEntry $parentPath -font $widget::option(entry,font) -editable 0                    -list [lsort -dictionary [font families]] -command configuration::application::fonts::family                ]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::application::fonts::family
                composite::configure $entry button -listheight 10
                grid $widget::($entry,path) -row 1 -column 2
                set entry [new comboEntry $parentPath -font $widget::option(entry,font) -width 2 -editable 0                    -command configuration::application::fonts::size                    -list {0 2 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 24 25 26 32 33 34}                ]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::application::fonts::size
                composite::configure $entry button -listheight 10
                grid $widget::($entry,path) -row 1 -column 3
                grid [label $parentPath.pixels -text [mc pixels]] -row 1 -column 4 -padx 2
                set label [label $parentPath.label -background $widget::option(entry,background) -relief sunken                    -borderwidth 1 -pady 5 -text [mc "ABCDEFGHIJKLMNOPQRSTUVWXYZ\nabcdefghijklmnopqrstuvwxyz"]
                ]
                grid $label -sticky ew -row 2 -column 0 -columnspan 100 -padx 10 -pady 10
                bind $message <Destroy> "delete $objects"
                update
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable family
                variable size

                if {![check]} return
                configuration::apply fontFamily $family
                configuration::apply fontSize $size
            }

            proc help {} {
                generalHelpWindow #preferences.application.fonts
            }

            proc family {name} {
                variable family $name
                update
            }

            proc size {value} {
                variable size $value
                update
            }

            proc update {} {
                variable family
                variable size
                variable label

                $label configure -font -*-$family-medium-r-*-*-$size-*
            }

        }

        namespace eval printing {

            proc variables {} {
                return {printToFile fileToPrintTo printCommand printOrientation printPalette printPaperSize}
            }

            proc initialize {} {
                variable toFile [configuration::initialize printToFile]
                variable printFile [configuration::initialize fileToPrintTo]
                variable command [configuration::initialize printCommand]
                variable orientations
                variable orientation
                variable palettes
                variable palette
                variable sizes
                variable size

                if {![info exists orientations]} {
                    foreach orientation $global::printOrientations {lappend orientations [mc $orientation]}
                    foreach palette $global::printPalettes {lappend palettes [mc $palette]}
                    foreach size $global::printPaperSizes {lappend sizes [mc $size]}
                }
                set index [lsearch -exact $global::printOrientations [configuration::initialize printOrientation]]
                if {$index < 0} {set index 0}
                set orientation [lindex $orientations $index]
                set index [lsearch -exact $global::printPalettes [configuration::initialize printPalette]]
                if {$index < 0} {set index 0}
                set palette [lindex $palettes $index]
                set index [lsearch -exact $global::printPaperSizes [configuration::initialize printPaperSize]]
                if {$index < 0} {set index 0}
                set size [lindex $sizes $index]
            }

            proc edit {parentPath} {
                variable toFile
                variable printFile
                variable command
                variable orientations
                variable palettes
                variable sizes

                set objects {}
                set row 0
                set message [configuration::createMessage $parentPath.message -text [mc {Printing setup:}]]
                grid $message -sticky nsew -row $row -column 0 -columnspan 3
                grid rowconfigure $parentPath $row -weight 1
                incr row
                radiobutton $parentPath.toCommand                    -variable configuration::application::printing::toFile -value 0 -text [mc Command:]
                grid $parentPath.toCommand -row $row -column 0 -sticky w -padx 2
                entry $parentPath.command -textvariable configuration::application::printing::command
                grid $parentPath.command -row $row -column 1 -columnspan 2 -sticky ew -padx 2
                incr row
                radiobutton $parentPath.toFile -variable configuration::application::printing::toFile -value 1 -text [mc {to File:}]
                grid $parentPath.toFile -row $row -column 0 -sticky w -padx 2
                entry $parentPath.file -textvariable configuration::application::printing::printFile
                grid $parentPath.file -row $row -column 1 -sticky ew -padx 2
                button $parentPath.browse                    -text [mc Browse]... -command "configuration::application::printing::inquirePrintFile $parentPath"
                grid $parentPath.browse -row $row -column 2 -sticky ew -padx 2
                if {$toFile} {
                    $parentPath.toFile invoke
                } else {
                    $parentPath.toCommand invoke
                }
                incr row
                grid [label $parentPath.orientation -text [mc Orientation:]] -row $row -column 0 -sticky w -padx 2
                set entry [new comboEntry $parentPath -font $widget::option(entry,font) -list $orientations -editable 0]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::application::printing::orientation
                composite::configure $entry button -listheight [llength $orientations]
                composite::configure $entry button scroll -selectmode single
                grid $widget::($entry,path) -row $row -column 1 -columnspan 2 -sticky ew -padx 2
                incr row
                grid [label $parentPath.palette -text [mc Palette:]] -row $row -column 0 -sticky w -padx 2
                set entry [new comboEntry $parentPath -font $widget::option(entry,font) -list $palettes -editable 0]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::application::printing::palette
                composite::configure $entry button -listheight [llength $palettes]
                composite::configure $entry button scroll -selectmode single
                grid $widget::($entry,path) -row $row -column 1 -columnspan 2 -sticky ew -padx 2
                incr row
                grid [label $parentPath.size -text [mc {Paper size:}]] -row $row -column 0 -sticky w -padx 2
                set entry [new comboEntry $parentPath -font $widget::option(entry,font) -list $sizes -editable 0]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::application::printing::size
                composite::configure $entry button -listheight [llength $sizes]
                composite::configure $entry button scroll -selectmode single
                grid $widget::($entry,path) -row $row -column 1 -columnspan 2 -sticky ew -padx 2
                grid rowconfigure $parentPath [incr row] -weight 1
                grid columnconfigure $parentPath 1 -weight 1
                bind $message <Destroy> "delete $objects"
            }

            proc inquirePrintFile {parentPath} {
                variable printFile

                set file [tk_getSaveFile                    -title [mc {moodss: Print to file}] -parent $parentPath -initialdir [file dirname $printFile]                    -defaultextension .ps -filetypes [list {Postscript .ps} [list [mc {All files}] *]]                    -initialfile [file tail $printFile]                ]
                if {[string length $file] > 0} {
                    set printFile $file
                }
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable toFile
                variable printFile
                variable command
                variable orientations
                variable orientation
                variable palettes
                variable palette
                variable size
                variable sizes

                configuration::apply printToFile $toFile 1
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    if {[string length $printFile] > 0} {set file [file join [pwd] $printFile]} else {set file {}}
                    configuration::apply fileToPrintTo $file
                } else {
                    configuration::apply fileToPrintTo [file normalize $printFile] 1
                }
                configuration::apply printCommand $command 1
                set index [lsearch -exact $orientations $orientation]; if {$index < 0} {set index 0}
                configuration::apply printOrientation [lindex $global::printOrientations $index] 1
                set index [lsearch -exact $palettes $palette]; if {$index < 0} {set index 0}
                configuration::apply printPalette [lindex $global::printPalettes $index] 1
                set index [lsearch -exact $sizes $size]; if {$index < 0} {set index 0}
                configuration::apply printPaperSize [lindex $global::printPaperSizes $index] 1
            }

            proc help {} {
                generalHelpWindow #preferences.application.printing
            }

        }

        namespace eval pages {

            proc variables {} {
                return pagesTabPosition
            }

            proc initialize {} {
                variable position [configuration::initialize pagesTabPosition]
            }

            proc edit {parentPath} {
                set message [configuration::createMessage $parentPath.message -text [mc {Pages tab position:}]]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                grid [                    radiobutton $parentPath.top -variable configuration::application::pages::position -value top -text [mc top]                ] -row 1 -column 1
                grid [                    radiobutton $parentPath.bottom -variable configuration::application::pages::position -value bottom                    -text [mc bottom]                ] -row 1 -column 2
                grid columnconfigure $parentPath 3 -weight 1
                grid rowconfigure $parentPath 2 -weight 1
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable position

                configuration::apply pagesTabPosition $position
                pages::labelsSide $position
            }

            proc help {} {
                generalHelpWindow #preferences.application.pages
            }

        }

        namespace eval database {

            proc variables {} {
                return databaseOptions
            }

            proc initialize {} {
                variable data
                variable password
                variable type

                set data(-file) {}
                set data(-database) {}
                array set data [configuration::initialize databaseOptions]
                if {[string length $data(-dsn)] > 0} {
                    set type odbc
                } elseif {[string length $data(-host)] > 0} {
                    set type mysql
                    if {[string length $data(-database)] == 0} {set data(-database) moodss}
                } else {
                    set type sqlite
                    if {[string length $data(-file)] == 0} {set data(-file) $global::sqliteDefaultFile}
                }
                catch {set password $data(-password)}
                if {![info exists data(-debuglevel)]} {
                    set data(-debuglevel) 0
                }
                if {![string equal $::tcl_platform(platform) unix]} {set data(-debuglevel) 0}
            }

            proc edit {parentPath} {
                variable data
                variable message
                variable label
                variable radioButton
                variable checkButton
                variable entry
                variable password
                variable type

                set row 0
                set text [mc {Database setup:}]
                if {$global::database != 0} {
                    append text \n
                    append text [mc {(please disconnect from database first)}]
                }
                set message [configuration::createMessage $parentPath.message -text $text]
                grid $message -sticky nsew -row $row -column 0 -columnspan 100
                grid rowconfigure $parentPath $row -weight 1
                incr row
                set radioButton(file) [radiobutton $parentPath.fileChoice                    -variable configuration::application::database::type -value sqlite -text [mc {SQLite file:}]                    -command configuration::application::database::update                ]
                grid $radioButton(file) -row $row -column 0 -sticky w -padx 2
                set entry(file) [entry $parentPath.file -textvariable configuration::application::database::data(-file)]
                grid $entry(file) -row $row -column 1 -columnspan 3 -sticky ew -padx 2
                set entry(choose) [button $parentPath.chooseFile                    -text [mc Choose]... -command "configuration::application::database::inquireSQLiteFile $parentPath"                ]
                grid $entry(choose) -row $row -column 4 -sticky e -padx 2
                incr row
                set radioButton(dsn) [radiobutton $parentPath.dsnChoice                    -variable configuration::application::database::type -value odbc -text [mc {ODBC DSN:}]                    -command configuration::application::database::update                ]
                grid $radioButton(dsn) -row $row -column 0 -sticky w -padx 2
                set entry(dsn) [entry $parentPath.dsn -textvariable configuration::application::database::data(-dsn)]
                grid $entry(dsn) -row $row -column 1 -columnspan 100 -sticky ew -padx 2
                incr row
                set radioButton(host) [radiobutton $parentPath.hostChoice                    -variable configuration::application::database::type -value mysql -text [mc {MySQL host:}]                    -command configuration::application::database::update                ]
                grid $radioButton(host) -row $row -column 0 -sticky w -padx 2
                set entry(host) [entry $parentPath.host -textvariable configuration::application::database::data(-host)]
                grid $entry(host) -row $row -column 1 -columnspan 100 -sticky ew -padx 2
                incr row
                set label(user) [label $parentPath.userLabel -text [mc user:]]
                grid $label(user) -row $row -column 0 -sticky w -padx 2
                set entry(user) [entry $parentPath.user -textvariable configuration::application::database::data(-user)]
                grid $entry(user) -row $row -column 1 -columnspan 100 -sticky ew -padx 2
                incr row
                set label(password) [label $parentPath.passwordLabel -text [mc password:]]
                grid $label(password) -row $row -column 0 -sticky w -padx 2
                set entry(password) [entry $parentPath.password                    -textvariable configuration::application::database::data(-password) -width 8 -show *                ]
                grid $entry(password) -row $row -column 1 -sticky ew -padx 2
                set label(confirm) [label $parentPath.confirmLabel -text [mc confirm:]]
                grid $label(confirm) -row $row -column 2 -padx 2
                set entry(confirm)                    [entry $parentPath.confirm -textvariable configuration::application::database::password -width 8 -show *]
                grid $entry(confirm) -row $row -column 3 -sticky ew -padx 2 -columnspan 2
                incr row
                set label(port) [label $parentPath.portLabel -text [mc port:]]
                grid $label(port) -row $row -column 0 -sticky w -padx 2
                set entry(port) [entry $parentPath.port -textvariable configuration::application::database::data(-port)]
                setupEntryValidation $entry(port) {{check31BitUnsignedInteger %P}}
                grid $parentPath.port -row $row -column 1 -columnspan 100 -sticky ew -padx 2
                incr row
                set label(database) [label $parentPath.databaseLabel -text [mc database:]]
                grid $label(database) -row $row -column 0 -sticky w -padx 2
                set entry(database) [entry $parentPath.database -textvariable configuration::application::database::data(-database)]
                grid $parentPath.database -row $row -column 1 -columnspan 100 -sticky ew -padx 2
                incr row
                set checkButton(trace) [checkbutton $parentPath.trace                    -variable configuration::application::database::data(-debuglevel) -text [mc {Trace SQL statements and queries}]                ]
                if {![string equal $::tcl_platform(platform) unix]} {$checkButton(trace) configure -state disabled}
                grid $checkButton(trace) -row $row -column 0 -columnspan 100 -sticky w -padx 2
                grid rowconfigure $parentPath [incr row] -weight 1
                grid columnconfigure $parentPath 1 -weight 1
                grid columnconfigure $parentPath 3 -weight 1
                update
            }

            proc update {} {
                variable data
                variable type
                variable label
                variable radioButton
                variable checkButton
                variable entry

                if {$global::database != 0} {
                    foreach name {file dsn host} {$radioButton($name) configure -state disabled}
                    foreach name {user password confirm port database} {$label($name) configure -state disabled}
                    foreach name {file choose dsn host user password confirm port database} {
                        $entry($name) configure -state disabled
                    }
                    $checkButton(trace) configure -state disabled
                    return
                }
                switch $type {
                    sqlite {
                        foreach name {file choose} {$entry($name) configure -state normal}
                        foreach name {user password confirm port database} {$label($name) configure -state disabled}
                        foreach name {dsn host user password confirm port database} {$entry($name) configure -state disabled}
                        if {[string length $data(-file)] == 0} {set data(-file) moodss.dat}
                        focus $entry(file)
                    }
                    odbc {
                        foreach name {user password confirm} {$label($name) configure -state normal}
                        foreach name {dsn user password confirm} {$entry($name) configure -state normal}
                        foreach name {port database} {$label($name) configure -state disabled}
                        foreach name {file host choose port database} {$entry($name) configure -state disabled}
                        focus $entry(dsn)
                    }
                    mysql {
                        foreach name {user password confirm port database} {$label($name) configure -state normal}
                        foreach name {host user password confirm port database} {$entry($name) configure -state normal}
                        foreach name {file dsn choose} {$entry($name) configure -state disabled}
                        if {[string length $data(-host)] == 0} {set data(-host) localhost}
                        if {[string length $data(-database)] == 0} {set data(-database) moodss}
                        focus $entry(host)
                    }
                }
            }

            proc inquireSQLiteFile {parentPath} {
                variable data

                set file [tk_getSaveFile                    -title [mc {moodss: SQLite file}] -parent $parentPath                    -initialdir [file dirname $data(-file)] -initialfile [file tail $data(-file)]                ]
                if {[string length $file] > 0} {
                    set data(-file) $file
                }
            }

            proc check {} {
                variable data
                variable message
                variable type
                variable entry
                variable password

                if {![string equal $type sqlite] && ![string equal $data(-password) $password]} {
                    $message configure -font $font::(mediumBold) -text [mc {passwords do not match:}]
                    focus $entry(password)
                    return 0
                }
                switch $type {
                    sqlite {
                        if {[string length $data(-file)] == 0} {
                            $message configure -font $font::(mediumBold) -text [mc {a file name is needed:}]
                            focus $entry(file)
                            return 0
                        }
                        foreach name {host dsn user password port database} {set data(-$name) {}}
                    }
                    odbc {
                        if {[string length $data(-dsn)] == 0} {
                            $message configure -font $font::(mediumBold) -text [mc {a DSN is needed:}]
                            focus $entry(dsn)
                            return 0
                        }
                        foreach name {file host database} {set data(-$name) {}}
                    }
                    mysql {
                        if {[string length $data(-host)] == 0} {
                            $message configure -font $font::(mediumBold) -text [mc {a host is needed:}]
                            focus $entry(host)
                            return 0
                        }
                        if {[string equal $data(-host) localhost] && ([string length $data(-port)] > 0)} {
                            $message configure -font $font::(mediumBold) -text [mc {port useless with local socket connection:}]
                            focus $entry(port)
                            return 0
                        }
                        if {[string length $data(-database)] == 0} {
                            $message configure -font $font::(mediumBold) -text [mc {a database name is needed:}]
                            focus $entry(database)
                            return 0
                        }
                        foreach name {file dsn} {set data(-$name) {}}
                    }
                }
                return 1
            }

            proc apply {} {
                variable data

                if {![check]} return
                if {[string length $data(-file)] > 0} {
                    if {[package vcompare $::tcl_version 8.4] < 0} {
                        if {[string length $data(-file)] > 0} {set data(-file) [file join [pwd] $data(-file)]}
                    } else {
                        set data(-file) [file normalize $data(-file)]
                    }
                }
                configuration::apply databaseOptions [array get data] 1
            }

            proc help {} {
                generalHelpWindow #preferences.application.database
            }

        }

        namespace eval trace {

            proc variables {} {
                return traceNumberOfRows
            }

            proc initialize {} {
                variable numberOfRows [configuration::initialize traceNumberOfRows]
            }

            proc edit {parentPath} {
                variable numberOfRows
                variable message

                grid rowconfigure $parentPath 0 -weight 1
                grid rowconfigure $parentPath 2 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 3 -weight 1
                set message [configuration::createMessage $parentPath.message -text [mc {Trace window configuration:}]]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid [label $parentPath.rows -text [mc {number of rows:}]] -row 1 -column 1 -padx 2 -sticky w
                set values {5 10 15 20 30 50 100}
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    set entry [new spinEntry $parentPath -width 4 -list $values]
                    bind $message <Destroy> "delete $entry"
                    spinEntry::set $entry $numberOfRows
                    grid $widget::($entry,path) -row 1 -column 2 -sticky e
                    set path $composite::($entry,entry,path)
                } else {
                    set path [spinbox $parentPath.entry -width 4 -values $values]
                    $path set $numberOfRows
                    grid $path -row 1 -column 2 -sticky e
                }
                $path configure -textvariable configuration::application::trace::numberOfRows
                setupEntryValidation $path {{checkMaximumLength 4 %P} {check31BitUnsignedInteger %P}}
            }

            proc check {} {
                variable numberOfRows
                variable message

                set valid 1
                if {[string length $numberOfRows] == 0} {
                    set text [mc {please set number of rows}]
                    set valid 0
                } elseif {$numberOfRows == 0} {
                    set text [mc {number of rows cannot be set to 0}]
                    set valid 0
                }
                if {!$valid} {
                    $message configure -font $font::(mediumBold) -text $text
                }
                return $valid
            }

            proc apply {} {
                variable numberOfRows

                if {![check]} return
                configuration::apply traceNumberOfRows $numberOfRows 1
            }

            proc help {} {
                generalHelpWindow #preferences.application.trace
            }

        }

    }


    namespace eval viewers {

        proc initialize {} {}

        proc edit {parentPath} {
            set message [configuration::createMessage $parentPath.message -text [mc {Viewers configuration}]]
            pack $message -fill both -expand 1
        }

        proc check {} {
            return 1
        }

        proc apply {} {}

        proc variables {} {return {}}

        proc help {} {
            generalHelpWindow #configuration.viewers
        }

        namespace eval colors {

            proc variables {} {
                return viewerColors
            }

            proc initialize {} {
                variable colors [configuration::initialize viewerColors]
            }

            proc edit {parentPath} {
                variable colorsFrame

                set message [configuration::createMessage $parentPath.message -text [mc {Change colors:}]]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                set colorsFrame [frame $parentPath.colors -borderwidth 1 -background black]
                refresh
                grid $colorsFrame -row 1 -column 0
                grid rowconfigure $parentPath 2 -weight 1
            }

            proc refresh {} {
                variable colors
                variable colorsFrame

                eval destroy [winfo children $colorsFrame]
                set index 0
                foreach color $colors {
                    set button [button $colorsFrame.$index -background $color -activebackground $color -borderwidth 1]
                    $button configure -command "configuration::viewers::colors::choose $index"
                    pack $button -side left
                    incr index
                }
            }

            proc choose {index} {
                variable colors
                variable colorsFrame

                set button $colorsFrame.$index
                set background [tk_chooseColor -initialcolor [$button cget -background] -title [mc {Choose color:}] -parent $button]
                if {[string length $background] > 0} {
                    $button configure -background $background
                    set colors [lreplace $colors $index $index $background]
                }
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable colors
                variable colorsFrame

                if {![check]} return
                if {![info exists colorsFrame]} return
                configuration::apply viewerColors $colors
            }

            proc help {} {
                generalHelpWindow #configuration.viewers.colors
            }

        }

        namespace eval graphs {

            proc variables {} {
                return [list                    graphNumberOfIntervals graphMinimumY graphXAxisLabelsRotation graphLabelsPosition graphPlotBackground                    graphDisplayGrid                ]
            }

            proc initialize {} {
                variable numberOfSamples [configuration::initialize graphNumberOfIntervals]
                variable zeroBasedOrdinate [string equal [configuration::initialize graphMinimumY] 0]
                variable degrees [configuration::initialize graphXAxisLabelsRotation]
                variable labelsPositions
                variable labelsPositionsWidth
                variable labelsPosition
                variable plotBackground [configuration::initialize graphPlotBackground]
                variable grid [configuration::initialize graphDisplayGrid]

                if {![info exists labelsPositions]} {
                    set labelsPositionsWidth 0
                    foreach position $global::graphLabelsPositions {
                        lappend labelsPositions [set position [mc $position]]
                        set length [string length $position]
                        if {$length > $labelsPositionsWidth} {set labelsPositionsWidth $length}
                    }
                }
                set index [lsearch -exact $global::graphLabelsPositions [configuration::initialize graphLabelsPosition]]
                if {$index < 0} {set index 0}
                set labelsPosition [lindex $labelsPositions $index]
            }

            proc edit {parentPath} {
                variable numberOfSamples
                variable degrees
                variable message
                variable labelsPositions
                variable labelsPositionsWidth
                variable labelsPosition
                variable colorViewer

                grid rowconfigure $parentPath 0 -weight 1
                grid rowconfigure $parentPath 7 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 4 -weight 1
                set message [configuration::createMessage $parentPath.message -text [mc {Data graphs settings:}]]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                if {[info exists databaseInstances::singleton]} {
                    set state disabled
                } else {
                    set state normal
                }
                grid [label $parentPath.samplesLabel -text [mc {X axis:}] -state $state] -row 1 -column 1 -padx 2 -sticky e
                grid [set frame [frame $parentPath.samples]] -row 1 -column 2 -columnspan 100 -sticky w
                set values {20 50 100 150 200 300 500 1000}
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    set entry [new spinEntry $frame -width 4 -side right -list $values -state $state]
                    lappend objects $entry
                    spinEntry::set $entry $numberOfSamples
                    pack $widget::($entry,path) -side left
                    set path $composite::($entry,entry,path)
                } else {
                    set path [spinbox $frame.entry -width 4 -values $values -state $state]
                    $path set $numberOfSamples
                    pack $path -side left
                }
                $path configure -textvariable configuration::viewers::graphs::numberOfSamples
                setupEntryValidation $path {{checkMaximumLength 4 %P} {check31BitUnsignedInteger %P}}
                pack [label $frame.samples -text [mc samples] -state $state] -side left
                grid [label $parentPath.yAxis -text [mc {Y axis:}]] -row 2 -column 1 -padx 2 -sticky e
                grid [set frame [frame $parentPath.scale]] -row 2 -column 2 -columnspan 100 -sticky w
                set button [radiobutton $frame.zero                    -variable ::configuration::viewers::graphs::zeroBasedOrdinate -value 1 -text [mc {zero based}]                ]
                pack $button -side left
                set button [radiobutton $frame.scale                    -variable ::configuration::viewers::graphs::zeroBasedOrdinate -value 0 -text [mc {auto scale}]                ]
                pack $button -side left
                grid [label $parentPath.rotationLabel -text [mc {X axis labels rotation:}]] -row 3 -column 1 -padx 2 -sticky e
                grid [set frame [frame $parentPath.rotation]] -row 3 -column 2 -columnspan 100 -sticky w
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    set entry [new spinEntry $frame -width 2 -side right -editable 0 -range {45 90 5}]
                    lappend objects $entry
                    spinEntry::set $entry $degrees
                    pack $widget::($entry,path) -side left
                    set path $composite::($entry,entry,path)
                } else {
                    set path [spinbox $frame.entry -width 2 -state readonly -from 45 -to 90 -increment 5]
                    $path set $degrees
                    pack $path -side left
                }
                $path configure -textvariable configuration::viewers::graphs::degrees
                pack [label $frame.degrees -text [mc degrees]] -side left
                grid [label $parentPath.labelsLabel -text [mc {Position of labels:}]] -row 4 -column 1 -padx 2 -sticky e
                set entry [new comboEntry $parentPath                    -font $widget::option(entry,font) -editable 0 -list $labelsPositions -width $labelsPositionsWidth                ]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::viewers::graphs::labelsPosition
                composite::configure $entry button -listheight 4
                grid $widget::($entry,path) -row 4 -column 2 -columnspan 100 -sticky w -padx 2
                grid [label $parentPath.backgroundLabel -text [mc {Plot background:}]] -row 5 -column 1 -padx 2 -sticky e
                set colorViewer [button $parentPath.choose                    -text [mc Choose]... -command "configuration::viewers::graphs::choose $parentPath"                ]
                grid $colorViewer -row 5 -column 2 -columnspan 100 -sticky w -padx 2
                updateColorViewer
                grid rowconfigure $parentPath 5 -pad 2
                grid [label $parentPath.gridLabel -text [mc Grid:]] -row 6 -column 1 -padx 2 -sticky e
                grid [set frame [frame $parentPath.grid]] -row 6 -column 2 -columnspan 100 -sticky w
                set button [radiobutton $frame.on -variable ::configuration::viewers::graphs::grid -value 1 -text [mc displayed]]
                pack $button -side left
                set button [radiobutton $frame.off -variable ::configuration::viewers::graphs::grid -value 0 -text [mc hidden]]
                pack $button -side left
                if {!$configuration::preferences} {
                    grid [button $parentPath.apply -text [mc Apply] -command configuration::viewers::graphs::apply]                        -row 7 -column 0 -columnspan 100
                }
                if {[info exists objects]} {
                    bind $message <Destroy> "delete $objects"
                }
            }

            proc updateColorViewer {} {
                variable colorViewer
                variable plotBackground

                $colorViewer configure -background $plotBackground -foreground [visibleForeground $plotBackground]
            }

            proc choose {parentPath} {
                variable plotBackground

                set choice [tk_chooseColor -initialcolor $plotBackground -title [mc {Choose color:}] -parent $parentPath]
                if {[string length $choice] > 0} {
                    set plotBackground $choice
                    updateColorViewer
                }
            }

            proc check {} {
                variable numberOfSamples
                variable message

                set valid 1
                if {[string length $numberOfSamples] == 0} {
                    set text [mc {please set number of samples}]
                    set valid 0
                } elseif {$numberOfSamples == 0} {
                    set text [mc {number of samples cannot be set to 0}]
                    set valid 0
                }
                if {!$valid} {
                    $message configure -font $font::(mediumBold) -text $text
                }
                return $valid
            }

            proc apply {} {
                variable numberOfSamples
                variable zeroBasedOrdinate
                variable degrees
                variable labelsPositions
                variable labelsPosition
                variable plotBackground
                variable grid

                if {![check]} return
                configuration::apply graphNumberOfIntervals $numberOfSamples
                if {$zeroBasedOrdinate} {set minimum 0} else {set minimum {}}
                configuration::apply graphMinimumY $minimum
                configuration::apply graphXAxisLabelsRotation $degrees
                set index [lsearch -exact $labelsPositions $labelsPosition]; if {$index < 0} {set index 0}
                configuration::apply graphLabelsPosition [set position [lindex $global::graphLabelsPositions $index]]
                configuration::apply graphPlotBackground $plotBackground
                configuration::apply graphDisplayGrid $grid
                if {$configuration::preferences} return
                foreach graph $bltGraph::(graphs) {
                    composite::configure $graph -samples $numberOfSamples -xlabelsrotation $degrees -labelsposition $position                        -plotbackground $plotBackground -grid $grid
                    catch {composite::configure $graph -yminimum $minimum}
                }
                foreach chart $dataBarChart::(list) {
                    composite::configure $chart -labelsposition $position
                    catch {composite::configure $chart -yminimum $minimum}
                }
                if {[info exists databaseInstances::singleton]} {
                    composite::configure $databaseInstances::singleton -xlabelsrotation $degrees -plotbackground $plotBackground
                }
            }

            proc help {} {
                generalHelpWindow #configuration.viewers.graphs
            }

        }

        namespace eval pies {

            proc variables {} {
                return pieLabeler
            }

            proc initialize {} {
                variable labeler [configuration::initialize pieLabeler]
            }

            proc edit {parentPath} {
                set message [configuration::createMessage $parentPath.message -text [mc {Data values position:}]]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                set button [radiobutton $parentPath.box                    -variable ::configuration::viewers::pies::labeler -value box -text [mc {next to labels}]                ]
                grid $button -row 1 -column 1
                set button [radiobutton $parentPath.peripheral                    -variable ::configuration::viewers::pies::labeler -value peripheral -text [mc peripheral]                ]
                grid $button -row 1 -column 2
                grid columnconfigure $parentPath 3 -weight 1
                grid rowconfigure $parentPath 2 -weight 1
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable labeler

                if {![check]} return
                configuration::apply pieLabeler $labeler
            }

            proc help {} {
                generalHelpWindow #configuration.viewers.pies
            }

        }

        namespace eval tables {

            proc variables {} {
                return currentValueTableRows
            }

            proc initialize {} {
                variable numberOfRows [configuration::initialize currentValueTableRows]
            }

            proc edit {parentPath} {
                variable numberOfRows
                variable message

                grid rowconfigure $parentPath 0 -weight 1
                grid rowconfigure $parentPath 2 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 3 -weight 1
                set message [configuration::createMessage $parentPath.message                    -text [mc {Values table settings (in database history mode):}]                ]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid [label $parentPath.rows -text [mc {maximum number of rows:}]] -row 1 -column 1 -padx 2 -sticky w
                set values {10 20 50 100 200 500 1000 2000 5000 10000}
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    set entry [new spinEntry $parentPath -width 6 -list $values]
                    bind $message <Destroy> "delete $entry"
                    spinEntry::set $entry $numberOfRows
                    grid $widget::($entry,path) -row 1 -column 2 -sticky e
                    set path $composite::($entry,entry,path)
                } else {
                    set path [spinbox $parentPath.entry -width 6 -values $values]
                    $path set $numberOfRows
                    grid $path -row 1 -column 2 -sticky e
                }
                $path configure -textvariable configuration::viewers::tables::numberOfRows
                setupEntryValidation $path {{checkMaximumLength 6 %P} {check31BitUnsignedInteger %P}}
            }

            proc check {} {
                variable numberOfRows
                variable message

                set valid 1
                if {[string length $numberOfRows] == 0} {
                    set text [mc {please set number of rows}]
                    set valid 0
                } elseif {$numberOfRows == 0} {
                    set text [mc {number of rows cannot be set to 0}]
                    set valid 0
                }
                if {!$valid} {
                    $message configure -font $font::(mediumBold) -text $text
                }
                return $valid
            }

            proc apply {} {
                variable numberOfRows

                if {![check]} return
                configuration::apply currentValueTableRows $numberOfRows
            }

            proc help {} {
                generalHelpWindow #configuration.viewers.tables
            }

        }

        namespace eval cells {

            proc variables {} {
                return cellsLabelModuleHeader
            }

            proc initialize {} {
                variable identify [configuration::initialize cellsLabelModuleHeader]
            }

            proc edit {parentPath} {
                set message [configuration::createMessage $parentPath.message                    -text [mc "Whether module identifier\nis included in data cells labels:"]                ]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                grid [radiobutton $parentPath.top -variable configuration::viewers::cells::identify -value 1 -text [mc yes]]                    -row 1 -column 1
                grid [radiobutton $parentPath.bottom -variable configuration::viewers::cells::identify -value 0 -text [mc no]]                    -row 1 -column 2
                grid columnconfigure $parentPath 3 -weight 1
                grid rowconfigure $parentPath 2 -weight 1
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable identify

                if {![check]} return
                configuration::apply cellsLabelModuleHeader $identify
                if {$configuration::preferences} return
                foreach viewer $viewer::(list) {
                    viewer::updateLabels $viewer
                }
            }

            proc help {} {
                generalHelpWindow #configuration.viewers.cells
            }

        }

    }


    namespace eval thresholds {

        proc initialize {} {}

        proc edit {parentPath} {
            set message [configuration::createMessage $parentPath.message -text [mc {Thresholds configuration}]]
            pack $message -fill both -expand 1
        }

        proc check {} {
            return 1
        }

        proc apply {} {}

        proc variables {} {return {}}

        proc help {} {
            generalHelpWindow #preferences.thresholds
        }

        namespace eval email {

            proc variables {} {
                return {fromAddress smtpServers mailSubject mailBody}
            }

            proc initialize {} {
                variable from [configuration::initialize fromAddress]
                variable servers [configuration::initialize smtpServers]
                variable subject [configuration::initialize mailSubject]
                variable body [configuration::initialize mailBody]
            }

            proc edit {parentPath} {
                variable servers
                variable list
                variable body
                variable text
                variable parent $parentPath
                variable message

                set row 0
                set message [configuration::createMessage $parentPath.message -text [mc {Mail settings:}]]
                grid $message -row $row -column 0 -columnspan 3 -pady 5
                incr row
                set label [label $parentPath.from -text [mc {From address:}]]
                grid $label -row $row -column 0 -columnspan 2 -sticky w -padx 2
                set entry [entry $parentPath.address -textvariable configuration::thresholds::email::from]
                grid $entry -row $row -column 2 -sticky ew -padx 2
                incr row
                set label [label $parentPath.out -justify left -text [mc "Outgoing mail\nSMTP servers:"]]
                grid $label -row $row -column 0 -columnspan 2 -sticky nw -padx 2
                set list [new listEntry $parentPath]
                listEntry::set $list $servers
                grid $widget::($list,path) -row $row -column 2 -sticky nsew -padx 2
                incr row
                set label [label $parentPath.subjectLabel -text [mc Subject:]]
                grid $label -row $row -column 0 -sticky w -padx 2
                set font $font::(fixedNormal)
                set entry [entry $parentPath.subject -font $font -textvariable configuration::thresholds::email::subject]
                grid $entry -row $row -column 1 -columnspan 2 -sticky ew -padx 2
                incr row
                set label [label $parentPath.bodyLabel -text [mc Body:]]
                grid $label -row $row -column 0 -sticky nw -padx 2
                set text [text $parentPath.body -height 1 -background white -font $font]
                $text insert end $body
                setupTextBindings $text
                grid $text -row $row -column 1 -rowspan 2 -columnspan 2 -sticky nsew -padx 2
                incr row
                set button [button $parentPath.default                    -text [mc Default] -command configuration::thresholds::email::default -padx 2                ]
                set tip [new widgetTip -path $button -text [mc {reset email message subject and body to default values}]]
                bind $button <Destroy> "delete $tip"
                grid $button -row $row -column 0 -sticky s
                grid [frame $parentPath.filler -height [font metrics $font -ascent]]
                grid rowconfigure $parentPath $row -weight 1
                grid columnconfigure $parentPath 2 -weight 1
                bind $message <Destroy> "delete $list; unset configuration::thresholds::email::list"
            }

            proc default {} {
                variable subject
                variable body
                variable text

                set subject $global::mail(subject,default)
                set body $global::mail(body,default)
                $text delete 1.0 end
                $text insert end $body
            }

            proc check {} {
                variable from
                variable parent
                variable message

                set from [string trim $from]
                if {[string length $from] == 0} {
                    $message configure -font $font::(mediumBold) -text [mc {please set From address}]
                    return 0
                }
                if {[string length [emailAddressError $from]] > 0} {
                    tk_messageBox -parent $parent -title [mc {moodss: Email error}] -type ok -icon error                        -message "$from: [emailAddressError $from]"
                    return 0
                }
                return 1
            }

            proc apply {} {
                variable from
                variable servers
                variable subject
                variable body
                variable text
                variable list

                configuration::apply fromAddress $from 1
                if {[info exists list]} {
                    set servers [listEntry::get $list]
                    set body [$text get 1.0 end]
                }
                configuration::apply smtpServers $servers 1
                configuration::apply mailSubject [string trim $subject] 1
                configuration::apply mailBody [string trim $body] 1
            }

            proc help {} {
                generalHelpWindow #preferences.thresholds.email
            }

        }

        namespace eval trace {

            proc variables {} {
                return traceThresholds
            }

            proc initialize {} {
                variable trace [configuration::initialize traceThresholds]
            }

            proc edit {parentPath} {
                set message [configuration::createMessage $parentPath.message                    -text [mc "Whether thresholds messages\nare sent to the trace module:"]]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                set button [radiobutton $parentPath.yes -variable ::configuration::thresholds::trace::trace -value 1 -text [mc yes]]
                grid $button -row 1 -column 1
                set button [radiobutton $parentPath.no -variable ::configuration::thresholds::trace::trace -value 0 -text [mc no]]
                grid $button -row 1 -column 2
                grid columnconfigure $parentPath 3 -weight 1
                grid rowconfigure $parentPath 2 -weight 1
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable trace

                if {![check]} return
                configuration::apply traceThresholds $trace 1
            }

            proc help {} {
                generalHelpWindow #preferences.thresholds.trace
            }

        }

    }


    namespace eval daemon {

        proc variables {} {
            return moompsResourceFile
        }

        proc initialize {} {
            variable file [configuration::initialize moompsResourceFile]
            variable current $file
        }

        proc edit {parentPath} {
            variable file
            variable message

            set message [configuration::createMessage $parentPath.message]
            resetMessage $message
            grid $message -sticky nsew -row 0 -column 0 -columnspan 100
            grid rowconfigure $parentPath 0 -weight 1
            grid [label $parentPath.label -text [mc {Preferences file:}]] -row 1 -column 0 -sticky w -padx 2
            entry $parentPath.file -textvariable configuration::daemon::file -width 32
            grid $parentPath.file -row 2 -column 0 -sticky ew -padx 2
            grid columnconfigure $parentPath 0 -weight 1
            button $parentPath.browse -text [mc Browse]... -command "configuration::daemon::inquireFile $parentPath"
            grid $parentPath.browse -row 2 -column 1 -sticky e -padx 2
            grid rowconfigure $parentPath 3 -weight 1
        }

        proc resetMessage {message} {
            $message configure -font $font::(mediumNormal) -text [mc {moomps daemon configuration:}]
        }

        proc inquireFile {parentPath} {
            variable file

            set value [tk_getSaveFile                -title [mc {moodss: Daemon preferences file}] -parent $parentPath                -initialdir [file dirname $file] -initialfile [file tail $file]            ]
            if {[string length $value] > 0} {
                set file $value
            }
        }

        proc check {} {
            variable file
            variable message

            resetMessage $message
            set user $::tcl_platform(user)
            if {[file exists $file]} {
                if {[file isdirectory $file]} {
                    set error [mc {file cannot be a directory}]
                } elseif {![file writable $file]} {
                    set error [format [mc {file not writable by user: %s}] $user]
                } elseif {![catch {set channel [open $file]} error]} {
                    unset error
                    gets $channel
                    set line [string trim [gets $channel]]
                    if {![string equal $line {<!DOCTYPE moompsPreferences>}]} {
                        set error [mc {not a moomps preferences file}]
                    }
                    close $channel
                }
            } elseif {![file writable [file dirname $file]]} {
                set error [format [mc "directory: %1\$s\nnot writable by user: %2\$s"] [file dirname $file] $user]
            }
            if {[info exists error]} {
                $message configure -font $font::(mediumBold) -text $error
                return 0
            } else {
                return 1
            }
        }

        proc apply {} {
            variable file
            variable current

            if {[string equal $file $current]} return
            if {![check]} return
            set current $file
            if {[package vcompare $::tcl_version 8.4] < 0} {
                if {[string length $file] > 0} {set file [file join [pwd] $file]}
                configuration::apply moompsResourceFile $file 1
            } else {
                configuration::apply moompsResourceFile [file normalize $file] 1
            }
        }

        proc help {} {
            generalHelpWindow #preferences.moomps
        }

    }

    variable variables
    set variables(0) {}
    set variables(1) {}
    foreach entry $hierarchy forPreferences $prefer forConfiguration $configure {
        regsub -all {\.} $entry :: class
        if {$forConfiguration} {
            set variables(0) [concat $variables(0) [${class}::variables]]
        }
        if {$forPreferences} {
            set variables(1) [concat $variables(1) [${class}::variables]]
        }
    }

}

}
if 1 {


package require Tcl 8.3

package provide stooop 4.4

catch {rename proc _proc}

namespace eval ::stooop {
    variable check
    variable trace

    set check(code) {}
    if {[info exists ::env(STOOOPCHECKALL)]&&$::env(STOOOPCHECKALL)} {
        array set ::env            {STOOOPCHECKPROCEDURES 1 STOOOPCHECKDATA 1 STOOOPCHECKOBJECTS 1}
    }
    set check(procedures) [expr {        [info exists ::env(STOOOPCHECKPROCEDURES)]&&        $::env(STOOOPCHECKPROCEDURES)    }]
    set check(data) [expr {        [info exists ::env(STOOOPCHECKDATA)]&&$::env(STOOOPCHECKDATA)    }]
    set check(objects) [expr {        [info exists ::env(STOOOPCHECKOBJECTS)]&&$::env(STOOOPCHECKOBJECTS)    }]
    if {$check(procedures)} {
        append check(code) {::stooop::checkProcedure;}
    }
    if {[info exists ::env(STOOOPTRACEALL)]} {
        set ::env(STOOOPTRACEPROCEDURES) $::env(STOOOPTRACEALL)
        set ::env(STOOOPTRACEDATA) $::env(STOOOPTRACEALL)
    }
    if {[info exists ::env(STOOOPTRACEPROCEDURES)]} {
        set trace(procedureChannel) $::env(STOOOPTRACEPROCEDURES)
        switch $trace(procedureChannel) {
            stdout - stderr {}
            default {
                set trace(procedureChannel) [open $::env(STOOOPTRACEPROCEDURES) w+]
            }
        }
        set trace(procedureFormat)            {class: %C, procedure: %p, object: %O, arguments: %a}
        catch {set trace(procedureFormat) $::env(STOOOPTRACEPROCEDURESFORMAT)}
        append check(code) {::stooop::traceProcedure;}
    }
    if {[info exists ::env(STOOOPTRACEDATA)]} {
        set trace(dataChannel) $::env(STOOOPTRACEDATA)
        switch $trace(dataChannel) {
            stdout - stderr {}
            default {
                set trace(dataChannel) [open $::env(STOOOPTRACEDATA) w+]
            }
        }
        set trace(dataFormat) {class: %C, procedure: %p, array: %A, object: %O, member: %m, operation: %o, value: %v}
        catch {set trace(dataFormat) $::env(STOOOPTRACEDATAFORMAT)}
        set trace(dataOperations) rwu
        catch {set trace(dataOperations) $::env(STOOOPTRACEDATAOPERATIONS)}
    }

    namespace export class virtual new delete classof

    if {![info exists newId]} {
        variable newId 0
    }

    _proc new {classOrId args} {
        variable newId
        variable fullClass

        if {[string is integer $classOrId]} {
            if {[catch {                set fullClass([set id [incr newId]]) $fullClass($classOrId)            }]} {
                error "invalid object identifier $classOrId"
            }
            uplevel 1 $fullClass($classOrId)::_copy $id $classOrId
        } else {
            set constructor ${classOrId}::[namespace tail $classOrId]
            uplevel 1 $constructor [set id [incr newId]] $args
            set fullClass($id) [namespace qualifiers                [uplevel 1 namespace which -command $constructor]            ]
        }
        return $id
    }

    _proc delete {args} {
        variable fullClass

        foreach id $args {
            uplevel 1 ::stooop::deleteObject $fullClass($id) $id
            unset fullClass($id)
        }
    }

    _proc deleteObject {fullClass id} {
        uplevel 1 ${fullClass}::~[namespace tail $fullClass] $id
        array unset ${fullClass}:: $id,*
    }

    _proc classof {id} {
        variable fullClass

        return $fullClass($id)
    }

    _proc copy {fullClass from to} {
        set index [string length $from]
        foreach {name value} [array get ${fullClass}:: $from,*] {
            set ${fullClass}::($to[string range $name $index end]) $value
        }
    }
}

_proc ::stooop::class {args} {
    variable declared

    set class [lindex $args 0]
    set declared([uplevel 1 namespace eval $class {namespace current}]) {}
    uplevel 1 namespace eval $class [list "::variable {}\n[lindex $args end]"]
}

_proc ::stooop::parseProcedureName {    namespace name fullClassVariable procedureVariable messageVariable} {
    variable declared
    upvar 1 $fullClassVariable fullClass $procedureVariable procedure        $messageVariable message

    if {        [info exists declared($namespace)]&&        ([string length [namespace qualifiers $name]]==0)    } {
        set fullClass $namespace
        set procedure $name
        return 1
    } else {
        if {![string match ::* $name]} {
            if {[string equal $namespace ::]} {
                set name ::$name
            } else {
                set name ${namespace}::$name
            }
        }
        set fullClass [namespace qualifiers $name]
        if {[info exists declared($fullClass)]} {
            set procedure [namespace tail $name]
            return 1
        } else {
            if {[string length $fullClass]==0} {
                set message "procedure $name class name is empty"
            } else {
                set message "procedure $name class $fullClass is unknown"
            }
            return 0
        }
    }
}

_proc ::stooop::virtual {keyword name arguments args} {
    variable pureVirtual

    if {![string equal [uplevel 1 namespace which -command $keyword] ::proc]} {
        error "virtual operator works only on proc, not $keyword"
    }
    if {![parseProcedureName        [uplevel 1 namespace current] $name fullClass procedure message    ]} {
        error $message
    }
    set class [namespace tail $fullClass]
    if {[string equal $class $procedure]} {
        error "cannot make class $fullClass constructor virtual"
    }
    if {[string equal ~$class $procedure]} {
        error "cannot make class $fullClass destructor virtual"
    }
    if {![string equal [lindex $arguments 0] this]} {
        error "cannot make static procedure $procedure of class $fullClass virtual"
    }
    set pureVirtual [expr {[llength $args]==0}]
    uplevel 1 ::proc [list $name $arguments [lindex $args 0]]
    unset pureVirtual
}

_proc proc {name arguments args} {
    if {![::stooop::parseProcedureName        [uplevel 1 namespace current] $name fullClass procedure message    ]} {
        uplevel 1 _proc [list $name $arguments] $args
        return
    }
    if {[llength $args]==0} {
        error "missing body for ${fullClass}::$procedure"
    }
    set class [namespace tail $fullClass]
    if {[string equal $class $procedure]} {
        if {![string equal [lindex $arguments 0] this]} {
            error "class $fullClass constructor first argument must be this"
        }
        if {[string equal [lindex $arguments 1] copy]} {
            if {[llength $arguments]!=2} {
                error "class $fullClass copy constructor must have 2 arguments exactly"
            }
            if {[catch {info body ::${fullClass}::$class}]} {
                error "class $fullClass copy constructor defined before constructor"
            }
            eval ::stooop::constructorDeclaration                $fullClass $class 1 \{$arguments\} $args
        } else {
            eval ::stooop::constructorDeclaration                $fullClass $class 0 \{$arguments\} $args
            ::stooop::generateDefaultCopyConstructor $fullClass
        }
    } elseif {[string equal ~$class $procedure]} {
        if {[llength $arguments]!=1} {
            error "class $fullClass destructor must have 1 argument exactly"
        }
        if {![string equal [lindex $arguments 0] this]} {
            error "class $fullClass destructor argument must be this"
        }
        if {[catch {info body ::${fullClass}::$class}]} {
            error "class $fullClass destructor defined before constructor"
        }
        ::stooop::destructorDeclaration            $fullClass $class $arguments [lindex $args 0]
    } else {
        if {[catch {info body ::${fullClass}::$class}]} {
            error "class $fullClass member procedure $procedure defined before constructor"
        }
        ::stooop::memberProcedureDeclaration            $fullClass $class $procedure $arguments [lindex $args 0]
    }
}

_proc ::stooop::constructorDeclaration {fullClass class copy arguments args} {
    variable check
    variable fullBases
    variable variable

    set number [llength $args]
    if {($number%2)==0} {
        error "bad class $fullClass constructor declaration, a base class, contructor arguments or body may be missing"
    }
    if {[string equal [lindex $arguments end] args]} {
        set variable($fullClass) {}
    }
    if {!$copy} {
        set fullBases($fullClass) {}
    }
    foreach {base baseArguments} [lrange $args 0 [expr {$number-2}]] {
        set constructor ${base}::[namespace tail $base]
        catch {$constructor}
        set fullBase [namespace qualifiers            [uplevel 2 namespace which -command $constructor]        ]
        if {[string length $fullBase]==0} {
            if {[string match *$base $fullClass]} {
                error "class $fullClass cannot be derived from itself"
            } else {
                error "class $fullClass constructor defined before base class $base constructor"
            }
        }
        if {!$copy} {
            if {[lsearch -exact $fullBases($fullClass) $fullBase]>=0} {
                error "class $fullClass directly inherits from class $fullBase more than once"
            }
            lappend fullBases($fullClass) $fullBase
        }
        regsub -all {\n} $baseArguments { } constructorArguments($fullBase)
    }
    set constructorBody "::variable {}
$check(code)
"
    if {[llength $fullBases($fullClass)]>0} {
        if {[info exists variable($fullClass)]} {
            foreach fullBase $fullBases($fullClass) {
                if {![info exists constructorArguments($fullBase)]} {
                    error "missing base class $fullBase constructor arguments from class $fullClass constructor"
                }
                set baseConstructor ${fullBase}::[namespace tail $fullBase]
                if {                    [info exists variable($fullBase)]&&                    ([string first {$args} $constructorArguments($fullBase)]>=0)                } {
                    append constructorBody "::set _list \[::list $constructorArguments($fullBase)\]
::eval $baseConstructor \$this \[::lrange \$_list 0 \[::expr {\[::llength \$_list\]-2}\]\] \[::lindex \$_list end\]
::unset _list
::set ${fullBase}::(\$this,_derived) $fullClass
"
                } else {
                    append constructorBody "$baseConstructor \$this $constructorArguments($fullBase)
::set ${fullBase}::(\$this,_derived) $fullClass
"
                }
            }
        } else {
            foreach fullBase $fullBases($fullClass) {
                if {![info exists constructorArguments($fullBase)]} {
                    error "missing base class $fullBase constructor arguments from class $fullClass constructor"
                }
                set baseConstructor ${fullBase}::[namespace tail $fullBase]
                append constructorBody "$baseConstructor \$this $constructorArguments($fullBase)
::set ${fullBase}::(\$this,_derived) $fullClass
"
            }
        }
    }
    if {$copy} {
        append constructorBody "::catch {::set (\$this,_derived) \$(\$[::lindex $arguments 1],_derived)}
"
    }
    append constructorBody [lindex $args end]
    if {$copy} {
        _proc ${fullClass}::_copy $arguments $constructorBody
    } else {
        _proc ${fullClass}::$class $arguments $constructorBody
    }
}

_proc ::stooop::destructorDeclaration {fullClass class arguments body} {
    variable check
    variable fullBases

    set body "::variable {}
$check(code)
$body
"
    for {set index [expr {[llength $fullBases($fullClass)]-1}]} {$index>=0}        {incr index -1}    {
        set fullBase [lindex $fullBases($fullClass) $index]
        append body "::stooop::deleteObject $fullBase \$this
"
    }
    _proc ${fullClass}::~$class $arguments $body
}

_proc ::stooop::memberProcedureDeclaration {    fullClass class procedure arguments body} {
    variable check
    variable pureVirtual

    if {[info exists pureVirtual]} {
        if {$pureVirtual} {
            _proc ${fullClass}::$procedure $arguments "::variable {}
$check(code)
::uplevel 1 \$(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\]
"
        } else {
            _proc ${fullClass}::_$procedure $arguments "::variable {}
$check(code)
$body
"
            _proc ${fullClass}::$procedure $arguments "::variable {}
$check(code)
if {!\[::catch {::info body \$(\$this,_derived)::$procedure}\]} {
::return \[::uplevel 1 \$(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\]\]
}
::uplevel 1 ${fullClass}::_$procedure \[::lrange \[::info level 0\] 1 end\]
"
        }
    } else {
        _proc ${fullClass}::$procedure $arguments "::variable {}
$check(code)
$body
"
    }
}

_proc ::stooop::generateDefaultCopyConstructor {fullClass} {
    variable fullBases

    foreach fullBase $fullBases($fullClass) {
        append body "${fullBase}::_copy \$this \$sibling
"
    }
    append body "::stooop::copy $fullClass \$sibling \$this
"
    _proc ${fullClass}::_copy {this sibling} $body
}


if {[llength [array names ::env STOOOP*]]>0} {

    catch {rename ::stooop::class ::stooop::_class}
    _proc ::stooop::class {args} {
        variable trace
        variable check

        set class [lindex $args 0]
        if {$check(data)} {
            uplevel 1 namespace eval $class                [list {::trace variable {} wu ::stooop::checkData}]
        }
        if {[info exists ::env(STOOOPTRACEDATA)]} {
            uplevel 1 namespace eval $class [list                "::trace variable {} $trace(dataOperations) ::stooop::traceData"            ]
        }
        uplevel 1 ::stooop::_class $args
    }

    if {$::stooop::check(procedures)} {
        catch {rename ::stooop::virtual ::stooop::_virtual}
        _proc ::stooop::virtual {keyword name arguments args} {
            variable interface

            uplevel 1 ::stooop::_virtual [list $keyword $name $arguments] $args
            parseProcedureName [uplevel 1 namespace current] $name                fullClass procedure message
            if {[llength $args]==0} {
                set interface($fullClass) {}
            }
        }
    }

    if {$::stooop::check(objects)} {
        _proc invokingProcedure {} {
            if {[catch {set procedure [lindex [info level -2] 0]}]} {
                return {top level}
            } elseif {                ([string length $procedure]==0)||                [string equal $procedure namespace]            } {
                return "namespace [uplevel 2 namespace current]"
            } else {
                return [uplevel 3 namespace which -command $procedure]
            }
        }
    }

    if {$::stooop::check(procedures)||$::stooop::check(objects)} {
        catch {rename ::stooop::new ::stooop::_new}
        _proc ::stooop::new {classOrId args} {
            variable newId
            variable check

            if {$check(procedures)} {
                variable fullClass
                variable interface
            }
            if {$check(objects)} {
                variable creator
            }
            if {$check(procedures)} {
                if {[string is integer $classOrId]} {
                    set fullName $fullClass($classOrId)
                } else {
                    set constructor ${classOrId}::[namespace tail $classOrId]
                    catch {$constructor}
                    set fullName [namespace qualifiers                        [uplevel 1 namespace which -command $constructor]                    ]
                    set fullClass([expr {$newId+1}]) $fullName
                }
                if {[info exists interface($fullName)]} {
                    error "class $fullName with pure virtual procedures should not be instanciated"
                }
            }
            if {$check(objects)} {
                set creator([expr {$newId+1}]) [invokingProcedure]
            }
            return [uplevel 1 ::stooop::_new $classOrId $args]
        }
    }

    if {$::stooop::check(objects)} {
        _proc ::stooop::delete {args} {
            variable fullClass
            variable deleter

            set procedure [invokingProcedure]
            foreach id $args {
                uplevel 1 ::stooop::deleteObject $fullClass($id) $id
                unset fullClass($id)
                set deleter($id) $procedure
            }
        }
    }

    _proc ::stooop::ancestors {fullClass} {
        variable ancestors
        variable fullBases

        if {[info exists ancestors($fullClass)]} {
            return $ancestors($fullClass)
        }
        set list {}
        foreach class $fullBases($fullClass) {
            set list [concat $list [list $class] [ancestors $class]]
        }
        set ancestors($fullClass) $list
        return $list
    }

    _proc ::stooop::debugInformation {        className fullClassName procedureName fullProcedureName        thisParameterName    } {
        upvar 1 $className class $fullClassName fullClass            $procedureName procedure $fullProcedureName fullProcedure            $thisParameterName thisParameter
        variable declared

        set namespace [uplevel 2 namespace current]
        if {[lsearch -exact [array names declared] $namespace]<0} return
        set fullClass [string trimleft $namespace :]
        set class [namespace tail $fullClass]
        set list [info level -2]
        set first [lindex $list 0]
        if {([llength $list]==0)||[string equal $first namespace]}            return
        set procedure $first
        set fullProcedure [uplevel 3 namespace which -command $procedure]
        set procedure [namespace tail $procedure]
        if {[string equal $class $procedure]} {
            set procedure constructor
        } elseif {[string equal ~$class $procedure]} {
            set procedure destructor
        }
        if {[string equal [lindex [info args $fullProcedure] 0] this]} {
            set thisParameter [lindex $list 1]
        }
    }

    _proc ::stooop::checkProcedure {} {
        variable fullClass

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        if {![info exists this]} return
        if {[string equal $procedure constructor]} return
        if {![info exists fullClass($this)]} {
            error "$this is not a valid object identifier"
        }
        set fullName [string trimleft $fullClass($this) :]
        if {[string equal $fullName $qualifiedClass]} return
        if {[lsearch -exact [ancestors ::$fullName] ::$qualifiedClass]<0} {
            error "class $qualifiedClass of $qualifiedProcedure procedure not an ancestor of object $this class $fullName"
        }
    }

    _proc ::stooop::traceProcedure {} {
        variable trace

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        set text $trace(procedureFormat)
        regsub -all %C $text $qualifiedClass text
        regsub -all %c $text $class text
        regsub -all %P $text $qualifiedProcedure text
        regsub -all %p $text $procedure text
        if {[info exists this]} {
            regsub -all %O $text $this text
            regsub -all %a $text [lrange [info level -1] 2 end] text
        } else {
            regsub -all %O $text {} text
            regsub -all %a $text [lrange [info level -1] 1 end] text
        }
        puts $trace(procedureChannel) $text
    }

    _proc ::stooop::checkData {array name operation} {
        scan $name %u,%s identifier member
        if {[info exists member]&&[string equal $member _derived]} return

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        if {![info exists class]} return
        set array [uplevel 1 [list namespace which -variable $array]]
        if {![info exists procedure]} {
            if {![string equal $array ::${qualifiedClass}::]} {
                error                    "class access violation in class $qualifiedClass namespace"
            }
            return
        }
        if {[string equal $qualifiedProcedure ::stooop::copy]} return
        if {![string equal $array ::${qualifiedClass}::]} {
            error "class access violation in procedure $qualifiedProcedure"
        }
        if {![info exists this]} return
        if {![info exists identifier]} return
        if {$this!=$identifier} {
            error "object $identifier access violation in procedure $qualifiedProcedure acting on object $this"
        }
    }

    _proc ::stooop::traceData {array name operation} {
        variable trace

        scan $name %u,%s identifier member
        if {[info exists member]&&[string equal $member _derived]} return

        if {            ![catch {lindex [info level -1] 0} procedure]&&            [string equal ::stooop::deleteObject $procedure]        } return
        set class {}
        set qualifiedClass {}
        set procedure {}
        set qualifiedProcedure {}

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        set text $trace(dataFormat)
        regsub -all %C $text $qualifiedClass text
        regsub -all %c $text $class text
        if {[info exists member]} {
            regsub -all %m $text $member text
        } else {
            regsub -all %m $text $name text
        }
        regsub -all %P $text $qualifiedProcedure text
        regsub -all %p $text $procedure text
        regsub -all %A $text [string trimleft            [uplevel 1 [list namespace which -variable $array]] :        ] text
        if {[info exists this]} {
            regsub -all %O $text $this text
        } else {
            regsub -all %O $text {} text
        }
        array set string {r read w write u unset}
        regsub -all %o $text $string($operation) text
        if {[string equal $operation u]} {
            regsub -all %v $text {} text
        } else {
            regsub -all %v $text [uplevel 1 set ${array}($name)] text
        }
        puts $trace(dataChannel) $text
    }

    if {$::stooop::check(objects)} {
        _proc ::stooop::printObjects {{pattern *}} {
            variable fullClass
            variable creator

            puts "stooop::printObjects invoked from [invokingProcedure]:"
            foreach id [lsort -integer [array names fullClass]] {
                if {[string match $pattern $fullClass($id)]} {
                    puts "$fullClass($id)\($id\) + $creator($id)"
                }
            }
        }

        _proc ::stooop::record {} {
            variable fullClass
            variable checkpointFullClass

            puts "stooop::record invoked from [invokingProcedure]"
            catch {unset checkpointFullClass}
            array set checkpointFullClass [array get fullClass]
        }

        _proc ::stooop::report {{pattern *}} {
            variable fullClass
            variable checkpointFullClass
            variable creator
            variable deleter

            puts "stooop::report invoked from [invokingProcedure]:"
            set checkpointIds [lsort -integer [array names checkpointFullClass]]
            set currentIds [lsort -integer [array names fullClass]]
            foreach id $currentIds {
                if {                    [string match $pattern $fullClass($id)]&&                    ([lsearch -exact $checkpointIds $id]<0)                } {
                    puts "+ $fullClass($id)\($id\) + $creator($id)"
                }
            }
            foreach id $checkpointIds {
                if {                    [string match $pattern $checkpointFullClass($id)]&&                    ([lsearch -exact $currentIds $id]<0)                } {
                    puts "- $checkpointFullClass($id)\($id\) - $deleter($id) + $creator($id)"
                }
            }
        }
    }

}
}
namespace import stooop::*
if 1 {

package provide switched 2.2


::stooop::class switched {

    proc switched {this args} {
        if {([llength $args]%2)!=0} {
            error "value for \"[lindex $args end]\" missing"
        }
        set ($this,complete) 0
        set ($this,arguments) $args
    }

    proc ~switched {this} {}

    ::stooop::virtual proc options {this}

    proc complete {this} {
        foreach description [options $this] {
            set option [lindex $description 0]
            set ($this,$option) [set default [lindex $description 1]]
            if {[llength $description]<3} {
                set initialize($option) {}
            } elseif {![string equal $default [lindex $description 2]]} {
                set ($this,$option) [lindex $description 2]
                set initialize($option) {}
            }
        }
        foreach {option value} $($this,arguments) {
            if {[catch {string compare $($this,$option) $value} different]} {
                error "$($this,_derived): unknown option \"$option\""
            }
            if {$different} {
                set ($this,$option) $value
                set initialize($option) {}
            }
        }
        unset ($this,arguments)
        foreach option [array names initialize] {
            $($this,_derived)::set$option $this $($this,$option)
        }
        set ($this,complete) 1
    }

    proc configure {this args} {
        if {[llength $args]==0} {
            return [descriptions $this]
        }
        foreach {option value} $args {
            if {![info exists ($this,$option)]} {
                error "$($this,_derived): unknown option \"$option\""
            }
        }
        if {[llength $args]==1} {
            return [description $this [lindex $args 0]]
        }
        if {([llength $args]%2)!=0} {
            error "value for \"[lindex $args end]\" missing"
        }
        foreach {option value} $args {
            if {![string equal $($this,$option) $value]} {
                $($this,_derived)::set$option $this [set ($this,$option) $value]
            }
        }
    }

    proc cget {this option} {
        if {[catch {set value $($this,$option)}]} {
            error "$($this,_derived): unknown option \"$option\""
        }
        return $value
    }

    proc description {this option} {
        foreach description [options $this] {
            if {[string equal [lindex $description 0] $option]} {
                if {[llength $description]<3} {
                    lappend description $($this,$option)
                    return $description
                } else {
                    return [lreplace $description 2 2 $($this,$option)]
                }
            }
        }
    }

    proc descriptions {this} {
        set descriptions {}
        foreach description [options $this] {
            if {[llength $description]<3} {
                lappend description $($this,[lindex $description 0])
                lappend descriptions $description
            } else {
                lappend descriptions [lreplace                    $description 2 2 $($this,[lindex $description 0])                ]
            }
        }
        return $descriptions
    }

}
}




class database {

    set (dateTimeFormat) {%Y-%m-%d %T}

    proc database {this args} switched {$args} {
        set ($this,error) {}
        switched::complete $this
        if {[package vcompare $::tcl_version 8.4] < 0} {
            set ($this,rowType) INTEGER
        } else {
            set ($this,rowType) BIGINT
        }
        if {[string length $switched::($this,-file)] > 0} {
            set ($this,file) 1
            set ($this,odbc) 0
            if {[catch {package require sqlite3} result3] && [catch {package require sqlite 2} result2]} {
                set ($this,error) "SQLite interface error:\n$result3\n$result2"
                return
            } elseif {$switched::($this,-debuglevel)} {
                set message "loaded SQLite library version "
                if {[info exists result3]} {append message $result3} else {append message $result2}
                if {$global::withGUI} {puts $message} else {writeLog $message debug}
            }
            if {[catch {package present sqlite3}]} {set ($this,sqliteExtension) {}} else {set ($this,sqliteExtension) 3}
            sqliteOpen $this
            if {[string length $($this,error)] > 0} return
        } elseif {[string length $switched::($this,-dsn)] > 0} {
            set ($this,file) 0
            set ($this,odbc) 1
            if {[catch {package require tclodbc 2} result]} {
                set ($this,error) "Tcl ODBC interface error: $result"
                return
            }
            foreach list [::database datasources] {
                foreach {dsn driver} $list {}
                if {[string equal $dsn $switched::($this,-dsn)]} break
            }
            if {$switched::($this,-debuglevel)} {
                set message "loaded ODBC driver $driver version $result"
                if {$global::withGUI} {puts $message} else {writeLog $message debug}
            }
            odbcConnect $this
            if {[string length $($this,error)] > 0} return
            set ($this,limit) {LIMIT %l}
            set ($this,prefix) {}
            set ($this,timeStamp) TIMESTAMP
            set ($this,text) TEXT
            set ($this,lock) BEGIN
            set ($this,unlock) COMMIT
            switch -glob [string tolower $driver] {
                *my* {
                    set ($this,timeStamp) DATETIME
                    set ($this,lock) {LOCK TABLES %t WRITE}
                    set ($this,unlock) {UNLOCK TABLES}
                    set ($this,type) mysql
                }
                *postg* - *psql* - *pgsql* {
                    set ($this,type) postgres
                }
                *db2* {
                    set ($this,lock) {LOCK TABLE %t IN EXCLUSIVE MODE}
                    set ($this,limit) {FETCH FIRST %l ROWS ONLY}
                    set ($this,type) db2
                }
                *ora* {
                    set ($this,prefix) c
                    set ($this,timeStamp) DATE
                    set ($this,text) VARCHAR2(4000)
                    unset ($this,lock) ($this,unlock)
                    set ($this,rowType) INTEGER
                    set ($this,type) oracle
                }
            }
        } else {
            set ($this,file) 0
            set ($this,odbc) 0
            if {[catch {package require mysqltcl} result]} {
                set ($this,error) "Tcl MySQL interface error: $result"
                return
            } elseif {$switched::($this,-debuglevel)} {
                set message "loaded MySQL native driver version $result"
                if {$global::withGUI} {puts $message} else {writeLog $message debug}
            }
            mysqlConnect $this
            if {[string length $($this,error)] > 0} return
            set ($this,lock) {LOCK TABLES %t WRITE}
            set ($this,unlock) {UNLOCK TABLES}
        }
        initialize $this
        if {[string length $($this,error)] > 0} return
        checkFormat $this
        if {[string length $($this,error)] > 0} return
if {$global::withGUI} {
        set ($this,start) [dateTime $this]
} else {
        if {$($this,oldFormat)} {
            set ($this,error) {cannot write to a database in old format (see upgrading section in database documentation)}
        }
}
    }

    proc ~database {this} {
        variable ${this}cache

        catch {unset ${this}cache}
        disconnect $this
    }

    proc options {this} {
        return [list            [list -database moodss moodss]            [list -debuglevel 0 0]            [list -dsn {} {}]            [list -file {} {}]            [list -host {} {}]            [list -password {} {}]            [list -port {} {}]            [list -user $::tcl_platform(user) $::tcl_platform(user)]        ]
    }

    foreach option {-database -dsn -file -host -password -port -user} {
        proc set$option {this value} "
            if {\$switched::(\$this,complete)} {
                ::error {option $option cannot be set dynamically}
            }
        "
    }

    proc set-debuglevel {this value} {
        if {$switched::($this,complete)} {
            ::error {option -debuglevel cannot be set dynamically}
        }
   }

if {$global::withGUI} {


    proc errorTrace {this message} {
        if {[info exists ($this,ignoreErrors)]} return
        if {$switched::($this,-debuglevel)} {puts $message}
        residentTraceModule 1
        modules::trace {} moodss(database) $message
    }
    proc sqliteOpen {this} {
        set ($this,error) {}
        catch {unset ($this,connection)}
        if {$switched::($this,-debuglevel)} {puts "opening file \"$switched::($this,-file)\""}
        set connection sqlite$this
        if {[catch {::sqlite$($this,sqliteExtension) $connection $switched::($this,-file)} message]} {
            errorTrace $this [set ($this,error) $message]
        } else {
            set ($this,connection) $connection
        }
    }
    proc sqliteEvaluate {this sql} {
        set ($this,error) {}
        if {$switched::($this,-debuglevel)} {puts [string trim $sql]}
        if {[catch {$($this,connection) eval $sql} result]} {
            errorTrace $this [set ($this,error) $result]
            return {}
        } else {
            return $result
        }
    }
    proc sqliteClose {this} {
        set ($this,error) {}
        if {![info exists ($this,connection)]} return
        if {$switched::($this,-debuglevel)} {puts "closing file \"$switched::($this,-file)\""}
        if {[catch {$($this,connection) close} message]} {
            errorTrace $this [set ($this,error) $message]
        } else {
            unset ($this,connection)
        }
    }
    proc odbcConnect {this} {
        set ($this,error) {}
        catch {unset ($this,connection)}
        if {$switched::($this,-debuglevel)} {puts "connecting to ODBC DSN $switched::($this,-dsn)"}
        set arguments [list $switched::($this,-dsn)]
        if {[string length $switched::($this,-user)] > 0} {lappend arguments $switched::($this,-user)}
        if {[string length $switched::($this,-password)] > 0} {lappend arguments $switched::($this,-password)}
        if {[catch {set connection [eval ::database odbc$this $arguments]} message]} {
            errorTrace $this [set ($this,error) $message]
        } else {
            set ($this,connection) $connection
        }
    }
    proc odbcConnection {this args} {
        set ($this,error) {}
        if {$switched::($this,-debuglevel)} {puts "[eval concat $args]"}
        if {[catch {eval $($this,connection) $args} result]} {
            errorTrace $this [set ($this,error) $result]
            return {}
        } else {
            return $result
        }
    }
    proc odbcDisconnect {this} {
        set ($this,error) {}
        if {![info exists ($this,connection)]} return
        if {$switched::($this,-debuglevel)} {puts {closing ODBC connection}}
        if {[catch {$($this,connection) disconnect} message]} {
            errorTrace $this [set ($this,error) $message]
        } else {
            unset ($this,connection)
        }
    }
    proc mysqlConnect {this} {
        set ($this,error) {}
        catch {unset ($this,connection)}
        if {$switched::($this,-debuglevel)} {puts "connecting to database $switched::($this,-database)"}
        set arguments [list -db $switched::($this,-database)]
        if {[string length $switched::($this,-host)] > 0} {lappend arguments -host $switched::($this,-host)}
        if {[string length $switched::($this,-user)] > 0} {lappend arguments -user $switched::($this,-user)}
        if {[string length $switched::($this,-password)] > 0} {lappend arguments -password $switched::($this,-password)}
        if {[string length $switched::($this,-port)] > 0} {lappend arguments -port $switched::($this,-port)}
        if {[catch {set connection [eval mysqlconnect $arguments]} message]} {
            errorTrace $this [set ($this,error) $message]
        } else {
            set ($this,connection) $connection
        }
    }
    proc mysqlSelect {this args} {
        set ($this,error) {}
        if {$switched::($this,-debuglevel)} {puts [string trim [lindex $args 0]]}
        if {[catch {eval mysqlsel $($this,connection) $args} result]} {
            errorTrace $this [set ($this,error) $result]
            return {}
        } else {
            return $result
        }
    }
    proc mysqlExecute {this args} {
        set ($this,error) {}
        if {$switched::($this,-debuglevel)} {puts [string trim [lindex $args 0]]}
        if {[catch {eval mysqlexec $($this,connection) $args} message]} {
            errorTrace $this [set ($this,error) $message]
        }
    }
    proc mysqlColumns {this args} {
        set ($this,error) {}
        if {$switched::($this,-debuglevel)} {puts "SHOW COLUMNS FROM [lindex $args 0]"}
        if {[catch {eval mysqlcol $($this,connection) $args} result]} {
            errorTrace $this [set ($this,error) $result]
            return {}
        } else {
            return $result
        }
    }
    proc mysqlDisconnect {this} {
        set ($this,error) {}
        if {![info exists ($this,connection)]} return
        if {$switched::($this,-debuglevel)} {puts {closing MySQL connection}}
        if {[catch {mysqlclose $($this,connection)} message]} {
            errorTrace $this [set ($this,error) $message]
        } else {
            unset ($this,connection)
        }
    }

} else {

    proc error {this} {
        return $($this,error)
    }
    proc errorLog {this message} {
        if {[info exists ($this,ignoreErrors)]} return
        writeLog $message error
    }
    proc sqliteOpen {this} {
        set ($this,error) {}
        catch {unset ($this,connection)}
        if {$switched::($this,-debuglevel)} {writeLog "opening file \"$switched::($this,-file)\"" debug}
        set connection sqlite$this
        if {[catch {::sqlite$($this,sqliteExtension) $connection $switched::($this,-file)} message]} {
            errorLog $this [set ($this,error) $message]
        } else {
            set ($this,connection) $connection
        }
    }
    proc sqliteEvaluate {this sql} {
        set ($this,error) {}
        if {$switched::($this,-debuglevel)} {writeLog [string trim $sql] debug}
        if {[catch {$($this,connection) eval $sql} result]} {
            errorLog $this [set ($this,error) $result]
            return {}
        } else {
            return $result
        }
    }
    proc sqliteClose {this} {
        set ($this,error) {}
        if {![info exists ($this,connection)]} return
        if {$switched::($this,-debuglevel)} {writeLog "closing file \"$switched::($this,-file)\"" debug}
        if {[catch {$($this,connection) close} message]} {
            errorLog $this [set ($this,error) $message]
        } else {
            unset ($this,connection)
        }
    }
    proc odbcConnect {this} {
        set ($this,error) {}
        catch {unset ($this,connection)}
        if {$switched::($this,-debuglevel)} {writeLog "connecting to ODBC DSN $switched::($this,-dsn)" debug}
        set arguments [list $switched::($this,-dsn)]
        if {[string length $switched::($this,-user)] > 0} {lappend arguments $switched::($this,-user)}
        if {[string length $switched::($this,-password)] > 0} {lappend arguments $switched::($this,-password)}
        if {[catch {set connection [eval ::database odbc$this $arguments]} message]} {
            errorLog $this [set ($this,error) $message]
        } else {
            set ($this,connection) $connection
        }
    }
    proc odbcConnection {this args} {
        set ($this,error) {}
        if {$switched::($this,-debuglevel)} {writeLog "[eval concat $args]" debug}
        if {[catch {eval $($this,connection) $args} result]} {
            errorLog $this [set ($this,error) $result]
            return {}
        } else {
            return $result
        }
    }
    proc odbcDisconnect {this} {
        set ($this,error) {}
        if {![info exists ($this,connection)]} return
        if {$switched::($this,-debuglevel)} {writeLog {closing ODBC connection} debug}
        if {[catch {$($this,connection) disconnect} message]} {
            errorLog $this [set ($this,error) $message]
        } else {
            unset ($this,connection)
        }
    }
    proc mysqlConnect {this} {
        set ($this,error) {}
        catch {unset ($this,connection)}
        if {$switched::($this,-debuglevel)} {writeLog "connecting to database $switched::($this,-database)" debug}
        set arguments [list -db $switched::($this,-database)]
        if {[string length $switched::($this,-host)] > 0} {lappend arguments -host $switched::($this,-host)}
        if {[string length $switched::($this,-user)] > 0} {lappend arguments -user $switched::($this,-user)}
        if {[string length $switched::($this,-password)] > 0} {lappend arguments -password $switched::($this,-password)}
        if {[string length $switched::($this,-port)] > 0} {lappend arguments -port $switched::($this,-port)}
        if {[catch {set connection [eval mysqlconnect $arguments]} message]} {
            errorLog $this [set ($this,error) $message]
        } else {
            set ($this,connection) $connection
        }
    }
    proc mysqlSelect {this args} {
        set ($this,error) {}
        if {$switched::($this,-debuglevel)} {writeLog [string trim [lindex $args 0]] debug}
        if {[catch {eval mysqlsel $($this,connection) $args} result]} {
            errorLog $this [set ($this,error) $result]
            return {}
        } else {
            return $result
        }
    }
    proc mysqlExecute {this args} {
        set ($this,error) {}
        if {$switched::($this,-debuglevel)} {writeLog [string trim [lindex $args 0]] debug}
        if {[catch {eval mysqlexec $($this,connection) $args} message]} {
            errorLog $this [set ($this,error) $message]
        }
    }
    proc mysqlColumns {this args} {
        set ($this,error) {}
        if {$switched::($this,-debuglevel)} {writeLog "SHOW COLUMNS FROM [lindex $args 0]" debug}
        if {[catch {eval mysqlcol $($this,connection) $args} result]} {
            errorLog $this [set ($this,error) $result]
            return {}
        } else {
            return $result
        }
    }
    proc mysqlDisconnect {this} {
        set ($this,error) {}
        if {![info exists ($this,connection)]} return
        if {$switched::($this,-debuglevel)} {writeLog {closing MySQL connection} debug}
        if {[catch {mysqlclose $($this,connection)} message]} {
            errorLog $this [set ($this,error) $message]
        } else {
            unset ($this,connection)
        }
    }

}

    proc initialize {this} {
        set file $($this,file)
        set odbc $($this,odbc)
        if {$file} {
            set timeStamp INTEGER
            set prefix {}
            set text TEXT
        } elseif {$odbc} {
            set timeStamp $($this,timeStamp)
            set prefix $($this,prefix)
            set text $($this,text)
        } else {
            set timeStamp DATETIME
            set prefix {}
            set text TEXT
        }
        set rowType $($this,rowType)
        array set statements "
            instances {
                {
                    CREATE TABLE instances (
                        ${prefix}number INTEGER NOT NULL PRIMARY KEY,
                        ${prefix}start $timeStamp NOT NULL,
                        ${prefix}module VARCHAR(255) NOT NULL,
                        ${prefix}identifier VARCHAR(255),
                        ${prefix}major INTEGER NOT NULL,
                        ${prefix}minor INTEGER NOT NULL
                    )
                }
            } options {
                {
                    CREATE TABLE options (
                        ${prefix}instance INTEGER NOT NULL REFERENCES instances,
                        ${prefix}name VARCHAR(255) NOT NULL,
                        ${prefix}value $text
                    )
                }
            } entries {
                {
                    CREATE TABLE entries (
                        ${prefix}instance INTEGER NOT NULL REFERENCES instances,
                        ${prefix}number INTEGER NOT NULL,
                        ${prefix}indexed INTEGER NOT NULL,
                        ${prefix}label VARCHAR(255) NOT NULL,
                        ${prefix}type VARCHAR(16) NOT NULL,
                        ${prefix}message $text NOT NULL,
                        ${prefix}anchor VARCHAR(16),
                        UNIQUE(${prefix}instance, ${prefix}number)
                    )
                }
            } history {
                {
                    CREATE TABLE history (
                        ${prefix}instant $timeStamp NOT NULL,
                        ${prefix}instance INTEGER NOT NULL REFERENCES instances,
                        ${prefix}row $rowType NOT NULL,
                        ${prefix}entry INTEGER NOT NULL,
                        ${prefix}value VARCHAR(255)
                    )
                } {
                    CREATE INDEX cell ON history (${prefix}instance, ${prefix}row, ${prefix}entry)
                }
            } data {
                {
                    CREATE TABLE data (
                        ${prefix}instance INTEGER NOT NULL REFERENCES instances,
                        ${prefix}row $rowType NOT NULL,
                        ${prefix}entry INTEGER NOT NULL,
                        ${prefix}label VARCHAR(255) NOT NULL,
                        ${prefix}comment VARCHAR(255),
                        UNIQUE(${prefix}instance, ${prefix}row, ${prefix}entry)
                    )
                }
            }
        "
        set ($this,created) 0
        foreach table {instances options entries history data} {
            set query "SELECT COUNT(*) FROM $table"
            set ($this,ignoreErrors) {}
            if {$file} {
                sqliteEvaluate $this $query
            } elseif {$odbc} {
                odbcConnection $this $query
            } else {
                mysqlSelect $this $query
            }
            unset ($this,ignoreErrors)
            if {[string length $($this,error)] == 0} continue
if {$global::withGUI} {
            lifoLabel::push $global::messenger [format [mc {creating database table %s...}] $table]
            busy 1 .
}
            foreach statement $statements($table) {
                if {$file} {
                    sqliteEvaluate $this $statement
                } elseif {$odbc} {
                    odbcConnection $this $statement
                } else {
                    mysqlExecute $this $statement
                }
                if {[string length $($this,error)] > 0} break
            }
if {$global::withGUI} {
            busy 0 .
            lifoLabel::pop $global::messenger
}
            set ($this,created) [expr {[string length $($this,error)] == 0}]
            if {[string length $($this,error)] > 0} break
        }
    }

    proc checkFormat {this} {
        if {$($this,file)} {
            set ($this,oldFormat) 0
            set ($this,64bits) 1
            return
        }
        if {$($this,odbc)} {
            set prefix $($this,prefix)
            set ($this,ignoreErrors) {}
            odbcConnection $this "SELECT COUNT(${prefix}identifier) FROM instances"
            if {[string length $($this,error)] == 0} {set instances(identifier) {}}
            odbcConnection $this "SELECT COUNT(${prefix}instance) FROM entries"
            if {[string length $($this,error)] == 0} {set entries(instance) {}}
            unset ($this,ignoreErrors)
        } else {
            foreach table {instances entries} {
                set columns [mysqlColumns $this $table name]
                if {[string length $($this,error)] > 0} return
                foreach column $columns {
                    set ${table}($column) {}
                }
            }
        }
        if {[info exists instances(identifier)]} {
            set new instances
            if {![info exists entries(instance)]} {set old entries}
            set ($this,oldFormat) 0
        } else {
            set old instances
            if {[info exists entries(instance)]} {set new entries}
            set ($this,oldFormat) 1
        }
        if {[info exists old] && [info exists new]} {
            set ($this,error) "database fatal error: \"$new\" table in new format but \"$old\" table in old format (see upgrading section in database documentation)"
        }
        foreach {data history} [64bitRows $this] {}
        if {$data != $history} {
            set ($this,error) "database fatal error: data and history tables have mismatched types for the row column"
        }
        set ($this,64bits) $data
        if {$($this,64bits) && [package vcompare $::tcl_version 8.4] < 0} {
            set ($this,error) "error: database has 64 bits support for rows but Tcl core (version $::tcl_version) does not"
        }
    }

    proc 64bitRows {this} {
        if {$($this,odbc)} {
            if {[string equal $($this,type) oracle]} {
                return [list 1 1]
            }
            if {[string equal $::tcl_platform(platform) windows]} {
                return [list 1 1]

            }
            foreach data [concat [odbcConnection $this columns data] [odbcConnection $this columns history]] {
                foreach {qualifier owner name column typeCode type precision length scale radix nullable remarks} $data {}
                if {[string equal $column row]} {
                    lappend list [string equal $type bigint]
                    continue
                }
            }
            return $list
        } else {
            foreach table [list data history] {
                set type [lindex [mysqlSelect $this "SHOW COLUMNS FROM $table LIKE 'row'" -flatlist] 1]
                lappend list [string match -nocase BIGINT* $type]
            }
            return $list
        }
    }

    proc dateTime {this {seconds {}}} {
        if {[string length $seconds] == 0} {set seconds [clock seconds]}
        if {$($this,file)} {
            return $seconds
        }
        set string [clock format $seconds -format $(dateTimeFormat)]
        if {$($this,odbc) && [string equal $($this,type) oracle]} {
            return "TO_DATE('$string', 'YYYY-MM-DD HH:MI:SS')"
        } else {
            return '$string'
        }
    }

}

if {$global::withGUI} {

class database {

    proc modules {this} {
        if {$($this,odbc)} {
            set prefix $($this,prefix)
            set query "SELECT DISTINCT ${prefix}module FROM instances WHERE (${prefix}number > 0) AND (${prefix}start <= $($this,start)) ORDER BY ${prefix}module"
            return [join [odbcConnection $this $query]]
        } else {
            set query "SELECT DISTINCT module FROM instances WHERE (number > 0) AND (start <= $($this,start)) ORDER BY module"
            if {$($this,file)} {
                return [sqliteEvaluate $this $query]
            } else {
                return [mysqlSelect $this $query -flatlist]
            }
        }
    }

    proc moduleRange {this module {busyWidgets .}} {
        lifoLabel::push $global::messenger [mc {retrieving module instances range from database...}]
        busy 1 $busyWidgets
        if {$($this,odbc)} {
            set prefix $($this,prefix)
            set query "SELECT MIN(${prefix}instant), MAX(${prefix}instant) FROM instances, history WHERE (${prefix}module = '$module') AND (${prefix}instance = ${prefix}number) AND (${prefix}instant <= $($this,start))"
            set list [join [odbcConnection $this $query]]
        } else {
            set query "SELECT MIN(instant), MAX(instant) FROM instances, history WHERE (module = '$module') AND (instance = number) AND (instant <= $($this,start))"
            if {$($this,file)} {
                set list [sqliteEvaluate $this $query]
                foreach {minimum maximum} $list {}
                if {[string length $minimum] > 0} {
                    set list                        [list [clock format $minimum -format $(dateTimeFormat)] [clock format $maximum -format $(dateTimeFormat)]]
                }
            } else {
                set list [mysqlSelect $this $query -flatlist]
            }
        }
        busy 0 $busyWidgets
        lifoLabel::pop $global::messenger
        return $list
    }

    proc instances {this module} {
        if {$($this,odbc)} {
            set prefix $($this,prefix)
            set query "SELECT ${prefix}number FROM instances WHERE (${prefix}number > 0) AND (${prefix}module = '$module') AND (${prefix}start <= $($this,start)) ORDER BY ${prefix}number"
            return [join [odbcConnection $this $query]]
        } else {
            set query "SELECT number FROM instances WHERE (number > 0) AND (module = '$module') AND (start <= $($this,start)) ORDER BY number"
            if {$($this,file)} {
                return [sqliteEvaluate $this $query]
            } else {
                return [mysqlSelect $this $query -flatlist]
            }
        }
    }

    proc instanceRange {this instance {busyWidgets .}} {
        lifoLabel::push $global::messenger [mc {retrieving module instance range from database...}]
        busy 1 $busyWidgets
        if {$($this,odbc)} {
            set prefix $($this,prefix)
            set query "SELECT MIN(${prefix}instant), MAX(${prefix}instant) FROM history WHERE (${prefix}instance = $instance) AND (${prefix}instant <= $($this,start))"
            set list [join [odbcConnection $this $query]]
        } else {
            set query "SELECT MIN(instant), MAX(instant) FROM history WHERE (instance = $instance) AND (instant <= $($this,start))"
            if {$($this,file)} {
                set list [sqliteEvaluate $this $query]
                foreach {minimum maximum} $list {}
                if {[string length $minimum] > 0} {
                    set list                        [list [clock format $minimum -format $(dateTimeFormat)] [clock format $maximum -format $(dateTimeFormat)]]
                }
            } else {
                set list [mysqlSelect $this $query -flatlist]
            }
        }
        busy 0 $busyWidgets
        lifoLabel::pop $global::messenger
        return $list
    }

    proc arguments {this instance} {
        if {$($this,odbc)} {
            set prefix $($this,prefix)
            set query "SELECT ${prefix}name, ${prefix}value FROM options WHERE ${prefix}instance = $instance ORDER BY ${prefix}name"
            return [join [odbcConnection $this $query]]
        } else {
            set query "SELECT name, value FROM options WHERE instance = $instance ORDER BY name"
            if {$($this,file)} {
                return [sqliteEvaluate $this $query]
            } else {
                return [mysqlSelect $this $query -flatlist]
            }
        }
    }

    proc identifier {this instance} {
        if {!$($this,oldFormat)} {
            if {$($this,odbc)} {
                set prefix $($this,prefix)
                set query "SELECT ${prefix}identifier FROM instances WHERE ${prefix}number = $instance"
                set identifier [lindex [join [odbcConnection $this $query]] 0]
            } else {
                set query "SELECT identifier FROM instances WHERE number = $instance"
                if {$($this,file)} {
                    set identifier [lindex [sqliteEvaluate $this $query] 0]
                } else {
                    set identifier [lindex [mysqlSelect $this $query -flatlist] 0]
                }
            }
            if {[string length $($this,error)] > 0} {return {}}
            if {[string length $identifier] > 0} {
                return $identifier
            }
        }
        set query "SELECT module FROM instances WHERE number = $instance"
        if {$($this,odbc)} {
            return [lindex [join [odbcConnection $this $query]] 0]
        } else {
            return [lindex [mysqlSelect $this $query -flatlist] 0]
        }
    }

    proc version {this instance} {
        if {$($this,odbc)} {
            set prefix $($this,prefix)
            set query "SELECT ${prefix}major, ${prefix}minor FROM instances WHERE ${prefix}number = $instance"
            return [join [join [odbcConnection $this $query]] .]
        } else {
            set query "SELECT major, minor FROM instances WHERE number = $instance"
            if {$($this,file)} {
                return [join [sqliteEvaluate $this $query] .]
            } else {
                return [join [mysqlSelect $this $query -flatlist] .]
            }
        }
    }

    proc cellsData {this instance} {
        set list {}
        if {$($this,odbc)} {
            set prefix $($this,prefix)
            set query "SELECT ${prefix}row, ${prefix}entry, ${prefix}label, ${prefix}comment FROM data WHERE ${prefix}instance = $instance ORDER BY ${prefix}row, ${prefix}entry"
            foreach {row entry label comment} [join [odbcConnection $this $query]] {
                if {$row < 0} {set row [unsigned $this $row]}
                lappend list $row $entry $label $comment
            }
        } else {
            set query "SELECT row, entry, label, comment FROM data WHERE instance = $instance ORDER BY row, entry"
            if {$($this,file)} {
                foreach {row entry label comment} [sqliteEvaluate $this $query] {
                    if {$row < 0} {set row [unsigned $this $row]}
                    lappend list $row $entry $label $comment
                }
            } else {
                foreach {row entry label comment} [mysqlSelect $this $query -flatlist] {
                    if {$row < 0} {set row [unsigned $this $row]}
                    lappend list $row $entry $label $comment
                }
            }
        }
        return $list
    }

    proc cellRange {this instance row entry {startSeconds {}} {endSeconds {}} {busyWidgets .}} {
        variable ${this}cache

        set index range,$instance,$row,$entry,$startSeconds,$endSeconds
        if {[info exists ${this}cache($index)]} {
            return [set ${this}cache($index)]
        }
        set odbc $($this,odbc)
        if {$odbc} {
            set prefix $($this,prefix)
            set query "SELECT MIN(${prefix}instant), MAX(${prefix}instant) FROM history WHERE (${prefix}instance = $instance) AND (${prefix}row = [signed $this $row]) AND (${prefix}entry = $entry) AND (${prefix}instant <= $($this,start))"
        } else {
            set query "SELECT MIN(instant), MAX(instant) FROM history WHERE (instance = $instance) AND (row = [signed $this $row]) AND (entry = $entry) AND (instant <= $($this,start))"
        }
        if {([string length $startSeconds] > 0) && ([string length $endSeconds] > 0)} {
            if {$odbc} {
                append query " AND (${prefix}instant BETWEEN [dateTime $this $startSeconds] AND [dateTime $this $endSeconds])"
            } else {
                append query " AND (instant BETWEEN [dateTime $this $startSeconds] AND [dateTime $this $endSeconds])"
            }
        }
        lifoLabel::push $global::messenger [mc {retrieving cell range from database...}]
        busy 1 $busyWidgets
        if {$($this,file)} {
            set list [sqliteEvaluate $this $query]
            foreach {minimum maximum} $list {}
            if {[string length $minimum] > 0} {
                set list [list [clock format $minimum -format $(dateTimeFormat)] [clock format $maximum -format $(dateTimeFormat)]]
            }
        } elseif {$odbc} {
            set list [join [odbcConnection $this $query]]
        } else {
            set list [mysqlSelect $this $query -flatlist]
        }
        busy 0 $busyWidgets
        lifoLabel::pop $global::messenger
        return [set ${this}cache($index) $list]
    }

    proc moduleData {this instance} {
        if {!$($this,oldFormat)} {
            if {$($this,odbc)} {
                set prefix $($this,prefix)
                set query "SELECT ${prefix}number, ${prefix}indexed, ${prefix}label, ${prefix}type, ${prefix}message, ${prefix}anchor FROM entries WHERE ${prefix}instance = $instance"
                set list [odbcConnection $this $query]
            } else {
                set query "SELECT number, indexed, label, type, message, anchor FROM entries WHERE instance = $instance"
                if {$($this,file)} {
                    set list {}
                    foreach {number indexed label type message anchor} [sqliteEvaluate $this $query] {
                        lappend list [list $number $indexed $label $type $message $anchor]
                    }
                } else {
                    set list [mysqlSelect $this $query -list]
                }
            }
            if {[string length $($this,error)] > 0} {return {}}
            if {[llength $list] > 0} {
                return $list
            }
        }
        set query "SELECT module, major, minor FROM instances WHERE number = $instance"
        if {$($this,odbc)} {
            foreach {module major minor} [join [odbcConnection $this $query]] {}
        } else {
            foreach {module major minor} [mysqlSelect $this $query -flatlist] {}
        }
        set query "SELECT number, indexed, label, type, message, anchor FROM entries WHERE (module = '$module') AND (major = $major) AND (minor = $minor)"
        if {$($this,odbc)} {
            return [odbcConnection $this $query]
        } else {
            return [mysqlSelect $this $query -list]
        }
    }

    proc cellHistory {this instance row entry startSeconds endSeconds last {busyWidgets .}} {
        variable ${this}cache

        set index history,$instance,$row,$entry,$startSeconds,$endSeconds
        if {$last && [info exists ${this}cache($index)]} {
            return [set ${this}cache($index)]
        }
        set odbc $($this,odbc)
        if {$odbc} {
            set prefix $($this,prefix)
            set query "SELECT ${prefix}instant, ${prefix}value FROM history WHERE (${prefix}instance = $instance) AND (${prefix}row = [signed $this $row]) AND (${prefix}entry = $entry) AND (${prefix}instant BETWEEN [dateTime $this $startSeconds] AND [dateTime $this $endSeconds]) AND (${prefix}instant <= $($this,start))"
        } else {
            set query "SELECT instant, value FROM history WHERE (instance = $instance) AND (row = [signed $this $row]) AND (entry = $entry) AND (instant BETWEEN [dateTime $this $startSeconds] AND [dateTime $this $endSeconds]) AND (instant <= $($this,start))"
        }
        if {$last} {
            if {$odbc} {
                if {[string equal $($this,type) oracle]} {
                    append query " AND (ROWNUM <= 1) ORDER BY ${prefix}instant DESC"
                } else {
                    append query " ORDER BY ${prefix}instant DESC "
                    regsub -all %l $($this,limit) 1 limit
                    append query $limit
                }
            } else {
                append query " ORDER BY instant DESC LIMIT 1"
            }
        } else {
            if {$odbc} {
                append query " ORDER BY ${prefix}instant"
            } else {
                append query " ORDER BY instant"
            }
        }
        if {$last} {
            lifoLabel::push $global::messenger [mc {retrieving cell value before end cursor from database...}]
        } else {
            lifoLabel::push $global::messenger [mc {retrieving cell history from database...}]
        }
        busy 1 $busyWidgets
        if {$($this,file)} {
            set list {}
            foreach {seconds value} [sqliteEvaluate $this $query] {
                lappend list [clock format $seconds -format $(dateTimeFormat)] $value
            }
        } elseif {$odbc} {
            set list [join [odbcConnection $this $query]]
        } else {
            set list [mysqlSelect $this $query -flatlist]
        }
        busy 0 $busyWidgets
        lifoLabel::pop $global::messenger
        if {$last} {
            set ${this}cache($index) $list
        }
        return $list
    }

    proc historyQuery {this instance row entry start end} {
        set odbc $($this,odbc)
        if {$odbc} {
            set prefix $($this,prefix)
            lappend list "SELECT ${prefix}instant, ${prefix}value FROM history
    WHERE (${prefix}instance = $instance) AND (${prefix}row = [signed $this $row]) AND (${prefix}entry = $entry)"
        } else {
            lappend list "SELECT instant, value FROM history
    WHERE (instance = $instance) AND (row = [signed $this $row]) AND (entry = $entry)"
        }
        if {([string length $start] > 0) && ([string length $end] > 0)} {
            if {$odbc} {
                if {[string equal $($this,type) oracle]} {
                    lappend list "AND (${prefix}instant >= TO_DATE('$start', 'YYYY-MM-DD HH:MI:SS')) AND (${prefix}instant <= TO_DATE('$end', 'YYYY-MM-DD HH:MI:SS'))"
                } else {
                    lappend list "AND (${prefix}instant >= '$start') AND (${prefix}instant <= '$end')"
                }
            } else {
                lappend list "AND (instant >= '$start') AND (instant <= '$end')"
            }
        } else {
            lappend list {}
        }
        if {$odbc} {
            lappend list "ORDER BY ${prefix}instant"
        } else {
            lappend list "ORDER BY instant"
        }
        return $list
    }

}

}

class database {


    proc register {this instanceData} {
        array set data $instanceData
        set module $data(module)
        set file $($this,file)
        set odbc $($this,odbc)
        foreach {major minor} [lrange [split $data(version) .] 0 1] {}
        if {$odbc} {
            set prefix $($this,prefix)
            set arguments {}
        }
        if {![info exists data(options)] || ([llength $data(options)] == 0)} {
            if {$odbc} {
                set query "SELECT ${prefix}number FROM instances LEFT OUTER JOIN options ON ${prefix}number = ${prefix}instance WHERE (${prefix}module = '$module') AND (${prefix}major = $major) GROUP BY ${prefix}number HAVING COUNT(${prefix}instance) = 0"
            } else {
                set query "SELECT number FROM instances LEFT OUTER JOIN options ON number = instance WHERE (module = '$module') AND (major = $major) GROUP BY number HAVING COUNT(instance) = 0"
            }
        } else {
            if {$odbc} {
                set query "SELECT ${prefix}number FROM instances, options LEFT OUTER JOIN options AS joined ON (options.${prefix}instance = joined.${prefix}instance) AND (options.${prefix}name = joined.${prefix}name)"
            } else {
                set query "SELECT number FROM instances, options LEFT OUTER JOIN options AS joined ON (options.instance = joined.instance) AND (options.name = joined.name)"
            }
            set count 0
            foreach {name value} $data(options) {
                if {$count == 0} {
                    append query " AND ("
                } else {
                    append query " OR "
                }
                if {$odbc} {
                    append query "((options.${prefix}name = "
                    append query ?
                    lappend arguments $name
                    append query ") AND (options.${prefix}value "
                } else {
                    append query "((options.name = "
                    if {$file} {
                        append query '[sqliteEscape $name]'
                    } else {
                        append query '[mysqlescape $name]'
                    }
                    append query ") AND (options.value "
                }
                if {[string length $value] == 0} {
                    append query "IS NULL"
                } else {
                    append query "= "
                    if {$file} {
                        append query '[sqliteEscape $value]'
                    } elseif {$odbc} {
                        append query ?
                        lappend arguments $value
                    } else {
                        append query '[mysqlescape $value]'
                    }
                }
                append query "))"
                incr count
            }
            if {$count > 0} {
                append query ")"
            }
            if {$odbc} {
                append query " WHERE (${prefix}module = '$module') AND (${prefix}major = $major) AND (${prefix}number = options.${prefix}instance) GROUP BY ${prefix}number, options.${prefix}instance HAVING (COUNT(*) = COUNT(joined.${prefix}instance)) AND (COUNT(*) = $count)"
            } else {
                append query " WHERE (module = '$module') AND (major = $major) AND (number = options.instance) GROUP BY number, options.instance HAVING (COUNT(*) = COUNT(joined.instance)) AND (COUNT(*) = $count)"
            }
        }
        if {$file} {
            set instance [lindex [sqliteEvaluate $this $query] 0]
        } elseif {$odbc} {
            set instance [lindex [join [odbcConnection $this $query $arguments]] 0]
        } else {
            set instance [lindex [mysqlSelect $this $query -flatlist] 0]
        }
        if {[string length $($this,error)] > 0} {return {}}
        if {[string length $instance] == 0} {
            if {[info exists data(options)]} {set options $data(options)} else {set options {}}
            set instance [insertInstance $this $module $data(identifier) $major $minor $options]
        } else {
            updateInstance $this $instance $data(identifier) $minor
        }
        if {[string length $($this,error)] > 0} {return {}}
        updateEntries $this $instance $data(indexColumns) $data(data)
        if {[string length $($this,error)] > 0} {return {}}
        return $instance
    }

    proc insertInstance {this module identifier major minor options} {
        set file $($this,file)
        set odbc $($this,odbc)
        if {[info exists ($this,lock)]} {
            regsub -all %t $($this,lock) instances statement
            if {$odbc} {odbcConnection $this $statement} else {mysqlExecute $this $statement}
        }
        if {$odbc} {
            set prefix $($this,prefix)
            set query "SELECT MAX(${prefix}number) FROM instances"
            set instance [lindex [join [odbcConnection $this $query]] 0]
        } else {
            set query "SELECT MAX(number) FROM instances"
            if {$file} {
                set instance [lindex [sqliteEvaluate $this $query] 0]
            } else {
                set instance [lindex [mysqlSelect $this $query -flatlist] 0]
            }
        }
        if {[string length $($this,error)] > 0} {return {}}
        if {[string length $instance] == 0} {set instance 0}
        incr instance
        set statement "INSERT INTO instances VALUES ($instance, [dateTime $this], "
        if {$file} {
            append statement "'[sqliteEscape $module]', '[sqliteEscape $identifier]', "
        } elseif {$odbc} {
            append statement {?, ?, }
            set arguments [list $module $identifier]
        } else {
            append statement "'[mysqlescape $module]', '[mysqlescape $identifier]', "
        }
        append statement "$major, $minor)"
        if {$file} {
            sqliteEvaluate $this $statement
        } elseif {$odbc} {
            odbcConnection $this $statement $arguments
        } else {
            mysqlExecute $this $statement
        }
        if {[string length $($this,error)] > 0} {return {}}
        if {[info exists ($this,unlock)]} {
            regsub -all %t $($this,unlock) instances statement
            if {$odbc} {odbcConnection $this $statement} else {mysqlExecute $this $statement}
        }
        foreach {name value} $options {
            if {$odbc} {
                set arguments {}
            }
            set statement "INSERT INTO options VALUES ($instance, "
            if {$file} {
                append statement '[sqliteEscape $name]'
            } elseif {$odbc} {
                append statement ?
                lappend arguments $name
            } else {
                append statement '[mysqlescape $name]'
            }
            append statement ", "
            if {[string length $value] == 0} {
                append statement NULL
            } else {
                if {[regexp $global::passwordOptionExpression $name]} {
                    set value [string repeat * [string length $value]]
                }
                if {$file} {
                    append statement '[sqliteEscape $value]'
                } elseif {$odbc} {
                    append statement ?
                    lappend arguments $value
                } else {
                    append statement '[mysqlescape $value]'
                }
            }
            append statement )
            if {$file} {
                sqliteEvaluate $this $statement
            } elseif {$odbc} {
                odbcConnection $this $statement $arguments
            } else {
                mysqlExecute $this $statement
            }
            if {[string length $($this,error)] > 0} {return {}}
        }
        return $instance
    }

    proc updateInstance {this instance identifier minor} {
        set odbc $($this,odbc)
        set file $($this,file)
        if {$odbc} {
            set prefix $($this,prefix)
            set statement "UPDATE instances SET ${prefix}start = [dateTime $this], ${prefix}identifier = "
            append statement ?
            append statement ", ${prefix}minor = $minor WHERE ${prefix}number = $instance"
        } else {
            set statement "UPDATE instances SET start = [dateTime $this], identifier = "
            if {$file} {
                append statement '[sqliteEscape $identifier]'
            } else {
                append statement '[mysqlescape $identifier]'
            }
            append statement ", minor = $minor WHERE number = $instance"
        }
        if {$file} {
            sqliteEvaluate $this $statement
        } elseif {$odbc} {
            odbcConnection $this $statement [list $identifier]
        } else {
            mysqlExecute $this $statement
        }
    }

    proc updateEntries {this instance indexColumns data} {
        set file $($this,file)
        set odbc $($this,odbc)
        if {$odbc} {
            set prefix $($this,prefix)
            set statement "DELETE FROM entries WHERE ${prefix}instance = $instance"
            odbcConnection $this $statement
        } else {
            set statement "DELETE FROM entries WHERE instance = $instance"
            if {$file} {
                sqliteEvaluate $this $statement
            } else {
                mysqlExecute $this $statement
            }
        }
        if {[string length $($this,error)] > 0} return
        foreach index $indexColumns {set indexed($index) {}}
        set index 0
        foreach {label type message anchor} $data {
            if {$odbc} {
                set arguments {}
            }
            if {$odbc} {
                set statement "INSERT INTO entries (${prefix}instance, ${prefix}number, ${prefix}indexed, ${prefix}label, ${prefix}type, ${prefix}message, ${prefix}anchor) VALUES ("
            } else {
                set statement "INSERT INTO entries (instance, number, indexed, label, type, message, anchor) VALUES ("
            }
            append statement "$instance, $index, [info exists indexed($index)], "
            if {$file} {
                append statement '[sqliteEscape $label]'
            } elseif {$odbc} {
                append statement ?
                lappend arguments $label
            } else {
                append statement '[mysqlescape $label]'
            }
            append statement ", '$type', "
            if {$file} {
                append statement '[sqliteEscape $message]'
            } elseif {$odbc} {
                append statement ?
                lappend arguments $message
            } else {
                append statement '[mysqlescape $message]'
            }
            append statement ", "
            if {[string length $anchor] == 0} {
                append statement NULL
            } else {
                append statement '$anchor'
            }
            append statement )
            if {$file} {
                sqliteEvaluate $this $statement
            } elseif {$odbc} {
                odbcConnection $this $statement $arguments
            } else {
                mysqlExecute $this $statement
            }
            if {[string length $($this,error)] > 0} return
            incr index
        }
    }

    proc update {this instance row entry value} {
        set file $($this,file)
        set odbc $($this,odbc)
        if {![info exists ($this,connection)]} {
            if {$file} {
                sqliteOpen $this
            } elseif {$odbc} {
                odbcConnect $this
            } else {
                mysqlConnect $this
            }
            if {[string length $($this,error)] > 0} return
        }
        if {$odbc} {
            set arguments {}
        }
        set statement "INSERT"
        if {!$file && (!$odbc || [string equal $($this,type) mysql])} {
            append statement " DELAYED"
        }
        append statement " INTO history VALUES ([dateTime $this], $instance, [signed $this $row], $entry, "
        if {[string equal $value ?]} {
            append statement NULL
        } elseif {$odbc} {
            append statement ?
            lappend arguments $value
        } else {
            if {$file} {
                append statement '[sqliteEscape $value]'
            } else {
                append statement '[mysqlescape $value]'
            }
        }
        append statement )
        if {$file} {
            sqliteEvaluate $this $statement
        } elseif {$odbc} {
            odbcConnection $this $statement $arguments
        } else {
            mysqlExecute $this $statement
        }
        if {[string length $($this,error)] > 0} {
            disconnect $this
        }
    }

    proc monitor {this instance row entry label comment} {
        set file $($this,file)
        set odbc $($this,odbc)
        if {$odbc} {
            set arguments {}
        }
        if {$odbc} {
            set prefix $($this,prefix)
            set statement "DELETE FROM data WHERE (${prefix}instance = $instance) AND (${prefix}row = [signed $this $row]) AND (${prefix}entry = $entry)"
            odbcConnection $this $statement
        } else {
            set statement "DELETE FROM data WHERE (instance = $instance) AND (row = [signed $this $row]) AND (entry = $entry)"
            if {$file} {
                sqliteEvaluate $this $statement
            } else {
                mysqlExecute $this $statement
            }
        }
        set statement "INSERT INTO data VALUES ($instance, [signed $this $row], $entry, "
        if {$file} {
            append statement '[sqliteEscape $label]'
        } elseif {$odbc} {
            append statement ?
            lappend arguments $label
        } else {
            append statement '[mysqlescape $label]'
        }
        append statement ", "
        if {[string equal $comment {}]} {
            append statement NULL
        } elseif {$odbc} {
            append statement ?
            lappend arguments $comment
        } else {
            if {$file} {
                append statement '[sqliteEscape $comment]'
            } else {
                append statement '[mysqlescape $comment]'
            }
        }
        append statement )
        if {$file} {
            sqliteEvaluate $this $statement
        } elseif {$odbc} {
            odbcConnection $this $statement $arguments
        } else {
            mysqlExecute $this $statement
        }
    }

    proc sqliteEscape {string} {
        regsub -all ' $string '' string
        return $string
    }

    proc disconnect {this} {
        if {$($this,file)} {
            sqliteClose $this
        } elseif {$($this,odbc)} {
            odbcDisconnect $this
        } else {
            mysqlDisconnect $this
        }
    }

if {[package vcompare $::tcl_version 8.4] < 0} {
    proc signed {this integer} {return [expr {$integer}]}
    proc unsigned {this integer} {return [format %lu $integer]}
} else {
    proc signed {this integer} {
        if {$($this,64bits)} {return [expr {$integer}]} else {return [expr {int($integer)}]}
    }
    proc unsigned {this integer} {
        if {$($this,64bits)} {return [format %lu $integer]} else {return [expr {$integer & 0xFFFFFFFF}]}
    }
}

}



class modules {

    class instance {

        proc instance {this module index} {
            set ($this,module) $module
            set ($this,loaded) [new module $module $index]
        }

        proc ~instance {this} {
            delete $($this,loaded)
        }

        proc load {this} {
            set loaded $($this,loaded)
            module::load $loaded
            set namespace $module::($loaded,namespace)
            set ($this,namespace) $namespace
            if {[info exists ::${namespace}::data(switches)]} {
                array set switch [set ::${namespace}::data(switches)]
                if {[info exists switch(--daemon)] && ($switch(--daemon) != 0)} {
                    error {--daemon option must not take any argument}
                }
                set ($this,switches) [set ::${namespace}::data(switches)]
            }
            set ($this,initialize) $module::($loaded,initialize)
            set ($this,version) $module::($loaded,version)
            initialize $this
        }

        proc initialize {this} {
            set namespace $($this,namespace)
            set ($this,identifier) [set ${namespace}::data(identifier)]
            if {![modules::validName $($this,identifier)]} {
                foreach {name index} [modules::decoded $namespace] {}
                puts stderr "\"$name\" module identifier: \"$($this,identifier)\" contains invalid characters"
                exit 1
            }
            catch {set ($this,times) [set ${namespace}::data(pollTimes)]}
            catch {set ($this,views) [set ${namespace}::data(views)]}
        }

        proc synchronize {this} {
            module::synchronize $($this,loaded)
            initialize $this
        }

        proc empty {this} {
            module::clear $($this,loaded)
        }

    }


    set (instances) {}

    proc modules {this} error

    proc source {interpreter package file} {
        switch [file extension $file] {
            .py {
                if {[catch {package require tclpython 3}]} return
                set python [python::interp new]
                set code [catch {
                    $python exec "import sys\nsys.path.insert(0, '.')"
                    $python exec {import re}
                    $python exec "import $package"
                    $python exec $module::python::utilityFunctions
                    array set data [$python eval formstring($package.form)]
                    foreach name {helpText switches updates} {
                        catch {$interpreter eval [list namespace eval $package [list set data($name) $data($name)]]}
                    }
                    $interpreter eval "package provide $package [$python eval $package.__version__]"
                } message]
                python::interp delete $python
                if {$code} {
                    error $message $::errorInfo $code
                }
            }
            .pm {
                if {[catch {package require tclperl 3}] && [catch {package require tclperl 2}]} return
                set perl [perl::interp new]
                set code [catch {
                    $perl eval "use $package"
                    $perl eval $module::perl::utilities
                    array set data [$perl eval hash_string(%${package}::data)]
                    foreach name {helpText switches updates} {
                        catch {$interpreter eval [list namespace eval $package [list set data($name) $data($name)]]}
                    }
                    $interpreter eval "package provide $package [$perl eval \$${package}::VERSION]"
                } message]
                perl::interp delete $perl
                if {$code} {
                    error $message $::errorInfo $code
                }
            }
            default {
                $interpreter eval _source [list $file]
            }
        }
    }

    proc available {{command {}} {scanCommand {}}} {
        set directory [pwd]
        set packages {}
        foreach package [package names] {
            if {[string match *::* $package]} continue
            if {![info exists ::package(directory,$package)]} continue
            switch $package {instance - formulas continue}
            if {!$global::debug && ![string match *moodss* $::package(directory,$package)]} {
                continue
            }
            if {[string length $scanCommand] > 0} {
                regsub -all %M $scanCommand $package string
                uplevel #0 $string
            }
            cd $::package(directory,$package)
            set interpreter [interp create]
            $interpreter eval "set auto_path [list $::auto_path]"
            catch {$interpreter eval {package require {}}}
            $interpreter eval {rename source _source}; $interpreter alias source ::modules::source $interpreter $package
            if {[info exists ::package(exact,$package)]} {
                set error [catch {$interpreter eval "package require -exact $package $::package(version,$package)"}]
            } else {
                set error [catch {$interpreter eval "package require $package"}]
            }
            if {!$error && [$interpreter eval info exists ::${package}::data(updates)]} {
                lappend packages $package
                set switches {}
                catch {set switches [$interpreter eval "set ::${package}::data(switches)"]}
                set switches [list $switches]
                if {[string length $command] > 0} {
                    regsub -all %M $command $package string
                    regsub -all %S $string $switches string
                    uplevel #0 $string
                }
            }
            interp delete $interpreter
        }
        cd $directory
        return [lsort $packages]
    }

    proc printAvailable {} {
        puts {searching for module packages, please wait...}
        foreach package [available] {
            puts -nonewline "$package: possibly in"
            set count 0
            foreach directory $::auto_path {
                if {[file readable [file join $directory $package pkgIndex.tcl]]} {
                    if {$count > 0} {
                        puts -nonewline ,
                    }
                    puts -nonewline " [file join $directory $package]"
                    incr count
                }
            }
            puts {}
        }
    }

    proc parse {arguments} {
        if {[llength $arguments] == 0} return
        set name [lindex $arguments 0]
        set arguments [lrange $arguments 1 end]
        foreach {name index} [decoded $name] {}
        if {![info exists ::package(directory,$name)]} {
            error "error: \"$name\" is not a valid moodss module name"
        }
        if {![validName $name]} {
            error "\"$name\" module name contains invalid characters"
        }
        switch $name formulas - thresholds {
            error "\"$name\" is a reserved module name"
        }
        if {$global::withGUI} {
            lifoLabel::push $global::messenger [format [mc {loading %s...}] $name]
        } elseif {$global::debug} {
            writeLog "loading $name..."
        }
        set instance [new instance $name $index]
        if {[catch {instance::load $instance} message]} {
            if {$global::debug} {set information $::errorInfo}
            if {$global::withGUI} {
                lifoLabel::pop $global::messenger
            }
            delete $instance
            if {$global::debug} {
                error $information
            } else {
                error "module \"$name\" load error:\n$message"
            }
        }
        if {$global::withGUI} {
            lifoLabel::pop $global::messenger
        }
        set help [expr {[lsearch -exact $arguments --help] >= 0}]
        if {[info exists instance::($instance,switches)]} {
            if {[llength $instance::($instance,switches)] == 0} {
                error "module \"$name\" switches are empty"
            }
            if {$help} {
                displayHelpMessage $name $instance::($instance,switches)
                exit
            }
            if {[catch {set next [parseCommandLineArguments $instance::($instance,switches) $arguments options]} message]} {
                delete $instance
                error "module \"$name\" options error: $message"
            }
            if {!$instance::($instance,initialize)} {
                error "module \"$name\" has no initialize procedure"
            }
            set instance::($instance,options) [array get options]
            set instance::($instance,arguments) [lrange $arguments 0 [expr {[llength $arguments] - [llength $next] - 1}]]
            set arguments $next
        } else {
            if {$help} {
                displayHelpMessage $name
                exit
            }
            set instance::($instance,arguments) {}
        }
        lappend (instances) $instance
        parse $arguments
        if {$global::withGUI} {
            update idletasks
        }
    }

    proc helpHTMLData {name} {
        set noHelpText [mc {no help available}]
        foreach instance $(instances) {
            set namespace $instance::($instance,namespace)
            foreach {module index} [decoded $namespace] {}
            if {[string compare $module $name]} continue
            if {![info exists text]} {
                set text $noHelpText
                catch {set text [set ${namespace}::data(helpText)]}
                set version $instance::($instance,version)
                break
            }
        }
        if {![info exists text]} {
            foreach {version text} [versionAndHelpText $name] {}
            if {[string length $text] == 0} {
                set text $noHelpText
            }
        }
        set header [format [mc {<b>%s</b> module version <i>%s</i>}] $name $version]
        append header <br><br>
        if {[regsub -nocase <body> $text <body>$header text] > 0} {
            regsub -nocase {<title>.*</title>} $text {} text
            return $text
        } else {
            regsub -all \n $text <br> text
            return ${header}$text
        }
    }

    proc versionAndHelpText {name} {
        set directory [pwd]
        cd $::package(directory,$name)
        set interpreter [interp create]
        $interpreter eval "set auto_path [list $::auto_path]"
        catch {$interpreter eval {package require {}}}
        $interpreter eval {rename source _source}; $interpreter alias source ::modules::source $interpreter $name
        $interpreter eval "package require $name"
        set version [$interpreter eval "package provide $name"]
        set text {}
        catch {set text [$interpreter eval "namespace eval $name {set data(helpText)}"]}
        interp delete $interpreter
        cd $directory
        return [list $version $text]
    }

    proc initialize {{daemon 0} {errorCommand {}}} {
        foreach instance $(instances) {
            set namespace $instance::($instance,namespace)
            set error 0
            if {$instance::($instance,initialize)} {
                regsub {<0>$} $namespace {} string
                if {$global::withGUI} {
                    lifoLabel::push $global::messenger [format [mc {initializing %s...}] $string]
                } elseif {$global::debug} {
                    writeLog "initializing $string module..."
                }
                catch {unset options}
                catch {array set options $instance::($instance,options)}
                if {$daemon && [info exists instance::($instance,switches)]} {
                    array set switch $instance::($instance,switches)
                    if {![info exists option(--daemon)] && [info exists switch(--daemon)]} {
                        set options(--daemon) {}
                    }
                    unset switch
                }
                if {[info exists options]} {
                    if {[catch {::${namespace}::initialize [array get options]} message]} {
                        if {$global::debug} {set information $::errorInfo}
                        set error 1
                    }
                } else {
                    if {[catch ::${namespace}::initialize message]} {
                        if {$global::debug} {set information $::errorInfo}
                        set error 1
                    }
                }
                if {$global::withGUI} {
                    lifoLabel::pop $global::messenger
                }
            }
            if {!$error} {
                instance::synchronize $instance
                set 64BitsName ::${namespace}::data(64Bits)
                if {([package vcompare $::tcl_version 8.4] < 0) && [info exists $64BitsName] && [set $64BitsName]} {
                    set message {Tcl/Tk core version 8.4 or above is required for 64 bits support}
                    set information $message
                    set error 1
                }
            }
            if {$error} {
                unload $instance
                regsub {<0>$} $namespace {} namespace
                set message "module \"$namespace\" initialize error:\n$message"
                if {$global::debug} {
                    error $information
                } elseif {[string length $errorCommand] > 0} {
                    uplevel #0 $errorCommand $namespace [list $message]
                } else {
                    error $message
                }
            }
            set instance::($instance,initialize) 0
        }
        if {$global::withGUI} {
            update idletasks
        }
    }

    proc setPollTimes {{override {}}} {
        if {[llength $(instances)] == 0} {
            set global::pollTimes {}
            set global::pollTime 0
            return
        }
        set default 0
        set minimum 0
        foreach instance $(instances) {
            set times $instance::($instance,times)
            if {[llength $times] == 0} {
                error "module $instance::($instance,namespace) poll times list is empty"
            }
            set time [lindex $times 0]
            if {$time < 0} {
                set intervals($time) {}
                continue
            }
            if {$time > $default} {
                set default $time
            }
            set times [lsort -integer $times]
            set time [lindex $times 0]
            if {$time > $minimum} {
                set minimum $time
                set minimumModule $instance::($instance,namespace)
            }
            foreach time $times {
                set data($time) {}
            }
        }
        set global::pollTimes [lsort -integer [array names data]]
        set global::pollTimes [lrange $global::pollTimes [lsearch -exact $global::pollTimes $minimum] end]
        if {$global::pollTime < $default} {
            set global::pollTime $default
        }
        if {[string length $override] > 0} {
            if {$override < $minimum} {
                puts stderr "$::argv0: minimum poll time is $minimum seconds for module $minimumModule"
                exit 1
            }
            set global::pollTime $override
        }
        if {($global::pollTime == 0) && [info exists intervals]} {
            set sum 0
            set number 0
            foreach interval [array names intervals] {
                incr sum $interval
                incr number
            }
            set global::pollTime [expr {round(double($sum) / -$number)}]
        }
    }

    proc identifier {array} {
        set namespace [namespaceFromArray $array]
        foreach instance $(instances) {
            if {[string equal $namespace $instance::($instance,namespace)]} {
                return $instance::($instance,identifier)
            }
        }
        return {}
    }

    proc asynchronous {array} {
        set namespace [namespaceFromArray $array]
        foreach instance $(instances) {
            if {[string equal $namespace $instance::($instance,namespace)]} {
                return [expr {[lindex $instance::($instance,times) 0] < 0}]
            }
        }
        error "could not find module instance for array $array"
    }

    proc instanceData {array} {
        variable instanceData

        set namespace [namespaceFromArray $array]
        foreach identifier $(instances) {
            if {[string equal $namespace $instance::($identifier,namespace)]} {
                set instance $identifier
                break
            }
        }
        if {![info exists instance]} {
            return {}
        }
        if {[info exists instanceData($instance)]} {
            return $instanceData($instance)
        }
        foreach {data(module) dummy} [modules::decoded $namespace] {}
        set data(identifier) $instance::($instance,identifier)
        set data(version) $instance::($instance,version)
        catch {set data(options) $instance::($instance,options)}
        upvar 1 ::${namespace}::data module
        set columns {}
        foreach name [array names module *,label] {
            if {[scan $name %u column] > 0} {lappend columns $column}
        }
        set list {}
        foreach column [lsort -integer $columns] {
            lappend list $module($column,label) $module($column,type) $module($column,message)
            if {[catch {lappend list $module($column,anchor)}]} {lappend list {}}
        }
        set data(data) $list
        set data(indexColumns) 0; catch {set data(indexColumns) $module(indexColumns)}
        return [set instanceData($instance) [array get data]]
    }

    proc decoded {name} {
        set index {}
        scan $name {%[^<]<%u>} name index
        return [list $name $index]
    }

    proc validName {string} {
        return [regexp {^[\w ,<>@%&*()=+:.-]+$} $string]
    }

    proc displayHelpMessage {name {switches {}}} {
        puts -nonewline "$name module usage:"
        if {[llength $switches] == 0} {
            puts -nonewline { <no arguments allowed>}
        } else {
            foreach {switch argument} $switches {
                puts -nonewline " \[$switch"
                if {$argument} {
                    puts -nonewline { argument}
                }
                puts -nonewline \]
            }
        }
        puts {}
    }

    proc loaded {} {
        if {[llength $(instances)] == 0} {
            return {}
        }
        foreach instance $(instances) {
            lappend list [list $instance $instance::($instance,namespace)]
        }
        set return {}
        foreach list [lsort -dictionary -index 1 $list] {
            foreach {instance namespace} $list {}
            lappend return $namespace $instance::($instance,identifier)
            set switches {}
            catch {set switches $instance::($instance,switches)}
            if {[llength $switches] == 0} {
                lappend return {}
            } else {
                set arguments $instance::($instance,arguments)
                set list {}
                foreach {switch required} $switches {
                    lappend list $switch $required
                    set index [lsearch -exact $arguments $switch]
                    if {$required} {
                        if {$index < 0} {
                            lappend list {}
                        } else {
                            lappend list [lindex $arguments [incr index]]
                        }
                    } else {
                        lappend list [expr {$index >= 0}]
                    }
                }
                lappend return $list
            }
        }
        return $return
    }

    proc instancesWithout {{modules {}}} {
        foreach module $modules {set skip($module) {}}
        set instances {}
        foreach instance $(instances) {
            if {[info exists skip($instance::($instance,module))]} continue
            lappend instances $instance
        }
        return $instances
    }

    proc namesWithout {modules} {
        set list {}
        foreach instance [instancesWithout $modules] {
            set module $instance::($instance,module)
            if {[lsearch -exact $list $module] < 0} {
                lappend list $module
            }
        }
        return $list
    }

    proc unload {instance} {
        ldelete (instances) $instance
        delete $instance
        if {$global::withGUI} {
            pages::monitorActiveCells
            thresholdLabel::monitorActiveCells
        }
    }

    proc loadedNamespace {string} {
        foreach instance $(instances) {
            if {[string equal $string $instance::($instance,namespace)]} {
                return 1
            }
        }
        return 0
    }

    proc namespaceFromArray {name} {
        return [string trimleft [namespace qualifiers [namespace which -variable $name]] :]
    }

    proc loadResidentTraceModule {} {
        if {[info exists (trace)]} {error {trying to load several resident trace modules}}
        set (trace) [new instance trace {}]
        instance::load $(trace)
        set namespace $instance::($(trace),namespace)
        ::${namespace}::initialize [list --rows $global::traceNumberOfRows]
    }

    proc trace {module identifier message} {
        regsub {<0>$} $identifier {} identifier
        set namespace $instance::($(trace),namespace)
        ::${namespace}::update $module $identifier $message
        foreach instance $(instances) {
            if {[string equal $instance::($instance,module) trace]} {
                set namespace $instance::($instance,namespace)
                ::${namespace}::update $module $identifier $message
            }
        }
    }

    proc loadFormulasModule {index object category} {
        set instance [new instance formulas $index]
        instance::load $instance
        set namespace $instance::($instance,namespace)
        set options {}
        if {[string length $object] > 0} {lappend options --object $object}
        if {[string length $category] > 0} {lappend options --category $category}
        set instance::($instance,options) $options
        ::${namespace}::initialize $options
        set instance::($instance,initialize) 0
        set instance::($instance,arguments) {}
        instance::synchronize $instance
        lappend (instances) $instance
        return $instance
    }

    proc flashMessage {module namespace message {seconds 1}} {
        regsub {<0>$} [set ::${namespace}::data(identifier)] {} identifier
        if {$global::withGUI} {
            ::lifoLabel::flash $::global::messenger "$identifier: $message" $seconds
            switched::configure [moduleFromNamespace $namespace] -state error
        } else {
            writeLog "$identifier: $message"
        }
        trace $module $identifier $message
    }

    proc pushMessage {module namespace message} {
        regsub {<0>$} [set ::${namespace}::data(identifier)] {} identifier
        if {$global::withGUI} {
            ::lifoLabel::push $::global::messenger "$identifier: $message"
        } else {
            writeLog "$identifier: $message"
        }
        trace $module $identifier $message
    }

    proc popMessage {} {
        if {$global::withGUI} {
            ::lifoLabel::pop $::global::messenger
        }
    }

    proc moduleFromNamespace {string} {
        foreach instance $(instances) {
            if {[string equal $instance::($instance,namespace) $string]} {
                return $instance::($instance,loaded)
            }
        }
        return 0
    }

}



class record {

    proc record {this args} switched {$args} {
        switched::complete $this
    }

    proc ~record {this} {
        if {[info exists ($this,root)]} {
            dom::destroy $($this,root)
        }
    }

    proc options {this} {
        return [list            [list -file {} {}]        ]
    }

    proc set-file {this value} {}

if {$global::withGUI} {

    array set series {
        ::store,comments {} ::thresholds,addresses {} ::dataTable,columnwidths {} ::freeText,cellindices {}
        ::summaryTable,cellrows {} ::summaryTable,columns {} ::summaryTable,columnwidths {} ::data2DPieChart,cellcolors {}
        ::data3DPieChart,cellcolors {} ::dataGraph,cellcolors {} ::dataStackedGraph,cellcolors {} ::dataBarChart,cellcolors {}
        ::dataSideBarChart,cellcolors {} ::dataStackedBarChart,cellcolors {} ::dataOverlapBarChart,cellcolors {}
        ::formulas::table,cellindexes {} ::formulas::table,cells {} ::formulas::table,rows {}
    }

    proc write {this} {
        variable series

        if {[string length $switched::($this,-file)] == 0} {
            error {-file option undefined}
        }
        set document [dom::create]
        set root [dom::document createElement $document moodssConfiguration]
        dom::document createTextNode [dom::document createElement $root version] $global::applicationVersion
        set seconds [clock seconds]
        dom::document createTextNode [dom::document createElement $root date] [clock format $seconds -format %D]
        dom::document createTextNode [dom::document createElement $root time] [clock format $seconds -format %T]
        set node [dom::document createElement $root configuration]
        foreach name [configuration::variables 0] {
            if {[string equal $name viewerColors]} continue
            dom::element setAttribute $node $name [set ::global::$name]
        }
        nodeFromList $node viewerColors $::global::viewerColors
        dom::document createTextNode [dom::document createElement $root width] [winfo width $widget::($global::scroll,path)]
        dom::document createTextNode [dom::document createElement $root height] [winfo height $widget::($global::scroll,path)]
        dom::document createTextNode [dom::document createElement $root pollTime] $global::pollTime
        if {[info exists databaseInstances::singleton]} {
            set node [dom::document createElement $root databaseRange]
            foreach {from to} [databaseInstances::cursorsRange] {}
            dom::element setAttribute $node from $from
            dom::element setAttribute $node to $to
            set node [dom::document createElement $root databaseViewer]
            set path $widget::($databaseInstances::singleton,path)
            foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $path] {}
            foreach {xIcon yIcon} [canvasWindowManager::iconCoordinates $global::windowManager $path] {}
            dom::element setAttribute $node x $x; dom::element setAttribute $node y $y
            dom::element setAttribute $node width $width; dom::element setAttribute $node height $height
            dom::element setAttribute $node xIcon $xIcon; dom::element setAttribute $node yIcon $yIcon
        }
        set modules [dom::document createElement $root modules]
        foreach instance $modules::(instances) {
            if {[string equal $modules::instance::($instance,module) formulas]} {
                continue
            }
            set namespace $modules::instance::($instance,namespace)
            set module [dom::document createElement $modules module]
            dom::element setAttribute $module namespace $namespace
            dom::document createTextNode [dom::document createElement $module arguments] $modules::instance::($instance,arguments)
            set tables [dom::document createElement $module tables]
            foreach table $dataTable::(list) {
                if {![string equal $namespace [namespace qualifiers [composite::cget $table -data]]]} continue
                foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $widget::($table,path)] {}
                set level [canvasWindowManager::getStackLevel $global::windowManager $widget::($table,path)]
                foreach {xIcon yIcon} [canvasWindowManager::iconCoordinates $global::windowManager $widget::($table,path)] {}
                set node [dom::document createElement $tables table]
                dom::element setAttribute $node x $x; dom::element setAttribute $node y $y
                dom::element setAttribute $node width $width; dom::element setAttribute $node height $height
                dom::element setAttribute $node level $level
                dom::element setAttribute $node xIcon $xIcon; dom::element setAttribute $node yIcon $yIcon
                set list [dataTable::initializationConfiguration $table]
                if {[llength $list] > 0} {
                    set options [dom::document createElement $node configuration]
                    foreach {switch value} $list {
                        set switch [string trimleft $switch -]
                        if {[info exists series(::dataTable,$switch)]} {
                            nodeFromList $options $switch $value
                        } else {
                            dom::element setAttribute $options $switch $value
                        }
                    }
                }
            }
        }
        set viewers [dom::document createElement $root viewers]
        foreach viewer $viewer::(list) {
            if {![viewer::saved $viewer]} continue
            set node [dom::document createElement $viewers viewer]
            set class [classof $viewer]
            dom::element setAttribute $node class $class
            if {[viewer::manageable $viewer]} {
                foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $widget::($viewer,path)] {}
                set level [canvasWindowManager::getStackLevel $global::windowManager $widget::($viewer,path)]
                dom::element setAttribute $node x $x; dom::element setAttribute $node y $y
                dom::element setAttribute $node width $width; dom::element setAttribute $node height $height
                dom::element setAttribute $node level $level
                foreach {xIcon yIcon} [canvasWindowManager::iconCoordinates $global::windowManager $widget::($viewer,path)] {}
                if {[string length $xIcon] > 0} {
                    dom::element setAttribute $node xIcon $xIcon; dom::element setAttribute $node yIcon $yIcon
                }
            }
            nodeFromList $node cells [viewer::cells $viewer]
            set list [viewer::initializationConfiguration $viewer]
            if {[llength $list] > 0} {
                catch {unset configurationNode}
                foreach {switch value} $list {
                    set switch [string trimleft $switch -]
                    if {[string equal $switch configurations]} {
                        foreach sublist $value {
                            set options [dom::document createElement $node configurations]
                            foreach {switch value} $sublist {
                                set switch [string trimleft $switch -]
                                if {[info exists series($class,$switch)]} {
                                    nodeFromList $options $switch $value
                                } else {
                                    switch -glob [string tolower $switch] {
                                        *text {dom::document createTextNode [dom::document createElement $options $switch] $value}
                                        *data                                            {dom::document createCDATASection [dom::document createElement $options $switch] $value}
                                        default {dom::element setAttribute $options $switch $value}
                                    }
                                }
                            }
                        }
                    } else {
                        if {![info exists configurationNode]} {
                            set configurationNode [dom::document createElement $node configuration]
                        }
                        set options $configurationNode
                        if {[info exists series($class,$switch)]} {
                            nodeFromList $options $switch $value
                        } else {
                            switch -glob [string tolower $switch] {
                                *text {dom::document createTextNode [dom::document createElement $options $switch] $value}
                                *data {dom::document createCDATASection [dom::document createElement $options $switch] $value}
                                default {dom::element setAttribute $options $switch $value}
                            }
                        }
                    }
                }
            }
        }
        set images [dom::document createElement $root images]
        foreach {file format data} [images::values] {
            set node [dom::document createElement $images image]
            dom::element setAttribute $node file $file
            dom::element setAttribute $node format $format
            dom::document createCDATASection $node \n$data\n
        }
        set file [open $switched::($this,-file) w+]
        dom::document configure $document -encoding [fconfigure $file -encoding]
        set data [serialize $document]
        dom::destroy $root
        puts $file $data
        close $file
    }

}

    proc read {this} {
        if {[string length $switched::($this,-file)] == 0} {
            error {-file option undefined}
        }
        if {[catch {set file [open $switched::($this,-file)]} message]} {
            puts stderr $message
            exit 1
        }
        set line [gets $file]
        seek $file 0
        if {[catch {set ($this,root) [dom::parse [::read $file]]} message]} {
            puts stderr "file $switched::($this,-file) is not a valid moodss configuration file:\n$message"
            exit 1
        }
        close $file
        set ($this,convertNamespaces) [expr {[package vcompare [version $this] 19.0] < 0}]
    }

    proc modules {this} {
        set list {}
        foreach node [dom::selectNode $($this,root) /moodssConfiguration/modules/module] {
            set namespace [dom::element getAttribute $node namespace]
            if {$($this,convertNamespaces)} {
                foreach {name index} [modules::decoded $namespace] {}
                if {[string length $index] == 0} {append namespace <0>}
            }
            lappend list $namespace
        }
        return $list
    }

    proc modulesWithArguments {this {validateCommand {}}} {
        set list {}
        foreach node [dom::selectNode $($this,root) /moodssConfiguration/modules/module] {
            set namespace [dom::element getAttribute $node namespace]
            if {([string length $validateCommand] > 0) && ![uplevel #0 $validateCommand $namespace]} continue
            lappend list $namespace
            eval lappend list [dom::node stringValue [dom::selectNode $node arguments]]
        }
        return $list
    }

    proc pollTime {this} {
        return [dom::node stringValue [dom::selectNode $($this,root) /moodssConfiguration/pollTime]]
    }

    proc sizes {this} {
        return [list            [dom::node stringValue [dom::selectNode $($this,root) /moodssConfiguration/width]]            [dom::node stringValue [dom::selectNode $($this,root) /moodssConfiguration/height]]        ]
    }

    proc viewersData {this} {
        set list {}
        foreach viewerNode [dom::selectNode $($this,root) /moodssConfiguration/viewers/viewer] {
            set class [dom::element getAttribute $viewerNode class]
            if {$($this,convertNamespaces)} {
                set cells [convertedCells [listFromNode $viewerNode cells]]
            } else {
                set cells [listFromNode $viewerNode cells]
            }
            lappend list $class $cells [dom::element getAttribute $viewerNode x] [dom::element getAttribute $viewerNode y]                [dom::element getAttribute $viewerNode width] [dom::element getAttribute $viewerNode height]                [dom::element getAttribute $viewerNode level] [dom::element getAttribute $viewerNode xIcon]                [dom::element getAttribute $viewerNode yIcon]
            set options {}
            set node [dom::selectNode $viewerNode configuration]
            if {[string length $node] > 0} {
                foreach {name value} [array get [dom::node cget $node -attributes]] {
                    if {$($this,convertNamespaces)} {
                        switch $name totalcell - ymaximumcell {set value [converted $value]}
                    }
                    lappend options -$name $value
                }
                foreach node [dom::selectNode $node *] {
                    set name [dom::node cget $node -nodeName]
                    switch -glob [string tolower $name] {
                        *text - *data {lappend options -$name [dom::node stringValue $node]}
                        default {lappend options -$name [listFromNode $node]}
                    }
                }
            }
            set nodes [dom::selectNode $viewerNode configurations]
            if {[llength $nodes] > 0} {
                set lists {}
                foreach node $nodes {
                    set append {}
                    foreach {name value} [array get [dom::node cget $node -attributes]] {
                        lappend append -$name $value
                    }
                    foreach node [dom::selectNode $node *] {
                        set name [dom::node cget $node -nodeName]
                        switch -glob [string tolower $name] {
                            *text - *data {lappend append -$name [dom::node stringValue $node]}
                            default {
                                if {                                    $($this,convertNamespaces) &&                                    [string equal $class ::formulas::table] && [string equal $name cells]                                } {
                                    lappend append -$name [convertedCells [listFromNode $node]]
                                } else {
                                    lappend append -$name [listFromNode $node]
                                }
                            }
                        }
                    }
                    lappend lists $append
                }
                lappend options -configurations $lists
            }
            lappend list $options
        }
        return $list
    }

    proc tableNode {this namespace creationIndex} {
        if {$($this,convertNamespaces) && [string match *<0> $namespace]} {
            regsub {<0>$} $namespace {} namespace
        }
        set node [dom::selectNode $($this,root) /moodssConfiguration/modules/module\[@namespace=\"$namespace\"\]]
        if {[string length $node] == 0} {error {internal error: please report to author}}
        return [lindex [dom::selectNode $node tables/table] $creationIndex]
    }

    proc tableWindowManagerData {this namespace creationIndex} {
        if {[string length [set node [tableNode $this $namespace $creationIndex]]] == 0} {
            return {}
        }
        array set data [array get [dom::node cget $node -attributes]]
        return [list $data(x) $data(y) $data(width) $data(height) $data(level) $data(xIcon) $data(yIcon)]
    }

    proc tableOptions {this namespace creationIndex} {
        if {[string length [set node [tableNode $this $namespace $creationIndex]]] == 0} {
            return {}
        }
        set options {}
        set node [dom::selectNode $node configuration]
        if {[string length $node] > 0} {
            foreach {name value} [array get [dom::node cget $node -attributes]] {
                lappend options -$name $value
            }
            foreach node [dom::selectNode $node *] {
                lappend options -[dom::node cget $node -nodeName] [listFromNode $node]
            }
        }
        return $options
    }

    proc configurationData {this} {
        set node [dom::selectNode $($this,root) /moodssConfiguration/configuration]
        set list [array get [dom::node cget $node -attributes]]
        lappend list viewerColors [listFromNode $node viewerColors]
        return $list
    }

    proc version {this} {
        return [dom::node stringValue [dom::selectNode $($this,root) /moodssConfiguration/version]]
    }

    proc databaseRange {this} {
        set node [dom::selectNode $($this,root) /moodssConfiguration/databaseRange]
        if {[string length $node] == 0} {return {}}
        array set data [array get [dom::node cget $node -attributes]]
        return [list $data(from) $data(to)]
    }

    proc databaseViewerWindowManagerData {this} {
        set node [dom::selectNode $($this,root) /moodssConfiguration/databaseViewer]
        if {[string length $node] == 0} {return {}}
        array set data [array get [dom::node cget $node -attributes]]
        return [list $data(x) $data(y) $data(width) $data(height) $data(xIcon) $data(yIcon)]
    }

    proc converted {cell} {
        if {[string length $cell] == 0} {return {}}
        viewer::parse $cell array row column ignore
        set namespace [namespace qualifiers $array]
        foreach {name index} [modules::decoded $namespace] {}
        if {[string length $index] == 0} {
            set cell $namespace<0>::[namespace tail $array]($row,$column)
        }
        return $cell
    }
    proc convertedCells {list} {
        set cells {}
        foreach cell $list {lappend cells [converted $cell]}
        return $cells
    }

if {$global::withGUI} {

    proc imagesData {this} {
        set list {}
        foreach node [dom::selectNode $($this,root) /moodssConfiguration/images/image] {
            lappend list [dom::element getAttribute $node file] [string trim [dom::node stringValue $node]]
            dom::destroy $node
        }
        return $list
    }

    proc currentConfiguration {} {
        set root [new container]
        container::bind $root [set container [new container configuration]]
        foreach name [configuration::variables 0] {
            container::set $container $name [set ::global::$name]
        }
        container::set $root width [winfo width $widget::($global::scroll,path)]
        container::set $root height [winfo height $widget::($global::scroll,path)]
        container::set $root pollTime $global::pollTime
        if {[info exists databaseInstances::singleton]} {
            container::bind $root [set container [new container databaseRange]]
            foreach {from to} [databaseInstances::cursorsRange] {}
            container::set $container from $from
            container::set $container to $to
            container::bind $root [set container [new container databaseViewer]]
            set path $widget::($databaseInstances::singleton,path)
            foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $path] {}
            foreach {xIcon yIcon} [canvasWindowManager::iconCoordinates $global::windowManager $path] {}
            container::set $container x $x; container::set $container y $y
            container::set $container width $width; container::set $container height $height
            container::set $container xIcon $xIcon; container::set $container yIcon $yIcon
        }
        container::bind $root [set modules [new container modules]]
        foreach instance $modules::(instances) {
            set namespace $modules::instance::($instance,namespace)
            container::bind $modules [set module [new container module]]
            container::set $module namespace $namespace
            container::set $module arguments $modules::instance::($instance,arguments)
            container::bind $module [set tables [new container tables]]
            foreach table $dataTable::(list) {
                if {![string equal $namespace [namespace qualifiers [composite::cget $table -data]]]} continue
                foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $widget::($table,path)] {}
                set level [canvasWindowManager::getStackLevel $global::windowManager $widget::($table,path)]
                foreach {xIcon yIcon} [canvasWindowManager::iconCoordinates $global::windowManager $widget::($table,path)] {}
                container::bind $tables [set container [new container table]]
                container::set $container x $x; container::set $container y $y
                container::set $container width $width; container::set $container height $height
                container::set $container level $level
                container::set $container xIcon $xIcon; container::set $container yIcon $yIcon
                set list [dataTable::initializationConfiguration $table]
                if {[llength $list] > 0} {
                    container::bind $container [set options [new container configuration]]
                    foreach {switch value} $list {
                        container::set $options $switch $value
                    }
                }
            }
        }
        container::bind $root [set viewers [new container viewers]]
        foreach viewer $viewer::(list) {
            if {![viewer::saved $viewer]} continue
            container::bind $viewers [set container [new container viewer]]
            container::set $container class [classof $viewer]
            if {[viewer::manageable $viewer]} {
                foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $widget::($viewer,path)] {}
                set level [canvasWindowManager::getStackLevel $global::windowManager $widget::($viewer,path)]
                container::set $container x $x; container::set $container y $y
                container::set $container width $width; container::set $container height $height
                container::set $container level $level
                foreach {xIcon yIcon} [canvasWindowManager::iconCoordinates $global::windowManager $widget::($viewer,path)] {}
                if {[string length $xIcon] > 0} {
                    container::set $container xIcon $xIcon; container::set $container yIcon $yIcon
                }
            }
            container::set $container cells [viewer::cells $viewer]
            set list [viewer::initializationConfiguration $viewer]
            if {[llength $list] > 0} {
                container::bind $container [set options [new container configuration]]
                foreach {switch value} $list {
                    if {[string match -nocase *data $switch]} continue
                    if {[string equal $switch -configurations]} {
                        foreach list $value {
                            container::bind $options [set configurations [new container configurations]]
                            foreach {switch value} $list {
                                container::set $configurations $switch $value
                            }
                        }
                    } else {
                        container::set $options $switch $value
                    }
                }
            }
        }
        container::bind $root [set images [new container images]]
        foreach file [images::names] {
            container::bind $images [set container [new container image]]
            container::set $container file $file
        }
        return $root
    }

    proc snapshot {} {
        if {[info exists (data)]} {delete $(data)}
        set (data) [currentConfiguration]
    }

    proc changed {} {
        if {[info exists (data)]} {
            set container [currentConfiguration]
            set equal [container::equal $(data) [currentConfiguration]]
            delete $container
            return [expr {!$equal}]
        } else {
            return 0
        }
    }

}

}



class viewer {

    set (list) {}
if {$global::withGUI} {
    set (background) $widget::option(label,background)
    set (rightRedArrow) [image create photo -data {R0lGODlhBQAJAIAAAP8AAP8AACH5BAEKAAEALAAAAAAFAAkAAAIMRB5gp9v2YlJsJRQKADs=}]
    set (rightDarkGrayArrow) [image create photo -data {R0lGODlhBQAJAIAAAKCgoP///yH5BAEKAAEALAAAAAAFAAkAAAIMRB5gp9v2YlJsJRQKADs=}]
    set (limitAreaWidth) 40
    set (limitAreaHeight) 20
}

    proc viewer {this} {
        lappend (list) $this
    }

    proc ~viewer {this} {
        dataTrace::unregister $this
        if {[info exists ($this,drop)]} {
            delete $($this,drop)
        }
        ldelete (list) $this
if {$global::withGUI} {
        pages::monitorActiveCells
        thresholdLabel::monitorActiveCells
}
    }

    virtual proc supportedTypes {this}

    proc view {this cells} {
        set list {}
        foreach cell $cells {
            parse $cell array row column type
            if {![info exists $array]} continue
            if {[lsearch -exact [supportedTypes $this] $type] < 0} {
if {$global::withGUI} {
                wrongTypeMessage $type
}
                return 0
            }
            set update($array) {}
            lappend list $array $row $column
        }
        foreach {array row column} $list {
            monitorCell $this $array $row $column
if {$global::withGUI} {
            foreach {color level summary} [thresholds::cellData $array $row $column] {
                thresholdCondition $this $array $row $column $color $level $summary
            }
            setCellColor $this ${array}($row,$column) [cellThresholdColor $array $row $column]
}
        }
        foreach array [array names update] {
            update $this $array
        }
        return 1
    }

    virtual proc monitorCell {this array row column}

    proc parse {dataCell arrayName rowName columnName typeName} {
        upvar 1 $arrayName cellArray $rowName cellRow $columnName cellColumn $typeName cellType

        if {([scan $dataCell {%[^(](%lu,%u)} array row column] != 3) || ($column < 0)} {
            error "\"$dataCell\" is not a valid array cell"
        }
        set cellArray $array; set cellRow $row; set cellColumn $column; catch {set cellType [set ${array}($column,type)]}
    }

    proc updateInterval {value} {
        foreach viewer $(list) {
            catch {composite::configure $viewer -interval $value}
        }
    }

    proc label {array row column {identify {}}} {
        set label {}
        if {[string length $identify] == 0} {
            set identify $global::cellsLabelModuleHeader
        }
        if {$identify} {
            set identifier [modules::identifier $array]
            if {[string length $identifier] > 0} {
                regsub {<0>$} $identifier {} identifier
                set label "$identifier: "
            }
        }
        if {[catch {set ${array}(indexColumns)} columns]} {
            set columns 0
        }
        foreach index $columns {
            if {[catch {set ${array}($row,$index)} value]} {
                append label {? }
            } elseif {[string length $value] > 0} {
                append label "$value "
            }
        }
        append label [set ${array}($column,label)]
        return [list $label [string match {*\?*} $label]]
    }

    virtual proc update {this array}

    proc registerTrace {this array {last 0}} {
        dataTrace::register $this $array "viewer::update $this $array" $last
    }

    proc unregisterTrace {this array} {
        dataTrace::unregister $this $array
    }

    virtual proc cells {this}

if {$global::withGUI} {

    virtual proc initializationConfiguration {this} {
        return {}
    }

    proc setupDropSite {this path} {
        set ($this,drop) [new dropSite -path $path -formats {DATACELLS VIEWER KILL} -command "viewer::handleDrop $this"]
    }

    proc handleDrop {this} {
        if {![catch {set data $dragSite::data(DATACELLS)}]} {
            view $this $data
        } elseif {![catch {set data $dragSite::data(VIEWER)}]} {
            mutate $this $data
        } elseif {[info exists dragSite::data(KILL)]} {
            delete $this
        }
    }

    proc mutate {this class} {
        if {[string equal $class [classof $this]]} return
        set draggable [composite::cget $this -draggable]
        switch $class {
            ::currentValueTable {
                set viewer [new currentValueTable $global::canvas $global::pollTime -draggable $draggable]
            }
            ::canvas::iconic {
                if {[string length [set name [canvas::iconic::chooseFile]]] == 0} return
                set viewer [new $class $global::canvas -draggable $draggable -static $global::static -file $name]
            }
            default {
                set viewer [new $class $global::canvas -draggable $draggable]
            }
        }
        foreach list [composite::configure $viewer] {
            if {[string equal [lindex $list 0] -interval]} {
                composite::configure $viewer -interval $global::pollTime
                break
            }
        }
        set cells {}
        set count 0
        foreach cell [cells $this] {
            if {[info exists $cell]} {
                lappend cells $cell
            }
            incr count
        }
        if {[llength $cells] > 0} {
            view $viewer $cells
        }
        if {[llength $cells] < $count} {
            lifoLabel::flash $global::messenger [mc {some data cells no longer exist}]
        }
        if {[manageable $this]} {
            foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $widget::($this,path)] {}
            set level [canvasWindowManager::getStackLevel $global::windowManager $widget::($this,path)]
        } else {
            set x [composite::cget $this -x]; set y [composite::cget $this -y]
            set width {}; set height {}; set level {}
        }
        delete $this
        if {[manageable $viewer]} {
            manageViewer $viewer 1 -static $global::static -setx $x -sety $y -setwidth $width -setheight $height -level $level                -dragobject $viewer
        } else {
            composite::configure $viewer -x $x -y $y
        }
    }

    proc cellThresholdColor {array row column} {
        set manager [new thresholdsManager]
        set cell ${array}($row,$column)
        foreach {color level summary} [thresholds::cellData $array $row $column] {
            thresholdsManager::condition $manager $cell $color $level $summary
        }
        set color [lindex [lindex [thresholdsManager::colorsAndTexts $manager] 0] 0]
        delete $manager
        return $color
    }

    proc cellThresholdCondition {array row column color level summary} {
        set topColor [cellThresholdColor $array $row $column]
        foreach viewer $(list) {
            thresholdCondition $viewer $array $row $column $color $level $summary
            setCellColor $viewer ${array}($row,$column) $topColor
        }
    }


    virtual proc thresholdCondition {this array row column color level summary} {}
    virtual proc setCellColor {this cell color} {}

    virtual proc manageable {this} {return 1}

    proc monitoring {cell} {
        set viewers {}
        foreach viewer $(list) {
            if {[monitored $viewer $cell]} {
                lappend viewers $viewer
            }
        }
        return $viewers
    }

    virtual proc monitored {this cell}

    proc getDisplayColor {cell} {
        variable colorIndex
        variable usageCount

        if {![info exists colorIndex($cell)]} {
            set colors [llength $global::viewerColors]
            for {set index 0} {$index < $colors} {incr index} {
                set count($index) 0
            }
            foreach {name index} [array get colorIndex] {
                incr count($index)
            }
            set color 0
            set minimum $global::32BitIntegerMaximum
            for {set index 0} {$index < $colors} {incr index} {
                if {$count($index) < $minimum} {
                    set minimum $count($index)
                    set color $index
                }
            }
            set colorIndex($cell) $color
            set usageCount($cell) 0
        }
        incr usageCount($cell)
        return [lindex $global::viewerColors $colorIndex($cell)]
    }
    proc returnDisplayColor {cell} {
        variable colorIndex
        variable usageCount

        if {[catch {incr usageCount($cell) -1}]} return
        if {$usageCount($cell) == 0} {
            unset colorIndex($cell) usageCount($cell)
        }
    }

    proc limitEntry {this path anchor x y option name font command yCommand type} {
        set entry [entry $path.maximum -borderwidth 0 -highlightthickness 0 -width 10 -font $font]
        switch $type {
            float {setupEntryValidation $entry {{checkFloatingPoint %P}}; set type double}
            signed {setupEntryValidation $entry {{check32BitSignedInteger %P}}; set type integer}
            unsigned {setupEntryValidation $entry {{check31BitUnsignedInteger %P}}; set type integer}
            default error
        }
        lifoLabel::push $global::messenger            [format [mc {enter %s value (empty for automatic scale, Return to valid, Escape to abort)}] $name]
        foreach key {<KP_Enter> <Return>} {
            bind $entry $key "
                if {\[string is $type \[%W get\]\]} {
                    $command \[%W get\]
                    destroy %W
                    lifoLabel::pop $global::messenger
                }
            "
        }
        bind $entry <Escape> "destroy %W; lifoLabel::pop $global::messenger"
        $entry insert 0 [composite::cget $this $option]
        $entry selection range 0 end
        if {[string length $yCommand] > 0} {set y [uplevel #0 $yCommand]}
        place $entry -anchor $anchor -x $x -y $y
        focus $entry
        ::update idletasks
        grab $entry
    }

    proc wrongTypeMessage {type} {
        lifoLabel::flash $global::messenger [format [mc {cannot display data of type %s}] $type]
        bell
        if {![info exists (wrongTypeDrop)]} {
            set (wrongTypeDrop) {}
            tk_messageBox -title {moodss: drag and drop} -type ok -icon info -message [format [mc                {Some viewers only accept a limited set of data types (if this case, this viewer cannot display data of type %s)}            ] $type]
        }
    }

    proc createColorsMenu {parentPath command} {
        set menu [menu $parentPath.colorsMenu -tearoff 0]
        set spaces {   }
        if {[string equal $::tcl_platform(platform) windows]} {set spaces {      }}
        set rows 0
        set index 0
        foreach color $global::viewerColors {
            $menu add command -label $spaces -background $color -activebackground $color
            regsub -all %c $command $color string
            $menu entryconfigure $index -hidemargin 1 -command $string
            if {$rows >= 3} {
                $menu entryconfigure $index -columnbreak 1
                set rows 0
            }
            incr rows
            incr index
        }
        return $menu
    }

    virtual proc updateLabels {this} {}

}

    proc numericType {type} {
        switch $type {
            integer - real {return 1}
            default {return 0}
        }
    }

    virtual proc saved {this} {return 1}

}



class thresholds {

    variable levelColor
    array set levelColor {emergency red alert red critical red error red warning orange notice yellow info white debug blue}
    set (levels) {emergency alert critical error warning notice info debug}
    set (colors) {red orange yellow white green cyan blue ? {}}
    variable help
    variable translated

if {$global::withGUI} {

    set (default,button,background) $widget::option(button,background)
    variable cameraIcon [image create photo -data {
        R0lGODlhEgAQAMYAAAAAAB0dHWpqatfX1+Xl5eLi4tLS0t3d3SIiIszMzM3NzdDQ0NXV1dzc3OTk5OHh4bGxsQEBAbKyslVVVTY2NmdnZ8fHxxQUFIODgwgI
        CAQEBAwMDAoKCmxsbMnJydvb2+Pj47S0tBEREU5OTkVFRSoqKgMDA3BwcNPT097e3r6+vnx8fCQkJHp6eiEhIbe3t5GRkX19fUNDQyYmJgcHBx8fH3Nzc2Zm
        Zm1tbZubm4eHh39/f0dHRygoKAICAg4ODrCwsHFxcY2NjRgYGHZ2dicnJ6urqzU1NWVlZSsrKxAQEJOTkzAwMERERC0tLWBgYKCgoLW1tV5eXoWFhcrKyo+P
        j8HBwaenp1tbW0ZGRv//////////////////////////////////////////////////////////////////////////////////////////////////////
        /////////////////////////////////////////////////yH5BAEKAH8ALAAAAAASABAAAAfDgH8Ag4N/hoeIhgECAwQFhACJiAAGBwSXmIMIkgAJCgsM
        DQUOlw8QgxGHnQkJEhMUFRYFmASDF4KsGBkaGxccHR4fIJgGgwkhIhQjJCUXJicJKCkEKissnS0uLzAxMjM0NawJFjY31wk4NTk6Ozw9Pj/iQEHmnUJDAjtE
        RUMcFOJG6J1LQOIIkiRKfIhYAlAgoQQTZCRh0sSIuAQBzRki5OQJlCgeLmZkkQiSlClUWI2UtJFQFStXsDiZwXLSoCw9DAUCADs=
    }]

    variable mailIcon [image create photo -data {
        R0lGODlhCgAKAMIAAPgA+MDAwHh8ePj8+AAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAKAAoAAAMiCLoc/k8EMWqdJAxiQ84V52kgRkibI03siXbCScw0zdxAAgA7
    }]
    variable customMailIcon [image create photo -data {
        R0lGODlhCgAKAMIAAL+/YHt7Pvz7fgAAAP///////////////yH5BAEAAAQALAAAAAAKAAoAAAMiSLoM/i+AIGqdA4hhQc4V52kgNkibI03siXbBOcw0zdxEAgA7
    }]
    variable gearIcon [image create photo -data {
        R0lGODlhCgAKAKEAAPgA+MDAwHh8eAAAACH5BAEAAAAALAAAAAAKAAoAAAIhhBFyFoGaWJthnDZGRDjrKgiVF1pctnFiWBmCFWULIB8FADs=
    }]

}

    proc thresholds {this args} switched {$args} viewer {} {
        variable singleton
        variable thresholds {}

        if {[info exists singleton]} {
            error {only 1 thresholds object can exist}
        }
        switched::complete $this
    }

    proc ~thresholds {this} {
        error {not implemented}
    }

    proc options {this} {
        return [list [list -configurations {} {}]]
    }

if {$global::withGUI} {

    proc iconData {} {
        return {
            R0lGODdhJAAkAKUAAPj8+Hh4eHh8eHBIAPj0wAAAAPDssOjkqODgoPgAAODYmNjUkNDMiNDEgMjAeMC4cMC0aJicmLisYLCkWKigUKiYSKCUQJiMOICEgJiE
            MIiQiJCAKJCYkIh4IKCkoKisqLi8uMDEwMjQyNDY0ODk4Ojs6AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
            AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAJAAkAAAG/kCAcCgMEI/G4zBZVBKZSijy6RwKqgAp8bosCr7gsHhMHmuFXGdauT5bseujYEDPYgHxrZM+
            IBAGAkllg2N8focDBQGLVXlvAHQGkpOSgG5ocJAHm5ydlneOmJB8CKWmnwAJqqusra6rAwqys3yqfLe4ubkLvAsDvLiNWFADDMZ0x4GgQrddzA3QgHMNqIvW
            YgMO2g4D1gFz29wFc3SKjGoDD+rrA3jM7FdX0peQEPb39oD1+VxcEXZVBuAbCIEOPn3unH0LM0CCw4d0HkqUkKiMtSMDJmjcKC3jRo0IRTXBSKGkSWnMTJYM
            mXDkkAEVYsqswBJmTJYtARYoMMCCj8+fFhLtHMqzHNGjR8EMuMC0qbQxQwmFwUAVw4AMWDNIq8q1q1evGsKGHbChLCCxaNOqXcuhrdsBHaS5nUu3rl0PePN6
            oCNAr9+/gPV+GEx48JfCiBMrLgyisePHkCNLnhyisuXLmDNr3iyis+fPoEOLHj2itOnTqFOrXk2itevXsGPLnl2itu3buHPr3h0EADs=
        }
    }

}

    proc supportedTypes {this} {
        return $global::dataTypes
    }

    proc set-configurations {this value} {}

if {$global::withGUI} {

    proc edit {} {
        variable singleton
        variable thresholds
        variable cameraIcon
        variable number

        set this $singleton
        if {[info exists ($this,dialog)]} {
            raise $widget::($($this,dialog),path)
            return
        }
        set dialog [createDialog $this]
        set frame [frame $widget::($dialog,path).frame]

        set table [createTable $this $frame]
        grid $widget::($table,path) -row 0 -column 0 -sticky nsew

        set details [frame $frame.details]
        set ($this,initial) 0
        set ($this,initialButton) [checkbutton $details.initial            -font $font::(mediumBold) -text [mc {Initial condition}] -variable thresholds::($this,initial) -state disabled        ]
        lappend ($this,objects) [new widgetTip            -path $($this,initialButton) -text [mc {no action (even if condition is met) when application is started}]        ]
        grid $($this,initialButton) -row 0 -column 0 -columnspan 2 -sticky w -padx 5
        set ($this,emailsLabel) [label $details.emailsLabel -font $font::(mediumBold) -text [mc Emails:] -state disabled]
        grid $($this,emailsLabel) -row 0 -column 2 -sticky e
        set ($this,emails) [new listEntry $details -state disabled]
        grid $widget::($($this,emails),path) -row 0 -column 3 -rowspan 3 -sticky nsew
        set ($this,cellLabel) [label $details.cellLabel -font $font::(mediumBold) -text [mc {Original cell:}] -state disabled]
        grid $($this,cellLabel) -row 1 -column 0 -sticky w
        set ($this,cell) [label $details.cell -font $font::(mediumNormal) -relief sunken -width 20]
        grid $($this,cell) -row 1 -column 1 -columnspan 2 -sticky we -padx 5
        set ($this,currentLabel) [label $details.currentLabel -font $font::(mediumBold) -text [mc {Current value:}] -state disabled]
        grid $($this,currentLabel) -row 2 -column 0 -sticky w
        set ($this,current) [label $details.current -font $font::(mediumNormal) -relief sunken -width 20]
        grid $($this,current) -row 2 -column 1 -columnspan 2 -sticky we -padx 5
        set ($this,drag) [new dragSite -path $($this,current) -validcommand "thresholds::validateDrag $this"]
        dragSite::provide $($this,drag) DATACELLS "thresholds::dragData $this"
        grid columnconfigure $details 1 -weight 1
        grid columnconfigure $details 3 -weight 2
        grid $details -row 1 -column 0 -sticky ew

        set arrowSize [font metrics $font::(mediumBold) -ascent]

        set mailFrame [frame $frame.mailFrame]
        set ($this,mailLabel) [label $mailFrame.label -font $font::(mediumBold) -text [mc {Mail message}] -state disabled]
        grid $($this,mailLabel) -row 0 -column 0 -sticky w
        set arrow [new arrowButton $mailFrame -width $arrowSize -height $arrowSize]
        lappend ($this,objects) $arrow
        grid $widget::($arrow,path) -row 0 -column 1 -sticky w
        set ($this,default) 1
        set ($this,defaultButton) [checkbutton $mailFrame.default -command "thresholds::updateMailSection $this"            -font $font::(mediumBold) -text [mc Default] -variable thresholds::($this,default) -state disabled        ]
        lappend ($this,objects) [new widgetTip -path $($this,defaultButton)            -text [mc {use default subject and body for email message, as defined in preferences}]        ]
        grid $($this,defaultButton) -row 0 -column 2 -sticky e
        set partsFrame [frame $mailFrame.parts]
        set ($this,subjectLabel) [label $partsFrame.subjectLabel -font $font::(mediumBold) -text [mc Subject:] -state disabled]
        grid $($this,subjectLabel) -row 0 -column 0 -sticky w
        set ($this,subjectEntry) [entry $partsFrame.subjectEntry -font $font::(fixedNormal) -state disabled]
        grid $($this,subjectEntry) -row 0 -column 1 -sticky ew
        set ($this,bodyLabel) [label $partsFrame.bodyLabel -font $font::(mediumBold) -text [mc Body:] -state disabled]
        grid $($this,bodyLabel) -row 1 -column 0 -sticky nw
        set ($this,body) [new scroll text $partsFrame -height 80]
        set ($this,bodyText) $composite::($($this,body),scrolled,path)
        $($this,bodyText) configure -state disabled -background white -font $font::(fixedNormal)
        setupTextBindings $($this,bodyText)
        grid $widget::($($this,body),path) -row 1 -column 1 -rowspan 2 -sticky nsew
        set ($this,emailShot) 0
        set ($this,shot) [checkbutton $partsFrame.shot -image $cameraIcon -variable thresholds::($this,emailShot) -state disabled]
        lappend ($this,objects) [new widgetTip -path $($this,shot) -text [mc {attach screen shot to email message}]]
        grid $($this,shot) -row 2 -column 0
        composite::configure $arrow -command "thresholds::toggleGrid $arrow $partsFrame -row 1 -column 0 -columnspan 3 -sticky nsew"
        grid columnconfigure $partsFrame 1 -weight 1
        grid columnconfigure $mailFrame 1 -weight 1
        grid $mailFrame -row 2 -column 0 -sticky nsew

        set scriptFrame [frame $frame.scriptFrame]
        set ($this,scriptLabel) [label $scriptFrame.label -font $font::(mediumBold) -text [mc Script] -state disabled]
        grid $($this,scriptLabel) -row 0 -column 0 -sticky w
        set arrow [new arrowButton $scriptFrame -width $arrowSize -height $arrowSize]
        lappend ($this,objects) $arrow
        grid $widget::($arrow,path) -row 0 -column 1 -sticky w
        set panes [new panner $scriptFrame -panes 2]
        set ($this,script) [new scroll text $panner::($panes,frame1) -height 80]
        set ($this,scriptText) $composite::($($this,script),scrolled,path)
        $($this,scriptText) configure -state disabled -background white -font $font::(fixedNormal)
        setupTextBindings $($this,scriptText)
        pack $widget::($($this,script),path) -fill both -expand 1
        set ($this,testLabel) [label $panner::($panes,frame2).testLabel            -font $font::(mediumBold) -text [mc {Test trace:}] -state disabled        ]
        pack $($this,testLabel) -anchor nw
        set ($this,test) [new scroll text $panner::($panes,frame2) -height 120]
        set text $composite::($($this,test),scrolled,path)
        $text configure -state disabled -font $font::(fixedNormal)
        bind $text <Configure>            {foreach window [%W window names] {$window configure -width [expr {%w - $global::separatorCut}]}}
        set ($this,testText) $text
        pack $widget::($($this,test),path) -fill both -expand 1
        composite::configure $arrow            -command "thresholds::toggleGrid $arrow $widget::($panes,path) -row 1 -column 0 -columnspan 2 -sticky nsew"
        grid rowconfigure $scriptFrame 1 -weight 1
        grid columnconfigure $scriptFrame 1 -weight 1
        set ($this,panes) $panes
        grid $scriptFrame -row 3 -column 0 -sticky nsew

        grid rowconfigure $frame 0 -weight 1
        grid columnconfigure $frame 0 -weight 1

        foreach {string underline} [underlineAmpersand [mc &Test]] {}
        composite::configure $dialog test -text $string -underline $underline -command "thresholds::test $this" -state disabled
        set button $composite::($dialog,test,path)
        lappend ($this,objects) [new widgetTip -path $button -text [mc {test email and script}]]
        set ($this,testButton) $button
        foreach {string underline} [underlineAmpersand [mc &Delete]] {}
        composite::configure $dialog delete -text $string -underline $underline -command "thresholds::delete $this" -state disabled
        set button $composite::($dialog,delete,path)
        lappend ($this,objects) [new widgetTip -path $button -text [mc {delete selected entry}]]
        set ($this,deleteButton) $button

        dialogBox::display $dialog $frame
        set ($this,table) $table
        set ($this,dialog) $dialog
        foreach threshold [lsort -command threshold::comparison -decreasing $thresholds] {
            display $this $threshold
        }
        selectTable::refreshBorders $table
        selectTable::adjustTableColumns $table
    }

}

    proc monitorCell {this array row column} {
        variable thresholds

        viewer::registerTrace $this $array 1
        set cell ${array}($row,$column)
        if {[llength $switched::($this,-configurations)] > 0} {
            set index 0
            foreach configuration $switched::($this,-configurations) {
                catch {unset option}; array set option $configuration
                if {![info exists option(-cell)]} break
                if {[string equal $option(-cell) $cell]} {
                    unset option(-cell)
                    break
                }
                incr index
            }
            set threshold [eval new threshold $cell [array get option]]
            switched::configure $this -configurations [lrange $switched::($this,-configurations) [incr index] end]
        } else {
            set threshold [new threshold $cell]
            switched::configure $threshold -label $threshold::($threshold,cellLabel)
        }
        lappend thresholds $threshold
        if {[info exists ($this,dialog)]} {
            set (held,$threshold) {}
            display $this $threshold
            selectTable::refreshBorders $($this,table)
            selectTable::adjustTableColumns $($this,table)
        }
        set ($this,lastMonitored) $threshold
    }

if {$global::withGUI} {

    proc display {this threshold} {
        variable data
        variable number
        variable translated

        set table $($this,table)
        set path $selectTable::($table,tablePath)
        set row [selectTable::rows $table]
        selectTable::rows $table [expr {$row + 1}]
        set background [composite::cget $table -background]
        set data($row,$number(threshold)) $threshold
        selectTable::spans $table $row,$number(active) 0,$(hiddenColumns)
        set data($row,$number(active)) [switched::cget $threshold -active]
        set button $path.$threshold,active
        checkbutton $button            -activebackground $background -highlightthickness 0 -variable thresholds::data($row,$number(active)) -takefocus 0
        bind $button <ButtonRelease-1> "thresholds::select $this $threshold"
        selectTable::windowConfigure $table $row,$number(active) -window $button -padx 1 -pady 1 -sticky nsew
        set data($row,$number(type)) [switched::cget $threshold -type]
        set label $path.$threshold,type
        label $label -image [threshold::typeImage $data($row,$number(type))]
        bind $label <ButtonRelease-1> "
            thresholds::circleType $this $number(type) $label $threshold
            thresholds::select $this $threshold
        "
        selectTable::windowConfigure $table $row,$number(type) -window $label -relief sunken -padx 1 -pady 1
        set data($row,$number(once)) [switched::cget $threshold -actonce]
        set button $path.$threshold,once
        checkbutton $button            -activebackground $background -highlightthickness 0 -variable thresholds::data($row,$number(once)) -takefocus 0
        bind $button <ButtonRelease-1> "thresholds::select $this $threshold"
        selectTable::windowConfigure $table $row,$number(once) -window $button -padx 1 -pady 1 -sticky nsew
        if {![info exists translated(levels)]} {
            foreach level $(levels) {lappend translated(levels) [mc $level]}
        }
        set data($row,$number(level)) [switched::cget $threshold -level]
        set index [lsearch -exact $(levels) $data($row,$number(level))]; if {$index < 0} {set index 0}
        set menu [new optionMenu $path            -font $font::(tinyNormal) -choices $translated(levels) -text [lindex $translated(levels) $index] -takefocus 0            -popupcommand "thresholds::select $this $threshold"        ]
        composite::configure $menu base -highlightthickness 0
        selectTable::windowConfigure $table $row,$number(level) -window $widget::($menu,path) -padx 1 -pady 1 -sticky nsew
        lappend ($this,objects) $menu
        set data($row,$number(color)) [switched::cget $threshold -color]
        set button [createColorsMenuButton $this $path $threshold]
        bind $button <ButtonPress-1> "+ thresholds::select $this $threshold"
        selectTable::windowConfigure $table $row,$number(color) -window $button -padx 1 -pady 1 -sticky nsew
        composite::configure $menu -command "thresholds::updateLevel $this $threshold $button"
        set frame [frame $path.$threshold,actions]
        selectTable::windowConfigure $table $row,$number(actions) -window $frame -padx 1 -pady 1
        set cell $row,$number(value)
        set data($cell) [switched::cget $threshold -value]
        set entry $path.$threshold,value
        entry $entry -font $font::(mediumNormal) -textvariable thresholds::data($cell) -borderwidth 0 -highlightthickness 0            -width 10
        bind $entry <FocusIn> "thresholds::select $this $threshold"
        selectTable::windowConfigure $table $cell -window $entry -padx 1 -pady 1 -sticky nsew
        set cell $row,$number(source)
        regsub -all {\n} [switched::cget $threshold -label] { } data($cell)
        set entry $path.$threshold,source
        entry $entry -font $font::(mediumNormal) -textvariable thresholds::data($cell) -borderwidth 0 -highlightthickness 0 -width 1
        bind $entry <FocusIn> "thresholds::select $this $threshold"
        selectTable::windowConfigure $table $cell -window $entry -padx 1 -pady 1 -sticky nsew
        set data($row,$number(addresses)) [switched::cget $threshold -addresses]
        set data($row,$number(subject)) [set subject [switched::cget $threshold -subject]]
        set data($row,$number(body)) [set body [switched::cget $threshold -bodytext]]
        set data($row,$number(default)) [expr {([string length $subject] == 0) && ([string length $body] == 0)}]
        set data($row,$number(script)) [switched::cget $threshold -scripttext]
        set data($row,$number(label)) $threshold::($threshold,cellLabel)
        set data($row,$number(initial)) [switched::cget $threshold -initial]
        set data($row,$number(emailShot)) [switched::cget $threshold -emailshot]
        updateActions $this $row
        if {[string equal $::tcl_platform(platform) windows]} ::update
    }

}

    proc update {this array} {
        variable thresholds

        if {[info exists ($this,dialog)]} {
            if {[info exists ($this,selected)]} {
                updateCurrentValue $this $($this,selected)
            }
        } else {
            foreach threshold $thresholds {
                threshold::check $threshold $array
            }
        }
    }

if {$global::withGUI} {

    proc updateCurrentValue {this row} {
        variable data
        variable number

        set threshold $data($row,$number(threshold))
        set value ?
        catch {set value [set $threshold::($threshold,cell)]}
        $($this,current) configure -text $value
    }

    proc createDialog {this} {
        variable geometry

        set dialog [new dialogBox .            -buttons hoc -default o -title [mc {moodss: Thresholds}] -die 0 -grab release -enterreturn 0            -x [winfo pointerx .] -y [winfo pointery .] -helpcommand {generalHelpWindow #menus.edit.thresholds}            -command "thresholds::done $this 0" -deletecommand "thresholds::done $this 1" -otherbuttons {test delete}        ]
        set ($this,helpTip) [linkedHelpWidgetTip $composite::($dialog,help,path)]
        if {![info exists geometry]} {set geometry 600x550}
        wm geometry $widget::($dialog,path) $geometry
        bind $widget::($dialog,path) <Configure> "set thresholds::geometry \[wm geometry $widget::($dialog,path)\]"
        return $dialog
    }

    proc createTable {this parentPath} {
        variable data
        variable help
        variable number

        if {![info exists help]} {
            set help(active) [mc {whether the threshold condition is checked}]
            set help(type) [mc {threshold type (click for next type)}]
            set help(once) [mc {whether actions are taken only once when threshold condition is maintained over time (reset when condition disappears)}]
            set help(level) [mc {importance level (used by moomps for system logging and included in email alert)}]
            set help(color) [mc {color showing threshold condition occurred (click to edit)}]
            set help(actions) [mc {actions (email, script) taken when threshold condition occurs}]
            set help(value) [mc {threshold value}]
            set help(source) [mc {data description (can be edited)}]
        }
        set table [new selectTable $parentPath            -selectcommand "thresholds::selected $this" -followfocus 0 -variable thresholds::data -titlerows 1 -roworigin -1        ]
        set path $selectTable::($table,tablePath)
        set column 0
        foreach title {
            active threshold addresses script label initial default subject body emailShot
            type once level color actions value source
        } {
            set data(-1,$column) $title
            set number($title) $column
            incr column
        }
        composite::configure $table -columns [llength [array names data -1,*]]
        foreach {cell title} [array get data -1,*] {
            if {![info exists help($title)]} continue
            set label [label $path.$cell -font $font::(mediumBold) -text [mc $title]]
            selectTable::windowConfigure $table $cell -window $label -padx 1 -pady 1 -sticky nsew
            lappend ($this,objects) [new widgetTip -path $label -text $help($title)]
        }
        set (hiddenColumns) [expr {$number(type) - $number(active) - 1}]
        selectTable::spans $table -1,$number(active) 0,$(hiddenColumns)
        set ($this,drop) [new dropSite -path $path -formats DATACELLS -command "viewer::view $this \$dragSite::data(DATACELLS)"]
        return $table
    }

    proc done {this destroy} {
        variable data
        variable thresholds
        variable deleted
        variable number

        if {$destroy} {
            eval ::delete $($this,helpTip) $($this,objects) $($this,emails) $($this,body) $($this,script) $($this,test)                $($this,panes) $($this,table) $($this,drop) $($this,drag)
            unset ($this,dialog) ($this,helpTip) ($this,objects) ($this,emails) ($this,cell) ($this,current) ($this,body)                ($this,bodyText) ($this,script) ($this,scriptText) ($this,test) ($this,testText) ($this,panes) ($this,table)                ($this,drop) ($this,drag)
            catch {unset ($this,selected)}
            unset data
            foreach threshold $thresholds {
                if {[info exists (held,$threshold)]} {
                    viewer::unregisterTrace $this $threshold::($threshold,array)
                    ldelete thresholds $threshold
                    ::delete $threshold
                }
            }
            if {[info exists deleted]} {
                foreach threshold $deleted {
                    if {[info exists (held,$threshold)]} continue
                    lappend thresholds $threshold
                }
                unset deleted
            }
            array unset {} held,*
            set thresholds [lsort -command threshold::comparison $thresholds]
            pages::monitorActiveCells
            thresholdLabel::monitorActiveCells
        } else {
            if {[info exists ($this,selected)]} {
                set row $($this,selected)
                set data($row,$number(addresses)) [listEntry::get $($this,emails)]
                if {[string length [set errors [checkEmails $this $row]]] > 0} {
                    tk_messageBox -parent $widget::($($this,dialog),path)                        -title [mc {moodss: Email error}] -type ok -icon error -message $errors
                    return
                }
            }
            foreach {name threshold} [array get data "\[0-9\]*,$number(threshold)"] {
                scan $name %u row
                if {[info exists ($this,selected)] && ($row == $($this,selected))} {
                    set data($row,$number(addresses)) [listEntry::get $($this,emails)]
                    if {[set data($row,$number(default)) $($this,default)]} {
                        set data($row,$number(subject)) {}
                        set data($row,$number(body)) {}
                    } else {
                        set data($row,$number(subject)) [string trim [$($this,subjectEntry) get]]
                        set data($row,$number(body)) [string trim [$($this,bodyText) get 1.0 end]]
                    }
                    set data($row,$number(script)) [string trim [$($this,scriptText) get 1.0 end]]
                    set data($row,$number(initial)) $($this,initial)
                    set data($row,$number(emailShot)) $($this,emailShot)
                }
                switched::configure $threshold -active $data($row,$number(active)) -type $data($row,$number(type))                    -color $data($row,$number(color)) -level $data($row,$number(level)) -emailshot $data($row,$number(emailShot))                    -label $data($row,$number(source)) -addresses $data($row,$number(addresses)) -actonce $data($row,$number(once))                    -subject $data($row,$number(subject)) -bodytext $data($row,$number(body)) -value $data($row,$number(value))                    -initial $data($row,$number(initial)) -scripttext $data($row,$number(script))
            }
            if {[info exists deleted]} {
                foreach threshold $deleted {
                    viewer::unregisterTrace $this $threshold::($threshold,array)
                    ::delete $threshold
                }
                unset deleted
            }
            array unset {} held,*
            ::delete $($this,dialog)
        }
    }

    proc updateMailSection {this} {
        variable data
        variable number

        set entry $($this,subjectEntry)
        set text $($this,bodyText)
        if {$($this,default)} {
            $($this,subjectLabel) configure -state disabled
            $entry configure -state normal; $entry delete 0 end; $entry configure -state disabled
            $($this,bodyLabel) configure -state disabled
            $text configure -state normal; $text delete 1.0 end; $text configure -state disabled
        } else {
            $($this,subjectLabel) configure -state normal
            $entry configure -state normal
            $entry delete 0 end
            $($this,bodyLabel) configure -state normal
            $text configure -state normal
            $text delete 1.0 end
            if {[info exists ($this,selected)]} {
                set row $($this,selected)
                $entry insert 0 $data($row,$number(subject))
                $text insert 1.0 $data($row,$number(body))
            }
        }
    }

    proc toggleGrid {arrow path args} {
        if {[llength [grid info $path]] == 0} {
            composite::configure $arrow -direction right
            eval grid $path $args
        } else {
            composite::configure $arrow -direction down
            grid forget $path
        }
    }

}

    proc cells {this} {
        variable thresholds

        set cells {}
        foreach threshold $thresholds {
            lappend cells $threshold::($threshold,cell)
        }
        return $cells
    }

    proc initializationConfiguration {this} {
        variable thresholds

        set arguments {}
        foreach threshold $thresholds {
            set list [list -cell $threshold::($threshold,cell)]
            foreach configuration [switched::configure $threshold] {
                foreach {option default value} $configuration {}
                if {[string equal $option -script]} continue
                lappend list $option $value
            }
            lappend arguments $list
        }
        return [list -configurations $arguments]
    }

    proc manageable {this} {return 0}

if {$global::withGUI} {

    proc monitored {this cell} {
        variable thresholds

        foreach threshold $thresholds {
            if {[string equal $threshold::($threshold,cell) $cell]} {
                return 1
            }
        }
        return 0
    }

    proc test {this} {
        variable data
        variable number

        set emails [listEntry::get $($this,emails)]
        if {[string length [set errors [checkEmailAddresses $emails]]] > 0} {
            tk_messageBox -parent $widget::($($this,dialog),path)                -title [mc {moodss: Email error}] -type ok -icon error -message $errors
            return
        }
        set row $($this,selected)
        set threshold $data($row,$number(threshold))
        if {$($this,default)} {
            set subject {}
            set body {}
        } else {
            set subject [string trim [$($this,subjectEntry) get]]
            set body [string trim [$($this,bodyText) get 1.0 end]]
        }
        set script [string trim [$($this,scriptText) get 1.0 end]]
        set temporary [new threshold $threshold::($threshold,cell)            -active $data($row,$number(active)) -type $data($row,$number(type)) -color $data($row,$number(color))            -level $data($row,$number(level)) -value $data($row,$number(value)) -label $data($row,$number(source))            -addresses $emails -scripttext $script -emailshot $($this,emailShot) -initial 0 -actonce 0 -test 1            -subject $subject -bodytext $body        ]
        set output [threshold::test $temporary]
        if {[string length $script] > 0} {
            set text $($this,testText)
            $text configure -state normal
            $text insert end \n$output\n
            $text window create end -window [frame $text.$temporary                -relief sunken -borderwidth 1 -height 2 -width [expr {[winfo width $text] - $global::separatorCut}]            ]
            $text see end
            $text configure -state disabled
        }
        ::delete $temporary
    }

    proc delete {this} {
        variable thresholds
        variable deleted
        variable data
        variable number

        set table $($this,table)
        set path $selectTable::($table,tablePath)
        set row $($this,selected)
        deselect $this $row
        set threshold $data($row,$number(threshold))
        selectTable::delete $table $row
        ldelete thresholds $threshold
        lappend deleted $threshold
        for {} {$row < [llength $thresholds]} {incr row} {
            set threshold $data($row,$number(threshold))
            $path.$threshold,active configure -variable thresholds::data($row,$number(active))
            $path.$threshold,once configure -variable thresholds::data($row,$number(once))
            $path.$threshold,value configure -textvariable thresholds::data($row,$number(value))
            $path.$threshold,source configure -textvariable thresholds::data($row,$number(source))
        }
        array unset data [llength $thresholds],\[0-9\]*
        selectTable::clear $table
        selectTable::refreshBorders $table
        selectTable::adjustTableColumns $table
    }

    proc circleType {this column label threshold} {
        variable data

        set row [row $this $threshold]
        $label configure -image [threshold::typeImage [set data($row,$column) [threshold::nextType $data($row,$column)]]]
    }

    proc row {this threshold} {
        variable data
        variable number

        foreach {name value} [array get data "\[0-9\]*,$number(threshold)"] {
            if {$value == $threshold} {
                scan $name %u row
                return $row
            }
        }
        error "row not found for threshold $threshold"
    }

    proc select {this threshold} {
        return [selectTable::select $($this,table) [row $this $threshold]]
    }

    proc selected {this row} {
        variable data
        variable number

        set topPath $widget::($($this,dialog),path)
        catch {set selection [selection get]}
        if {[info exists ($this,selected)]} {
            set selected $($this,selected)
            set data($selected,$number(addresses)) [listEntry::get $($this,emails)]
            if {[set data($selected,$number(default)) $($this,default)]} {
                set data($selected,$number(subject)) {}
                set data($selected,$number(body)) {}
            } else {
                set data($selected,$number(subject)) [string trim [$($this,subjectEntry) get]]
                set data($selected,$number(body)) [string trim [$($this,bodyText) get 1.0 end]]
            }
            set data($selected,$number(script)) [string trim [$($this,scriptText) get 1.0 end]]
            set data($selected,$number(initial)) $($this,initial)
            set data($selected,$number(emailShot)) $($this,emailShot)
            updateActions $this $selected
        }
        if {[info exists selected] && ([string length [set errors [checkEmails $this $selected]]] > 0)} {
            focus $widget::($($this,emails),path)
            tk_messageBox -parent $topPath -title [mc {moodss: Email error}] -type ok -icon error -message $errors
            return 0
        }
        set ($this,selected) $row
        set button $($this,testButton)
        $button configure -state normal
        bind $topPath <Alt-KeyPress-t> "$button configure -relief sunken"
        bind $topPath <Alt-KeyRelease-t> "$button configure -relief raised; $button invoke"
        set button $($this,deleteButton)
        $button configure -state normal
        bind $topPath <Alt-KeyPress-d> "$button configure -relief sunken"
        bind $topPath <Alt-KeyRelease-d> "$button configure -relief raised; $button invoke"
        $($this,emailsLabel) configure -state normal
        composite::configure $($this,emails) -state normal
        $($this,initialButton) configure -state normal
        if {[string equal $::tcl_platform(platform) unix]} {
            $($this,shot) configure -state normal
        }
        listEntry::set $($this,emails) $data($row,$number(addresses))
        $($this,cellLabel) configure -state normal
        $($this,cell) configure -text $data($row,$number(label))
        $($this,currentLabel) configure -state normal
        $($this,mailLabel) configure -state normal
        $($this,defaultButton) configure -state normal
        set ($this,default) $data($row,$number(default))
        updateMailSection $this
        $($this,scriptLabel) configure -state normal
        $($this,scriptText) configure -state normal
        $($this,scriptText) delete 1.0 end
        $($this,scriptText) insert 1.0 $data($row,$number(script))
        $($this,testLabel) configure -state normal
        $($this,testText) configure -state normal
        $($this,testText) delete 1.0 end
        $($this,testText) configure -state disabled
        set ($this,initial) $data($row,$number(initial))
        set ($this,emailShot) $data($row,$number(emailShot))
        updateCurrentValue $this $row
        if {[info exists selection]} {
            clipboard clear
            clipboard append $selection
        }
        return 1
    }

    proc deselect {this row} {
        set topPath $widget::($($this,dialog),path)
        unset ($this,selected)
        composite::configure $($this,emails) -state disabled
        listEntry::set $($this,emails) {}
        $($this,cellLabel) configure -state disabled
        $($this,currentLabel) configure -state disabled
        $($this,emailsLabel) configure -state disabled
        $($this,mailLabel) configure -state disabled
        set ($this,default) 1
        $($this,defaultButton) configure -state disabled
        updateMailSection $this
        $($this,scriptLabel) configure -state disabled
        $($this,scriptText) delete 1.0 end
        $($this,scriptText) configure -state disabled
        $($this,testLabel) configure -state disabled
        $($this,testText) configure -state normal; $($this,testText) delete 1.0 end; $($this,testText) configure -state disabled
        $($this,testButton) configure -state disabled
        bind $topPath <Alt-KeyPress-t> {}; bind $topPath <Alt-KeyRelease-t> {}
        $($this,deleteButton) configure -state disabled
        bind $topPath <Alt-KeyPress-d> {}; bind $topPath <Alt-KeyRelease-d> {}
        $($this,cell) configure -text {}
        $($this,current) configure -text {}
        set ($this,initial) 0
        $($this,initialButton) configure -state disabled
        set ($this,emailShot) 0
        $($this,shot) configure -state disabled
    }

    proc chooseColor {this button row value} {
        variable data
        variable number

        switch $value {
            {} {
                set color $data($row,$number(color))
                if {[string length $color] == 0} {
                    set color $(default,button,background)
                }
                set color [tk_chooseColor -initialcolor $color -title [mc {Choose color}] -parent $widget::($($this,dialog),path)]
                if {[string length $color] == 0} return
                $button configure -text {} -background $color -activebackground $color
            }
            ? {
                $button configure -text ? -background $(default,button,background) -activebackground $(default,button,background)
                set color {}
            }
            default {
                $button configure -text {} -background $value -activebackground $value
                set color $value
            }
        }
        set data($row,$number(color)) $color
    }

    proc createColorsMenuButton {this parentPath threshold} {
        variable data
        variable number

        set button $parentPath.$threshold,color
        set row [row $this $threshold]
        set initialColor $data($row,$number(color))
        menubutton $button -relief raised -borderwidth 0 -highlightthickness 0 -indicatoron 1 -font $font::(mediumNormal)
        if {[string length $initialColor] == 0} {
            $button configure -text ? -background $(default,button,background) -activebackground $(default,button,background)
        } else {
            $button configure -text {} -background $initialColor -activebackground $initialColor
        }
        set menu [menu $button.menu -tearoff 0]
        set rows 0
        set index 0
        set spaces {   }
        if {[string equal $::tcl_platform(platform) windows]} {
            set spaces {      }
        }
        foreach color $(colors) {
            switch $color {
                {} {
                    $menu add command -label ...
                }
                ? {
                    $menu add command -label { ?}
                }
                default {
                    $menu add command -label $spaces -background $color -activebackground $color
                }
            }
            $menu entryconfigure $index -hidemargin 1 -command [list thresholds::chooseColor $this $button $row $color]
            if {$rows >= 3} {
                $menu entryconfigure $index -columnbreak 1
                set rows 0
            }
            incr rows
            incr index
        }
        $menu configure -postcommand "thresholds::updateMenu $this $menu $threshold"
        $button configure -menu $menu
        return $button
    }

    proc updateMenu {this menu threshold} {
        variable data
        variable number

        set color $data([row $this $threshold],$number(color))
        if {[string length $color] == 0} {
            set color $(default,button,background)
        }
        $menu entryconfigure end -background $color -activebackground $color
    }

    proc updateLevel {this threshold colorsMenu value} {
        variable data
        variable number
        variable levelColor
        variable translated

        set index [lsearch -exact $translated(levels) $value]; if {$index < 0} {set index 0}
        set value [lindex $(levels) $index]
        set row [row $this $threshold]
        if {[string equal $levelColor($data($row,$number(level))) $data($row,$number(color))]} {
            chooseColor $this $colorsMenu $row $levelColor($value)
        }
        set data($row,$number(level)) $value
    }

    proc updateActions {this row} {
        variable data
        variable number
        variable mailIcon
        variable customMailIcon
        variable gearIcon

        set threshold $data($row,$number(threshold))
        set path $selectTable::($($this,table),tablePath)
        set frame $path.$threshold,actions
        foreach label [winfo children $frame] {destroy $label}
        if {[llength $data($row,$number(addresses))] > 0} {
            if {$data($row,$number(default))} {
                pack [label $frame.mail -image $mailIcon] -side left
            } else {
                pack [label $frame.mail -image $customMailIcon] -side left
            }
        }
        if {[string length $data($row,$number(script))] > 0} {
            pack [label $frame.gear -image $gearIcon]
        }
    }

}

if {$global::withGUI} {

    proc cellData {array row column} {
        variable thresholds

        set list {}
        foreach threshold $thresholds {
            if {                ![switched::cget $threshold -active] || ![string equal $threshold::($threshold,array) $array] ||                ![string equal $threshold::($threshold,row) $row] || ![string equal $threshold::($threshold,column) $column]            } continue
            lappend list $switched::($threshold,-color) $switched::($threshold,-level)
            if {$threshold::($threshold,condition)} {
                lappend list [threshold::summary $threshold]
            } else {
                lappend list {}
            }
        }
        return $list
    }

    proc activeCells {} {
        variable thresholds

        foreach threshold $thresholds {
            if {[switched::cget $threshold -active]} {
                set active($threshold::($threshold,cell)) {}
            }
        }
        return [array names active]
    }

    proc validateDrag {this x y} {
        return [info exists ($this,selected)]
    }

    proc dragData {this format} {
        variable data
        variable number

        set threshold $data($($this,selected),$number(threshold))
        return $threshold::($threshold,cell)
    }

}

    proc reset {this} {
        variable thresholds

if {$global::withGUI} {
        if {[info exists ($this,dialog)]} {
            ::delete $($this,dialog)
        }
}
        foreach threshold $thresholds {
            viewer::unregisterTrace $this $threshold::($threshold,array)
            ldelete thresholds $threshold
            ::delete $threshold
        }
    }

    proc checkEmails {this row} {
        variable data
        variable number

        return [checkEmailAddresses $data($row,$number(addresses))]
    }

    proc checkEmailAddresses {list} {
        set errors {}
        foreach address $list {
            set message [emailAddressError $address]
            if {[string length $message] == 0} continue
            append errors "$address: $message\n"
        }
        return $errors
    }

    proc active {options} {
        array set value $options
        if {![info exists value(-configurations)]} {
            return [list 0 0]
        }
        set emails 0; set scripts 0
        foreach options $value(-configurations) {
            set list [threshold::active $options]
            incr emails [lindex $list 0]
            incr scripts [lindex $list end]
        }
        return [list $emails $scripts]
    }

    proc create {this array row column args} {
        viewer::view $this ${array}($row,$column)
        eval switched::configure $($this,lastMonitored) $args
        pages::monitorActiveCells
        thresholdLabel::monitorActiveCells
    }

    proc current {this array} {
        variable thresholds

        set list {}
        foreach threshold $thresholds {
            if {[string equal $threshold::($threshold,array) $array]} {
                lappend list $threshold
            }
        }
        return $list
    }


}

set ::thresholds::singleton [new thresholds]


class thresholds {

    class threshold {

if {$global::withGUI} {

        set (image,differ) [image create photo -data            R0lGODlhFAAKAKEAAPgA+AAAAHh8ePgAACH5BAEAAAAALAAAAAAUAAoAAAIjhBGnqW18mHANQkTV2E3YAIbbEJYhNXZXFS0Z5gJTtj7vnRUAOw==        ]
        set (image,down) [image create photo -data            R0lGODlhFAAKAPEAAP8A/wAAAPgAAHh8eCH5BAEAAAAALAAAAAAUAAoAAAIdhB2ny9i/EpyiwoAzrkL7x02TJIlKMJSmkaqmthQAOw==        ]
        set (image,equal) [image create photo -data            R0lGODlhFAAKAKEAAPgA+Hh8eAAAAPgAACH5BAEAAAAALAAAAAAUAAoAAAIdhI+pq8F/BDSjoiCN2HzX0YXMd2VTYp6Ho7auUQAAOw==        ]
        set (image,unknown) [image create photo -data            R0lGODlhFAAKAKEAAPgA+Hh8eAAAAPgAACH5BAEAAAAALAAAAAAUAAoAAAIghB+iG+euHojyUCiqtnm7pDTPQJalYqbb5bWuwb5TVxUAOw==        ]
        set (image,up) [image create photo -data            R0lGODlhFAAKAPEAAP8A/wAAAHh8ePgAACH5BAEAAAAALAAAAAAUAAoAAAIehI8QG+ku1psmRPqawmd4yoSBN4jhRHKJpiJsW8EFADs=        ]

}

        set (types) {differ down equal unknown up}

        proc threshold {this cell args} switched {$args} {
            set ($this,cell) $cell
            viewer::parse $cell ($this,array) ($this,row) ($this,column) ($this,cellType)
            set ($this,numeric) [viewer::numericType $($this,cellType)]
            set ($this,condition) 0
            set ($this,cellLabel) [lindex [viewer::label $($this,array) $($this,row) $($this,column) 1] 0]
            set ($this,checked) 0
            switched::complete $this
        }

        proc ~threshold {this} {
            if {$($this,condition)} {
                cellThresholdCondition $($this,array) $($this,row) $($this,column)                    $switched::($this,-color) $switched::($this,-level) {}
            }
        }

        proc options {this} {
            return [list                [list -active 0 0]                [list -actonce 0 0]                [list -addresses {} {}]                [list -bodytext {} {}]                [list -color white]                [list -emailshot 0 0]                [list -initial 0 0]                [list -label {} {}]                [list -level info info]                [list -script {} {}]                [list -scripttext {} {}]                [list -subject {} {}]                [list -type up up]                [list -test 0 0]                [list -value {} {}]            ]
        }

        proc set-active {this value} {
            if {!$switched::($this,complete)} return
            if {$value} {
                check $this $($this,array)
            } elseif {$($this,condition)} {
                cellThresholdCondition $($this,array) $($this,row) $($this,column)                    $switched::($this,-color) $switched::($this,-level) {}
                set ($this,condition) 0
            }
        }

        proc set-actonce {this value} {}

        proc set-addresses {this value} {}

        proc set-color {this value} {
            if {$switched::($this,complete) && $($this,condition)} {
                cellThresholdCondition $($this,array) $($this,row) $($this,column) $value $switched::($this,-level) [summary $this]
            }
        }

        proc set-emailshot {this value} {}

        proc set-initial {this value} {}

        proc set-label {this value} {}

        proc set-level {this value} {
            if {[lsearch -exact $thresholds::(levels) $value] < 0} {
                error {invalid level value}
            }
            if {$switched::($this,complete) && $($this,condition)} {
                cellThresholdCondition $($this,array) $($this,row) $($this,column) $switched::($this,-color) $value [summary $this]
            }
        }

        proc set-scripttext {this value} {}
        proc set-script {this value} {switched::configure $this -scripttext $value}

        proc set-test {this value} {}

        proc set-type {this value} {
            if {$switched::($this,complete)} {
                check $this $($this,array)
            }
        }

        proc set-value {this value} {
            if {$switched::($this,complete)} {
                check $this $($this,array)
            }
        }

        proc set-subject {this value} {}
        proc set-bodytext {this value} {}

        proc nextType {type} {
            set index [lsearch -exact $(types) $type]
            if {[incr index] >= [llength $(types)]} {
                set index 0
            }
            return [lindex $(types) $index]
        }

        proc typeImage {type} {
            return $(image,$type)
        }

        proc check {this array} {
            if {$switched::($this,-test) || ![string equal $array $($this,array)]} return
            set ($this,cellLabel) [lindex [viewer::label $array $($this,row) $($this,column) 1] 0]
            if {!$switched::($this,-active) || ([set ${array}(updates)] < 1)} return
            set threshold [string trim $switched::($this,-value)]
            catch {set value [set $($this,cell)]}
            set condition 0
            set act                [expr {(!$switched::($this,-actonce) || !$($this,condition)) && (!$switched::($this,-initial) || $($this,checked))}]
            if {![info exists value] || ([string equal $value ?] && $($this,numeric))} {
                if {[string equal $switched::($this,-type) unknown]} {
                    if {$act} {act $this {} ?}
                    set condition 1
                }
            } else {
                if {![string equal $switched::($this,-type) unknown] && [compare $this $threshold $value]} {
                    if {$act} {act $this $threshold $value}
                    set condition 1
                }
            }
            if {$condition} {
                set ($this,seconds) [clock seconds]
                set ($this,condition) 1
                cellThresholdCondition $($this,array) $($this,row) $($this,column)                    $switched::($this,-color) $switched::($this,-level) [summary $this]
if {$global::withGUI} {
                if {$global::traceThresholds && $act} {
                    if {![info exists value]} {if {$($this,numeric)} {set value ?} else {set value {}}}
                    modules::trace {} moodss(thresholds) [replacePercents $this $threshold $value $global::logMessage]
                }
}
            } elseif {$($this,condition)} {
                unset ($this,seconds)
                set ($this,condition) 0
                cellThresholdCondition $($this,array) $($this,row) $($this,column)                    $switched::($this,-color) $switched::($this,-level) {}
            }
            incr ($this,checked)
        }

if {$global::withGUI} {

        proc test {this} {
            if {[string equal $switched::($this,-type) unknown]} {
                act $this {} ?
                return $($this,output)
            }
            set threshold [string trim $switched::($this,-value)]
            switch $($this,cellType) {
                clock {
                    if {[catch {clock scan $threshold}]} {set threshold [clock format [clock seconds]]}
                }
                integer {
                    if {![string is integer -strict $threshold]} {set threshold 10}
                }
                real {
                    if {![string is double -strict $threshold]} {set threshold 10.0}
                }
            }
            if {[string equal $switched::($this,-type) equal]} {
                act $this $threshold $threshold
                return $($this,output)
            }
            switch $($this,cellType) {
                ascii - dictionary {
                    switch $switched::($this,-type) {
                        down {act $this $threshold {}}
                        differ - up {act $this $threshold ^${threshold}}
                    }
                }
                clock {
                    switch $switched::($this,-type) {
                        down {act $this $threshold [clock format [expr {[clock scan $threshold] - 1}]]}
                        differ - up {act $this $threshold [clock format [expr {[clock scan $threshold] + 1}]]}
                    }
                }
                integer - real {
                    switch $switched::($this,-type) {
                        down {act $this $threshold [expr {$threshold - 1}]}
                        differ - up {act $this $threshold [expr {$threshold + 1}]}
                    }
                }
            }
            return $($this,output)
        }

}

        proc replacePercents {this threshold value text} {
            regsub -all %% $text \001 text
            regsub -all %A $text $global::applicationName text
            regsub -all %c $text $($this,cellLabel) text
            regsub -all %l $text $switched::($this,-level) text
            regsub -all %s $text $switched::($this,-label) text
            regsub -all %t $text $threshold text
            regsub -all %T $text $switched::($this,-type) text
            regsub -all %v $text $value text
            regsub -all \001 $text % text
            return $text
        }

        proc compare {this threshold value} {
            return [compare-$($this,cellType) $switched::($this,-type) $threshold $value]
        }

        proc compare-ascii {type threshold value} {
            switch $type {
                differ {return [string compare -nocase $value $threshold]}
                down {return [expr {[string compare -nocase $value $threshold] < 0}]}
                equal {return [string equal -nocase $value $threshold]}
                up {return [expr {[string compare -nocase $value $threshold] > 0}]}
            }
        }

        proc compare-clock {type threshold value} {
            if {[catch {set threshold [clock scan $threshold -base 0]}] || [catch {set value [clock scan $value -base 0]}]} {
                return 0
            }
            switch $type {
                differ {return [expr {$value != $threshold}]}
                down {return [expr {$value < $threshold}]}
                equal {return [expr {$value == $threshold}]}
                up {return [expr {$value > $threshold}]}
            }
        }

        proc compare-dictionary {type threshold value} {
            switch $type {
                differ {return [string compare $value $threshold]}
                down {return [lindex [lindex [lsort -dictionary -index 0 [list [list $value 0] [list $threshold 1]]] 1] 1]}
                equal {return [string equal $value $threshold]}
                up {return [lindex [lindex [lsort -dictionary -index 0 [list [list $value 0] [list $threshold 1]]] 0] 1]}
            }
        }

        proc compareNumbers {type threshold value} {
            if {![string is double -strict $threshold] || ![string is double -strict $value]} {
                return [compare-dictionary $type $threshold $value]
            }
            switch $type {
                differ {return [expr {$value != $threshold}]}
                down {return [expr {$value < $threshold}]}
                equal {return [expr {$value == $threshold}]}
                up {return [expr {$value > $threshold}]}
            }
        }

        proc compare-integer {type threshold value} {
            return [compareNumbers $type $threshold $value]
        }

        proc compare-real {type threshold value} {
            return [compareNumbers $type $threshold $value]
        }

        proc act {this threshold value} {
            set ($this,output) {}
            if {[string length $switched::($this,-scripttext)] > 0} {
                set script [replacePercents $this $threshold $value $switched::($this,-scripttext)]
                if {[string equal $::tcl_platform(platform) unix]} {
                    if {![info exists ::env(SHELL)]} {set ::env(SHELL) sh}
                    set error [catch {exec 2>@ stdout $::env(SHELL) -c $script} ($this,output)]
                } else {
                    if {![info exists ::env(COMSPEC)]} {set ::env(COMSPEC) cmd}
                    set error [catch {eval exec [list $::env(COMSPEC)] /c $script} ($this,output)]
                }
                if {$error} {
                    set message "$switched::($this,-label): $($this,output)"
                    if {$global::withGUI} {
                        modules::trace {} moodss(thresholds) $message
                    } else {
                        writeLog $message error
                    }
                }
            }
            if {!$global::withGUI} {
                writeLog "($switched::($this,-level)) [replacePercents $this $threshold $value $global::logMessage]"                    $switched::($this,-level)
            }
            if {[llength $switched::($this,-addresses)] > 0} {
                if {[llength $global::smtpServers] == 0} {
                    set message {no SMTP servers defined}
                    if {$global::withGUI} {
                        modules::trace {} moodss(thresholds) [mc $message]
                    } else {
                        writeLog $message error
                    }
                } else {
                    set noDefault [string length $switched::($this,-subject)]
                    if {!$noDefault && ([string length $switched::($this,-bodytext)] == 0)} {
                        set body [replacePercents $this $threshold $value $global::mailBody]
                    } else {
                        set body [replacePercents $this $threshold $value $switched::($this,-bodytext)]
                    }
                    if {$switched::($this,-emailshot) && $global::withGUI} {
                        set shot [print::createTemporaryCanvasShot]
                        set token [mime::initialize -canonical multipart/mixed -parts [list                            [mime::initialize -canonical text/plain -string $body]                            [mime::initialize -canonical image/gif -file $shot]                        ]]
                    } else {
                        set token [mime::initialize -canonical text/plain -string $body]
                    }
                    lappend headers -servers [list $global::smtpServers]
                    lappend headers -header [list From $global::fromAddress]
                    foreach address $switched::($this,-addresses) {
                        lappend headers -header [list To $address]
                    }
                    if {$noDefault} {
                        set subject $switched::($this,-subject)
                    } else {
                        set subject $global::mailSubject
                    }
                    lappend headers -header [list Subject [replacePercents $this $threshold $value $subject]]
                    if {[catch {eval smtp::sendmessage $token $headers} error]} {
                        set message "SMTP error: $error"
                        if {[string length $($this,output)] > 0} {
                            append ($this,output) \n
                        }
                        append ($this,output) $message
                        if {$global::withGUI} {
                            modules::trace {} moodss(thresholds) $message
                        } else {
                            writeLog $message error
                        }
                    } else {
                        foreach list $error {
                            foreach {address code message} $list {
                                set message "$switched::($this,-label): on \"$address\", SMTP $code error: $message"
                                if {[string length $($this,output)] > 0} {
                                    append ($this,output) \n
                                }
                                append ($this,output) $message
                                if {$global::withGUI} {
                                    modules::trace {} moodss(thresholds) $message
                                } else {
                                    writeLog $message error
                                }
                            }
                        }
                    }
                    mime::finalize $token -subordinates all
                    if {[info exists shot]} {
                        file delete $shot
                    }
                }
            }
        }

        proc initializeLevelsMapping {} {
            variable level

            if {![info exists level]} {
                set index 0
                foreach name $thresholds::(levels) {
                    set level($name) $index
                    incr index
                }
            }
        }

if {$global::withGUI} {

        proc compareLevels {level1 level2} {
            variable level

            initializeLevelsMapping
            return [expr {$level($level2) - $level($level1)}]
        }

}

        proc comparison {threshold1 threshold2} {
            variable level

            initializeLevelsMapping
            set level1 $level($switched::($threshold1,-level))
            set level2 $level($switched::($threshold2,-level))
            if {$level1 == $level2} {
                if {                    [string equal $($threshold1,cell) $($threshold2,cell)] &&                    [string equal $switched::($threshold1,-type) $switched::($threshold2,-type)]                } {
                    set value1 [string trim $switched::($threshold1,-value)]
                    set value2 [string trim $switched::($threshold2,-value)]
                    if {[compare $threshold1 $value2 $value1]} {
                        return 1
                    } elseif {[compare $threshold1 $value1 $value2]} {
                        return -1
                    }
                }
                return 0
            } elseif {$level1 < $level2} {
                return 1
            } else {
                return -1
            }
        }

        proc summary {this} {
            if {$($this,condition)} {
                set threshold [string trim $switched::($this,-value)]
                set value ?
                catch {set value [set $($this,cell)]}
                return            "[clock format $($this,seconds) -format {%d %b %Y %T}]: [replacePercents $this $threshold $value $global::logMessage]"
            } else {
                return {}
            }
        }

        proc active {options} {
            array set value $options
            if {$value(-active)} {
                return [list [llength $value(-addresses)] [expr {[llength $value(-scripttext)] > 0}]]
            } else {
                return [list 0 0]
            }
        }

    }

}




class store {

    variable number
    variable titles {label active current comment}
    set column 0
    foreach title $titles {
        set number($title) $column
        incr column
    }
    unset column

    proc store {this args} switched {$args} viewer {} {
        variable singleton

        if {[info exists singleton]} {
            error {only 1 store object can exist}
        }
        switched::complete $this
    }

    proc ~store {this} {
        error {not implemented}
    }

    proc options {this} {
        return [list            [list -configurations {} {}]        ]
    }

    proc set-configurations {this value} {}

    proc setData {dataName row cell active comment} {
        variable number
        upvar 1 $dataName data

        viewer::parse $cell array cellRow cellColumn type
        foreach {label incomplete} [viewer::label $array $cellRow $cellColumn 1] {}
        set data($row,-1) $cell
        set data($row,$number(label)) $label
        set data($row,$number(active)) $active
        set data($row,$number(current)) {}
        set data($row,$number(comment)) $comment
        return $incomplete
    }

    proc sortedRows {dataName} {
        upvar 1 $dataName data

        set rows {}
        foreach name [array names data *,-1] {
            lappend rows [lindex [split $name ,] 0]
        }
        return [lsort -integer $rows]
    }

    proc supportedTypes {this} {
        return $global::dataTypes
    }

    proc monitorCell {this array row column} {
        variable data
        variable number

        if {[llength $switched::($this,-configurations)] == 0} return
        set cell ${array}($row,$column)
        viewer::registerTrace $this $array
        set rowIndex [llength [array names data *,-1]]
        set index 0
        foreach configuration $switched::($this,-configurations) {
            catch {unset option}; array set option $configuration
            if {![info exists option(-cell)]} break
            if {[string equal $option(-cell) $cell]} break
            incr index
        }
        set incomplete [setData data $rowIndex $cell $option(-active) $option(-comment)]
        switched::configure $this -configurations [lrange $switched::($this,-configurations) [incr index] end]
        if {$incomplete} {
            set ($this,relabel,$rowIndex) {}
        }
        set ($this,register,$rowIndex) {}
    }

    proc update {this array} {
        variable data
        variable number

        set externalUpdate [string length $array]
        foreach {name cell} [array get data *,-1] {
            if {$externalUpdate && ([string first $array $cell] != 0)} continue
            set row [lindex [split $name ,] 0]
            viewer::parse $cell array cellRow cellColumn type
            if {[info exists ($this,relabel,$row)] && [info exists $cell]} {
                foreach [list data($row,$number(label)) incomplete] [viewer::label $array $cellRow $cellColumn 1] {}
                if {!$incomplete} {
                    unset ($this,relabel,$row)
                }
                set ($this,register,$row) {}
            }
            set database $global::database
            if {$database == 0} continue
            if {!$data($row,$number(active))} continue
            set label $data($row,$number(label))
            set comment $data($row,$number(comment))
if {$global::withGUI} {
            if {[catch {set instance $($this,databaseInstance,$array)}]} {
                set instance [database::register $database [modules::instanceData $array]]
                if {[string length $database::($database,error)] > 0} {
                    traceDialog {moodss fatal error: database module instance registration} $database::($database,error) 1
                    _exit 1
                }
                set ($this,databaseInstance,$array) $instance
            }
            if {[info exists ($this,register,$row)]} {
                database::monitor                    $database $instance $cellRow $cellColumn [lindex [viewer::label $array $cellRow $cellColumn 0] 0] $comment
                unset ($this,register,$row)
            }
            if {$externalUpdate} {
                set value ?; catch {set value [set $cell]}
                database::update $database $instance $cellRow $cellColumn $value
            }
} else {
            if {[catch {set instance $($this,databaseInstance,$array)}]} {
                set instance [$database register [modules::instanceData $array]]
                if {[string length [$database error]] > 0} {
                    exit 1
                }
                set ($this,databaseInstance,$array) $instance
            }
            if {[info exists ($this,register,$row)]} {
                $database monitor $instance $cellRow $cellColumn [lindex [viewer::label $array $cellRow $cellColumn 0] 0] $comment
                unset ($this,register,$row)
            }
            set value ?; catch {set value [set $cell]}
            $database update $instance $cellRow $cellColumn $value
}
        }
    }

    proc cells {this} {
        variable data

        set cells {}
        foreach row [sortedRows data] {
            lappend cells $data($row,-1)
        }
        return $cells
    }

    proc manageable {this} {return 0}

if {$global::withGUI} {

    proc initializationConfiguration {this} {
        variable number
        variable data

        set arguments {}
        foreach row [sortedRows data] {
            lappend arguments [list -cell $data($row,-1) -active $data($row,$number(active)) -comment $data($row,$number(comment))]
        }
        return [list -configurations $arguments]
    }

    proc reload {dataName} {
        variable data
        variable singleton
        upvar 1 $dataName new

        reset $singleton
        array set data [array get new]
        foreach row [sortedRows data] {
            viewer::parse $data($row,-1) array dummy dummy dummy
            viewer::registerTrace $singleton $array
            set ($singleton,register,$row) {}
            store::update $singleton {}
        }
    }

    proc monitored {this cell} {
        variable data

        foreach {name monitored} [array get data *,-1] {
            if {[string equal $monitored $cell]} {
                return 1
            }
        }
        return 0
    }

    proc anyActiveCells {this} {
        variable data
        variable number

        foreach name [array names data *,-1] {
            set row [lindex [split $name ,] 0]
            if {$data($row,$number(active))} {return 1}
        }
        return 0
    }

}

    proc reset {this} {
        variable data

        foreach row [sortedRows data] {
            viewer::parse $data($row,-1) array dummy dummy dummy
            viewer::unregisterTrace $this $array
        }
        catch {unset data}
    }

    proc active {options} {
        array set value $options
        if {![info exists value(-configurations)]} {
            return 0
        }
        set cells 0
        foreach options $value(-configurations) {
            array set option $options
            if {$option(-active)} {incr cells}
        }
        return $cells
    }

}

set ::store::singleton [new store]


if {$global::withGUI} {

class store {

    proc edit {writable destroyCommand} {
        if {[info exists (dialog)]} {
            raise $widget::($dialog::($(dialog),dialog),path)
        } else {
            append destroyCommand "\nunset store::(dialog)"
            set (dialog) [new dialog . $writable $destroyCommand]
        }
    }

    proc setCellColor {this cell color} {
        variable ${this}data

        if {![info exists (dialog)]} return
        dialog::setCellColor $(dialog) $cell $color
    }

    class dialog {

        proc dialog {this parentPath writable {deleteCommand {}}} viewer {} {
            variable ${this}data

            set dialog [new dialogBox .                -buttons hoc -default o -title [mc {moodss: Database archiving}]                -helpcommand {generalHelpWindow #menus.edit.database} -x [winfo pointerx .] -y [winfo pointery .]                -grab release -otherbuttons delete -command "set store::dialog::($this,valid) 1" -deletecommand "delete $this"            ]
            lappend ($this,tips) [linkedHelpWidgetTip $composite::($dialog,help,path)]
            foreach {string underline} [underlineAmpersand [mc &Delete]] {}
            composite::configure $dialog delete -text $string -underline $underline -command "store::dialog::delete $this"                -state disabled
            set frame [frame $widget::($dialog,path).frame]
            set table [createTable $this $frame]
            set ($this,drop) [new dropSite -path $selectTable::($table,tablePath) -formats DATACELLS                -command "store::dialog::dropped $this \$dragSite::data(DATACELLS)"            ]
            pack $widget::($table,path) -anchor nw -fill both -expand 1
            wm geometry $widget::($dialog,path) 400x300
            dialogBox::display $dialog $frame
            set ($this,table) $table
            set ($this,dialog) $dialog
            array set ${this}data [array get store::data]
            selectTable::rows $table [llength [array names ${this}data *,-1]]
            initialize $this [store::sortedRows ${this}data] $writable
            selectTable::refreshBorders $table
            selectTable::adjustTableColumns $table
            colorRows $this
            set ($this,valid) 0
            set ($this,deleteCommand) $deleteCommand
        }

        proc ~dialog {this} {
            variable ${this}data

            if {$($this,valid)} {
                store::reload ${this}data
            }
            eval ::delete $($this,tips) $($this,drop) $($this,table)
            catch {unset ${this}data}
            if {[string length $($this,deleteCommand)] > 0} {
                uplevel #0 $($this,deleteCommand)
            }
        }

        proc createTable {this parentPath} {
            variable ${this}data

            set help(label) [mc {data cell identification}]
            set help(active) [mc {whether data cell history should be recorded in database}]
            set help(current) [mc {current value of data cell}]
            set help(comment) [mc {user editable comment}]
            set table [new selectTable $parentPath                -selectcommand "store::dialog::select $this" -variable store::dialog::${this}data -titlerows 1 -roworigin -1                -columns [llength $store::titles]            ]
            set path $selectTable::($table,tablePath)
            set column 0
            foreach title $store::titles {
                set label [label $path.$column -font $font::(mediumBold) -text [mc $title]]
                selectTable::windowConfigure $table -1,$column -window $label -padx 1 -pady 1 -sticky nsew
                lappend ($this,tips) [new widgetTip -path $label -text $help($title)]
                incr column
            }
            return $table
        }

        proc dropped {this cells} {
            variable ${this}data

            set table $($this,table)
            foreach {name cell} [array get ${this}data *,-1] {
                set saved($cell) {}
            }
            set rows [store::sortedRows ${this}data]
            set length [llength $rows]
            if {$length == 0} {
                set last -1
            } else {
                set last [lindex $rows end]
            }
            set row $last
            set new {}
            foreach cell $cells {
                if {[info exists saved($cell)]} continue
                viewer::parse $cell array ignore ignore ignore
                set module [modules::identifier $array]
                if {[string length $module] == 0} {
                    lifoLabel::flash $global::messenger [mc {data does not belong to an original module table}]
                    bell
                    continue
                }
                if {[string equal $module trace]} {
                    lifoLabel::flash $global::messenger [mc {cannot monitor cells from trace module}]
                    bell
                    continue
                }
                store::setData ${this}data [incr row] $cell 1 {}
                selectTable::height $table $row [linesCount [set ${this}data($row,$store::number(label))]]
                lappend new $row
                incr length
            }
            if {[llength $new] > 0} {
                selectTable::rows $table $length
                initialize $this $new
                selectTable::refreshBorders $table
                selectTable::adjustTableColumns $table
                colorRows $this
                update $this {}
            }
        }

        proc select {this row} {
            set topPath $widget::($($this,dialog),path)
            set button $composite::($($this,dialog),delete,path)
            $button configure -state normal
            bind $topPath <Alt-KeyPress-d> "$button configure -relief sunken"
            bind $topPath <Alt-KeyRelease-d> "$button configure -relief raised; $button invoke"
            return 1
        }

        proc delete {this} {
            variable ${this}data

            set table $($this,table)
            set row [selectTable::selected $table]
            if {[string length $row] == 0} return
            set path $selectTable::($table,tablePath)
            foreach index [store::sortedRows ${this}data] {
                destroy $path.$index,active $path.$index,comment
            }
            viewer::parse [set ${this}data($row,-1)] array dummy dummy dummy
            viewer::unregisterTrace $this $array
            array unset ${this}data $row,*
            array set data [array get ${this}data]
            unset ${this}data
            set row 0; set rows {}
            foreach index [store::sortedRows data] {
                set ${this}data($row,-1) $data($index,-1)
                set column $store::number(label); set ${this}data($row,$column) $data($index,$column)
                set column $store::number(active); set ${this}data($row,$column) $data($index,$column)
                set column $store::number(comment); set ${this}data($row,$column) $data($index,$column)
                lappend rows $row; incr row
            }
            selectTable::rows $table $row
            initialize $this $rows
            selectTable::clear $table
            selectTable::refreshBorders $table
            selectTable::adjustTableColumns $table
            colorRows $this
            set topPath $widget::($($this,dialog),path)
            bind $topPath <Alt-KeyPress-d> {}; bind $topPath <Alt-KeyRelease-d> {}
            composite::configure $($this,dialog) delete -state disabled
        }

        proc setCellColor {this cell color} {
            variable ${this}data

            foreach {name value} [array get ${this}data *,-1] {
                if {[string equal $value $cell]} {
                    colorRow $this [lindex [split $name ,] 0] $color
                    return
                }
            }
        }

        proc colorRow {this row color} {
            set cell $row,$store::number(current)
            if {[string length $color] == 0} {
                selectTable::tag $($this,table) cell {} $cell
            } else {
                selectTable::tag $($this,table) configure color$color -background $color
                selectTable::tag $($this,table) cell color$color $cell
            }
        }

        proc colorRows {this} {
            variable ${this}data

            foreach {name cell} [array get ${this}data *,-1] {
                viewer::parse $cell array row column type
                colorRow $this [lindex [split $name ,] 0] [viewer::cellThresholdColor $array $row $column]
            }
        }

        proc initialize {this rows {writable 1}} {
            variable ${this}data

            set table $($this,table)
            set path $selectTable::($table,tablePath)
            set background [$path cget -background]
            foreach row $rows {
                set cell [set ${this}data($row,-1)]
                viewer::parse $cell array dummy dummy dummy
                viewer::registerTrace $this $array
                set cell $row,$store::number(active)
                set button [checkbutton $path.$row,active                    -activebackground $background -highlightthickness 0 -variable store::dialog::${this}data($cell) -takefocus 0                ]
                bind $button <ButtonRelease-1> "selectTable::select $table $row"
                selectTable::windowConfigure $table $cell -window $button -padx 1 -pady 1 -sticky nsew
                set cell $row,$store::number(comment)
                set entry [entry $path.$row,comment                    -font $font::(mediumNormal) -textvariable store::dialog::${this}data($cell) -borderwidth 0                    -highlightthickness 0                ]
                if {!$writable} {
                    $entry configure -state disabled
                }
                bind $entry <FocusIn> "selectTable::select $table $row"
                selectTable::windowConfigure $table $cell -window $entry -padx 1 -pady 1 -sticky nsew
                selectTable::height $table $row [linesCount [set ${this}data($row,$store::number(label))]]
            }
            update $this {}
        }

        proc update {this array} {
            variable ${this}data

            set externalUpdate [string length $array]
            foreach {name cell} [array get ${this}data *,-1] {
                if {$externalUpdate && ([string first $array $cell] != 0)} continue
                set row [lindex [split $name ,] 0]
                set value ?
                catch {set value [set $cell]}
                set ${this}data($row,$store::number(current)) $value
            }
        }

        proc saved {this} {return 0}

        proc manageable {this} {return 0}

        proc reset {this} {
            ::delete $($this,dialog)
        }

    }

}

}


if {[string length $preferencesFile] > 0} {
    configuration::load [preferences::read $preferencesFile]
}
set startMessage "$::argv0 $global::applicationVersion starting..."

if {[info exists arguments(-m)]} {
    set message [emailAddressError $arguments(-m)]
    if {[string length $message] > 0} {
        puts stderr "invalid email address: \"$arguments(-m)\""
        exit 1
    }
    if {[catch {sendTextEmail $global::fromAddress $arguments(-m) {moomps starting} $startMessage} message]} {
        puts stderr "email error: $message"
        exit 1
    }
}

set current [pwd]
foreach file $argv {
    if {[catch {file stat $file data} message]} {
        puts stderr "error: $message"
        exit 2
    }
    if {[string equal $data(type) directory]} {
        foreach file [glob -nocomplain [file join $file *.moo]] {
            if {[package vcompare $::tcl_version 8.4] < 0} {
                set file [file join $current $file]
            } else {
                set file [file normalize $file]
            }
            set fileName($file) {}
        }
    } else {
        if {[package vcompare $::tcl_version 8.4] < 0} {set file [file join $current $file]} else {set file [file normalize $file]}
        set fileName($file) {}
    }
}
if {![info exists fileName]} {
    catch {unset message}
    foreach file $argv {
        if {[info exists message]} {append message {, }} else {set message {error: could not find any dashboard files in: }}
        append message "\"$file\""
    }
    puts stderr $message
    exit 1
}
set fileNames [array names fileName]
unset fileName; catch {unset file data}

proc archive {} {
    set data(-file) {}
    array set data $global::databaseOptions
    return [expr {([string length $data(-file)] > 0) || ([string length $data(-dsn)] > 0) || ([string length $data(-host)] > 0)}]
}

proc checkFilesContents {names} {
    set archive [archive]
    set store 0; set emails 0; set scripts 0
    foreach name $names {
        set record [new record -file $name]
        record::read $record
        foreach {class cells x y width height level xIcon yIcon switchedOptions} [record::viewersData $record] {
            switch $class {
                ::store {
                    if {([llength $cells] > 0) && $archive} {incr store [store::active $switchedOptions]}
                }
                ::thresholds {
                    if {[llength $cells] > 0} {
                        set list [thresholds::active $switchedOptions]
                        incr emails [lindex $list 0]; incr scripts [lindex $list end]
                    }
                }
            }
        }
        delete $record
    }
    if {!$emails && !$scripts && !$store} {
        puts stderr {error: nothing to do (database archiving, thresholds emails or scripts)}
    }
}
checkFilesContents $fileNames

if {[info exists arguments(-f)]} {
    proc writeLog {message {level info}} {
        puts "[clock format [clock seconds] -format {%b %d %T}] $level: $message"
    }
} else {
    package require logging

    rename exit _exit
    proc exit {{code 0}} {
        writeLog "$::argv0 exiting..."
        if {[info exists ::processFile]} {
            file delete -force $::processFile
        }
        _exit $code
    }

    rename puts _puts
    proc puts {args} {
        if {[string equal [lindex $args 0] -nonewline]} {
            set arguments [lreplace $args 0 0]
        } else {
            set arguments $args
        }
        if {[llength $arguments] == 1} {
            writeLog [lindex $arguments 0]
        } elseif {[llength $arguments] == 2} {
            switch -- [lindex $arguments 0] {
                stdout {writeLog [lindex $arguments 1]}
                stderr {writeLog [lindex $arguments 1] error}
                default {eval _puts $args}
            }
        } else {
            eval _puts $args
        }
    }

    proc writeLog {message {level info}} {
        logging::system moomps $level $message
    }

    proc daemonize {} {
       if {[fork]} _exit
       cd /
       set null [open /dev/null r+]
       dup $null stdin
       dup $null stdout
       dup $null stderr
       close $null
    }

    proc bgerror {message} {
        writeLog $message error
    }

    daemonize
    signal ignore SIGHUP
    signal unblock {QUIT TERM}
    signal trap {QUIT TERM} exit
}


proc initialize {interpreter} {
    interp eval $interpreter "set ::argv0 $::argv0"
    interp eval $interpreter "array set ::package [list [array get ::package]]"
    $interpreter alias exit exit
    $interpreter alias writeLog writeLog
    $interpreter alias mc mc
    interp eval $interpreter {



package provide miscellaneous [lindex {$Revision: 1.13 $} 1]


proc minimum {a b} {return [expr {$a < $b? $a: $b}]}
proc maximum {a b} {return [expr {$a > $b? $a: $b}]}

proc ldelete {listName value} {
    upvar 1 $listName list

    set index [lsearch -exact $list $value]
    if {$index < 0} {
        error "\"$value\" is not in list"
    }
    set list [lreplace $list $index $index]
}

proc static {localName args} {
    set global [uplevel 1 namespace which -command [lindex [info level -1] 0]]:$localName
    uplevel 1 upvar #0 $global $localName
    if {![info exists $global]} {
        switch [llength $args] {
            0 return
            1 {set $global [lindex $args 0]}
            default {error {usage: static name ?value?}}
        }
    }
}

proc formattedTime {seconds} {
    set string {}
    set interval [expr {$seconds / 86400}]
    if {$interval > 0} {
        append string ${interval}d
        set seconds [expr {$seconds % 86400}]
    }
    set interval [expr {$seconds / 3600}]
    if {$interval > 0} {
        append string ${interval}h
        set seconds [expr {$seconds % 3600}]
    }
    set interval [expr {$seconds / 60}]
    if {$interval > 0} {
        append string ${interval}m
        set seconds [expr {$seconds % 60}]
    }
    append string ${seconds}s
    return $string
}



namespace eval global {
    variable withGUI [expr {![catch {package present Tk}]}]
    variable debug 0
    variable 32BitIntegerMinimum -2147483648
    variable 32BitIntegerMaximum 2147483647
    variable 32BitUnsignedIntegerMaximum 4294967295
    variable 64BitIntegerMinimum -9223372036854775808
    variable 64BitIntegerMaximum 9223372036854775807
    variable 64BitUnsignedIntegerMaximum 18446744073709551615
    if {$withGUI} {
        variable applicationName moodss
        variable applicationVersion 19.7
        variable messenger
        variable scroll
        variable canvas
        variable static
        variable windowManager
        variable fileMenuContextHelper
        variable fileMenuContextHelperSaveIndex
        variable fileDatabaseMenu
        variable fileDatabaseMenuStartIndex
        variable fileDatabaseStartButton
        variable fileDatabaseStartButtonTip
        variable saveFile
        variable xWindowManagerInitialOffset 30
        variable yWindowManagerInitialOffset 20
        variable graphNumberOfIntervals 100
        variable graphMinimumY {}
        variable graphXAxisLabelsRotation 90
        variable graphLabelsPositions [list right bottom left top]
        variable graphLabelsPosition right
        variable graphPlotBackground black
        variable graphDisplayGrid 0
        variable viewerHeight 200
        variable viewerWidth 400
        variable canvasWidth 0; variable canvasHeight 0
        variable canvasBackground white
        variable canvasImage
        variable canvasImageFile {}
        variable canvasImagePosition nw
        variable canvasImageItem
        variable pieLabeler peripheral
        variable viewerColors {#7FFFFF #FFFF7F #FF7F7F #7FFF7F #7F7FFF #FFBF00 #BFBFBF #FF7FFF #FFFFFF}
        variable fileDirectory [pwd]
        variable readOnly
        variable showTrace 0
        variable traceGeometry
        variable iconPadding 2
        variable printDialogCommand
        if {[string equal $::tcl_platform(platform) unix]} {
            set printDialogCommand print::printOrSaveCanvas
        } else {
            set printDialogCommand {after idle PrintWindow $global::canvas -margins 0.5,0.5,0.5,0.5 -colordepth 8 -title moodss}
        }
        variable showToolBar 1
        variable fileSaveHelpTip
        variable pagesWidth 65536
        variable pagesTabPosition bottom
        variable traceThresholds 1
        button .temporary
        variable fontFamily [font actual [.temporary cget -font] -family]
        variable fontSize [font actual [.temporary cget -font] -size]
        if {$fontSize < 12} {set fontSize 12}
        destroy .temporary
        variable viewerMessageColor blue
        variable snapDistance; array set snapDistance {window 10 border 10}
        variable currentValueTableRows 1000
        variable cellsLabelModuleHeader 1
        variable fileCloseImage
        variable separatorCut 6
        variable printToFile 0
        variable fileToPrintTo moodss.ps
        variable printCommand {lpr -P%P}
        variable printOrientations {landscape portrait}
        variable printOrientation portrait
        variable printPalettes {color gray monochrome}
        variable printPalette color
        variable printPaperSizes [list            {A3 (297 x 420 millimeters)} {A4 (210 x 297 millimeters)} {executive (7 1/2 x 10 inches)} {legal (8 1/2 x 14 inches)}            {letter (8 1/2 x 11 inches)}        ]
        variable printPaperSize [lindex $printPaperSizes end]
    } else {
        variable applicationName moomps
        variable applicationVersion 4.6
        variable formulasDialog
    }
    variable pollTimes {}
    variable pollTime 0
    variable fromAddress $::tcl_platform(user)
    variable smtpServers 127.0.0.1
    variable mail
    set mail(subject,default) {%A threshold %l message}
    set mail(body,default) "%l: \"%s\" data value is now \"%v\",\nwhich triggered the \"%T\" threshold of \"%t\"."
    variable mailSubject $mail(subject,default)
    variable mailBody $mail(body,default)
    variable logMessage {"%s" = "%v" (triggered "%T" threshold "%t")}
    variable dataTypes {ascii clock dictionary integer real}
    variable numericDataTypes {integer real}
    variable traceNumberOfRows 20
    if {[package vcompare $::tcl_version 8.4] < 0} {
        variable sqliteDefaultFile [file join $::env(HOME) moodss.dat]
    } else {
        variable sqliteDefaultFile [file normalize ~/moodss.dat]
    }
    variable databaseOptions [list -dsn {} -file $sqliteDefaultFile -host {} -password {} -port {} -user {}]
    variable database 0
    variable moompsResourceFile /etc/moomps/rc
    if {![file writable $moompsResourceFile]} {
        set moompsResourceFile {}
    }
    variable passwordOptionExpression {^-.*passw(d|ord)$}
}



proc commaSeparatedString {words} {
    for {set index 0} {$index < ([llength $words] - 1)} {incr index} {
        append string "[lindex $words $index], "
    }
    append string [lindex $words $index]
    return $string
}

proc startGatheringPackageDirectories {} {
    catch {rename source _source}
    proc source {file} {
        if {![string equal [file tail $file] pkgIndex.tcl]} {
            return [uplevel 1 _source [list $file]]
        }
        foreach name [package names] {
            set versions($name) [package versions $name]
        }
        uplevel 1 _source [list $file]
        set directory [file dirname $file]
        foreach name [package names] {
            set available [package versions $name]
            if {[info exists versions($name)]} {
                if {[llength $available] > [llength $versions($name)]} {
                    set ::package(exact,$name) {}
                    if {![info exists ::package(moodss,$name)]} {
                        set ::package(directory,$name) $directory
                        set ::package(version,$name) [lindex $available end]
                    }
                }
            } else {
                set ::package(directory,$name) $directory
                set ::package(version,$name) $available
                if {[string match *moodss* $directory]} {
                    set ::package(moodss,$name) {}
                }
            }
        }
    }
}

proc temporaryFileName {{extension {}} {identifier {}}} {
    if {[string length $identifier] == 0} {
        set identifier [pid]
    }
    switch $::tcl_platform(platform) {
        macintosh {
            error {not implemented yet}
        }
        unix {
            foreach directory {/var/tmp /usr/tmp /tmp} {
                if {[file isdirectory $directory] && [file writable $directory]} break
            }
        }
        windows {
            set directory c:/windows/temp
            catch {set directory $::env(TEMP)}
        }
    }
    set name [file join $directory moodss$identifier]
    if {[string length $extension] > 0} {
        append name .$extension
    }
    return $name
}

proc linesCount {string} {
    return [llength [split $string \n]]
}

proc compareClocks {value1 value2} {
    return [expr {[clock scan $value1 -base 0] - [clock scan $value2 -base 0]}]
}

proc emailAddressError {string} {
    set string [string trim $string]
    if {[string length $string] == 0} {return {blank address}}
    foreach list [mime::parseaddress $string] {
        array set array $list
    }
    return $array(error)
}

proc sendTextEmail {from to subject text} {
    set token [mime::initialize -canonical text/plain -string $text]
    lappend headers -servers [list $global::smtpServers]
    lappend headers -header [list From $from]
    foreach address $to {
        lappend headers -header [list To $address]
    }
    lappend headers -header [list Subject $subject]
    eval smtp::sendmessage $token $headers
}

if {$global::withGUI} {

proc intersect {rectangle1 rectangle2} {
    foreach {left1 top1 right1 bottom1} $rectangle1 {left2 top2 right2 bottom2} $rectangle2 {}
    return [expr {!(($right1 < $left2) || ($left1 > $right2) || ($bottom1 < $top2) || ($top1 > $bottom2))}]
}

proc serialize {document} {
    return [dom::serialize $document -indent 0 -indentspec {2 {{} {}}}]
}

proc nodeFromList {parentNode name values} {
    set node [dom::document createElement $parentNode $name]
    foreach value $values {
        dom::document createTextNode [dom::document createElement $node item] $value
    }
    return $node
}

}

proc listFromNode {parentNode {path {}}} {
    if {[string length $path] > 0} {
        append path /
    }
    append path item
    set values {}
    foreach node [dom::selectNode $parentNode $path] {
        lappend values [dom::node stringValue $node]
    }
    return $values
}

if {$global::withGUI} {

proc busy {set {paths {}} {cursor watch}} {
    static lifo

    if {[llength $paths] == 0} {
        set paths .
        foreach path [winfo children .] {
            if {[string equal [winfo class $path] Toplevel]} {
                lappend paths $path
            }
        }
    }
    if {$set} {
        foreach path $paths {
            if {![info exists lifo($path)]} {
                set lifo($path) [new lifo]
            }
            xifo::in $lifo($path) [$path cget -cursor]
            $path configure -cursor $cursor
        }
        update idletasks
    } else {
        foreach path $paths {
            if {[catch {set stack $lifo($path)}]} continue
            catch {$path configure -cursor [xifo::out $stack]}
            if {[xifo::isEmpty $stack]} {
                delete $stack
                unset lifo($path)
            }
        }
    }
    if {[string equal $::tcl_platform(platform) windows]} update
}

proc centerMessage {path text {background {}} {foreground {}}} {
    set label $path.centeredMessage
    if {[string length $text] == 0} {
        catch {destroy $label}
        set label {}
    } else {
        if {![winfo exists $label]} {
            label $label
        }
        $label configure -text $text -background $background -foreground $foreground
        place $label -relx 0.5 -rely 0.5 -anchor center
    }
    return $label
}

proc 3DBorders {path background} {
    set intensity 65535
    foreach {red green blue} [winfo rgb $path $background] {}
    if {(($red * 0.5 * $red) + ($green * 1.0 * $green) + ($blue * 0.28 * $blue)) < ($intensity * 0.05 * $intensity)} {
        set dark [format {#%04X%04X%04X}            [expr {($intensity + (3 * $red)) / 4}] [expr {($intensity + (3 * $green)) / 4}] [expr {($intensity + (3 * $blue)) / 4}]        ]
    } else {
        set dark [format {#%04X%04X%04X} [expr {(60 * $red) / 100}] [expr {(60 * $green) / 100}] [expr {(60 * $blue) / 100}]]
    }
    if {$green > ($intensity * 0.95)} {
        set light [format {#%04X%04X%04X} [expr {(90 * $red) / 100}] [expr {(90 * $green) / 100}] [expr {(90 * $blue) / 100}]]
    } else {
        set tmp1 [expr {(14 * $red) / 10}]
        if {$tmp1 > $intensity} {set tmp1 $intensity}
        set tmp2 [expr {($intensity + $red) / 2}]
        set lightRed [expr {($tmp1 > $tmp2)? $tmp1: $tmp2}]
        set tmp1 [expr {(14 * $green) / 10}]
        if {$tmp1 > $intensity} {set tmp1 $intensity}
        set tmp2 [expr {($intensity + $green) / 2}]
        set lightGreen [expr {($tmp1 > $tmp2)? $tmp1: $tmp2}]
        set tmp1 [expr {(14 * $blue) / 10}]
        if {$tmp1 > $intensity} {set tmp1 $intensity}
        set tmp2 [expr {($intensity + $blue) / 2}]
        set lightBlue [expr {($tmp1 > $tmp2)? $tmp1: $tmp2}]
        set light [format {#%04X%04X%04X} $lightRed $lightGreen $lightBlue]
    }
    return [list $dark $light]
}

proc setupTextBindings {path} {
    bind $path <Control-x> [bind Text <<Cut>>]
    bind $path <Control-c> [bind Text <<Copy>>]
    bind $path <Control-v> [bind Text <<Paste>>]
}

proc vectors {left top width height} {
    return [list        $left $top $width 0 $left [expr {$top + $height}] $width 0 $left $top 0 $height [expr {$left + $width}] $top 0 $height    ]
}

if {[package vcompare $::tcl_version 8.4] < 0} {

    proc setupGlobalMouseWheelBindings {} {
        set classes [list Text Listbox Table TreeCtrl]
        foreach class $classes {bind $class <MouseWheel> {}}
        if {[string equal $::tcl_platform(platform) unix]} {
            foreach class $classes {
                bind $class <4> {}
                bind $class <5> {}
            }
        }
        bind all <MouseWheel> [list ::tkMouseWheel %W %D %X %Y]
        if {[string equal $::tcl_platform(platform) unix]} {
            bind all <4> [list ::tkMouseWheel %W 120 %X %Y]
            bind all <5> [list ::tkMouseWheel %W -120 %X %Y]
        }
    }
    proc ::tkMouseWheel {fired D X Y} {
        if {[string length [bind [winfo class $fired] <MouseWheel>]] > 0} return
        set w [winfo containing $X $Y]
        if {![winfo exists $w]} {catch {set w [focus]}}
        if {[winfo exists $w]} {
            if {[string equal [winfo class $w] Scrollbar]} {
                catch {tkScrollByUnits $w [string index [$w cget -orient] 0] [expr {-($D / 30)}]}
            } else {
                switch [winfo class $w] {Text - Listbox - Table - TreeCtrl {} default return}
                catch {$w yview scroll [expr {-($D / 120) * 4}] units}
            }
        }
    }

    proc underlineAmpersand {text} {
        set idx [string first "&" $text]
        if {$idx >= 0} {
            set underline $idx
            while {[string match "&" [string index $text [expr {$idx + 1}]]]} {
                set base [expr {$idx + 2}]
                set idx  [string first "&" [string range $text $base end]]
                if {$idx < 0} {
                    break
                } else {
                    set underline [expr {$underline + $idx + 1}]
                    incr idx $base
                }
            }
        }
        if {$idx >= 0} {
            regsub -all -- {&([^&])} $text {\1} text
        }
        return [list $text $idx]
    }

} else {

    proc setupGlobalMouseWheelBindings {} {
        set mw_classes [list Text Listbox Table TreeCtrl]
        foreach class $mw_classes { bind $class <MouseWheel> {} }
        if {[tk windowingsystem] eq "x11"} {
            foreach class $mw_classes {
                bind $class <4> {}
                bind $class <5> {}
            }
        }
        bind all <MouseWheel> [list ::tk::MouseWheel %W %D %X %Y]
        if {[tk windowingsystem] eq "x11"} {
            bind all <4> [list ::tk::MouseWheel %W 120 %X %Y]
            bind all <5> [list ::tk::MouseWheel %W -120 %X %Y]
        }
    }
    proc ::tk::MouseWheel {wFired D X Y} {
        if {[bind [winfo class $wFired] <MouseWheel>] ne ""} { return }
        set w [winfo containing $X $Y]
        if {![winfo exists $w]} { catch {set w [focus]} }
        if {[winfo exists $w]} {
            if {[winfo class $w] eq "Scrollbar"} {
                catch {tk::ScrollByUnits $w                     [string index [$w cget -orient] 0]                     [expr {-($D / 30)}]}
            } else {
                switch [winfo class $w] {Text - Listbox - Table - TreeCtrl {} default return}
                catch {$w yview scroll [expr {-($D / 120) * 4}] units}
            }
        }
    }

    proc underlineAmpersand {text} {
        return [::tk::UnderlineAmpersand $text]
    }

}

proc dragEcho {data format} {
    return $data
}

proc bounds {canvas} {
    foreach {left top right bottom} [$canvas cget -scrollregion] {}
    return [list        $left $top        [expr {$left + [maximum [winfo width $canvas] [expr {$right - $left}]]}]        [expr {$top + [maximum [winfo height $canvas] [expr {$bottom - $top}]]}]    ]
}

proc fenceRectangle {canvas list} {
    foreach {xMinimum yMinimum} [pages::closestPageTopLeftCorner [lindex $list 0]] {}
    foreach {left top right bottom} [bounds $canvas] {}
    set xMaximum [expr {$xMinimum + ($right - $left)}]; set yMaximum [expr {$yMinimum + ($bottom - $top)}]
    foreach {left top right bottom} $list {}
    set x 0; set y 0
    if {$left < $xMinimum} {
        set x [expr {$xMinimum - $left}]
    } elseif {$right > $xMaximum} {
        set x [expr {$xMaximum - $right}]
    }
    if {$top < $yMinimum} {
        set y [expr {$yMinimum - $top}]
    } elseif {$bottom > $yMaximum} {
        set y [expr {$yMaximum - $bottom}]
    }
    return [list $x $y]
}

proc fence {canvas itemOrTag} {
    if {([winfo width $canvas] <= 1) || ([winfo height $canvas] <= 1)} return
    foreach {x y} [fenceRectangle $canvas [$canvas bbox $itemOrTag]] {}
    if {($x != 0) || ($y != 0)} {
        $canvas move $itemOrTag $x $y
    }
}

proc visibleForeground {background {path .}} {
    foreach {red green blue} [winfo rgb $path $background] {}
    if {($red + $green + $blue) >= (32768 * 3)} {
        return black
    } else {
        return white
    }
}


}



proc parseCommandLineArguments {switches arguments arrayName} {
    upvar 1 $arrayName data

    if {[llength $switches] == 0} {
        return $arguments
    }
    foreach {value flag} $switches {
        if {![string match {[-+]*} $value] || ![string match {[01]} $flag]} {
            error "invalid switches: $switches"
        }
    }
    unset flag
    array set flag $switches

    set index 0
    foreach value $arguments {
        set argument($index) $value
        incr index
    }
    set maximum $index
    for {set index 0} {$index < $maximum} {incr index} {
        set switch $argument($index)
        if {![info exists flag($switch)]} break
        if {[string equal $switch --]} {
            incr index
            break
        }
        if {$flag($switch)} {
            if {[catch {set value $argument([incr index])}] || [string match {[-+]*} $value]} {
                error "no value for switch $switch"
            }
            set data($switch) $value
        } else {
            set data($switch) {}
        }
    }
    return [lrange $arguments $index end]
}
# 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
##################################################
#
# md5.tcl - MD5 in Tcl
# Author: Don Libes <libes@nist.gov>, July 1999
# Version 1.2.0
#
# MD5  defined by RFC 1321, "The MD5 Message-Digest Algorithm"
# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
#
# Most of the comments below come right out of RFC 1321; That's why
# they have such peculiar numbers.  In addition, I have retained
# original syntax, bugs in documentation (yes, really), etc. from the
# RFC.  All remaining bugs are mine.
#
# HMAC implementation by D. J. Hagberg <dhagberg@millibits.com> and
# is based on C code in RFC 2104.
#
# For more info, see: http://expect.nist.gov/md5pure
#
# - Don
#
# Modified by Miguel Sofer to use inlines and simple variables
##################################################

package require Tcl 8.2
namespace eval ::md5 {
}

if {![catch {package require Trf 2.0}] && ![catch {::md5 -- test}]} {
    # Trf is available, so implement the functionality provided here
    # in terms of calls to Trf for speed.

    proc ::md5::md5 {msg} {
	string tolower [::hex -mode encode -- [::md5 -- $msg]]
    }

    # hmac: hash for message authentication

    # MD5 of Trf and MD5 as defined by this package have slightly
    # different results. Trf returns the digest in binary, here we get
    # it as hex-string. In the computation of the HMAC the latter
    # requires back conversion into binary in some places. With Trf we
    # can use omit these.

    proc ::md5::hmac {key text} {
	# if key is longer than 64 bytes, reset it to MD5(key).  If shorter, 
	# pad it out with null (\x00) chars.
	set keyLen [string length $key]
	if {$keyLen > 64} {
	    #old: set key [binary format H32 [md5 $key]]
	    set key [::md5 -- $key]
	    set keyLen [string length $key]
	}
    
	# ensure the key is padded out to 64 chars with nulls.
	set padLen [expr {64 - $keyLen}]
	append key [binary format "a$padLen" {}]

	# Split apart the key into a list of 16 little-endian words
	binary scan $key i16 blocks

	# XOR key with ipad and opad values
	set k_ipad {}
	set k_opad {}
	foreach i $blocks {
	    append k_ipad [binary format i [expr {$i ^ 0x36363636}]]
	    append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]]
	}
    
	# Perform inner md5, appending its results to the outer key
	append k_ipad $text
	#old: append k_opad [binary format H* [md5 $k_ipad]]
	append k_opad [::md5 -- $k_ipad]

	# Perform outer md5
	#old: md5 $k_opad
	string tolower [::hex -mode encode -- [::md5 -- $k_opad]]
    }

} else {
    # Without Trf use the all-tcl implementation by Don Libes.

    # T will be inlined after the definition of md5body

    # test md5
    #
    # This proc is not necessary during runtime and may be omitted if you
    # are simply inserting this file into a production program.
    #
    proc ::md5::test {} {
	foreach {msg expected} {
	    ""
	    "d41d8cd98f00b204e9800998ecf8427e"
	    "a"
	    "0cc175b9c0f1b6a831c399e269772661"
	    "abc"
	    "900150983cd24fb0d6963f7d28e17f72"
	    "message digest"
	    "f96b697d7cb7938d525a2f31aaf161d0"
	    "abcdefghijklmnopqrstuvwxyz"
	    "c3fcd3d76192e4007dfb496cca67e13b"
	    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
	    "d174ab98d277d9f5a5611c2c9f419d9f"
	    "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
	    "57edf4a22be3c955ac49da2e2107b67a"
	} {
	    puts "testing: md5 \"$msg\""
	    set computed [md5 $msg]
	    puts "expected: $expected"
	    puts "computed: $computed"
	    if {0 != [string compare $computed $expected]} {
		puts "FAILED"
	    } else {
		puts "SUCCEEDED"
	    }
	}
    }

    # time md5
    #
    # This proc is not necessary during runtime and may be omitted if you
    # are simply inserting this file into a production program.
    #
    proc ::md5::time {} {
	foreach len {10 50 100 500 1000 5000 10000} {
	    set time [::time {md5 [format %$len.0s ""]} 100]
	    set msec [lindex $time 0]
	    puts "input length $len: [expr {$msec/1000}] milliseconds per interation"
	}
    }

    #
    # We just define the body of md5pure::md5 here; later we
    # regsub to inline a few function calls for speed
    #

    set ::md5::md5body {

	#
	# 3.1 Step 1. Append Padding Bits
	#

	set msgLen [string length $msg]

	set padLen [expr {56 - $msgLen%64}]
	if {$msgLen % 64 > 56} {
	    incr padLen 64
	}

	# pad even if no padding required
	if {$padLen == 0} {
	    incr padLen 64
	}

	# append single 1b followed by 0b's
	append msg [binary format "a$padLen" \200]

	#
	# 3.2 Step 2. Append Length
	#

	# RFC doesn't say whether to use little- or big-endian
	# code demonstrates little-endian
	# This step limits our input to size 2^32b or 2^24B
	append msg [binary format "i1i1" [expr {8*$msgLen}] 0]
	
	#
	# 3.3 Step 3. Initialize MD Buffer
	#

	set A [expr 0x67452301]
	set B [expr 0xefcdab89]
	set C [expr 0x98badcfe]
	set D [expr 0x10325476]

	#
	# 3.4 Step 4. Process Message in 16-Word Blocks
	#

	# process each 16-word block
	# RFC doesn't say whether to use little- or big-endian
	# code says little-endian
	binary scan $msg i* blocks

	# loop over the message taking 16 blocks at a time

	foreach {X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15} $blocks {

	    # Save A as AA, B as BB, C as CC, and D as DD.
	    set AA $A
	    set BB $B
	    set CC $C
	    set DD $D

	    # Round 1.
	    # Let [abcd k s i] denote the operation
	    #      a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s).
	    # [ABCD  0  7  1]  [DABC  1 12  2]  [CDAB  2 17  3]  [BCDA  3 22  4]
	    set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X0  + $T01}]  7]}]
	    set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X1  + $T02}] 12]}]
	    set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X2  + $T03}] 17]}]
	    set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X3  + $T04}] 22]}]
	    # [ABCD  4  7  5]  [DABC  5 12  6]  [CDAB  6 17  7]  [BCDA  7 22  8]
	    set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X4  + $T05}]  7]}]
	    set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X5  + $T06}] 12]}]
	    set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X6  + $T07}] 17]}]
	    set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X7  + $T08}] 22]}]
	    # [ABCD  8  7  9]  [DABC  9 12 10]  [CDAB 10 17 11]  [BCDA 11 22 12]
	    set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X8  + $T09}]  7]}]
	    set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X9  + $T10}] 12]}]
	    set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X10 + $T11}] 17]}]
	    set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X11 + $T12}] 22]}]
	    # [ABCD 12  7 13]  [DABC 13 12 14]  [CDAB 14 17 15]  [BCDA 15 22 16]
	    set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X12 + $T13}]  7]}]
	    set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X13 + $T14}] 12]}]
	    set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X14 + $T15}] 17]}]
	    set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X15 + $T16}] 22]}]

	    # Round 2.
	    # Let [abcd k s i] denote the operation
	    #      a = b + ((a + G(b,c,d) + X[k] + T[i]) <<< s).
	    # Do the following 16 operations.
	    # [ABCD  1  5 17]  [DABC  6  9 18]  [CDAB 11 14 19]  [BCDA  0 20 20]
	    set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X1  + $T17}]  5]}]
	    set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X6  + $T18}]  9]}]
	    set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X11 + $T19}] 14]}]
	    set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X0  + $T20}] 20]}]
	    # [ABCD  5  5 21]  [DABC 10  9 22]  [CDAB 15 14 23]  [BCDA  4 20 24]
	    set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X5  + $T21}]  5]}]
	    set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X10 + $T22}]  9]}]
	    set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X15 + $T23}] 14]}]
	    set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X4  + $T24}] 20]}]
	    # [ABCD  9  5 25]  [DABC 14  9 26]  [CDAB  3 14 27]  [BCDA  8 20 28]
	    set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X9  + $T25}]  5]}]
	    set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X14 + $T26}]  9]}]
	    set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X3  + $T27}] 14]}]
	    set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X8  + $T28}] 20]}]
	    # [ABCD 13  5 29]  [DABC  2  9 30]  [CDAB  7 14 31]  [BCDA 12 20 32]
	    set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X13 + $T29}]  5]}]
	    set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X2  + $T30}]  9]}]
	    set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X7  + $T31}] 14]}]
	    set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X12 + $T32}] 20]}]

	    # Round 3.
	    # Let [abcd k s t] [sic] denote the operation
	    #     a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s).
	    # Do the following 16 operations.
	    # [ABCD  5  4 33]  [DABC  8 11 34]  [CDAB 11 16 35]  [BCDA 14 23 36]
	    set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X5  + $T33}]  4]}]
	    set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X8  + $T34}] 11]}]
	    set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X11 + $T35}] 16]}]
	    set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X14 + $T36}] 23]}]
	    # [ABCD  1  4 37]  [DABC  4 11 38]  [CDAB  7 16 39]  [BCDA 10 23 40]
	    set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X1  + $T37}]  4]}]
	    set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X4  + $T38}] 11]}]
	    set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X7  + $T39}] 16]}]
	    set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X10 + $T40}] 23]}]
	    # [ABCD 13  4 41]  [DABC  0 11 42]  [CDAB  3 16 43]  [BCDA  6 23 44]
	    set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X13 + $T41}]  4]}]
	    set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X0  + $T42}] 11]}]
	    set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X3  + $T43}] 16]}]
	    set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X6  + $T44}] 23]}]
	    # [ABCD  9  4 45]  [DABC 12 11 46]  [CDAB 15 16 47]  [BCDA  2 23 48]
	    set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X9  + $T45}]  4]}]
	    set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X12 + $T46}] 11]}]
	    set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X15 + $T47}] 16]}]
	    set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X2  + $T48}] 23]}]

	    # Round 4.
	    # Let [abcd k s t] [sic] denote the operation
	    #     a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s).
	    # Do the following 16 operations.
	    # [ABCD  0  6 49]  [DABC  7 10 50]  [CDAB 14 15 51]  [BCDA  5 21 52]
	    set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X0  + $T49}]  6]}]
	    set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X7  + $T50}] 10]}]
	    set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X14 + $T51}] 15]}]
	    set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X5  + $T52}] 21]}]
	    # [ABCD 12  6 53]  [DABC  3 10 54]  [CDAB 10 15 55]  [BCDA  1 21 56]
	    set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X12 + $T53}]  6]}]
	    set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X3  + $T54}] 10]}]
	    set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X10 + $T55}] 15]}]
	    set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X1  + $T56}] 21]}]
	    # [ABCD  8  6 57]  [DABC 15 10 58]  [CDAB  6 15 59]  [BCDA 13 21 60]
	    set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X8  + $T57}]  6]}]
	    set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X15 + $T58}] 10]}]
	    set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X6  + $T59}] 15]}]
	    set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X13 + $T60}] 21]}]
	    # [ABCD  4  6 61]  [DABC 11 10 62]  [CDAB  2 15 63]  [BCDA  9 21 64]
	    set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X4  + $T61}]  6]}]
	    set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X11 + $T62}] 10]}]
	    set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X2  + $T63}] 15]}]
	    set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X9  + $T64}] 21]}]

	    # Then perform the following additions. (That is increment each
	    #   of the four registers by the value it had before this block
	    #   was started.)
	    incr A $AA
	    incr B $BB
	    incr C $CC
	    incr D $DD
	}
	# 3.5 Step 5. Output

	# ... begin with the low-order byte of A, and end with the high-order byte
	# of D.

	return [bytes $A][bytes $B][bytes $C][bytes $D]
    }

    #
    # Here we inline/regsub the functions F, G, H, I and <<< 
    #

    namespace eval ::md5 {
	#proc md5pure::F {x y z} {expr {(($x & $y) | ((~$x) & $z))}}
	regsub -all -- {\[ *F +(\$.) +(\$.) +(\$.) *\]} $md5body {((\1 \& \2) | ((~\1) \& \3))} md5body

	#proc md5pure::G {x y z} {expr {(($x & $z) | ($y & (~$z)))}}
	regsub -all -- {\[ *G +(\$.) +(\$.) +(\$.) *\]} $md5body {((\1 \& \3) | (\2 \& (~\3)))} md5body

	#proc md5pure::H {x y z} {expr {$x ^ $y ^ $z}}
	regsub -all -- {\[ *H +(\$.) +(\$.) +(\$.) *\]} $md5body {(\1 ^ \2 ^ \3)} md5body

	#proc md5pure::I {x y z} {expr {$y ^ ($x | (~$z))}}
	regsub -all -- {\[ *I +(\$.) +(\$.) +(\$.) *\]} $md5body {(\2 ^ (\1 | (~\3)))} md5body

	# bitwise left-rotate
	if {0} {
	    proc md5pure::<<< {x i} {
		# This works by bitwise-ORing together right piece and left
		# piece so that the (original) right piece becomes the left
		# piece and vice versa.
		#
		# The (original) right piece is a simple left shift.
		# The (original) left piece should be a simple right shift
		# but Tcl does sign extension on right shifts so we
		# shift it 1 bit, mask off the sign, and finally shift
		# it the rest of the way.
		
		# expr {($x << $i) | ((($x >> 1) & 0x7fffffff) >> (31-$i))}

		#
		# New version, faster when inlining
		# We replace inline (computing at compile time):
		#   R$i -> (32 - $i)
		#   S$i -> (0x7fffffff >> (31-$i))
		#

		expr { ($x << $i) | (($x >> [set R$i]) & [set S$i])}
	    }
	}
	# inline <<<
	regsub -all -- {\[ *<<< +\[ *expr +({[^\}]*})\] +([0-9]+) *\]} $md5body {(([set x [expr \1]] << \2) |  (($x >> R\2) \& S\2))} md5body

	# now replace the R and S
	set map {}
	foreach i { 
	    7 12 17 22
	    5  9 14 20
	    4 11 16 23
	    6 10 15 21 
	} {
	    lappend map R$i [expr {32 - $i}] S$i [expr {0x7fffffff >> (31-$i)}]
	}
	
	# inline the values of T
	foreach 		tName {
	    T01 T02 T03 T04 T05 T06 T07 T08 T09 T10 
	    T11 T12 T13 T14 T15 T16 T17 T18 T19 T20 
	    T21 T22 T23 T24 T25 T26 T27 T28 T29 T30 
	    T31 T32 T33 T34 T35 T36 T37 T38 T39 T40 
	    T41 T42 T43 T44 T45 T46 T47 T48 T49 T50 
	    T51 T52 T53 T54 T55 T56 T57 T58 T59 T60 
	    T61 T62 T63 T64 } 		tVal {
	    0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee
	    0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501
	    0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be
	    0x6b901122 0xfd987193 0xa679438e 0x49b40821

	    0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa
	    0xd62f105d 0x2441453  0xd8a1e681 0xe7d3fbc8
	    0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed
	    0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a

	    0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c
	    0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70
	    0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05
	    0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665

	    0xf4292244 0x432aff97 0xab9423a7 0xfc93a039
	    0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1
	    0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1
	    0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391
	} {
	    lappend map \$$tName $tVal
	}
	set md5body [string map $map $md5body]
	

	# Finally, define the proc
	proc md5 {msg} $md5body

	# unset auxiliary variables
	unset md5body tName tVal map
    }

    proc ::md5::byte0 {i} {expr {0xff & $i}}
    proc ::md5::byte1 {i} {expr {(0xff00 & $i) >> 8}}
    proc ::md5::byte2 {i} {expr {(0xff0000 & $i) >> 16}}
    proc ::md5::byte3 {i} {expr {((0xff000000 & $i) >> 24) & 0xff}}

    proc ::md5::bytes {i} {
	format %0.2x%0.2x%0.2x%0.2x [byte0 $i] [byte1 $i] [byte2 $i] [byte3 $i]
    }

    # hmac: hash for message authentication
    proc ::md5::hmac {key text} {
	# if key is longer than 64 bytes, reset it to MD5(key).  If shorter, 
	# pad it out with null (\x00) chars.
	set keyLen [string length $key]
	if {$keyLen > 64} {
	    set key [binary format H32 [md5 $key]]
	    set keyLen [string length $key]
	}

	# ensure the key is padded out to 64 chars with nulls.
	set padLen [expr {64 - $keyLen}]
	append key [binary format "a$padLen" {}]
	
	# Split apart the key into a list of 16 little-endian words
	binary scan $key i16 blocks

	# XOR key with ipad and opad values
	set k_ipad {}
	set k_opad {}
	foreach i $blocks {
	    append k_ipad [binary format i [expr {$i ^ 0x36363636}]]
	    append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]]
	}
    
	# Perform inner md5, appending its results to the outer key
	append k_ipad $text
	append k_opad [binary format H* [md5 $k_ipad]]

	# Perform outer md5
	md5 $k_opad
    }
}

package provide md5 1.4.3

# mime.tcl - MIME body parts
#
# (c) 1999-2000 Marshall T. Rose
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's
# unpublished package of 1999.
#

# new string features and inline scan are used, requiring 8.3.
package require Tcl 8.3

package provide mime 1.4

if {[catch {package require Trf  2.0}]} {

    # Fall-back to tcl-based procedures of base64 and quoted-printable encoders
    # Warning!
    # These are a fragile emulations of the more general calling sequence
    # that appears to work with this code here.

    package require base64 2.0
    set major [lindex [split [package require md5] .] 0]

    # Create these commands in the mime namespace so that they
    # won't collide with things at the global namespace level

    namespace eval ::mime {
        proc base64 {-mode what -- chunk} {
   	    return [base64::$what $chunk]
        }
        proc quoted-printable {-mode what -- chunk} {
  	    return [mime::qp_$what $chunk]
        }

	if {$::major < 2} {
	    # md5 v1, result is hex string ready for use.
	    proc md5 {-- string} {
		return [md5::md5 $string]
	    }
	} else {
	    # md5 v2, need option to get hex string
	    proc md5 {-- string} {
		return [md5::md5 -hex $string]
	    }
	}
        proc unstack {channel} {
	    # do nothing
	    return
        }
    }

    unset major
}        

#
# state variables:
#
#     canonicalP: input is in its canonical form
#     content: type/subtype
#     params: seralized array of key/value pairs (keys are lower-case)
#     encoding: transfer encoding
#     version: MIME-version
#     header: serialized array of key/value pairs (keys are lower-case)
#     lowerL: list of header keys, lower-case
#     mixedL: list of header keys, mixed-case
#     value: either "file", "parts", or "string"
#
#     file: input file
#     fd: cached file-descriptor, typically for root
#     root: token for top-level part, for (distant) subordinates
#     offset: number of octets from beginning of file/string
#     count: length in octets of (encoded) content
#
#     parts: list of bodies (tokens)
#
#     string: input string
#
#     cid: last child-id assigned
#


namespace eval ::mime {
    variable mime
    array set mime { uid 0 cid 0 }

# 822 lexemes
    variable addrtokenL  [list ";"          ","                                        "<"          ">"                                        ":"          "."                                        "("          ")"                                        "@"          "\""                                       "\["         "\]"                                       "\\"]
    variable addrlexemeL [list LX_SEMICOLON LX_COMMA                                   LX_LBRACKET  LX_RBRACKET                                LX_COLON     LX_DOT                                     LX_LPAREN    LX_RPAREN                                  LX_ATSIGN    LX_QUOTE                                   LX_LSQUARE   LX_RSQUARE                                  LX_QUOTE]

# 2045 lexemes
    variable typetokenL  [list ";"          ","                                        "<"          ">"                                        ":"          "?"                                        "("          ")"                                        "@"          "\""                                       "\["         "\]"                                       "="          "/"                                        "\\"]
    variable typelexemeL [list LX_SEMICOLON LX_COMMA                                   LX_LBRACKET  LX_RBRACKET                                LX_COLON     LX_QUESTION                                LX_LPAREN    LX_RPAREN                                  LX_ATSIGN    LX_QUOTE                                   LX_LSQUARE   LX_RSQUARE                                 LX_EQUALS    LX_SOLIDUS                                 LX_QUOTE]

    set encList [list             ascii US-ASCII             big5 Big5             cp1250 Windows-1250             cp1251 Windows-1251             cp1252 Windows-1252             cp1253 Windows-1253             cp1254 Windows-1254             cp1255 Windows-1255             cp1256 Windows-1256             cp1257 Windows-1257             cp1258 Windows-1258             cp437 IBM437             cp737 ""             cp775 IBM775             cp850 IBM850             cp852 IBM852             cp855 IBM855             cp857 IBM857             cp860 IBM860             cp861 IBM861             cp862 IBM862             cp863 IBM863             cp864 IBM864             cp865 IBM865             cp866 IBM866             cp869 IBM869             cp874 ""             cp932 ""             cp936 GBK             cp949 ""             cp950 ""             dingbats "" 	    ebcdic ""             euc-cn EUC-CN             euc-jp EUC-JP             euc-kr EUC-KR             gb12345 GB12345             gb1988 GB1988             gb2312 GB2312             iso2022 ISO-2022             iso2022-jp ISO-2022-JP             iso2022-kr ISO-2022-KR             iso8859-1 ISO-8859-1             iso8859-2 ISO-8859-2             iso8859-3 ISO-8859-3             iso8859-4 ISO-8859-4             iso8859-5 ISO-8859-5             iso8859-6 ISO-8859-6             iso8859-7 ISO-8859-7             iso8859-8 ISO-8859-8             iso8859-9 ISO-8859-9             iso8859-10 ISO-8859-10             iso8859-13 ISO-8859-13             iso8859-14 ISO-8859-14             iso8859-15 ISO-8859-15             iso8859-16 ISO-8859-16             jis0201 JIS_X0201             jis0208 JIS_C6226-1983             jis0212 JIS_X0212-1990             koi8-r KOI8-R             koi8-u KOI8-U             ksc5601 KS_C_5601-1987             macCentEuro ""             macCroatian ""             macCyrillic ""             macDingbats ""             macGreek ""             macIceland ""             macJapan ""             macRoman ""             macRomania ""             macThai ""             macTurkish ""             macUkraine ""             shiftjis Shift_JIS             symbol ""             tis-620 TIS-620             unicode ""             utf-8 UTF-8]

    variable encodings
    array set encodings $encList
    variable reversemap
    foreach {enc mimeType} $encList {
        if {$mimeType != ""} {
            set reversemap([string tolower $mimeType]) $enc
        }
    } 

    set encAliasList [list             ascii ANSI_X3.4-1968             ascii iso-ir-6             ascii ANSI_X3.4-1986             ascii ISO_646.irv:1991             ascii ASCII             ascii ISO646-US             ascii us             ascii IBM367             ascii cp367             cp437 cp437             cp437 437             cp775 cp775             cp850 cp850             cp850 850             cp852 cp852             cp852 852             cp855 cp855             cp855 855             cp857 cp857             cp857 857             cp860 cp860             cp860 860             cp861 cp861             cp861 861             cp861 cp-is             cp862 cp862             cp862 862             cp863 cp863             cp863 863             cp864 cp864             cp865 cp865             cp865 865             cp866 cp866             cp866 866             cp869 cp869             cp869 869             cp869 cp-gr             cp936 CP936             cp936 MS936             cp936 Windows-936             iso8859-1 ISO_8859-1:1987             iso8859-1 iso-ir-100             iso8859-1 ISO_8859-1             iso8859-1 latin1             iso8859-1 l1             iso8859-1 IBM819             iso8859-1 CP819             iso8859-2 ISO_8859-2:1987             iso8859-2 iso-ir-101             iso8859-2 ISO_8859-2             iso8859-2 latin2             iso8859-2 l2             iso8859-3 ISO_8859-3:1988             iso8859-3 iso-ir-109             iso8859-3 ISO_8859-3             iso8859-3 latin3             iso8859-3 l3             iso8859-4 ISO_8859-4:1988             iso8859-4 iso-ir-110             iso8859-4 ISO_8859-4             iso8859-4 latin4             iso8859-4 l4             iso8859-5 ISO_8859-5:1988             iso8859-5 iso-ir-144             iso8859-5 ISO_8859-5             iso8859-5 cyrillic             iso8859-6 ISO_8859-6:1987             iso8859-6 iso-ir-127             iso8859-6 ISO_8859-6             iso8859-6 ECMA-114             iso8859-6 ASMO-708             iso8859-6 arabic             iso8859-7 ISO_8859-7:1987             iso8859-7 iso-ir-126             iso8859-7 ISO_8859-7             iso8859-7 ELOT_928             iso8859-7 ECMA-118             iso8859-7 greek             iso8859-7 greek8             iso8859-8 ISO_8859-8:1988             iso8859-8 iso-ir-138             iso8859-8 ISO_8859-8             iso8859-8 hebrew             iso8859-9 ISO_8859-9:1989             iso8859-9 iso-ir-148             iso8859-9 ISO_8859-9             iso8859-9 latin5             iso8859-9 l5             iso8859-10 iso-ir-157             iso8859-10 l6             iso8859-10 ISO_8859-10:1992             iso8859-10 latin6             iso8859-14 iso-ir-199             iso8859-14 ISO_8859-14:1998             iso8859-14 ISO_8859-14             iso8859-14 latin8             iso8859-14 iso-celtic             iso8859-14 l8             iso8859-15 ISO_8859-15             iso8859-15 Latin-9             iso8859-16 iso-ir-226             iso8859-16 ISO_8859-16:2001             iso8859-16 ISO_8859-16             iso8859-16 latin10             iso8859-16 l10             jis0201 X0201             jis0208 iso-ir-87             jis0208 x0208             jis0208 JIS_X0208-1983             jis0212 x0212             jis0212 iso-ir-159             ksc5601 iso-ir-149             ksc5601 KS_C_5601-1989             ksc5601 KSC5601             ksc5601 korean             shiftjis MS_Kanji             utf-8 UTF8]

    foreach {enc mimeType} $encAliasList {
        set reversemap([string tolower $mimeType]) $enc
    }

    namespace export initialize finalize getproperty                      getheader setheader                      getbody                      copymessage                      mapencoding                      reversemapencoding                      parseaddress                      parsedatetime                      uniqueID
}

# ::mime::initialize --
#
#	Creates a MIME part, and returnes the MIME token for that part.
#
# Arguments:
#	args   Args can be any one of the following:
#                  ?-canonical type/subtype
#                  ?-param    {key value}?...
#                  ?-encoding value?
#                  ?-header   {key value}?... ?
#                  (-file name | -string value | -parts {token1 ... tokenN})
#
#       If the -canonical option is present, then the body is in
#       canonical (raw) form and is found by consulting either the -file,
#       -string, or -part option. 
#
#       In addition, both the -param and -header options may occur zero
#       or more times to specify "Content-Type" parameters (e.g.,
#       "charset") and header keyword/values (e.g.,
#       "Content-Disposition"), respectively. 
#
#       Also, -encoding, if present, specifies the
#       "Content-Transfer-Encoding" when copying the body.
#
#       If the -canonical option is not present, then the MIME part
#       contained in either the -file or the -string option is parsed,
#       dynamically generating subordinates as appropriate.
#
# Results:
#	An initialized mime token.

proc ::mime::initialize {args} {
    global errorCode errorInfo

    variable mime

    set token [namespace current]::[incr mime(uid)]
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[set code [catch { eval [linsert $args 0 mime::initializeaux $token] }                          result]]} {
        set ecode $errorCode
        set einfo $errorInfo

        catch { mime::finalize $token -subordinates dynamic }

        return -code $code -errorinfo $einfo -errorcode $ecode $result
    }

    return $token
}

# ::mime::initializeaux --
#
#	Configures the MIME token created in mime::initialize based on
#       the arguments that mime::initialize supports.
#
# Arguments:
#       token  The MIME token to configure.
#	args   Args can be any one of the following:
#                  ?-canonical type/subtype
#                  ?-param    {key value}?...
#                  ?-encoding value?
#                  ?-header   {key value}?... ?
#                  (-file name | -string value | -parts {token1 ... tokenN})
#
# Results:
#       Either configures the mime token, or throws an error.

proc ::mime::initializeaux {token args} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set params [set state(params) ""]
    set state(encoding) ""
    set state(version) "1.0"

    set state(header) ""
    set state(lowerL) ""
    set state(mixedL) ""

    set state(cid) 0

    set argc [llength $args]
    for {set argx 0} {$argx < $argc} {incr argx} {
        set option [lindex $args $argx]
        if {[incr argx] >= $argc} {
            error "missing argument to $option"
        }
	set value [lindex $args $argx]

        switch -- $option {
            -canonical {
                set state(content) [string tolower $value]
            }

            -param {
                if {[llength $value] != 2} {
                    error "-param expects a key and a value, not $value"
                }
                set lower [string tolower [set mixed [lindex $value 0]]]
                if {[info exists params($lower)]} {
                    error "the $mixed parameter may be specified at most once"
                }

                set params($lower) [lindex $value 1]
                set state(params) [array get params]
            }

            -encoding {
                switch -- [set state(encoding) [string tolower $value]] {
                    7bit - 8bit - binary - quoted-printable - base64 {
                    }

                    default {
                        error "unknown value for -encoding $state(encoding)"
                    }
                }
            }

            -header {
                if {[llength $value] != 2} {
                    error "-header expects a key and a value, not $value"
                }
                set lower [string tolower [set mixed [lindex $value 0]]]
                if {![string compare $lower content-type]} {
                    error "use -canonical instead of -header $value"
                }
                if {![string compare $lower content-transfer-encoding]} {
                    error "use -encoding instead of -header $value"
                }
                if {(![string compare $lower content-md5])                         || (![string compare $lower mime-version])} {
                    error "don't go there..."
                }
                if {[lsearch -exact $state(lowerL) $lower] < 0} {
                    lappend state(lowerL) $lower
                    lappend state(mixedL) $mixed
                }               

                array set header $state(header)
                lappend header($lower) [lindex $value 1]
                set state(header) [array get header]
            }

            -file {
                set state(file) $value
            }

            -parts {
                set state(parts) $value
            }

            -string {
                set state(string) $value

		set state(lines) [split $value "\n"]
		set state(lines.count) [llength $state(lines)]
		set state(lines.current) 0
            }

            -root {
                # the following are internal options

                set state(root) $value
            }

            -offset {
                set state(offset) $value
            }

            -count {
                set state(count) $value
            }

	    -lineslist { 
		set state(lines) $value 
		set state(lines.count) [llength $state(lines)]
		set state(lines.current) 0
		#state(string) is needed, but will be built when required
		set state(string) ""
	    }

            default {
                error "unknown option $option"
            }
        }
    }

    #We only want one of -file, -parts or -string:
    set valueN 0
    foreach value [list file parts string] {
        if {[info exists state($value)]} {
            set state(value) $value
            incr valueN
        }
    }
    if {$valueN != 1 && ![info exists state(lines)]} {
        error "specify exactly one of -file, -parts, or -string"
    }

    if {[set state(canonicalP) [info exists state(content)]]} {
        switch -- $state(value) {
            file {
                set state(offset) 0
            }

            parts {
                switch -glob -- $state(content) {
                    text/*
                        -
                    image/*
                        -
                    audio/*
                        -
                    video/* {
                        error "-canonical $state(content) and -parts do not mix"
                    }
    
                    default {
                        if {[string compare $state(encoding) ""]} {
                            error "-encoding and -parts do not mix"
                        }
                    }
                }
            }
	    default {# Go ahead}
        }

        if {[lsearch -exact $state(lowerL) content-id] < 0} {
            lappend state(lowerL) content-id
            lappend state(mixedL) Content-ID

            array set header $state(header)
            lappend header(content-id) [uniqueID]
            set state(header) [array get header]
        }

        set state(version) 1.0

        return
    }

    if {[string compare $state(params) ""]} {
        error "-param requires -canonical"
    }
    if {[string compare $state(encoding) ""]} {
        error "-encoding requires -canonical"
    }
    if {[string compare $state(header) ""]} {
        error "-header requires -canonical"
    }
    if {[info exists state(parts)]} {
        error "-parts requires -canonical"
    }

    if {[set fileP [info exists state(file)]]} {
        if {[set openP [info exists state(root)]]} {
	    # FRINK: nocheck
            variable $state(root)
            upvar 0 $state(root) root

            set state(fd) $root(fd)
        } else {
            set state(root) $token
            set state(fd) [open $state(file) { RDONLY }]
            set state(offset) 0
            seek $state(fd) 0 end
            set state(count) [tell $state(fd)]

            fconfigure $state(fd) -translation binary
        }
    }

    set code [catch { mime::parsepart $token } result]
    set ecode $errorCode
    set einfo $errorInfo

    if {$fileP} {
        if {!$openP} {
            unset state(root)
            catch { close $state(fd) }
        }
        unset state(fd)
    }

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::mime::parsepart --
#
#       Parses the MIME headers and attempts to break up the message
#       into its various parts, creating a MIME token for each part.
#
# Arguments:
#       token  The MIME token to parse.
#
# Results:
#       Throws an error if it has problems parsing the MIME token,
#       otherwise it just sets up the appropriate variables.

proc ::mime::parsepart {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[set fileP [info exists state(file)]]} {
        seek $state(fd) [set pos $state(offset)] start
        set last [expr {$state(offset)+$state(count)-1}]
    } else {
        set string $state(string)
    }

    set vline ""
    while {1} {
        set blankP 0
        if {$fileP} {
            if {($pos > $last) || ([set x [gets $state(fd) line]] <= 0)} {
                set blankP 1
            } else {
                incr pos [expr {$x+1}]
            }
        } else {

	    if { $state(lines.current) >= $state(lines.count) } {
		set blankP 1
		set line ""
	    } else {
		set line [lindex $state(lines) $state(lines.current)]
		incr state(lines.current)
		set x [string length $line]
		if { $x == 0 } { set blankP 1 }
	    }

        }

         if {(!$blankP) && ([string last "\r" $line] == [expr {$x-1}])} {
	    
             set line [string range $line 0 [expr {$x-2}]]
             if {$x == 1} {
                 set blankP 1
             }
         }

        if {(!$blankP)                 && (([string first " " $line] == 0)                         || ([string first "\t" $line] == 0))} {
            append vline "\n" $line
            continue
        }      

        if {![string compare $vline ""]} {
            if {$blankP} {
                break
            }

            set vline $line
            continue
        }

        if {([set x [string first ":" $vline]] <= 0)                 || (![string compare                              [set mixed                                   [string trimright                                           [string range                                                   $vline 0 [expr {$x-1}]]]]                             ""])} {
            error "improper line in header: $vline"
        }
        set value [string trim [string range $vline [expr {$x+1}] end]]
        switch -- [set lower [string tolower $mixed]] {
            content-type {
                if {[info exists state(content)]} {
                    error "multiple Content-Type fields starting with $vline"
                }

                if {![catch { set x [parsetype $token $value] }]} {
                    set state(content) [lindex $x 0]
                    set state(params) [lindex $x 1]
                }
            }

            content-md5 {
            }

            content-transfer-encoding {
                if {([string compare $state(encoding) ""])                         && ([string compare $state(encoding)                                     [string tolower $value]])} {
                    error "multiple Content-Transfer-Encoding fields starting with $vline"
                }

                set state(encoding) [string tolower $value]
            }

            mime-version {
                set state(version) $value
            }

            default {
                if {[lsearch -exact $state(lowerL) $lower] < 0} {
                    lappend state(lowerL) $lower
                    lappend state(mixedL) $mixed
                }

                array set header $state(header)
                lappend header($lower) $value
                set state(header) [array get header]
            }
        }

        if {$blankP} {
            break
        }
        set vline $line
    }

    if {![info exists state(content)]} {
        set state(content) text/plain
        set state(params) [list charset us-ascii]
    }

    if {![string match multipart/* $state(content)]} {
        if {$fileP} {
            set x [tell $state(fd)]
            incr state(count) [expr {$state(offset)-$x}]
            set state(offset) $x
        } else {
	    # rebuild string, this is cheap and needed by other functions    
	    set state(string) [join [lrange $state(lines) 					 $state(lines.current) end] "\n"]
        }

        if {[string match message/* $state(content)]} {
	    # FRINK: nocheck
            variable [set child $token-[incr state(cid)]]

            set state(value) parts
            set state(parts) $child
            if {$fileP} {
                mime::initializeaux $child                     -file $state(file) -root $state(root)                     -offset $state(offset) -count $state(count)
            } else {
		mime::initializeaux $child 		    -lineslist [lrange $state(lines) 				    $state(lines.current) end] 
            }
        }

        return
    } 

    set state(value) parts

    set boundary ""
    foreach {k v} $state(params) {
        if {![string compare $k boundary]} {
            set boundary $v
            break
        }
    }
    if {![string compare $boundary ""]} {
        error "boundary parameter is missing in $state(content)"
    }
    if {![string compare [string trim $boundary] ""]} {
        error "boundary parameter is empty in $state(content)"
    }

    if {$fileP} {
        set pos [tell $state(fd)]
    }

    set inP 0
    set moreP 1
    while {$moreP} {
        if {$fileP} {
            if {$pos > $last} {
                 error "termination string missing in $state(content)"
                 set line "--$boundary--"
            } else {
              if {[set x [gets $state(fd) line]] < 0} {
                  error "end-of-file encountered while parsing $state(content)"
              }
           }
            incr pos [expr {$x+1}]
        } else {

	    if { $state(lines.current) >= $state(lines.count) } {
		error "end-of-string encountered while parsing $state(content)"
	    } else {
		set line [lindex $state(lines) $state(lines.current)]
		incr state(lines.current)
		set x [string length $line]
	    }

            set x [string length $line]
        }
        if {[string last "\r" $line] == [expr {$x-1}]} {
            set line [string range $line 0 [expr {$x-2}]]
        }

        if {[string first "--$boundary" $line] != 0} {
             if {$inP && !$fileP} {
 		lappend start $line
             }

             continue
        }

        if {!$inP} {
            if {![string compare $line "--$boundary"]} {
                set inP 1
                if {$fileP} {
                    set start $pos
                } else {
		    set start [list]
                }
            }

            continue
        }

        if {([set moreP [string compare $line "--$boundary--"]])                 && ([string compare $line "--$boundary"])} {
            if {$inP && !$fileP} {
		lappend start $line
            }
            continue
        }
	# FRINK: nocheck
        variable [set child $token-[incr state(cid)]]

        lappend state(parts) $child

        if {$fileP} {
            if {[set count [expr {$pos-($start+$x+3)}]] < 0} {
                set count 0
            }

            mime::initializeaux $child                 -file $state(file) -root $state(root)                 -offset $start -count $count

            seek $state(fd) [set start $pos] start
        } else {
	    mime::initializeaux $child -lineslist $start
            set start ""
        }
    }
}

# ::mime::parsetype --
#
#       Parses the string passed in and identifies the content-type and
#       params strings.
#
# Arguments:
#       token  The MIME token to parse.
#       string The content-type string that should be parsed.
#
# Results:
#       Returns the content and params for the string as a two element
#       tcl list.

proc ::mime::parsetype {token string} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    variable typetokenL
    variable typelexemeL

    set state(input)   $string
    set state(buffer)  ""
    set state(lastC)   LX_END
    set state(comment) ""
    set state(tokenL)  $typetokenL
    set state(lexemeL) $typelexemeL

    set code [catch { mime::parsetypeaux $token $string } result]    
    set ecode $errorCode
    set einfo $errorInfo

    unset state(input)             state(buffer)            state(lastC)             state(comment)           state(tokenL)            state(lexemeL)

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::mime::parsetypeaux --
#
#       A helper function for mime::parsetype.  Parses the specified
#       string looking for the content type and params.
#
# Arguments:
#       token  The MIME token to parse.
#       string The content-type string that should be parsed.
#
# Results:
#       Returns the content and params for the string as a two element
#       tcl list.

proc ::mime::parsetypeaux {token string} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[string compare [parselexeme $token] LX_ATOM]} {
        error [format "expecting type (found %s)" $state(buffer)]
    }
    set type [string tolower $state(buffer)]

    switch -- [parselexeme $token] {
        LX_SOLIDUS {
        }

        LX_END {
            if {[string compare $type message]} {
                error "expecting type/subtype (found $type)"
            }

            return [list message/rfc822 ""]
        }

        default {
            error [format "expecting \"/\" (found %s)" $state(buffer)]
        }
    }

    if {[string compare [parselexeme $token] LX_ATOM]} {
        error [format "expecting subtype (found %s)" $state(buffer)]
    }
    append type [string tolower /$state(buffer)]

    array set params ""
    while {1} {
        switch -- [parselexeme $token] {
            LX_END {
                return [list $type [array get params]]
            }

            LX_SEMICOLON {
            }

            default {
                error [format "expecting \";\" (found %s)" $state(buffer)]
            }
        }

        switch -- [parselexeme $token] {
            LX_END {
                return [list $type [array get params]]
            }

            LX_ATOM {
            }

            default {
                error [format "expecting attribute (found %s)" $state(buffer)]
            }
        }

        set attribute [string tolower $state(buffer)]

        if {[string compare [parselexeme $token] LX_EQUALS]} {
            error [format "expecting \"=\" (found %s)" $state(buffer)]
        }

        switch -- [parselexeme $token] {
            LX_ATOM {
            }

            LX_QSTRING {
                set state(buffer)                     [string range $state(buffer) 1                             [expr {[string length $state(buffer)]-2}]]
            }

            default {
                error [format "expecting value (found %s)" $state(buffer)]
            }
        }
        set params($attribute) $state(buffer)
    }
}

# ::mime::finalize --
#
#   mime::finalize destroys a MIME part.
#
#   If the -subordinates option is present, it specifies which
#   subordinates should also be destroyed. The default value is
#   "dynamic".
#
# Arguments:
#       token  The MIME token to parse.
#       args   Args can be optionally be of the following form:
#              ?-subordinates "all" | "dynamic" | "none"?
#
# Results:
#       Returns an empty string.

proc ::mime::finalize {token args} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options [list -subordinates dynamic]
    array set options $args

    switch -- $options(-subordinates) {
        all {
            if {![string compare $state(value) parts]} {
                foreach part $state(parts) {
                    eval [linsert $args 0 mime::finalize $part]
                }
            }
        }

        dynamic {
            for {set cid $state(cid)} {$cid > 0} {incr cid -1} {
                eval [linsert $args 0 mime::finalize $token-$cid]
            }
        }

        none {
        }

        default {
            error "unknown value for -subordinates $options(-subordinates)"
        }
    }

    foreach name [array names state] {
        unset state($name)
    }
    # FRINK: nocheck
    unset $token
}

# ::mime::getproperty --
#
#   mime::getproperty returns the properties of a MIME part.
#
#   The properties are:
#
#       property    value
#       ========    =====
#       content     the type/subtype describing the content
#       encoding    the "Content-Transfer-Encoding"
#       params      a list of "Content-Type" parameters
#       parts       a list of tokens for the part's subordinates
#       size        the approximate size of the content (unencoded)
#
#   The "parts" property is present only if the MIME part has
#   subordinates.
#
#   If mime::getproperty is invoked with the name of a specific
#   property, then the corresponding value is returned; instead, if
#   -names is specified, a list of all properties is returned;
#   otherwise, a serialized array of properties and values is returned.
#
# Arguments:
#       token      The MIME token to parse.
#       property   One of 'content', 'encoding', 'params', 'parts', and
#                  'size'. Defaults to returning a serialized array of
#                  properties and values.
#
# Results:
#       Returns the properties of a MIME part

proc ::mime::getproperty {token {property ""}} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -- $property {
        "" {
            array set properties [list content  $state(content)                                        encoding $state(encoding)                                        params   $state(params)                                        size     [getsize $token]]
            if {[info exists state(parts)]} {
                set properties(parts) $state(parts)
            }

            return [array get properties]
        }

        -names {
            set names [list content encoding params]
            if {[info exists state(parts)]} {
                lappend names parts
            }

            return $names
        }

        content
            -
        encoding
            -
        params {
            return $state($property)
        }

        parts {
            if {![info exists state(parts)]} {
                error "MIME part is a leaf"
            }

            return $state(parts)
        }

        size {
            return [getsize $token]
        }

        default {
            error "unknown property $property"
        }
    }
}

# ::mime::getsize --
#
#    Determine the size (in bytes) of a MIME part/token
#
# Arguments:
#       token      The MIME token to parse.
#
# Results:
#       Returns the size in bytes of the MIME token.

proc ::mime::getsize {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -- $state(value)/$state(canonicalP) {
        file/0 {
            set size $state(count)
        }

        file/1 {
            return [file size $state(file)]
        }

        parts/0
            -
        parts/1 {
            set size 0
            foreach part $state(parts) {
                incr size [getsize $part]
            }

            return $size
        }

        string/0 {
            set size [string length $state(string)]
        }

        string/1 {
            return [string length $state(string)]
        }
	default {
	    error "Unknown combination \"$state(value)/$state(canonicalP)\""
	}
    }

    if {![string compare $state(encoding) base64]} {
        set size [expr {($size*3+2)/4}]
    }

    return $size
}

# ::mime::getheader --
#
#    mime::getheader returns the header of a MIME part.
#
#    A header consists of zero or more key/value pairs. Each value is a
#    list containing one or more strings.
#
#    If mime::getheader is invoked with the name of a specific key, then
#    a list containing the corresponding value(s) is returned; instead,
#    if -names is specified, a list of all keys is returned; otherwise, a
#    serialized array of keys and values is returned. Note that when a
#    key is specified (e.g., "Subject"), the list returned usually
#    contains exactly one string; however, some keys (e.g., "Received")
#    often occur more than once in the header, accordingly the list
#    returned usually contains more than one string.
#
# Arguments:
#       token      The MIME token to parse.
#       key        Either a key or '-names'.  If it is '-names' a list
#                  of all keys is returned.
#
# Results:
#       Returns the header of a MIME part.

proc ::mime::getheader {token {key ""}} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set header $state(header)
    switch -- $key {
        "" {
            set result ""
            foreach lower $state(lowerL) mixed $state(mixedL) {
                lappend result $mixed $header($lower)
            }
            return $result
        }

        -names {
            return $state(mixedL)
        }

        default {
            set lower [string tolower [set mixed $key]]

            if {![info exists header($lower)]} {
                error "key $mixed not in header"
            }
            return $header($lower)
        }
    }
}

# ::mime::setheader --
#
#    mime::setheader writes, appends to, or deletes the value associated
#    with a key in the header.
#
#    The value for -mode is one of: 
#
#       write: the key/value is either created or overwritten (the
#       default);
#
#       append: a new value is appended for the key (creating it as
#       necessary); or,
#
#       delete: all values associated with the key are removed (the
#       "value" parameter is ignored).
#
#    Regardless, mime::setheader returns the previous value associated
#    with the key.
#
# Arguments:
#       token      The MIME token to parse.
#       key        The name of the key whose value should be set.
#       value      The value for the header key to be set to.
#       args       An optional argument of the form:
#                  ?-mode "write" | "append" | "delete"?
#
# Results:
#       Returns previous value associated with the specified key.

proc ::mime::setheader {token key value args} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options [list -mode write]
    array set options $args

    switch -- [set lower [string tolower $key]] {
        content-md5
            -
        content-type
            -
        content-transfer-encoding
            -
        mime-version {
            error "key $key may not be set"
        }
	default {# Skip key}
    }

    array set header $state(header)
    if {[set x [lsearch -exact $state(lowerL) $lower]] < 0} {
        if {![string compare $options(-mode) delete]} {
            error "key $key not in header"
        }

        lappend state(lowerL) $lower
        lappend state(mixedL) $key

        set result ""
    } else {
        set result $header($lower)
    }
    switch -- $options(-mode) {
        append {
            lappend header($lower) $value
        }

        delete {
            unset header($lower)
            set state(lowerL) [lreplace $state(lowerL) $x $x]
            set state(mixedL) [lreplace $state(mixedL) $x $x]
        }

        write {
            set header($lower) [list $value]
        }

        default {
            error "unknown value for -mode $options(-mode)"
        }
    }

    set state(header) [array get header]

    return $result
}

# ::mime::getbody --
#
#    mime::getbody returns the body of a leaf MIME part in canonical form.
#
#    If the -command option is present, then it is repeatedly invoked
#    with a fragment of the body as this:
#
#        uplevel #0 $callback [list "data" $fragment]
#
#    (The -blocksize option, if present, specifies the maximum size of
#    each fragment passed to the callback.)
#    When the end of the body is reached, the callback is invoked as:
#
#        uplevel #0 $callback "end"
#
#    Alternatively, if an error occurs, the callback is invoked as:
#
#        uplevel #0 $callback [list "error" reason]
#
#    Regardless, the return value of the final invocation of the callback
#    is propagated upwards by mime::getbody.
#
#    If the -command option is absent, then the return value of
#    mime::getbody is a string containing the MIME part's entire body.
#
# Arguments:
#       token      The MIME token to parse.
#       args       Optional arguments of the form:
#                  ?-decode? ?-command callback ?-blocksize octets? ?
#
# Results:
#       Returns a string containing the MIME part's entire body, or
#       if '-command' is specified, the return value of the command
#       is returned.

proc ::mime::getbody {token args} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set decode 0
    if {[set pos [lsearch -exact $args -decode]] >= 0} {
        set decode 1
        set args [lreplace $args $pos $pos]
    }

    array set options [list -command [list mime::getbodyaux $token]                             -blocksize 4096]
    array set options $args
    if {$options(-blocksize) < 1} {
        error "-blocksize expects a positive integer, not $options(-blocksize)"
    }

    set code 0
    set ecode ""
    set einfo ""

    switch -- $state(value)/$state(canonicalP) {
        file/0 {
            set fd [open $state(file) { RDONLY }]

            set code [catch {
                fconfigure $fd -translation binary
                seek $fd [set pos $state(offset)] start
                set last [expr {$state(offset)+$state(count)-1}]

                set fragment ""
                while {$pos <= $last} {
                    if {[set cc [expr {($last-$pos)+1}]]                             > $options(-blocksize)} {
                        set cc $options(-blocksize)
                    }
                    incr pos [set len                                   [string length [set chunk [read $fd $cc]]]]
                    switch -exact -- $state(encoding) {
                        base64
                            -
                        quoted-printable {
                            if {([set x [string last "\n" $chunk]] > 0)                                     && ($x+1 != $len)} {
                                set chunk [string range $chunk 0 $x]
                                seek $fd [incr pos [expr {($x+1)-$len}]] start
                            }
                            set chunk [$state(encoding) -mode decode                                                         -- $chunk]
                        }
			7bit - 8bit - binary - "" {
			    # Bugfix for [#477088]
			    # Go ahead, leave chunk alone
			}
			default {
			    error "Can't handle content encoding \"$state(encoding)\""
			}
                    }
                    append fragment $chunk

                    set cc [expr {$options(-blocksize)-1}]
                    while {[string length $fragment] > $options(-blocksize)} {
                        uplevel #0 $options(-command)                                    [list data                                          [string range $fragment 0 $cc]]

                        set fragment [string range                                              $fragment $options(-blocksize)                                              end]
                    }
                }
                if {[string length $fragment] > 0} {
                    uplevel #0 $options(-command) [list data $fragment]
                }
            } result]
            set ecode $errorCode
            set einfo $errorInfo

            catch { close $fd }
        }

        file/1 {
            set fd [open $state(file) { RDONLY }]

            set code [catch {
                fconfigure $fd -translation binary

                while {[string length                                [set fragment                                     [read $fd $options(-blocksize)]]] > 0} {
                    uplevel #0 $options(-command) [list data $fragment]
                }
            } result]
            set ecode $errorCode
            set einfo $errorInfo

            catch { close $fd }
        }

        parts/0
            -
        parts/1 {
            error "MIME part isn't a leaf"
        }

        string/0
            -
        string/1 {
            switch -- $state(encoding)/$state(canonicalP) {
                base64/0
                    -
                quoted-printable/0 {
                    set fragment [$state(encoding) -mode decode                                                    -- $state(string)]
                }

                default {
		    # Not a bugfix for [#477088], but clarification
		    # This handles no-encoding, 7bit, 8bit, and binary.
                    set fragment $state(string)
                }
            }

            set code [catch {
                set cc [expr {$options(-blocksize)-1}]
                while {[string length $fragment] > $options(-blocksize)} {
                    uplevel #0 $options(-command)                             [list data [string range $fragment 0 $cc]]

                    set fragment [string range $fragment                                          $options(-blocksize) end]
                }
                if {[string length $fragment] > 0} {
                    uplevel #0 $options(-command) [list data $fragment]
                }
            } result]
            set ecode $errorCode
            set einfo $errorInfo
	}
	default {
	    error "Unknown combination \"$state(value)/$state(canonicalP)\""
	}
    }

    set code [catch {
        if {$code} {
            uplevel #0 $options(-command) [list error $result]
        } else {
            uplevel #0 $options(-command) [list end]
        }
    } result]
    set ecode $errorCode
    set einfo $errorInfo    

    if {$code} {
        return -code $code -errorinfo $einfo -errorcode $ecode $result
    }

    if {$decode} {
        array set params [mime::getproperty $token params]

        if {[info exists params(charset)]} {
            set charset $params(charset)
        } else {
            set charset US-ASCII
        }

        set enc [reversemapencoding $charset]
        if {$enc != ""} {
            set result [::encoding convertfrom $enc $result]
        } else {
            return -code error "-decode failed: can't reversemap charset $charset"
        }
    }

    return $result
}

# ::mime::getbodyaux --
#
#    Builds up the body of the message, fragment by fragment.  When
#    the entire message has been retrieved, it is returned.
#
# Arguments:
#       token      The MIME token to parse.
#       reason     One of 'data', 'end', or 'error'.
#       fragment   The section of data data fragment to extract a
#                  string from.
#
# Results:
#       Returns nothing, except when called with the 'end' argument
#       in which case it returns a string that contains all of the
#       data that 'getbodyaux' has been called with.  Will throw an
#       error if it is called with the reason of 'error'.

proc ::mime::getbodyaux {token reason {fragment ""}} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -- $reason {
        data {
            append state(getbody) $fragment
	    return ""
        }

        end {
            if {[info exists state(getbody)]} {
                set result $state(getbody)
                unset state(getbody)
            } else {
                set result ""
            }

            return $result
        }

        error {
            catch { unset state(getbody) }
            error $reason
        }

	default {
	    error "Unknown reason \"$reason\""
	}
    }
}

# ::mime::copymessage --
#
#    mime::copymessage copies the MIME part to the specified channel.
#
#    mime::copymessage operates synchronously, and uses fileevent to
#    allow asynchronous operations to proceed independently.
#
# Arguments:
#       token      The MIME token to parse.
#       channel    The channel to copy the message to.
#
# Results:
#       Returns nothing unless an error is thrown while the message
#       is being written to the channel.

proc ::mime::copymessage {token channel} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set openP [info exists state(fd)]

    set code [catch { mime::copymessageaux $token $channel } result]
    set ecode $errorCode
    set einfo $errorInfo

    if {(!$openP) && ([info exists state(fd)])} {
        if {![info exists state(root)]} {
            catch { close $state(fd) }
        }
        unset state(fd)
    }

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::mime::copymessageaux --
#
#    mime::copymessageaux copies the MIME part to the specified channel.
#
# Arguments:
#       token      The MIME token to parse.
#       channel    The channel to copy the message to.
#
# Results:
#       Returns nothing unless an error is thrown while the message
#       is being written to the channel.

proc ::mime::copymessageaux {token channel} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set header $state(header)

    if {[string compare $state(version) ""]} {
        puts $channel "MIME-Version: $state(version)"
    }
    foreach lower $state(lowerL) mixed $state(mixedL) {
        foreach value $header($lower) {
            puts $channel "$mixed: $value"
        }
    }
    if {(!$state(canonicalP))             && ([string compare [set encoding $state(encoding)] ""])} {
        puts $channel "Content-Transfer-Encoding: $encoding"
    }

    puts -nonewline $channel "Content-Type: $state(content)"
    set boundary ""
    foreach {k v} $state(params) {
        if {![string compare $k boundary]} {
            set boundary $v
        }

        puts -nonewline $channel ";\n              $k=\"$v\""
    }

    set converter ""
    set encoding ""
    if {[string compare $state(value) parts]} {
        puts $channel ""

        if {$state(canonicalP)} {
            if {![string compare [set encoding $state(encoding)] ""]} {
                set encoding [encoding $token]
            }
            if {[string compare $encoding ""]} {
                puts $channel "Content-Transfer-Encoding: $encoding"
            }
            switch -- $encoding {
                base64
                    -
                quoted-printable {
                    set converter $encoding
                }
		7bit - 8bit - binary - "" {
		    # Bugfix for [#477088], also [#539952]
		    # Go ahead
		}
		default {
		    error "Can't handle content encoding \"$encoding\""
		}
            }
        }
    } elseif {([string match multipart/* $state(content)])                     && (![string compare $boundary ""])} {
# we're doing everything in one pass...
        set key [clock seconds]$token[info hostname][array get state]
        set seqno 8
        while {[incr seqno -1] >= 0} {
            set key [md5 -- $key]
        }
        set boundary "----- =_[string trim [base64 -mode encode -- $key]]"

        puts $channel ";\n              boundary=\"$boundary\""
    } else {
        puts $channel ""
    }

    if {[info exists state(error)]} {
        unset state(error)
    }
                
    switch -- $state(value) {
        file {
            set closeP 1
            if {[info exists state(root)]} {
		# FRINK: nocheck
                variable $state(root)
                upvar 0 $state(root) root 

                if {[info exists root(fd)]} {
                    set fd $root(fd)
                    set closeP 0
                } else {
                    set fd [set state(fd)                                 [open $state(file) { RDONLY }]]
                }
                set size $state(count)
            } else {
                set fd [set state(fd) [open $state(file) { RDONLY }]]
		# read until eof
                set size -1
            }
            seek $fd $state(offset) start
            if {$closeP} {
                fconfigure $fd -translation binary
            }

            puts $channel ""

	    while {($size != 0) && (![eof $fd])} {
		if {$size < 0 || $size > 32766} {
		    set X [read $fd 32766]
		} else {
		    set X [read $fd $size]
		}
		if {$size > 0} {
		    set size [expr {$size - [string length $X]}]
		}
		if {[string compare $converter ""]} {
		    puts -nonewline $channel [$converter -mode encode -- $X]
		} else {
		    puts -nonewline $channel $X
		}
	    }

            if {$closeP} {
                catch { close $state(fd) }
                unset state(fd)
            }
        }

        parts {
            if {(![info exists state(root)])                     && ([info exists state(file)])} {
                set state(fd) [open $state(file) { RDONLY }]
                fconfigure $state(fd) -translation binary
            }

            switch -glob -- $state(content) {
                message/* {
                    puts $channel ""
                    foreach part $state(parts) {
                        mime::copymessage $part $channel
                        break
                    }
                }

                default {
                    foreach part $state(parts) {
                        puts $channel "\n--$boundary"
                        mime::copymessage $part $channel
                    }
                    puts $channel "\n--$boundary--"
                }
            }

            if {[info exists state(fd)]} {
                catch { close $state(fd) }
                unset state(fd)
            }
        }

        string {
            if {[catch { fconfigure $channel -buffersize } blocksize]} {
                set blocksize 4096
            } elseif {$blocksize < 512} {
                set blocksize 512
            }
            set blocksize [expr {($blocksize/4)*3}]

	    # [893516]
	    fconfigure $channel -buffersize $blocksize

            puts $channel ""

            if {[string compare $converter ""]} {
                puts $channel [$converter -mode encode -- $state(string)]
            } else {
		puts $channel $state(string)
	    }
        }
	default {
	    error "Unknown value \"$state(value)\""
	}
    }

    flush $channel

    if {[string compare $converter ""]} {
        unstack $channel
    }
    if {[info exists state(error)]} {
        error $state(error)
    }
}

# ::mime::buildmessage --
#
#     The following is a clone of the copymessage code to build up the
#     result in memory, and, unfortunately, without using a memory channel.
#     I considered parameterizing the "puts" calls in copy message, but
#     the need for this procedure may go away, so I'm living with it for
#     the moment.
#
# Arguments:
#       token      The MIME token to parse.
#
# Results:
#       Returns the message that has been built up in memory.

proc ::mime::buildmessage {token} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set openP [info exists state(fd)]

    set code [catch { mime::buildmessageaux $token } result]
    set ecode $errorCode
    set einfo $errorInfo

    if {(!$openP) && ([info exists state(fd)])} {
        if {![info exists state(root)]} {
            catch { close $state(fd) }
        }
        unset state(fd)
    }

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::mime::buildmessageaux --
#
#     The following is a clone of the copymessageaux code to build up the
#     result in memory, and, unfortunately, without using a memory channel.
#     I considered parameterizing the "puts" calls in copy message, but
#     the need for this procedure may go away, so I'm living with it for
#     the moment.
#
# Arguments:
#       token      The MIME token to parse.
#
# Results:
#       Returns the message that has been built up in memory.

proc ::mime::buildmessageaux {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set header $state(header)

    set result ""
    if {[string compare $state(version) ""]} {
        append result "MIME-Version: $state(version)\r\n"
    }
    foreach lower $state(lowerL) mixed $state(mixedL) {
        foreach value $header($lower) {
            append result "$mixed: $value\r\n"
        }
    }
    if {(!$state(canonicalP))             && ([string compare [set encoding $state(encoding)] ""])} {
        append result "Content-Transfer-Encoding: $encoding\r\n"
    }

    append result "Content-Type: $state(content)"
    set boundary ""
    foreach {k v} $state(params) {
        if {![string compare $k boundary]} {
            set boundary $v
        }

        append result ";\r\n              $k=\"$v\""
    }

    set converter ""
    set encoding ""
    if {[string compare $state(value) parts]} {
        append result \r\n

        if {$state(canonicalP)} {
            if {![string compare [set encoding $state(encoding)] ""]} {
                set encoding [encoding $token]
            }
            if {[string compare $encoding ""]} {
                append result "Content-Transfer-Encoding: $encoding\r\n"
            }
            switch -- $encoding {
                base64
                    -
                quoted-printable {
                    set converter $encoding
                }
		7bit - 8bit - binary - "" {
		    # Bugfix for [#477088]
		    # Go ahead
		}
		default {
		    error "Can't handle content encoding \"$encoding\""
		}
            }
        }
    } elseif {([string match multipart/* $state(content)])                     && (![string compare $boundary ""])} {
# we're doing everything in one pass...
        set key [clock seconds]$token[info hostname][array get state]
        set seqno 8
        while {[incr seqno -1] >= 0} {
            set key [md5 -- $key]
        }
        set boundary "----- =_[string trim [base64 -mode encode -- $key]]"

        append result ";\r\n              boundary=\"$boundary\"\r\n"
    } else {
        append result "\r\n"
    }

    if {[info exists state(error)]} {
        unset state(error)
    }
                
    switch -- $state(value) {
        file {
            set closeP 1
            if {[info exists state(root)]} {
		# FRINK: nocheck
                variable $state(root)
                upvar 0 $state(root) root 

                if {[info exists root(fd)]} {
                    set fd $root(fd)
                    set closeP 0
                } else {
                    set fd [set state(fd)                                 [open $state(file) { RDONLY }]]
                }
                set size $state(count)
            } else {
                set fd [set state(fd) [open $state(file) { RDONLY }]]
                set size -1	;# Read until EOF
            }
            seek $fd $state(offset) start
            if {$closeP} {
                fconfigure $fd -translation binary
            }

            append result "\r\n"

	    while {($size != 0) && (![eof $fd])} {
		if {$size < 0 || $size > 32766} {
		    set X [read $fd 32766]
		} else {
		    set X [read $fd $size]
		}
		if {$size > 0} {
		    set size [expr {$size - [string length $X]}]
		}
		if {[string compare $converter ""]} {
		    append result "[$converter -mode encode -- $X]\r\n"
		} else {
		    append result "$X\r\n"
		}
	    }

            if {$closeP} {
                catch { close $state(fd) }
                unset state(fd)
            }
        }

        parts {
            if {(![info exists state(root)])                     && ([info exists state(file)])} {
                set state(fd) [open $state(file) { RDONLY }]
                fconfigure $state(fd) -translation binary
            }

            switch -glob -- $state(content) {
                message/* {
                    append result "\r\n"
                    foreach part $state(parts) {
                        append result [buildmessage $part]
                        break
                    }
                }

                default {
                    foreach part $state(parts) {
                        append result "\r\n--$boundary\r\n"
                        append result [buildmessage $part]
                    }
                    append result "\r\n--$boundary--\r\n"
                }
            }

            if {[info exists state(fd)]} {
                catch { close $state(fd) }
                unset state(fd)
            }
        }

        string {

            append result "\r\n"

	    if {[string compare $converter ""]} {
		append result "[$converter -mode encode -- $state(string)]\r\n"
	    } else {
		append result "$state(string)\r\n"
	    }
        }
	default {
	    error "Unknown value \"$state(value)\""
	}
    }

    if {[info exists state(error)]} {
        error $state(error)
    }
    return $result
}

# ::mime::encoding --
#
#     Determines how a token is encoded.
#
# Arguments:
#       token      The MIME token to parse.
#
# Results:
#       Returns the encoding of the message (the null string, base64,
#       or quoted-printable).

proc ::mime::encoding {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -glob -- $state(content) {
        audio/*
            -
        image/*
            -
        video/* {
            return base64
        }

        message/*
            -
        multipart/* {
            return ""
        }
	default {# Skip}
    }

    set asciiP 1
    set lineP 1
    switch -- $state(value) {
        file {
            set fd [open $state(file) { RDONLY }]
            fconfigure $fd -translation binary

            while {[gets $fd line] >= 0} {
                if {$asciiP} {
                    set asciiP [encodingasciiP $line]
                }
                if {$lineP} {
                    set lineP [encodinglineP $line]
                }
                if {(!$asciiP) && (!$lineP)} {
                    break
                }
            }

            catch { close $fd }
        }

        parts {
            return ""
        }

        string {
            foreach line [split $state(string) "\n"] {
                if {$asciiP} {
                    set asciiP [encodingasciiP $line]
                }
                if {$lineP} {
                    set lineP [encodinglineP $line]
                }
                if {(!$asciiP) && (!$lineP)} {
                    break
                }
            }
        }
	default {
	    error "Unknown value \"$state(value)\""
	}
    }

    switch -glob -- $state(content) {
        text/* {
            if {!$asciiP} {
                foreach {k v} $state(params) {
                    if {![string compare $k charset]} {
                        set v [string tolower $v]
                        if {([string compare $v us-ascii])                                 && (![string match {iso-8859-[1-8]} $v])} {
                            return base64
                        }

                        break
                    }
                }
            }

            if {!$lineP} {
                return quoted-printable
            }
        }

        
        default {
            if {(!$asciiP) || (!$lineP)} {
                return base64
            }
        }
    }

    return ""
}

# ::mime::encodingasciiP --
#
#     Checks if a string is a pure ascii string, or if it has a non-standard
#     form.
#
# Arguments:
#       line    The line to check.
#
# Results:
#       Returns 1 if \r only occurs at the end of lines, and if all
#       characters in the line are between the ASCII codes of 32 and 126.

proc ::mime::encodingasciiP {line} {
    foreach c [split $line ""] {
        switch -- $c {
            " " - "\t" - "\r" - "\n" {
            }

            default {
                binary scan $c c c
                if {($c < 32) || ($c > 126)} {
                    return 0
                }
            }
        }
    }
    if {([set r [string first "\r" $line]] < 0)             || ($r == [expr {[string length $line]-1}])} {
        return 1
    }

    return 0
}

# ::mime::encodinglineP --
#
#     Checks if a string is a line is valid to be processed.
#
# Arguments:
#       line    The line to check.
#
# Results:
#       Returns 1 the line is less than 76 characters long, the line
#       contains more characters than just whitespace, the line does
#       not start with a '.', and the line does not start with 'From '.

proc ::mime::encodinglineP {line} {
    if {([string length $line] > 76)             || ([string compare $line [string trimright $line]])             || ([string first . $line] == 0)             || ([string first "From " $line] == 0)} {
        return 0
    }

    return 1
}

# ::mime::fcopy --
#
#	Appears to be unused.
#
# Arguments:
#
# Results:
# 

proc ::mime::fcopy {token count {error ""}} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[string compare $error ""]} {
        set state(error) $error
    }
    set state(doneP) 1
}

# ::mime::scopy --
#
#	Copy a portion of the contents of a mime token to a channel.
#
# Arguments:
#	token     The token containing the data to copy.
#       channel   The channel to write the data to.
#       offset    The location in the string to start copying
#                 from.
#       len       The amount of data to write.
#       blocksize The block size for the write operation.
#
# Results:
#	The specified portion of the string in the mime token is
#       copied to the specified channel.

proc ::mime::scopy {token channel offset len blocksize} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {$len <= 0} {
        set state(doneP) 1
        fileevent $channel writable ""
        return
    }

    if {[set cc $len] > $blocksize} {
        set cc $blocksize
    }

    if {[catch { puts -nonewline $channel                       [string range $state(string) $offset                               [expr {$offset+$cc-1}]]
                 fileevent $channel writable                            [list mime::scopy $token $channel                                              [incr offset $cc]                                              [incr len -$cc]                                              $blocksize]
               } result]} {
        set state(error) $result
        set state(doneP) 1
        fileevent $channel writable ""
    }
    return
}

# ::mime::qp_encode --
#
#	Tcl version of quote-printable encode
#
# Arguments:
#	string        The string to quote.
#       encoded_word  Boolean value to determine whether or not encoded words
#                     (RFC 2047) should be handled or not. (optional)
#
# Results:
#	The properly quoted string is returned.

proc ::mime::qp_encode {string {encoded_word 0} {no_softbreak 0}} {
    # 8.1+ improved string manipulation routines used.
    # Replace outlying characters, characters that would normally
    # be munged by EBCDIC gateways, and special Tcl characters "[\]{}
    # with =xx sequence

    regsub -all -- 	    {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF]} 	    $string {[format =%02X [scan "\\&" %c]]} string

    # Replace the format commands with their result

    set string [subst -novariable $string]

    # soft/hard newlines and other
    # Funky cases for SMTP compatibility
    set mapChars [list " \n" "=20\n" "\t\n" "=09\n" 	    "\n\.\n" "\n=2E\n" "\nFrom " "\n=46rom "]
    if {$encoded_word} {
	# Special processing for encoded words (RFC 2047)
	lappend mapChars " " "_"
    }
    set string [string map $mapChars $string]

    # Break long lines - ugh

    # Implementation of FR #503336
    if {$no_softbreak} {
	set result $string
    } else {
	set result ""
	foreach line [split $string \n] {
	    while {[string length $line] > 72} {
		set chunk [string range $line 0 72]
		if {[regexp -- (=|=.)$ $chunk dummy end]} {
		    
		    # Don't break in the middle of a code

		    set len [expr {72 - [string length $end]}]
		    set chunk [string range $line 0 $len]
		    incr len
		    set line [string range $line $len end]
		} else {
		    set line [string range $line 73 end]
		}
		append result $chunk=\n
	    }
	    append result $line\n
	}
    }
    
    # Trim off last \n, since the above code has the side-effect
    # of adding an extra \n to the encoded string and return the result.

    set result [string range $result 0 end-1]

    # If the string ends in space or tab, replace with =xx

    set lastChar [string index $result end]
    if {$lastChar==" "} {
	set result [string replace $result end end "=20"]
    } elseif {$lastChar=="\t"} {
	set result [string replace $result end end "=09"]
    }

    return $result
}

# ::mime::qp_decode --
#
#	Tcl version of quote-printable decode
#
# Arguments:
#	string        The quoted-prinatble string to decode.
#       encoded_word  Boolean value to determine whether or not encoded words
#                     (RFC 2047) should be handled or not. (optional)
#
# Results:
#	The decoded string is returned.

proc ::mime::qp_decode {string {encoded_word 0}} {
    # 8.1+ improved string manipulation routines used.
    # Special processing for encoded words (RFC 2047)

    if {$encoded_word} {
	# _ == \x20, even if SPACE occupies a different code position
	set string [string map [list _ \u0020] $string]
    }

    # smash the white-space at the ends of lines since that must've been
    # generated by an MUA.

    regsub -all -- {[ \t]+\n} $string "\n" string
    set string [string trimright $string " \t"]

    # Protect the backslash for later subst and
    # smash soft newlines, has to occur after white-space smash
    # and any encoded word modification.

    set string [string map [list "\\" "\\\\" "=\n" ""] $string]

    # Decode specials

    regsub -all -nocase {=([a-f0-9][a-f0-9])} $string {\\u00\1} string

    # process \u unicode mapped chars

    return [subst -novar -nocommand $string]
}

# ::mime::parseaddress --
#
#       This was originally written circa 1982 in C. we're still using it
#       because it recognizes virtually every buggy address syntax ever
#       generated!
#
#       mime::parseaddress takes a string containing one or more 822-style
#       address specifications and returns a list of serialized arrays, one
#       element for each address specified in the argument.
#
#    Each serialized array contains these properties:
#
#       property    value
#       ========    =====
#       address     local@domain
#       comment     822-style comment
#       domain      the domain part (rhs)
#       error       non-empty on a parse error
#       group       this address begins a group
#       friendly    user-friendly rendering
#       local       the local part (lhs)
#       memberP     this address belongs to a group
#       phrase      the phrase part
#       proper      822-style address specification
#       route       822-style route specification (obsolete)
#
#    Note that one or more of these properties may be empty.
#
# Arguments:
#	string        The address string to parse
#
# Results:
#	Returns a list of serialized arrays, one element for each address
#       specified in the argument.

proc ::mime::parseaddress {string} {
    global errorCode errorInfo

    variable mime

    set token [namespace current]::[incr mime(uid)]
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set code [catch { mime::parseaddressaux $token $string } result]
    set ecode $errorCode
    set einfo $errorInfo

    foreach name [array names state] {
        unset state($name)
    }
    # FRINK: nocheck
    catch { unset $token }

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::mime::parseaddressaux --
#
#       This was originally written circa 1982 in C. we're still using it
#       because it recognizes virtually every buggy address syntax ever
#       generated!
#
#       mime::parseaddressaux does the actually parsing for mime::parseaddress
#
#    Each serialized array contains these properties:
#
#       property    value
#       ========    =====
#       address     local@domain
#       comment     822-style comment
#       domain      the domain part (rhs)
#       error       non-empty on a parse error
#       group       this address begins a group
#       friendly    user-friendly rendering
#       local       the local part (lhs)
#       memberP     this address belongs to a group
#       phrase      the phrase part
#       proper      822-style address specification
#       route       822-style route specification (obsolete)
#
#    Note that one or more of these properties may be empty.
#
# Arguments:
#       token         The MIME token to work from.
#	string        The address string to parse
#
# Results:
#	Returns a list of serialized arrays, one element for each address
#       specified in the argument.

proc ::mime::parseaddressaux {token string} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    variable addrtokenL
    variable addrlexemeL

    set state(input)   $string
    set state(glevel)  0
    set state(buffer)  ""
    set state(lastC)   LX_END
    set state(tokenL)  $addrtokenL
    set state(lexemeL) $addrlexemeL

    set result ""
    while {[addr_next $token]} {
        if {[string compare [set tail $state(domain)] ""]} {
            set tail @$state(domain)
        } else {
            set tail @[info hostname]
        }
        if {[string compare [set address $state(local)] ""]} {
            append address $tail
        }

        if {[string compare $state(phrase) ""]} {
            set state(phrase) [string trim $state(phrase) "\""]
            foreach t $state(tokenL) {
                if {[string first $t $state(phrase)] >= 0} {
                    set state(phrase) \"$state(phrase)\"
                    break
                }
            }

            set proper "$state(phrase) <$address>"
        } else {
            set proper $address
        }

        if {![string compare [set friendly $state(phrase)] ""]} {
            if {[string compare [set note $state(comment)] ""]} {
                if {[string first "(" $note] == 0} {
                    set note [string trimleft [string range $note 1 end]]
                }
                if {[string last ")" $note]                         == [set len [expr {[string length $note]-1}]]} {
                    set note [string range $note 0 [expr {$len-1}]]
                }
                set friendly $note
            }

            if {(![string compare $friendly ""])                     && ([string compare [set mbox $state(local)] ""])} {
                set mbox [string trim $mbox "\""]

                if {[string first "/" $mbox] != 0} {
                    set friendly $mbox
                } elseif {[string compare                                   [set friendly [addr_x400 $mbox PN]]                                   ""]} {
                } elseif {([string compare                                    [set friendly [addr_x400 $mbox S]]                                    ""])                             && ([string compare                                         [set g [addr_x400 $mbox G]]                                         ""])} {
                    set friendly "$g $friendly"
                }

                if {![string compare $friendly ""]} {
                    set friendly $mbox
                }
            }
        }
        set friendly [string trim $friendly "\""]

        lappend result [list address  $address                                     comment  $state(comment)                              domain   $state(domain)                               error    $state(error)                                friendly $friendly                                    group    $state(group)                                local    $state(local)                                memberP  $state(memberP)                              phrase   $state(phrase)                               proper   $proper                                      route    $state(route)]

    }

    unset state(input)             state(glevel)            state(buffer)            state(lastC)             state(tokenL)            state(lexemeL)

    return $result
}

# ::mime::addr_next --
#
#       Locate the next address in a mime token.
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns 1 if there is another address, and 0 if there is not.

proc ::mime::addr_next {token} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    foreach prop {comment domain error group local memberP phrase route} {
        catch { unset state($prop) }
    }

    switch -- [set code [catch { mime::addr_specification $token } result]] {
        0 {
            if {!$result} {
                return 0
            }

            switch -- $state(lastC) {
                LX_COMMA
                    -
                LX_END {
                }
                default {
                    # catch trailing comments...
                    set lookahead $state(input)
                    mime::parselexeme $token
                    set state(input) $lookahead
                }
            }
        }

        7 {
            set state(error) $result

            while {1} {
                switch -- $state(lastC) {
                    LX_COMMA
                        -
                    LX_END {
                        break
                    }

                    default {
                        mime::parselexeme $token
                    }
                }
            }
        }

        default {
            set ecode $errorCode
            set einfo $errorInfo

            return -code $code -errorinfo $einfo -errorcode $ecode $result
        }
    }

    foreach prop {comment domain error group local memberP phrase route} {
        if {![info exists state($prop)]} {
            set state($prop) ""
        }
    }

    return 1
}

# ::mime::addr_specification --
#
#   Uses lookahead parsing to determine whether there is another
#   valid e-mail address or not.  Throws errors if unrecognized
#   or invalid e-mail address syntax is used.
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns 1 if there is another address, and 0 if there is not.

proc ::mime::addr_specification {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set lookahead $state(input)
    switch -- [parselexeme $token] {
        LX_ATOM
            -
        LX_QSTRING {
            set state(phrase) $state(buffer)
        }

        LX_SEMICOLON {
            if {[incr state(glevel) -1] < 0} {
                return -code 7 "extraneous semi-colon"
            }

            catch { unset state(comment) }
            return [addr_specification $token]
        }

        LX_COMMA {
            catch { unset state(comment) }
            return [addr_specification $token]
        }

        LX_END {
            return 0
        }

        LX_LBRACKET {
            return [addr_routeaddr $token]
        }

        LX_ATSIGN {
            set state(input) $lookahead
            return [addr_routeaddr $token 0]
        }

        default {
            return -code 7                    [format "unexpected character at beginning (found %s)"                            $state(buffer)]
        }
    }

    switch -- [parselexeme $token] {
        LX_ATOM
            -
        LX_QSTRING {
            append state(phrase) " " $state(buffer)

            return [addr_phrase $token]
        }

        LX_LBRACKET {
            return [addr_routeaddr $token]
        }

        LX_COLON {
            return [addr_group $token]
        }

        LX_DOT {
            set state(local) "$state(phrase)$state(buffer)"
            unset state(phrase)
            mime::addr_routeaddr $token 0
            mime::addr_end $token
        }

        LX_ATSIGN {
            set state(memberP) $state(glevel)
            set state(local) $state(phrase)
            unset state(phrase)
            mime::addr_domain $token
            mime::addr_end $token
        }

        LX_SEMICOLON
            -
        LX_COMMA
            -
        LX_END {
            set state(memberP) $state(glevel)
            if {(![string compare $state(lastC) LX_SEMICOLON])                     && ([incr state(glevel) -1] < 0)} {
                return -code 7 "extraneous semi-colon"
            }

            set state(local) $state(phrase)
            unset state(phrase)
        }

        default {
            return -code 7 [format "expecting mailbox (found %s)"                                    $state(buffer)]
        }
    }

    return 1
}

# ::mime::addr_routeaddr --
#
#       Parses the domain portion of an e-mail address.  Finds the '@'
#       sign and then calls mime::addr_route to verify the domain.
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns 1 if there is another address, and 0 if there is not.

proc ::mime::addr_routeaddr {token {checkP 1}} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set lookahead $state(input)
    if {![string compare [parselexeme $token] LX_ATSIGN]} {
        mime::addr_route $token
    } else {
        set state(input) $lookahead
    }

    mime::addr_local $token

    switch -- $state(lastC) {
        LX_ATSIGN {
            mime::addr_domain $token
        }

        LX_SEMICOLON
            -
        LX_RBRACKET
            -
        LX_COMMA
            -
        LX_END {
        }

        default {
            return -code 7                    [format "expecting at-sign after local-part (found %s)"                            $state(buffer)]
        }
    }

    if {($checkP) && ([string compare $state(lastC) LX_RBRACKET])} {
        return -code 7 [format "expecting right-bracket (found %s)"                                $state(buffer)]
    }

    return 1
}

# ::mime::addr_route --
#
#    Attempts to parse the portion of the e-mail address after the @.
#    Tries to verify that the domain definition has a valid form.
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_route {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set state(route) @

    while {1} {
        switch -- [parselexeme $token] {
            LX_ATOM
                -
            LX_DLITERAL {
                append state(route) $state(buffer)
            }

            default {
                return -code 7                        [format "expecting sub-route in route-part (found %s)"                                $state(buffer)]
            }
        }

        switch -- [parselexeme $token] {
            LX_COMMA {
                append state(route) $state(buffer)
                while {1} {
                    switch -- [parselexeme $token] {
                        LX_COMMA {
                        }

                        LX_ATSIGN {
                            append state(route) $state(buffer)
                            break
                        }

                        default {
                            return -code 7                                    [format "expecting at-sign in route (found %s)"                                            $state(buffer)]
                        }
                    }
                }
            }

            LX_ATSIGN
                -
            LX_DOT {
                append state(route) $state(buffer)
            }

            LX_COLON {
                append state(route) $state(buffer)
                return
            }

            default {
                return -code 7                        [format "expecting colon to terminate route (found %s)"                                $state(buffer)]
            }
        }
    }
}

# ::mime::addr_domain --
#
#    Attempts to parse the portion of the e-mail address after the @.
#    Tries to verify that the domain definition has a valid form.
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_domain {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    while {1} {
        switch -- [parselexeme $token] {
            LX_ATOM
                -
            LX_DLITERAL {
                append state(domain) $state(buffer)
            }

            default {
                return -code 7                        [format "expecting sub-domain in domain-part (found %s)"                                $state(buffer)]
            }
        }

        switch -- [parselexeme $token] {
            LX_DOT {
                append state(domain) $state(buffer)
            }

            LX_ATSIGN {
                append state(local) % $state(domain)
                unset state(domain)
            }

            default {
                return
            }
        }
    }
}

# ::mime::addr_local --
#
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_local {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set state(memberP) $state(glevel)

    while {1} {
        switch -- [parselexeme $token] {
            LX_ATOM
                -
            LX_QSTRING {
                append state(local) $state(buffer)
            }

            default {
                return -code 7                        [format "expecting mailbox in local-part (found %s)"                                $state(buffer)]
            }
        }

        switch -- [parselexeme $token] {
            LX_DOT {
                append state(local) $state(buffer)
            }

            default {
                return
            }
        }
    }
}

# ::mime::addr_phrase --
#
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns nothing if successful, and throws an error if invalid
#       syntax is found.


proc ::mime::addr_phrase {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    while {1} {
        switch -- [parselexeme $token] {
            LX_ATOM
                -
            LX_QSTRING {
                append state(phrase) " " $state(buffer)
            }

            default {
                break
            }
        }
    }

    switch -- $state(lastC) {
        LX_LBRACKET {
            return [addr_routeaddr $token]
        }

        LX_COLON {
            return [addr_group $token]
        }

        LX_DOT {
            append state(phrase) $state(buffer)
            return [addr_phrase $token]   
        }

        default {
            return -code 7                    [format "found phrase instead of mailbox (%s%s)"                            $state(phrase) $state(buffer)]
        }
    }
}

# ::mime::addr_group --
#
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_group {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[incr state(glevel)] > 1} {
        return -code 7 [format "nested groups not allowed (found %s)"                                $state(phrase)]
    }

    set state(group) $state(phrase)
    unset state(phrase)

    set lookahead $state(input)
    while {1} {
        switch -- [parselexeme $token] {
            LX_SEMICOLON
                -
            LX_END {
                set state(glevel) 0
                return 1
            }

            LX_COMMA {
            }

            default {
                set state(input) $lookahead
                return [addr_specification $token]
            }
        }
    }
}

# ::mime::addr_end --
#
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_end {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -- $state(lastC) {
        LX_SEMICOLON {
            if {[incr state(glevel) -1] < 0} {
                return -code 7 "extraneous semi-colon"
            }
        }

        LX_COMMA
            -
        LX_END {
        }

        default {
            return -code 7 [format "junk after local@domain (found %s)"                                    $state(buffer)]
        }
    }    
}

# ::mime::addr_x400 --
#
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#	Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_x400 {mbox key} {
    if {[set x [string first "/$key=" [string toupper $mbox]]] < 0} {
        return ""
    }
    set mbox [string range $mbox [expr {$x+[string length $key]+2}] end]

    if {[set x [string first "/" $mbox]] > 0} {
        set mbox [string range $mbox 0 [expr {$x-1}]]
    }

    return [string trim $mbox "\""]
}

# ::mime::parsedatetime --
#
#    Fortunately the clock command in the Tcl 8.x core does all the heavy 
#    lifting for us (except for timezone calculations).
#
#    mime::parsedatetime takes a string containing an 822-style date-time
#    specification and returns the specified property.
#
#    The list of properties and their ranges are:
#
#       property     range
#       ========     =====
#       hour         0 .. 23
#       lmonth       January, February, ..., December
#       lweekday     Sunday, Monday, ... Saturday
#       mday         1 .. 31
#       min          0 .. 59
#       mon          1 .. 12
#       month        Jan, Feb, ..., Dec
#       proper       822-style date-time specification
#       rclock       elapsed seconds between then and now
#       sec          0 .. 59
#       wday         0 .. 6 (Sun .. Mon)
#       weekday      Sun, Mon, ..., Sat
#       yday         1 .. 366
#       year         1900 ...
#       zone         -720 .. 720 (minutes east of GMT)
#
# Arguments:
#       value       Either a 822-style date-time specification or '-now'
#                   if the current date/time should be used.
#       property    The property (from the list above) to return
#
# Results:
#	Returns the string value of the 'property' for the date/time that was
#       specified in 'value'.

proc ::mime::parsedatetime {value property} {
    if {![string compare $value -now]} {
        set clock [clock seconds]
    } else {
        set clock [clock scan $value]
    }

    switch -- $property {
        hour {
            set value [clock format $clock -format %H]
        }

        lmonth {
            return [clock format $clock -format %B]
        }

        lweekday {
            return [clock format $clock -format %A]
        }

        mday {
            set value [clock format $clock -format %d]
        }

        min {
            set value [clock format $clock -format %M]
        }

        mon {
            set value [clock format $clock -format %m]
        }

        month {
            return [clock format $clock -format %b]
        }

        proper {
            set gmt [clock format $clock -format "%d %b %Y %H:%M:%S"                            -gmt true]
            if {[set diff [expr {($clock-[clock scan $gmt])/60}]] < 0} {
                set s -
                set diff [expr {-($diff)}]
            } else {
                set s +
            }
            set zone [format %s%02d%02d $s [expr {$diff/60}] [expr {$diff%60}]]

            return [clock format $clock                           -format "%a, %d %b %Y %H:%M:%S $zone"]
        }

        rclock {
            if {![string compare $value -now]} {
                return 0
            } else {
                return [expr {[clock seconds]-$clock}]
            }
        }

        sec {
            set value [clock format $clock -format %S]
        }

        wday {
            return [clock format $clock -format %w]
        }

        weekday {
            return [clock format $clock -format %a]
        }

        yday {
            set value [clock format $clock -format %j]
        }

        year {
            set value [clock format $clock -format %Y]
        }

        zone {
	    set value [string trim [string map [list "\t" " "] $value]]
            if {[set x [string last " " $value]] < 0} {
                return 0
            }
            set value [string range $value [expr {$x+1}] end]
            switch -- [set s [string index $value 0]] {
                + - - {
                    if {![string compare $s +]} {
                        set s ""
                    }
                    set value [string trim [string range $value 1 end]]
                    if {([string length $value] != 4)                             || ([scan $value %2d%2d h m] != 2)                             || ($h > 12)                             || ($m > 59)                             || (($h == 12) && ($m > 0))} {
                        error "malformed timezone-specification: $value"
                    }
                    set value $s[expr {$h*60+$m}]
                }

                default {
                    set value [string toupper $value]
                    set z1 [list  UT GMT EST EDT CST CDT MST MDT PST PDT]
                    set z2 [list   0   0  -5  -4  -6  -5  -7  -6  -8  -7]
                    if {[set x [lsearch -exact $z1 $value]] < 0} {
                        error "unrecognized timezone-mnemonic: $value"
                    }
                    set value [expr {[lindex $z2 $x]*60}]
                }
            }
        }

        date2gmt
            -
        date2local
            -
        dst
            -
        sday
            -
        szone
            -
        tzone
            -
        default {
            error "unknown property $property"
        }
    }

    if {![string compare [set value [string trimleft $value 0]] ""]} {
        set value 0
    }
    return $value
}

# ::mime::uniqueID --
#
#    Used to generate a 'globally unique identifier' for the content-id.
#    The id is built from the pid, the current time, the hostname, and
#    a counter that is incremented each time a message is sent.
#
# Arguments:
#
# Results:
#	Returns the a string that contains the globally unique identifier
#       that should be used for the Content-ID of an e-mail message.

proc ::mime::uniqueID {} {
    variable mime

    return "<[pid].[clock seconds].[incr mime(cid)]@[info hostname]>"
}

# ::mime::parselexeme --
#
#    Used to implement a lookahead parser.
#
# Arguments:
#       token    The MIME token to operate on.
#
# Results:
#	Returns the next token found by the parser.

proc ::mime::parselexeme {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set state(input) [string trimleft $state(input)]

    set state(buffer) ""
    if {![string compare $state(input) ""]} {
        set state(buffer) end-of-input
        return [set state(lastC) LX_END]
    }

    set c [string index $state(input) 0]
    set state(input) [string range $state(input) 1 end]

    if {![string compare $c "("]} {
        set noteP 0
        set quoteP 0

        while {1} {
            append state(buffer) $c

            switch -- $c/$quoteP {
                "(/0" {
                    incr noteP
                }

                "\\/0" {
                    set quoteP 1
                }

                ")/0" {
                    if {[incr noteP -1] < 1} {
                        if {[info exists state(comment)]} {
                            append state(comment) " "
                        }
                        append state(comment) $state(buffer)

                        return [parselexeme $token]
                    }
                }

                default {
                    set quoteP 0
                }
            }

            if {![string compare [set c [string index $state(input) 0]] ""]} {
                set state(buffer) "end-of-input during comment"
                return [set state(lastC) LX_ERR]
            }
            set state(input) [string range $state(input) 1 end]
        }
    }

    if {![string compare $c "\""]} {
        set firstP 1
        set quoteP 0

        while {1} {
            append state(buffer) $c

            switch -- $c/$quoteP {
                "\\/0" {
                    set quoteP 1
                }

                "\"/0" {
                    if {!$firstP} {
                        return [set state(lastC) LX_QSTRING]
                    }
                    set firstP 0
                }

                default {
                    set quoteP 0
                }
            }

            if {![string compare [set c [string index $state(input) 0]] ""]} {
                set state(buffer) "end-of-input during quoted-string"
                return [set state(lastC) LX_ERR]
            }
            set state(input) [string range $state(input) 1 end]
        }
    }

    if {![string compare $c "\["]} {
        set quoteP 0

        while {1} {
            append state(buffer) $c

            switch -- $c/$quoteP {
                "\\/0" {
                    set quoteP 1
                }

                "\]/0" {
                    return [set state(lastC) LX_DLITERAL]
                }

                default {
                    set quoteP 0
                }
            }

            if {![string compare [set c [string index $state(input) 0]] ""]} {
                set state(buffer) "end-of-input during domain-literal"
                return [set state(lastC) LX_ERR]
            }
            set state(input) [string range $state(input) 1 end]
        }
    }

    if {[set x [lsearch -exact $state(tokenL) $c]] >= 0} {
        append state(buffer) $c

        return [set state(lastC) [lindex $state(lexemeL) $x]]
    }

    while {1} {
        append state(buffer) $c

        switch -- [set c [string index $state(input) 0]] {
            "" - " " - "\t" - "\n" {
                break
            }

            default {
                if {[lsearch -exact $state(tokenL) $c] >= 0} {
                    break
                }
            }
        }

        set state(input) [string range $state(input) 1 end]
    }

    return [set state(lastC) LX_ATOM]
}

# ::mime::mapencoding --
#
#    mime::mapencodings maps tcl encodings onto the proper names for their
#    MIME charset type.  This is only done for encodings whose charset types
#    were known.  The remaining encodings return "" for now.
#
# Arguments:
#       enc      The tcl encoding to map.
#
# Results:
#	Returns the MIME charset type for the specified tcl encoding, or ""
#       if none is known.

proc ::mime::mapencoding {enc} {

    variable encodings

    if {[info exists encodings($enc)]} {
        return $encodings($enc)
    }
    return ""
}

# ::mime::reversemapencoding --
#
#    mime::reversemapencodings maps MIME charset types onto tcl encoding names.
#    Those that are unknown return "".
#
# Arguments:
#       mimeType  The MIME charset to convert into a tcl encoding type.
#
# Results:
#	Returns the tcl encoding name for the specified mime charset, or ""
#       if none is known.

proc ::mime::reversemapencoding {mimeType} {

    variable reversemap
    
    set lmimeType [string tolower $mimeType]
    if {[info exists reversemap($lmimeType)]} {
        return $reversemap($lmimeType)
    }
    return ""
}

# ::mime::word_encode --
#
#    Word encodes strings as per RFC 2047.
#
# Arguments:
#       charset   The character set to encode the message to.
#       method    The encoding method (base64 or quoted-printable).
#       string    The string to encode.
#
# Results:
#	Returns a word encoded string.

proc ::mime::word_encode {charset method string} {

    variable encodings

    if {![info exists encodings($charset)]} {
	error "unknown charset '$charset'"
    }

    if {$encodings($charset) == ""} {
	error "invalid charset '$charset'"
    }

    if {$method != "base64" && $method != "quoted-printable"} {
	error "unknown method '$method', must be base64 or quoted-printable"
    }

    set result "=?$encodings($charset)?"
    switch -exact -- $method {
	base64 {
	    append result "B?[string trimright [base64 -mode encode -- $string] \n]?="
	}
	quoted-printable {
	    append result "Q?[qp_encode $string 1]?="
	}
	"" {
	    # Go ahead
	}
	default {
	    error "Can't handle content encoding \"$method\""
	}
    }

    return $result
}

# ::mime::word_decode --
#
#    Word decodes strings that have been word encoded as per RFC 2047.
#
# Arguments:
#       encoded   The word encoded string to decode.
#
# Results:
#	Returns the string that has been decoded from the encoded message.

proc ::mime::word_decode {encoded} {

    variable reversemap

    if {[regexp -- {=\?([^?]+)\?(.)\?([^?]*)\?=} $encoded 		- charset method string] != 1} {
	error "malformed word-encoded expression '$encoded'"
    }

    set enc [reversemapencoding $charset]
    if {[string equal "" $enc]} {
	error "unknown charset '$charset'"
    }

    switch -exact -- $method {
	b -
	B {
            set method base64
        }
	q -
	Q {
            set method quoted-printable
        }
	default {
	    error "unknown method '$method', must be B or Q"
        }
    }

    switch -exact -- $method {
	base64 {
	    set result [base64 -mode decode -- $string]
	}
	quoted-printable {
	    set result [qp_decode $string 1]
	}
	"" {
	    # Go ahead
	}
	default {
	    error "Can't handle content encoding \"$method\""
	}
    }

    return [list $enc $method $result]
}

# ::mime::field_decode --
#
#    Word decodes strings that have been word encoded as per RFC 2047
#    and converts the string from UTF to the original encoding/charset.
#
# Arguments:
#       field     The string to decode
#
# Results:
#	Returns the decoded string in its original encoding/charset..

proc ::mime::field_decode {field} {
    # ::mime::field_decode is broken.  Here's a new version.
    # This code is in the public domain.  Don Libes <don@libes.com>

    # Step through a field for mime-encoded words, building a new
    # version with unencoded equivalents.

    # Sorry about the grotesque regexp.  Most of it is sensible.  One
    # notable fudge: the final $ is needed because of an apparent bug
    # in the regexp engine where the preceding .* otherwise becomes
    # non-greedy - perhaps because of the earlier ".*?", sigh.

    while {[regexp {(.*?)(=\?(?:[^?]+)\?(?:.)\?(?:[^?]*)\?=)(.*)$} $field ignore prefix encoded field]} {
	# don't allow whitespace between encoded words per RFC 2047
	if {"" != $prefix} {
	    if {![string is space $prefix]} {
		append result $prefix
	    }
	}

	set decoded [word_decode $encoded]
        foreach {charset - string} $decoded break

	append result [::encoding convertfrom $charset $string]
    }

    append result $field
    return $result
}

# smtp.tcl - SMTP client
#
# (c) 1999-2000 Marshall T. Rose
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package require Tcl 8.3
package require mime 1.4
package provide smtp 1.4

#
# state variables:
#
#    sd: socket to server
#    afterID: afterID associated with ::smtp::timer
#    options: array of user-supplied options
#    readable: semaphore for vwait
#    addrs: number of recipients negotiated
#    error: error during read
#    line: response read from server
#    crP: just put a \r in the data
#    nlP: just put a \n in the data
#    size: number of octets sent in DATA
#


namespace eval ::smtp {
    variable trf 1
    variable smtp
    array set smtp { uid 0 }

    namespace export sendmessage
}

if {[catch {package require Trf  2.0}]} {
    # Trf is not available, but we can live without it as long as the
    # transform and unstack procs are defined.

    # Warning!
    # This is a fragile emulation of the more general calling sequence
    # that appears to work with this code here.

    proc transform {args} {
	upvar state mystate
	set mystate(size) 1
    }
    proc unstack {channel} {
        # do nothing
        return
    }
    set ::smtp::trf 0
}


# ::smtp::sendmessage --
#
#	Sends a mime object (containing a message) to some recipients
#
# Arguments:
#	part  The MIME object containing the message to send
#       args  A list of arguments specifying various options for sending the
#             message:
#             -atleastone  A boolean specifying whether or not to send the
#                          message at all if any of the recipients are 
#                          invalid.  A value of false (as defined by 
#                          ::smtp::boolean) means that ALL recipients must be
#                          valid in order to send the message.  A value of
#                          true means that as long as at least one recipient
#                          is valid, the message will be sent.
#             -debug       A boolean specifying whether or not debugging is
#                          on.  If debugging is enabled, status messages are 
#                          printed to stderr while trying to send mail.
#             -queue       A boolean specifying whether or not the message
#                          being sent should be queued for later delivery.
#             -header      A single RFC 822 header key and value (as a list),
#                          used to specify to whom to send the message 
#                          (To, Cc, Bcc), the "From", etc.
#             -originator  The originator of the message (equivalent to
#                          specifying a From header).
#             -recipients  A string containing recipient e-mail addresses.
#                          NOTE: This option overrides any recipient addresses
#                          specified with -header.
#             -servers     A list of mail servers that could process the
#                          request.
#             -ports       A list of SMTP ports to use for each SMTP server
#                          specified
#             -maxsecs     Maximum number of seconds to allow the SMTP server
#                          to accept the message. If not specified, the default
#                          is 120 seconds.
#             -usetls      A boolean flag. If the server supports it and we
#                          have the package, use TLS to secure the connection.
#             -tlspolicy   A command to call if the TLS negotiation fails for
#                          some reason. Return 'insecure' to continue with
#                          normal SMTP or 'secure' to close the connection and
#                          try another server.
#             -username    These are needed if your SMTP server requires
#             -password    authentication.
#
# Results:
#	Message is sent.  On success, return "".  On failure, throw an
#       exception with an error code and error message.

proc ::smtp::sendmessage {part args} {
    global errorCode errorInfo

    # Here are the meanings of the following boolean variables:
    # aloP -- value of -atleastone option above.
    # debugP -- value of -debug option above.
    # origP -- 1 if -originator option was specified, 0 otherwise.
    # queueP -- value of -queue option above.

    set aloP 0
    set debugP 0
    set origP 0
    set queueP 0
    set maxsecs 120
    set originator ""
    set recipients ""
    set servers [list localhost]
    set ports [list 25]
    set tlsP 1
    set tlspolicy {}
    set username {}
    set password {}

    array set header ""

    # lowerL will contain the list of header keys (converted to lower case) 
    # specified with various -header options.  mixedL is the mixed-case version
    # of the list.
    set lowerL ""
    set mixedL ""

    # Parse options (args).

    if {[expr {[llength $args]%2}]} {
        # Some option didn't get a value.
        error "Each option must have a value!  Invalid option list: $args"
    }
    
    foreach {option value} $args {
        switch -- $option {
            -atleastone {set aloP   [boolean $value]}
            -debug      {set debugP [boolean $value]}
            -queue      {set queueP [boolean $value]}
            -usetls     {set tlsP   [boolean $value]}
            -tlspolicy  {set tlspolicy $value}
	    -maxsecs    {set maxsecs [expr {$value < 0 ? 0 : $value}]}
            -header {
                if {[llength $value] != 2} {
                    error "-header expects a key and a value, not $value"
                }
                set mixed [lindex $value 0]
                set lower [string tolower $mixed]
                set disallowedHdrList                     [list content-type                           content-transfer-encoding                           content-md5                           mime-version]
                if {[lsearch -exact $disallowedHdrList $lower] > -1} {
                    error "Content-Type, Content-Transfer-Encoding,                        Content-MD5, and MIME-Version cannot be user-specified."
                }
                if {[lsearch -exact $lowerL $lower] < 0} {
                    lappend lowerL $lower
                    lappend mixedL $mixed
                }               

                lappend header($lower) [lindex $value 1]
            }

            -originator {
                set originator $value
                if {$originator == ""} {
                    set origP 1
                }
            }

            -recipients {
                set recipients $value
            }

            -servers {
                set servers $value
            }

            -ports {
                set ports $value
            }

            -username { set username $value }
            -password { set password $value }

            default {
                error "unknown option $option"
            }
        }
    }

    if {[lsearch -glob $lowerL resent-*] >= 0} {
        set prefixL resent-
        set prefixM Resent-
    } else {
        set prefixL ""
        set prefixM ""
    }

    # Set a bunch of variables whose value will be the real header to be used
    # in the outbound message (with proper case and prefix).

    foreach mixed {From Sender To cc Dcc Bcc Date Message-ID} {
        set lower [string tolower $mixed]
	# FRINK: nocheck
        set ${lower}L $prefixL$lower
	# FRINK: nocheck
        set ${lower}M $prefixM$mixed
    }

    if {$origP} {
        # -originator was specified with "", so SMTP sender should be marked "".
        set sender ""
    } else {
        # -originator was specified with a value, OR -originator wasn't
        # specified at all.
        
        # If no -originator was provided, get the originator from the "From"
        # header.  If there was no "From" header get it from the username
        # executing the script.

        set who "-originator"
        if {$originator == ""} {
            if {![info exists header($fromL)]} {
                set originator $::tcl_platform(user)
            } else {
                set originator [join $header($fromL) ,]

                # Indicate that we're using the From header for the originator.

                set who $fromM
            }
        }
        
	# If there's no "From" header, create a From header with the value
	# of -originator as the value.

        if {[lsearch -exact $lowerL $fromL] < 0} {
            lappend lowerL $fromL
            lappend mixedL $fromM
            lappend header($fromL) $originator
        }

	# ::mime::parseaddress returns a list whose elements are huge key-value
	# lists with info about the addresses.  In this case, we only want one
	# originator, so we want the length of the main list to be 1.

        set addrs [::mime::parseaddress $originator]
        if {[llength $addrs] > 1} {
            error "too many mailboxes in $who: $originator"
        }
        array set aprops [lindex $addrs 0]
        if {$aprops(error) != ""} {
            error "error in $who: $aprops(error)"
        }

	# sender = validated originator or the value of the From header.

        set sender $aprops(address)

	# If no Sender header has been specified and From is different from
	# originator, then set the sender header to the From.  Otherwise, don't
	# specify a Sender header.
        set from [join $header($fromL) ,]
        if {[lsearch -exact $lowerL $senderL] < 0 &&                 [string compare $originator $from]} {
            if {[info exists aprops]} {
                unset aprops
            }
            array set aprops [lindex [::mime::parseaddress $from] 0]
            if {$aprops(error) != ""} {
                error "error in $fromM: $aprops(error)"
            }
            if {[string compare $aprops(address) $sender]} {
                lappend lowerL $senderL
                lappend mixedL $senderM
                lappend header($senderL) $aprops(address)
            }
        }
    }

    # We're done parsing the arguments.

    if {$recipients != ""} {
        set who -recipients
    } elseif {![info exists header($toL)]} {
        error "need -header \"$toM ...\""
    } else {
        set recipients [join $header($toL) ,]
	# Add Cc values to recipients list
	set who $toM
        if {[info exists header($ccL)]} {
            append recipients ,[join $header($ccL) ,]
            append who /$ccM
        }

        set dccInd [lsearch -exact $lowerL $dccL]
        if {$dccInd >= 0} {
	    # Add Dcc values to recipients list, and get rid of Dcc header
	    # since we don't want to output that.
            append recipients ,[join $header($dccL) ,]
            append who /$dccM

            unset header($dccL)
            set lowerL [lreplace $lowerL $dccInd $dccInd]
            set mixedL [lreplace $mixedL $dccInd $dccInd]
        }
    }

    set brecipients ""
    set bccInd [lsearch -exact $lowerL $bccL]
    if {$bccInd >= 0} {
        set bccP 1

	# Build valid bcc list and remove bcc element of header array (so that
	# bcc info won't be sent with mail).
        foreach addr [::mime::parseaddress [join $header($bccL) ,]] {
            if {[info exists aprops]} {
                unset aprops
            }
            array set aprops $addr
            if {$aprops(error) != ""} {
                error "error in $bccM: $aprops(error)"
            }
            lappend brecipients $aprops(address)
        }

        unset header($bccL)
        set lowerL [lreplace $lowerL $bccInd $bccInd]
        set mixedL [lreplace $mixedL $bccInd $bccInd]
    } else {
        set bccP 0
    }

    # If there are no To headers, add "" to bcc list.  WHY??
    if {[lsearch -exact $lowerL $toL] < 0} {
        lappend lowerL $bccL
        lappend mixedL $bccM
        lappend header($bccL) ""
    }

    # Construct valid recipients list from recipients list.

    set vrecipients ""
    foreach addr [::mime::parseaddress $recipients] {
        if {[info exists aprops]} {
            unset aprops
        }
        array set aprops $addr
        if {$aprops(error) != ""} {
            error "error in $who: $aprops(error)"
        }
        lappend vrecipients $aprops(address)
    }

    # If there's no date header, get the date from the mime message.  Same for
    # the message-id.

    if {([lsearch -exact $lowerL $dateL] < 0)             && ([catch { ::mime::getheader $part $dateL }])} {
        lappend lowerL $dateL
        lappend mixedL $dateM
        lappend header($dateL) [::mime::parsedatetime -now proper]
    }

    if {([lsearch -exact $lowerL ${message-idL}] < 0)             && ([catch { ::mime::getheader $part ${message-idL} }])} {
        lappend lowerL ${message-idL}
        lappend mixedL ${message-idM}
        lappend header(${message-idL}) [::mime::uniqueID]

    }

    # Get all the headers from the MIME object and save them so that they can
    # later be restored.
    set savedH [::mime::getheader $part]

    # Take all the headers defined earlier and add them to the MIME message.
    foreach lower $lowerL mixed $mixedL {
        foreach value $header($lower) {
            ::mime::setheader $part $mixed $value -mode append
        }
    }

    if {![string compare $servers localhost]} {
        set client localhost
    } else {
        set client [info hostname]
    }

    # Create smtp token, which essentially means begin talking to the SMTP
    # server.
    set token [initialize -debug $debugP -client $client 		                -maxsecs $maxsecs -usetls $tlsP                                 -multiple $bccP -queue $queueP                                 -servers $servers -ports $ports                                 -tlspolicy $tlspolicy                                 -username $username -password $password]

    if {![string match "::smtp::*" $token]} {
	# An error occurred and $token contains the error info
	array set respArr $token
	return -code error $respArr(diagnostic)
    }

    set code [catch { sendmessageaux $token $part                                            $sender $vrecipients $aloP }                     result]
    set ecode $errorCode
    set einfo $errorInfo

    # Send the message to bcc recipients as a MIME attachment.

    if {($code == 0) && ($bccP)} {
        set inner [::mime::initialize -canonical message/rfc822                                     -header [list Content-Description                                                   "Original Message"]                                     -parts [list $part]]

        set subject "\[$bccM\]"
        if {[info exists header(subject)]} {
            append subject " " [lindex $header(subject) 0] 
        }

        set outer [::mime::initialize                          -canonical multipart/digest                          -header [list From $originator]                          -header [list Bcc ""]                          -header [list Date                                        [::mime::parsedatetime -now proper]]                          -header [list Subject $subject]                          -header [list Message-ID [::mime::uniqueID]]                          -header [list Content-Description                                        "Blind Carbon Copy"]                          -parts [list $inner]]


        set code [catch { sendmessageaux $token $outer                                                $sender $brecipients                                                $aloP } result2]
        set ecode $errorCode
        set einfo $errorInfo

        if {$code == 0} {
            set result [concat $result $result2]
        } else {
            set result $result2
        }

        catch { ::mime::finalize $inner -subordinates none }
        catch { ::mime::finalize $outer -subordinates none }
    }

    # Determine if there was any error in prior operations and set errorcodes
    # and error messages appropriately.
    
    switch -- $code {
        0 {
            set status orderly
        }

        7 {
            set code 1
            array set response $result
            set result "$response(code): $response(diagnostic)"
            set status abort
        }

        default {
            set status abort
        }
    }

    # Destroy SMTP token 'cause we're done with it.
    
    catch { finalize $token -close $status }

    # Restore provided MIME object to original state (without the SMTP headers).
    
    foreach key [::mime::getheader $part -names] {
        mime::setheader $part $key "" -mode delete
    }
    foreach {key values} $savedH {
        foreach value $values {
            ::mime::setheader $part $key $value -mode append
        }
    }

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::smtp::sendmessageaux --
#
#	Sends a mime object (containing a message) to some recipients using an
#       existing SMTP token.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	part        The MIME object containing the message to send.
#       originator  The e-mail address of the entity sending the message,
#                   usually the From clause.
#       recipients  List of e-mail addresses to whom message will be sent.
#       aloP        Boolean "atleastone" setting; see the -atleastone option
#                   in ::smtp::sendmessage for details.
#
# Results:
#	Message is sent.  On success, return "".  On failure, throw an
#       exception with an error code and error message.

proc ::smtp::sendmessageaux {token part originator recipients aloP} {
    global errorCode errorInfo

    winit $token $part $originator

    set goodP 0
    set badP 0
    set oops ""
    foreach recipient $recipients {
        set code [catch { waddr $token $recipient } result]
        set ecode $errorCode
        set einfo $errorInfo

        switch -- $code {
            0 {
                incr goodP
            }

            7 {
                incr badP

                array set response $result
                lappend oops [list $recipient $response(code)                                    $response(diagnostic)]
            }

            default {
                return -code $code -errorinfo $einfo -errorcode $ecode $result
            }
        }
    }

    if {($goodP) && ((!$badP) || ($aloP))} {
        wtext $token $part
    } else {
        catch { talk $token 300 RSET }
    }

    return $oops
}

# ::smtp::initialize --
#
#	Create an SMTP token and open a connection to the SMTP server.
#
# Arguments:
#       args  A list of arguments specifying various options for sending the
#             message:
#             -debug       A boolean specifying whether or not debugging is
#                          on.  If debugging is enabled, status messages are 
#                          printed to stderr while trying to send mail.
#             -client      Either localhost or the name of the local host.
#             -multiple    Multiple messages will be sent using this token.
#             -queue       A boolean specifying whether or not the message
#                          being sent should be queued for later delivery.
#             -servers     A list of mail servers that could process the
#                          request.
#             -ports       A list of ports on mail servers that could process
#                          the request (one port per server-- defaults to 25).
#             -usetls      A boolean to indicate we will use TLS if possible.
#             -tlspolicy   Command called if TLS setup fails.
#             -username    These provide the authentication information 
#             -password    to be used if needed by the SMTP server.
#
# Results:
#	On success, return an smtp token.  On failure, throw
#       an exception with an error code and error message.

proc ::smtp::initialize {args} {
    global errorCode errorInfo

    variable smtp

    set token [namespace current]::[incr smtp(uid)]
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set state [list afterID "" options "" readable 0]
    array set options [list -debug 0 -client localhost -multiple 1                             -maxsecs 120 -queue 0 -servers localhost                             -ports 25 -usetls 1 -tlspolicy {}                             -username {} -password {}]
    array set options $args
    set state(options) [array get options]

    # Iterate through servers until one accepts a connection (and responds
    # nicely).
   
    set index 0 
    foreach server $options(-servers) {
	set state(readable) 0
        if {[llength $options(-ports)] >= $index} {
            set port [lindex $options(-ports) $index]
        } else {
            set port 25
        }
        if {$options(-debug)} {
            puts stderr "Trying $server..."
            flush stderr
        }

        if {[info exists state(sd)]} {
            unset state(sd)
        }

        if {[set code [catch {
            set state(sd) [socket -async $server $port]
            fconfigure $state(sd) -blocking off -translation binary
            fileevent $state(sd) readable [list ::smtp::readable $token]
        } result]]} {
            set ecode $errorCode
            set einfo $errorInfo

            catch { close $state(sd) }
            continue
        }

        if {[set code [catch { hear $token 600 } result]]} {
            array set response [list code 400 diagnostic $result]
        } else {
            array set response $result
        }
        set ecode $errorCode
        set einfo $errorInfo
        switch -- $response(code) {
            220 {
            }

            421 - default {
                # 421 - Temporary problem on server
                catch {close $state(sd)}
                continue
            }
        }

        set r [initialize_ehlo $token]
        if {$r != {}} {
            return $r
        }
        incr index
    }

    # None of the servers accepted our connection, so close everything up and
    # return an error.
    finalize $token -close drop

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

proc ::smtp::initialize_ehlo {token} {
    global errorCode errorInfo
    upvar einfo einfo
    upvar ecode ecode
    upvar code  code
    
    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    array set options $state(options)

    # Try enhanced SMTP first.

    if {[set code [catch {smtp::talk $token 300 "EHLO $options(-client)"}                        result]]} {
        array set response [list code 400 diagnostic $result args ""]
    } else {
        array set response $result
    }
    set ecode $errorCode
    set einfo $errorInfo
    if {(500 <= $response(code)) && ($response(code) <= 599)} {
        if {[set code [catch { talk $token 300                                    "HELO $options(-client)" }                            result]]} {
            array set response [list code 400 diagnostic $result args ""]
        } else {
            array set response $result
        }
        set ecode $errorCode
        set einfo $errorInfo
    }
    
    if {$response(code) == 250} {
        # Successful response to HELO or EHLO command, so set up queuing
        # and whatnot and return the token.
        
        set state(esmtp) $response(args)

        if {(!$options(-multiple))                 && ([lsearch $response(args) ONEX] >= 0)} {
            catch {smtp::talk $token 300 ONEX}
        }
        if {($options(-queue))                 && ([lsearch $response(args) XQUE] >= 0)} {
            catch {smtp::talk $token 300 QUED}
        }
        
        # Support STARTTLS extension.
        # The state(tls) item is used to see if we have already tried this.
        if {($options(-usetls)) && ![info exists state(tls)]                 && (([lsearch $response(args) STARTTLS] >= 0)
                    || ([lsearch $response(args) TLS] >= 0))} {
            if {![catch {package require tls}]} {
                set state(tls) 0
                if {![catch {smtp::talk $token 300 STARTTLS} resp]} {
                    array set starttls $resp
                    if {$starttls(code) == 220} {
                        fileevent $state(sd) readable {}
                        catch {
                            ::tls::import $state(sd)
                            catch {::tls::handshake $state(sd)} msg
                            set state(tls) 1
                        } 
                        fileevent $state(sd) readable                             [list ::smtp::readable $token]
                        return [initialize_ehlo $token]
                    } else {
                        # Call a TLS client policy proc here
                        #  returns secure close and try another server.
                        #  returns insecure continue on current socket
                        set policy insecure
                        if {$options(-tlspolicy) != {}} {
                            catch {
                                eval $options(-tlspolicy)                                     [list $starttls(code)]                                     [list $starttls(diagnostic)]
                            } policy
                        }
                        if {$policy != "insecure"} {
                            set code error
                            set ecode $starttls(code)
                            set einfo $starttls(diagnostic)
                            catch {close $state(sd)}
                            return {}
                        }
                    }
                }
            }
        }

        # If we have not already tried and the server supports it and we 
        # have a username -- lets try to authenticate.
        #
        if {![info exists state(auth)]
            && [set andx [lsearch -glob $response(args) "AUTH*"]] >= 0 
            && [string length $options(-username)] > 0 } {
            
            # May be AUTH mech or AUTH=mech
            # We want to use the strongest mechanism that has been offered
            # and that we support. If we cannot find a mechanism that 
            # succeeds, we will go ahead and try to carry on unauthenticated.
            # This may still work else we'll get an unauthorised error later.

            set mechs [string range [lindex $response(args) $andx] 5 end]
            foreach mech [list DIGEST-MD5 CRAM-MD5 LOGIN PLAIN] {
                if {[lsearch -exact $mechs $mech] == -1} { continue }
                if {[info command [namespace current]::auth_$mech] != {}} {
                    if {[catch {
                        auth_$mech $token
                    } msg]} {
                        if {$options(-debug)} {
                            puts stderr "AUTH $mech failed: $msg "
                            flush stderr
                        }
                    }
                    if {[info exists state(auth)] && $state(auth)} {
                        if {$state(auth) == 1} {
                            break
                        } else {
                            # After successful AUTH we are supposed to redo
                            # our connection for mechanisms that setup a new
                            # security layer -- these should set state(auth) 
                            # greater than 1
                            fileevent $state(sd) readable                                 [list ::smtp::readable $token]
                            return [initialize_ehlo $token]
                        }
                    }
                }
            }
        }
        
        return $token
    } else {
        # Bad response; close the connection and hope the next server
        # is happier.
        catch {close $state(sd)}
    }
    return {}
}

# ::smtp::auth_LOGIN --
#
#	Perform LOGIN authentication to the SMTP server.
#
# Results:
#	Negiotiates user authentication. If successful returns the result
#       otherwise an error is thrown

proc ::smtp::auth_LOGIN {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    array set options $state(options)
    
    package require base64
    set user [base64::encode $options(-username)]
    set pass [base64::encode $options(-password)]

    set state(auth) 0
    set result [smtp::talk $token 300 "AUTH LOGIN"]
    array set response $result

    if {$response(code) == 334} {
        set result [smtp::talk $token 300 $user]
        array set response $result
    }
    if {$response(code) == 334} {
        set result [smtp::talk $token 300 $pass]
        array set response $result
    }
    if {$response(code) == 235} {
        set state(auth) 1
        return $result
    } else {
        return -code 7 $result
    }
}

# ::smtp::auth_PLAIN
#
# 	Implement PLAIN SASL mechanism (RFC2595).
#
# Results:
#	Negiotiates user authentication. If successful returns the result
#       otherwise an error is thrown

proc ::smtp::auth_PLAIN {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    array set options $state(options)
    
    package require base64
    set id [base64::encode "\x00$options(-username)\x00$options(-password)"]

    set state(auth) 0
    set result [smtp::talk $token 300 "AUTH PLAIN $id"]
    array set response $result
    
    if {$response(code) == 235} {
        set state(auth) 1
        return $result
    } else {
        return -code 7 $result
    }
}

# ::smtp::auth_CRAM-MD5
#
# 	Implement CRAM-MD5 SASL mechanism (RFC2195).
#
# Results:
#	Negiotiates user authentication. If successful returns the result
#       otherwise an error is thrown

proc ::smtp::auth_CRAM-MD5 {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    array set options $state(options)
    
    package require base64
    md5_init

    set state(auth) 0
    set result [smtp::talk $token 300 "AUTH CRAM-MD5"]
    array set response $result

    if {$response(code) == 334} {
        set challenge [base64::decode $response(diagnostic)]
        set reply [hmac_hex $options(-password) $challenge]
        set reply [base64::encode                        "$options(-username) [string tolower $reply]"]
        set result [smtp::talk $token 300 $reply]
        array set response $result
    }

    if {$response(code) == 235} {
        set state(auth) 1
        return $result
    } else {
        return -code 7 $result
    }
}

# ::smtp::auth_DIGEST-MD5
#
# 	Implement DIGEST-MD5 SASL mechanism (RFC2831).
#
# Results:
#	Negiotiates user authentication. If successful returns the result
#       otherwise an error is thrown

proc ::smtp::auth_DIGEST-MD5 {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    array set options $state(options)
    
    package require base64
    md5_init

    set state(auth) 0
    set result [smtp::talk $token 300 "AUTH DIGEST-MD5"]
    array set response $result

    if {$response(code) == 334} {
        set challenge [base64::decode $response(diagnostic)]
        
        # RFC 2831 2.1
        # Char categories as per spec...
        # Build up a regexp for splitting the challenge into key value pairs.
        set sep "\\\]\\\[\\\\()<>@,;:\\\"\\\?=\\\{\\\} \t"
        set tok {0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\-\|\~\!\#\$\%\&\*\+\.\^\_\`}
        set sqot {(?:\'(?:\\.|[^\'\\])*\')}
        set dqot {(?:\"(?:\\.|[^\"\\])*\")}
        array set params [regsub -all "(\[${tok}\]+)=(${dqot}|(?:\[${tok}\]+))(?:\[${sep}\]+|$)" $challenge {\1 \2 }]

        if {![info exists options(noncecount)]} {set options(noncecount) 0}
        set nonce $params(nonce)
        set cnonce [CreateNonce]
        set noncecount [format %08u [incr options(noncecount)]]
        set qop auth
        # If realm not specified - use the servers fqdn
        if {[info exists params(realm)]} {
            set realm $params(realm)
        } else {
            set realm [lindex [fconfigure $state(sd) -peername] 1]
        }
        set uri "smtp/$realm"

        set A1 [md5_bin "$options(-username):$realm:$options(-password)"]
        set A2 "AUTHENTICATE:$uri"
        if {![string equal $qop "auth"]} {
            append A2 :[string repeat 0 32]
        }
        
        set A1h [md5_hex "${A1}:$nonce:$cnonce"]
        set A2h [md5_hex $A2]
        set R  [md5_hex $A1h:$nonce:$noncecount:$cnonce:$qop:$A2h]

        set reply "username=\"$options(-username)\",realm=\"$realm\",nonce=\"$nonce\",nc=\"$noncecount\",cnonce=\"$cnonce\",digest-uri=\"$uri\",response=\"$R\",qop=$qop"
        if {$options(-debug)} {
            puts stderr "<*- $challenge"
            puts stderr "-*> $reply"
            flush stderr
        }

        # The server will provide a base64 encoded string for use with
        # subsequest authentication now. At this time we dont use this value.
        set result [smtp::talk $token 300 [join [base64::encode $reply] {}]]
        array set response $result
        if {$response(code) == 334} {
            #set authresp [base64::decode $response(diagnostic)]
            #if {$options(-debug)} { puts stderr "-*> $authresp" }
            set result [smtp::talk $token 300 {}]
            array set response $result
        }
    }

    if {$response(code) == 235} {
        set state(auth) 1
        return $result
    } else {
        return -code 7 $result
    }
}

proc ::smtp::md5_init {} {
    # Deal with either version of md5. We'd like version 2 but someone
    # may have already loaded version 1.
    set md5major [lindex [split [package require md5] .] 0]
    if {$md5major < 2} {
        # md5 v1, no options, and returns a hex string ready for
        # us.
        proc ::smtp::md5_hex {data} { return [::md5::md5 $data] }
        proc ::smtp::md5_bin {data} { return [binary format H* [::md5::md5 $data]] }
        proc ::smtp::hmac_hex {pass data} { return [::md5::hmac $pass $data] }
    } else {
        # md5 v2 requires -hex to return hash as hex-encoded
        # non-binary string.
        proc ::smtp::md5_hex {data} { return [string tolower [::md5::md5 -hex $data]] }
        proc ::smtp::md5_bin {data} { return [::md5::md5 $data] }
        proc ::smtp::hmac_hex {pass data} { return [::md5::hmac -hex -key $pass $data] }
    }
}

# Get 16 random bytes for a nonce value. If we can use /dev/random, do so
# otherwise we hash some values.
#
proc ::smtp::CreateNonce {} {
    set bytes {}
    if {[file readable /dev/random]} {
        catch {
            set f [open /dev/random r]
            fconfigure $f -translation binary -buffering none
            set bytes [read $f 16]
        }
    }
    if {[string length $bytes] < 1} {
        set bytes [md5_bin [clock seconds]:[pid]:[expr {rand()}]]
    }
    return [binary scan $bytes h* r; set r]
}

# ::smtp::finalize --
#
#	Deletes an SMTP token by closing the connection to the SMTP server,
#       cleanup up various state.
#
# Arguments:
#       token   SMTP token that has an open connection to the SMTP server.
#       args    Optional arguments, where the only useful option is -close,
#               whose valid values are the following:
#               orderly     Normal successful completion.  Close connection and
#                           clear state variables.
#               abort       A connection exists to the SMTP server, but it's in
#                           a weird state and needs to be reset before being
#                           closed.  Then clear state variables.
#               drop        No connection exists, so we just need to clean up
#                           state variables.
#
# Results:
#	SMTP connection is closed and state variables are cleared.  If there's
#       an error while attempting to close the connection to the SMTP server,
#       throw an exception with the error code and error message.

proc ::smtp::finalize {token args} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options [list -close orderly]
    array set options $args

    switch -- $options(-close) {
        orderly {
            set code [catch { talk $token 120 QUIT } result]
        }

        abort {
            set code [catch {
                talk $token 0 RSET
                talk $token 0 QUIT
            } result]
        }

        drop {
            set code 0
            set result ""
        }

        default {
            error "unknown value for -close $options(-close)"
        }
    }
    set ecode $errorCode
    set einfo $errorInfo

    catch { close $state(sd) }

    if {$state(afterID) != ""} {
        catch { after cancel $state(afterID) }
    }

    foreach name [array names state] {
        unset state($name)
    }
    # FRINK: nocheck
    unset $token

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::smtp::winit --
#
#	Send originator info to SMTP server.  This occurs after HELO/EHLO
#       command has completed successfully (in ::smtp::initialize).  This function
#       is called by ::smtp::sendmessageaux.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#       part        MIME token for the message to be sent. May be used for
#                   handling some SMTP extensions.
#       originator  The e-mail address of the entity sending the message,
#                   usually the From clause.
#       mode        SMTP command specifying the mode of communication.  Default
#                   value is MAIL.
#
# Results:
#	Originator info is sent and SMTP server's response is returned.  If an
#       error occurs, throw an exception.

proc ::smtp::winit {token part originator {mode MAIL}} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[lsearch -exact [list MAIL SEND SOML SAML] $mode] < 0} {
        error "unknown origination mode $mode"
    }

    set from "$mode FROM:<$originator>"

    # RFC 1870 -  SMTP Service Extension for Message Size Declaration
    if {[info exists state(esmtp)] 
        && [lsearch -glob $state(esmtp) "SIZE*"] != -1} {
        catch {
            set size [string length [mime::buildmessage $part]]
            append from " SIZE=$size"
        }
    }

    array set response [set result [talk $token 600 $from]]

    if {$response(code) == 250} {
        set state(addrs) 0
        return $result
    } else {
        return -code 7 $result
    }
}

# ::smtp::waddr --
#
#	Send recipient info to SMTP server.  This occurs after originator info
#       is sent (in ::smtp::winit).  This function is called by
#       ::smtp::sendmessageaux. 
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#       recipient   One of the recipients to whom the message should be
#                   delivered.  
#
# Results:
#	Recipient info is sent and SMTP server's response is returned.  If an
#       error occurs, throw an exception.

proc ::smtp::waddr {token recipient} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set result [talk $token 3600 "RCPT TO:<$recipient>"]
    array set response $result

    switch -- $response(code) {
        250 - 251 {
            incr state(addrs)
            return $result
        }

        default {
            return -code 7 $result
        }
    }
}

# ::smtp::wtext --
#
#	Send message to SMTP server.  This occurs after recipient info
#       is sent (in ::smtp::winit).  This function is called by
#       ::smtp::sendmessageaux. 
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	part        The MIME object containing the message to send.
#
# Results:
#	MIME message is sent and SMTP server's response is returned.  If an
#       error occurs, throw an exception.

proc ::smtp::wtext {token part} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    array set options $state(options)

    set result [talk $token 300 DATA]
    array set response $result
    if {$response(code) != 354} {
        return -code 7 $result
    }

    if {[catch { wtextaux $token $part } result]} {
        catch { puts -nonewline $state(sd) "\r\n.\r\n" ; flush $state(sd) }
        return -code 7 [list code 400 diagnostic $result]
    }

    set secs $options(-maxsecs)

    set result [talk $token $secs .]
    array set response $result
    switch -- $response(code) {
        250 - 251 {
            return $result
        }

        default {
            return -code 7 $result
        }
    }
}

# ::smtp::wtextaux --
#
#	Helper function that coordinates writing the MIME message to the socket.
#       In particular, it stacks the channel leading to the SMTP server, sets up
#       some file events, sends the message, unstacks the channel, resets the
#       file events to their original state, and returns.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	part        The MIME object containing the message to send.
#
# Results:
#	Message is sent.  If anything goes wrong, throw an exception.

proc ::smtp::wtextaux {token part} {
    global errorCode errorInfo

    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    # Workaround a bug with stacking channels on top of TLS.
    # FRINK: nocheck
    set trf [set [namespace current]::trf]
    if {[info exists state(tls)] && $state(tls)} {
        set trf 0
    }

    flush $state(sd)
    fileevent $state(sd) readable ""
    if {$trf} {
        transform -attach $state(sd) -command [list ::smtp::wdata $token]
    } else {
        set state(size) 1
    }
    fileevent $state(sd) readable [list ::smtp::readable $token]

    # If trf is not available, get the contents of the message,
    # replace all '.'s that start their own line with '..'s, and
    # then write the mime body out to the filehandle. Do not forget to
    # deal with bare LF's here too (SF bug #499242).

    if {$trf} {
        set code [catch { ::mime::copymessage $part $state(sd) } result]
    } else {
        set code [catch { ::mime::buildmessage $part } result]
        if {$code == 0} {
	    # Detect and transform bare LF's into proper CR/LF
	    # sequences.

	    while {[regsub -all -- {([^\r])\n} $result "\\1\r\n" result]} {}
            regsub -all -- {\n\.}      $result "\n.."   result

            set state(size) [string length $result]
            puts -nonewline $state(sd) $result
            set result ""
	}
    }
    set ecode $errorCode
    set einfo $errorInfo

    flush $state(sd)
    fileevent $state(sd) readable ""
    if {$trf} {
        unstack $state(sd)
    }
    fileevent $state(sd) readable [list ::smtp::readable $token]

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::smtp::wdata --
#
#	This is the custom transform using Trf to do CR/LF translation.  If Trf
#       is not installed on the system, then this function never gets called and
#       no translation occurs.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#       command     Trf provided command for manipulating socket data.
#	buffer      Data to be converted.
#
# Results:
#	buffer is translated, and state(size) is set.  If Trf is not installed
#       on the system, the transform proc defined at the top of this file sets
#       state(size) to 1.  state(size) is used later to determine a timeout
#       value.

proc ::smtp::wdata {token command buffer} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -- $command {
        create/write -
        clear/write  -
        delete/write {
            set state(crP) 0
            set state(nlP) 1
            set state(size) 0
        }

        write {
            set result ""

            foreach c [split $buffer ""] {
                switch -- $c {
                    "." {
                        if {$state(nlP)} {
                            append result .
                        }
                        set state(crP) 0
                        set state(nlP) 0
                    }

                    "\r" {
                        set state(crP) 1
                        set state(nlP) 0
                    }

                    "\n" {
                        if {!$state(crP)} {
                            append result "\r"
                        }
                        set state(crP) 0
                        set state(nlP) 1
                    }

                    default {
                        set state(crP) 0
                        set state(nlP) 0
                    }
                }

                append result $c
            }

            incr state(size) [string length $result]
            return $result
        }

        flush/write {
            set result ""

            if {!$state(nlP)} {
                if {!$state(crP)} {
                    append result "\r"
                }
                append result "\n"
            }

            incr state(size) [string length $result]
            return $result
        }

	create/read -
        delete/read {
	    # Bugfix for [#539952]
        }

	query/ratio {
	    # Indicator for unseekable channel,
	    # for versions of Trf which ask for
	    # this.
	    return {0 0}
	}
	query/maxRead {
	    # No limits on reading bytes from the channel below, for
	    # versions of Trf which ask for this information
	    return -1
	}

	default {
	    # Silently pass all unknown commands.
	    #error "Unknown command \"$command\""
	}
    }

    return ""
}

# ::smtp::talk --
#
#	Sends an SMTP command to a server
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	secs        Timeout after which command should be aborted.
#       command     Command to send to SMTP server.
#
# Results:
#	command is sent and response is returned.  If anything goes wrong, throw
#       an exception.

proc ::smtp::talk {token secs command} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options $state(options)

    if {$options(-debug)} {
        puts stderr "--> $command (wait upto $secs seconds)"
        flush stderr
    }

    if {[catch { puts -nonewline $state(sd) "$command\r\n"
                 flush $state(sd) } result]} {
        return [list code 400 diagnostic $result]
    }

    if {$secs == 0} {
        return ""
    }

    return [hear $token $secs]
}

# ::smtp::hear --
#
#	Listens for SMTP server's response to some prior command.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	secs        Timeout after which we should stop waiting for a response.
#
# Results:
#	Response is returned.

proc ::smtp::hear {token secs} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options $state(options)

    array set response [list args ""]

    set firstP 1
    while {1} {
        if {$secs >= 0} {
	    ## SF [ 836442 ] timeout with large data
	    ## correction, aotto 031105 -
	    if {$secs > 600} {set secs 600}
            set state(afterID) [after [expr {$secs*1000}]                                       [list ::smtp::timer $token]]
        }

        if {!$state(readable)} {
            vwait ${token}(readable)
        }

        # Wait until socket is readable.
        if {$state(readable) !=  -1} {
            catch { after cancel $state(afterID) }
            set state(afterID) ""
        }

        if {$state(readable) < 0} {
            array set response [list code 400 diagnostic $state(error)]
            break
        }
        set state(readable) 0

        if {$options(-debug)} {
            puts stderr "<-- $state(line)"
            flush stderr
        }

        if {[string length $state(line)] < 3} {
            array set response                   [list code 500                         diagnostic "response too short: $state(line)"]
            break
        }

        if {$firstP} {
            set firstP 0

            if {[scan [string range $state(line) 0 2] %d response(code)]                     != 1} {
                array set response                       [list code 500                             diagnostic "unrecognizable code: $state(line)"]
                break
            }

            set response(diagnostic)                 [string trim [string range $state(line) 4 end]]
        } else {
            lappend response(args)                     [string trim [string range $state(line) 4 end]]
        }

        # When status message line ends in -, it means the message is complete.
        
        if {[string compare [string index $state(line) 3] -]} {
            break
        }
    }

    return [array get response]
}

# ::smtp::readable --
#
#	Reads a line of data from SMTP server when the socket is readable.  This
#       is the callback of "fileevent readable".
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#
# Results:
#	state(line) contains the line of data and state(readable) is reset.
#       state(readable) gets the following values:
#       -3  if there's a premature eof,
#       -2  if reading from socket fails.
#       1   if reading from socket was successful

proc ::smtp::readable {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[catch { array set options $state(options) }]} {
        return
    }

    set state(line) ""
    if {[catch { gets $state(sd) state(line) } result]} {
        set state(readable) -2
        set state(error) $result
    } elseif {$result == -1} {
        if {[eof $state(sd)]} {
            set state(readable) -3
            set state(error) "premature end-of-file from server"
        }
    } else {
        # If the line ends in \r, remove the \r.
        if {![string compare [string index $state(line) end] "\r"]} {
            set state(line) [string range $state(line) 0 end-1]
        }
        set state(readable) 1
    }

    if {$state(readable) < 0} {
        if {$options(-debug)} {
            puts stderr "    ... $state(error) ..."
            flush stderr
        }

        catch { fileevent $state(sd) readable "" }
    }
}

# ::smtp::timer --
#
#	Handles timeout condition on any communication with the SMTP server.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#
# Results:
#	Sets state(readable) to -1 and state(error) to an error message.

proc ::smtp::timer {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options $state(options)

    set state(afterID) ""
    set state(readable) -1
    set state(error) "read from server timed out"

    if {$options(-debug)} {
        puts stderr "    ... $state(error) ..."
        flush stderr
    }
}

# ::smtp::boolean --
#
#	Helper function for unifying boolean values to 1 and 0.
#
# Arguments:
#       value   Some kind of value that represents true or false (i.e. 0, 1,
#               false, true, no, yes, off, on).
#
# Results:
#	Return 1 if the value is true, 0 if false.  If the input value is not
#       one of the above, throw an exception.

proc ::smtp::boolean {value} {
    switch -- [string tolower $value] {
        0 - false - no - off {
            return 0
        }

        1 - true - yes - on {
            return 1
        }

        default {
            error "unknown boolean value: $value"
        }
    }
}
    }
    interp eval $interpreter "set ::auto_path [list $::automaticPath]"
    interp eval $interpreter {
        if 1 {


package require Tcl 8.3

package provide stooop 4.4

catch {rename proc _proc}

namespace eval ::stooop {
    variable check
    variable trace

    set check(code) {}
    if {[info exists ::env(STOOOPCHECKALL)]&&$::env(STOOOPCHECKALL)} {
        array set ::env            {STOOOPCHECKPROCEDURES 1 STOOOPCHECKDATA 1 STOOOPCHECKOBJECTS 1}
    }
    set check(procedures) [expr {        [info exists ::env(STOOOPCHECKPROCEDURES)]&&        $::env(STOOOPCHECKPROCEDURES)    }]
    set check(data) [expr {        [info exists ::env(STOOOPCHECKDATA)]&&$::env(STOOOPCHECKDATA)    }]
    set check(objects) [expr {        [info exists ::env(STOOOPCHECKOBJECTS)]&&$::env(STOOOPCHECKOBJECTS)    }]
    if {$check(procedures)} {
        append check(code) {::stooop::checkProcedure;}
    }
    if {[info exists ::env(STOOOPTRACEALL)]} {
        set ::env(STOOOPTRACEPROCEDURES) $::env(STOOOPTRACEALL)
        set ::env(STOOOPTRACEDATA) $::env(STOOOPTRACEALL)
    }
    if {[info exists ::env(STOOOPTRACEPROCEDURES)]} {
        set trace(procedureChannel) $::env(STOOOPTRACEPROCEDURES)
        switch $trace(procedureChannel) {
            stdout - stderr {}
            default {
                set trace(procedureChannel) [open $::env(STOOOPTRACEPROCEDURES) w+]
            }
        }
        set trace(procedureFormat)            {class: %C, procedure: %p, object: %O, arguments: %a}
        catch {set trace(procedureFormat) $::env(STOOOPTRACEPROCEDURESFORMAT)}
        append check(code) {::stooop::traceProcedure;}
    }
    if {[info exists ::env(STOOOPTRACEDATA)]} {
        set trace(dataChannel) $::env(STOOOPTRACEDATA)
        switch $trace(dataChannel) {
            stdout - stderr {}
            default {
                set trace(dataChannel) [open $::env(STOOOPTRACEDATA) w+]
            }
        }
        set trace(dataFormat) {class: %C, procedure: %p, array: %A, object: %O, member: %m, operation: %o, value: %v}
        catch {set trace(dataFormat) $::env(STOOOPTRACEDATAFORMAT)}
        set trace(dataOperations) rwu
        catch {set trace(dataOperations) $::env(STOOOPTRACEDATAOPERATIONS)}
    }

    namespace export class virtual new delete classof

    if {![info exists newId]} {
        variable newId 0
    }

    _proc new {classOrId args} {
        variable newId
        variable fullClass

        if {[string is integer $classOrId]} {
            if {[catch {                set fullClass([set id [incr newId]]) $fullClass($classOrId)            }]} {
                error "invalid object identifier $classOrId"
            }
            uplevel 1 $fullClass($classOrId)::_copy $id $classOrId
        } else {
            set constructor ${classOrId}::[namespace tail $classOrId]
            uplevel 1 $constructor [set id [incr newId]] $args
            set fullClass($id) [namespace qualifiers                [uplevel 1 namespace which -command $constructor]            ]
        }
        return $id
    }

    _proc delete {args} {
        variable fullClass

        foreach id $args {
            uplevel 1 ::stooop::deleteObject $fullClass($id) $id
            unset fullClass($id)
        }
    }

    _proc deleteObject {fullClass id} {
        uplevel 1 ${fullClass}::~[namespace tail $fullClass] $id
        array unset ${fullClass}:: $id,*
    }

    _proc classof {id} {
        variable fullClass

        return $fullClass($id)
    }

    _proc copy {fullClass from to} {
        set index [string length $from]
        foreach {name value} [array get ${fullClass}:: $from,*] {
            set ${fullClass}::($to[string range $name $index end]) $value
        }
    }
}

_proc ::stooop::class {args} {
    variable declared

    set class [lindex $args 0]
    set declared([uplevel 1 namespace eval $class {namespace current}]) {}
    uplevel 1 namespace eval $class [list "::variable {}\n[lindex $args end]"]
}

_proc ::stooop::parseProcedureName {    namespace name fullClassVariable procedureVariable messageVariable} {
    variable declared
    upvar 1 $fullClassVariable fullClass $procedureVariable procedure        $messageVariable message

    if {        [info exists declared($namespace)]&&        ([string length [namespace qualifiers $name]]==0)    } {
        set fullClass $namespace
        set procedure $name
        return 1
    } else {
        if {![string match ::* $name]} {
            if {[string equal $namespace ::]} {
                set name ::$name
            } else {
                set name ${namespace}::$name
            }
        }
        set fullClass [namespace qualifiers $name]
        if {[info exists declared($fullClass)]} {
            set procedure [namespace tail $name]
            return 1
        } else {
            if {[string length $fullClass]==0} {
                set message "procedure $name class name is empty"
            } else {
                set message "procedure $name class $fullClass is unknown"
            }
            return 0
        }
    }
}

_proc ::stooop::virtual {keyword name arguments args} {
    variable pureVirtual

    if {![string equal [uplevel 1 namespace which -command $keyword] ::proc]} {
        error "virtual operator works only on proc, not $keyword"
    }
    if {![parseProcedureName        [uplevel 1 namespace current] $name fullClass procedure message    ]} {
        error $message
    }
    set class [namespace tail $fullClass]
    if {[string equal $class $procedure]} {
        error "cannot make class $fullClass constructor virtual"
    }
    if {[string equal ~$class $procedure]} {
        error "cannot make class $fullClass destructor virtual"
    }
    if {![string equal [lindex $arguments 0] this]} {
        error "cannot make static procedure $procedure of class $fullClass virtual"
    }
    set pureVirtual [expr {[llength $args]==0}]
    uplevel 1 ::proc [list $name $arguments [lindex $args 0]]
    unset pureVirtual
}

_proc proc {name arguments args} {
    if {![::stooop::parseProcedureName        [uplevel 1 namespace current] $name fullClass procedure message    ]} {
        uplevel 1 _proc [list $name $arguments] $args
        return
    }
    if {[llength $args]==0} {
        error "missing body for ${fullClass}::$procedure"
    }
    set class [namespace tail $fullClass]
    if {[string equal $class $procedure]} {
        if {![string equal [lindex $arguments 0] this]} {
            error "class $fullClass constructor first argument must be this"
        }
        if {[string equal [lindex $arguments 1] copy]} {
            if {[llength $arguments]!=2} {
                error "class $fullClass copy constructor must have 2 arguments exactly"
            }
            if {[catch {info body ::${fullClass}::$class}]} {
                error "class $fullClass copy constructor defined before constructor"
            }
            eval ::stooop::constructorDeclaration                $fullClass $class 1 \{$arguments\} $args
        } else {
            eval ::stooop::constructorDeclaration                $fullClass $class 0 \{$arguments\} $args
            ::stooop::generateDefaultCopyConstructor $fullClass
        }
    } elseif {[string equal ~$class $procedure]} {
        if {[llength $arguments]!=1} {
            error "class $fullClass destructor must have 1 argument exactly"
        }
        if {![string equal [lindex $arguments 0] this]} {
            error "class $fullClass destructor argument must be this"
        }
        if {[catch {info body ::${fullClass}::$class}]} {
            error "class $fullClass destructor defined before constructor"
        }
        ::stooop::destructorDeclaration            $fullClass $class $arguments [lindex $args 0]
    } else {
        if {[catch {info body ::${fullClass}::$class}]} {
            error "class $fullClass member procedure $procedure defined before constructor"
        }
        ::stooop::memberProcedureDeclaration            $fullClass $class $procedure $arguments [lindex $args 0]
    }
}

_proc ::stooop::constructorDeclaration {fullClass class copy arguments args} {
    variable check
    variable fullBases
    variable variable

    set number [llength $args]
    if {($number%2)==0} {
        error "bad class $fullClass constructor declaration, a base class, contructor arguments or body may be missing"
    }
    if {[string equal [lindex $arguments end] args]} {
        set variable($fullClass) {}
    }
    if {!$copy} {
        set fullBases($fullClass) {}
    }
    foreach {base baseArguments} [lrange $args 0 [expr {$number-2}]] {
        set constructor ${base}::[namespace tail $base]
        catch {$constructor}
        set fullBase [namespace qualifiers            [uplevel 2 namespace which -command $constructor]        ]
        if {[string length $fullBase]==0} {
            if {[string match *$base $fullClass]} {
                error "class $fullClass cannot be derived from itself"
            } else {
                error "class $fullClass constructor defined before base class $base constructor"
            }
        }
        if {!$copy} {
            if {[lsearch -exact $fullBases($fullClass) $fullBase]>=0} {
                error "class $fullClass directly inherits from class $fullBase more than once"
            }
            lappend fullBases($fullClass) $fullBase
        }
        regsub -all {\n} $baseArguments { } constructorArguments($fullBase)
    }
    set constructorBody "::variable {}
$check(code)
"
    if {[llength $fullBases($fullClass)]>0} {
        if {[info exists variable($fullClass)]} {
            foreach fullBase $fullBases($fullClass) {
                if {![info exists constructorArguments($fullBase)]} {
                    error "missing base class $fullBase constructor arguments from class $fullClass constructor"
                }
                set baseConstructor ${fullBase}::[namespace tail $fullBase]
                if {                    [info exists variable($fullBase)]&&                    ([string first {$args} $constructorArguments($fullBase)]>=0)                } {
                    append constructorBody "::set _list \[::list $constructorArguments($fullBase)\]
::eval $baseConstructor \$this \[::lrange \$_list 0 \[::expr {\[::llength \$_list\]-2}\]\] \[::lindex \$_list end\]
::unset _list
::set ${fullBase}::(\$this,_derived) $fullClass
"
                } else {
                    append constructorBody "$baseConstructor \$this $constructorArguments($fullBase)
::set ${fullBase}::(\$this,_derived) $fullClass
"
                }
            }
        } else {
            foreach fullBase $fullBases($fullClass) {
                if {![info exists constructorArguments($fullBase)]} {
                    error "missing base class $fullBase constructor arguments from class $fullClass constructor"
                }
                set baseConstructor ${fullBase}::[namespace tail $fullBase]
                append constructorBody "$baseConstructor \$this $constructorArguments($fullBase)
::set ${fullBase}::(\$this,_derived) $fullClass
"
            }
        }
    }
    if {$copy} {
        append constructorBody "::catch {::set (\$this,_derived) \$(\$[::lindex $arguments 1],_derived)}
"
    }
    append constructorBody [lindex $args end]
    if {$copy} {
        _proc ${fullClass}::_copy $arguments $constructorBody
    } else {
        _proc ${fullClass}::$class $arguments $constructorBody
    }
}

_proc ::stooop::destructorDeclaration {fullClass class arguments body} {
    variable check
    variable fullBases

    set body "::variable {}
$check(code)
$body
"
    for {set index [expr {[llength $fullBases($fullClass)]-1}]} {$index>=0}        {incr index -1}    {
        set fullBase [lindex $fullBases($fullClass) $index]
        append body "::stooop::deleteObject $fullBase \$this
"
    }
    _proc ${fullClass}::~$class $arguments $body
}

_proc ::stooop::memberProcedureDeclaration {    fullClass class procedure arguments body} {
    variable check
    variable pureVirtual

    if {[info exists pureVirtual]} {
        if {$pureVirtual} {
            _proc ${fullClass}::$procedure $arguments "::variable {}
$check(code)
::uplevel 1 \$(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\]
"
        } else {
            _proc ${fullClass}::_$procedure $arguments "::variable {}
$check(code)
$body
"
            _proc ${fullClass}::$procedure $arguments "::variable {}
$check(code)
if {!\[::catch {::info body \$(\$this,_derived)::$procedure}\]} {
::return \[::uplevel 1 \$(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\]\]
}
::uplevel 1 ${fullClass}::_$procedure \[::lrange \[::info level 0\] 1 end\]
"
        }
    } else {
        _proc ${fullClass}::$procedure $arguments "::variable {}
$check(code)
$body
"
    }
}

_proc ::stooop::generateDefaultCopyConstructor {fullClass} {
    variable fullBases

    foreach fullBase $fullBases($fullClass) {
        append body "${fullBase}::_copy \$this \$sibling
"
    }
    append body "::stooop::copy $fullClass \$sibling \$this
"
    _proc ${fullClass}::_copy {this sibling} $body
}


if {[llength [array names ::env STOOOP*]]>0} {

    catch {rename ::stooop::class ::stooop::_class}
    _proc ::stooop::class {args} {
        variable trace
        variable check

        set class [lindex $args 0]
        if {$check(data)} {
            uplevel 1 namespace eval $class                [list {::trace variable {} wu ::stooop::checkData}]
        }
        if {[info exists ::env(STOOOPTRACEDATA)]} {
            uplevel 1 namespace eval $class [list                "::trace variable {} $trace(dataOperations) ::stooop::traceData"            ]
        }
        uplevel 1 ::stooop::_class $args
    }

    if {$::stooop::check(procedures)} {
        catch {rename ::stooop::virtual ::stooop::_virtual}
        _proc ::stooop::virtual {keyword name arguments args} {
            variable interface

            uplevel 1 ::stooop::_virtual [list $keyword $name $arguments] $args
            parseProcedureName [uplevel 1 namespace current] $name                fullClass procedure message
            if {[llength $args]==0} {
                set interface($fullClass) {}
            }
        }
    }

    if {$::stooop::check(objects)} {
        _proc invokingProcedure {} {
            if {[catch {set procedure [lindex [info level -2] 0]}]} {
                return {top level}
            } elseif {                ([string length $procedure]==0)||                [string equal $procedure namespace]            } {
                return "namespace [uplevel 2 namespace current]"
            } else {
                return [uplevel 3 namespace which -command $procedure]
            }
        }
    }

    if {$::stooop::check(procedures)||$::stooop::check(objects)} {
        catch {rename ::stooop::new ::stooop::_new}
        _proc ::stooop::new {classOrId args} {
            variable newId
            variable check

            if {$check(procedures)} {
                variable fullClass
                variable interface
            }
            if {$check(objects)} {
                variable creator
            }
            if {$check(procedures)} {
                if {[string is integer $classOrId]} {
                    set fullName $fullClass($classOrId)
                } else {
                    set constructor ${classOrId}::[namespace tail $classOrId]
                    catch {$constructor}
                    set fullName [namespace qualifiers                        [uplevel 1 namespace which -command $constructor]                    ]
                    set fullClass([expr {$newId+1}]) $fullName
                }
                if {[info exists interface($fullName)]} {
                    error "class $fullName with pure virtual procedures should not be instanciated"
                }
            }
            if {$check(objects)} {
                set creator([expr {$newId+1}]) [invokingProcedure]
            }
            return [uplevel 1 ::stooop::_new $classOrId $args]
        }
    }

    if {$::stooop::check(objects)} {
        _proc ::stooop::delete {args} {
            variable fullClass
            variable deleter

            set procedure [invokingProcedure]
            foreach id $args {
                uplevel 1 ::stooop::deleteObject $fullClass($id) $id
                unset fullClass($id)
                set deleter($id) $procedure
            }
        }
    }

    _proc ::stooop::ancestors {fullClass} {
        variable ancestors
        variable fullBases

        if {[info exists ancestors($fullClass)]} {
            return $ancestors($fullClass)
        }
        set list {}
        foreach class $fullBases($fullClass) {
            set list [concat $list [list $class] [ancestors $class]]
        }
        set ancestors($fullClass) $list
        return $list
    }

    _proc ::stooop::debugInformation {        className fullClassName procedureName fullProcedureName        thisParameterName    } {
        upvar 1 $className class $fullClassName fullClass            $procedureName procedure $fullProcedureName fullProcedure            $thisParameterName thisParameter
        variable declared

        set namespace [uplevel 2 namespace current]
        if {[lsearch -exact [array names declared] $namespace]<0} return
        set fullClass [string trimleft $namespace :]
        set class [namespace tail $fullClass]
        set list [info level -2]
        set first [lindex $list 0]
        if {([llength $list]==0)||[string equal $first namespace]}            return
        set procedure $first
        set fullProcedure [uplevel 3 namespace which -command $procedure]
        set procedure [namespace tail $procedure]
        if {[string equal $class $procedure]} {
            set procedure constructor
        } elseif {[string equal ~$class $procedure]} {
            set procedure destructor
        }
        if {[string equal [lindex [info args $fullProcedure] 0] this]} {
            set thisParameter [lindex $list 1]
        }
    }

    _proc ::stooop::checkProcedure {} {
        variable fullClass

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        if {![info exists this]} return
        if {[string equal $procedure constructor]} return
        if {![info exists fullClass($this)]} {
            error "$this is not a valid object identifier"
        }
        set fullName [string trimleft $fullClass($this) :]
        if {[string equal $fullName $qualifiedClass]} return
        if {[lsearch -exact [ancestors ::$fullName] ::$qualifiedClass]<0} {
            error "class $qualifiedClass of $qualifiedProcedure procedure not an ancestor of object $this class $fullName"
        }
    }

    _proc ::stooop::traceProcedure {} {
        variable trace

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        set text $trace(procedureFormat)
        regsub -all %C $text $qualifiedClass text
        regsub -all %c $text $class text
        regsub -all %P $text $qualifiedProcedure text
        regsub -all %p $text $procedure text
        if {[info exists this]} {
            regsub -all %O $text $this text
            regsub -all %a $text [lrange [info level -1] 2 end] text
        } else {
            regsub -all %O $text {} text
            regsub -all %a $text [lrange [info level -1] 1 end] text
        }
        puts $trace(procedureChannel) $text
    }

    _proc ::stooop::checkData {array name operation} {
        scan $name %u,%s identifier member
        if {[info exists member]&&[string equal $member _derived]} return

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        if {![info exists class]} return
        set array [uplevel 1 [list namespace which -variable $array]]
        if {![info exists procedure]} {
            if {![string equal $array ::${qualifiedClass}::]} {
                error                    "class access violation in class $qualifiedClass namespace"
            }
            return
        }
        if {[string equal $qualifiedProcedure ::stooop::copy]} return
        if {![string equal $array ::${qualifiedClass}::]} {
            error "class access violation in procedure $qualifiedProcedure"
        }
        if {![info exists this]} return
        if {![info exists identifier]} return
        if {$this!=$identifier} {
            error "object $identifier access violation in procedure $qualifiedProcedure acting on object $this"
        }
    }

    _proc ::stooop::traceData {array name operation} {
        variable trace

        scan $name %u,%s identifier member
        if {[info exists member]&&[string equal $member _derived]} return

        if {            ![catch {lindex [info level -1] 0} procedure]&&            [string equal ::stooop::deleteObject $procedure]        } return
        set class {}
        set qualifiedClass {}
        set procedure {}
        set qualifiedProcedure {}

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        set text $trace(dataFormat)
        regsub -all %C $text $qualifiedClass text
        regsub -all %c $text $class text
        if {[info exists member]} {
            regsub -all %m $text $member text
        } else {
            regsub -all %m $text $name text
        }
        regsub -all %P $text $qualifiedProcedure text
        regsub -all %p $text $procedure text
        regsub -all %A $text [string trimleft            [uplevel 1 [list namespace which -variable $array]] :        ] text
        if {[info exists this]} {
            regsub -all %O $text $this text
        } else {
            regsub -all %O $text {} text
        }
        array set string {r read w write u unset}
        regsub -all %o $text $string($operation) text
        if {[string equal $operation u]} {
            regsub -all %v $text {} text
        } else {
            regsub -all %v $text [uplevel 1 set ${array}($name)] text
        }
        puts $trace(dataChannel) $text
    }

    if {$::stooop::check(objects)} {
        _proc ::stooop::printObjects {{pattern *}} {
            variable fullClass
            variable creator

            puts "stooop::printObjects invoked from [invokingProcedure]:"
            foreach id [lsort -integer [array names fullClass]] {
                if {[string match $pattern $fullClass($id)]} {
                    puts "$fullClass($id)\($id\) + $creator($id)"
                }
            }
        }

        _proc ::stooop::record {} {
            variable fullClass
            variable checkpointFullClass

            puts "stooop::record invoked from [invokingProcedure]"
            catch {unset checkpointFullClass}
            array set checkpointFullClass [array get fullClass]
        }

        _proc ::stooop::report {{pattern *}} {
            variable fullClass
            variable checkpointFullClass
            variable creator
            variable deleter

            puts "stooop::report invoked from [invokingProcedure]:"
            set checkpointIds [lsort -integer [array names checkpointFullClass]]
            set currentIds [lsort -integer [array names fullClass]]
            foreach id $currentIds {
                if {                    [string match $pattern $fullClass($id)]&&                    ([lsearch -exact $checkpointIds $id]<0)                } {
                    puts "+ $fullClass($id)\($id\) + $creator($id)"
                }
            }
            foreach id $checkpointIds {
                if {                    [string match $pattern $checkpointFullClass($id)]&&                    ([lsearch -exact $currentIds $id]<0)                } {
                    puts "- $checkpointFullClass($id)\($id\) - $deleter($id) + $creator($id)"
                }
            }
        }
    }

}
        }
        namespace import stooop::*
        if 1 {

package provide switched 2.2


::stooop::class switched {

    proc switched {this args} {
        if {([llength $args]%2)!=0} {
            error "value for \"[lindex $args end]\" missing"
        }
        set ($this,complete) 0
        set ($this,arguments) $args
    }

    proc ~switched {this} {}

    ::stooop::virtual proc options {this}

    proc complete {this} {
        foreach description [options $this] {
            set option [lindex $description 0]
            set ($this,$option) [set default [lindex $description 1]]
            if {[llength $description]<3} {
                set initialize($option) {}
            } elseif {![string equal $default [lindex $description 2]]} {
                set ($this,$option) [lindex $description 2]
                set initialize($option) {}
            }
        }
        foreach {option value} $($this,arguments) {
            if {[catch {string compare $($this,$option) $value} different]} {
                error "$($this,_derived): unknown option \"$option\""
            }
            if {$different} {
                set ($this,$option) $value
                set initialize($option) {}
            }
        }
        unset ($this,arguments)
        foreach option [array names initialize] {
            $($this,_derived)::set$option $this $($this,$option)
        }
        set ($this,complete) 1
    }

    proc configure {this args} {
        if {[llength $args]==0} {
            return [descriptions $this]
        }
        foreach {option value} $args {
            if {![info exists ($this,$option)]} {
                error "$($this,_derived): unknown option \"$option\""
            }
        }
        if {[llength $args]==1} {
            return [description $this [lindex $args 0]]
        }
        if {([llength $args]%2)!=0} {
            error "value for \"[lindex $args end]\" missing"
        }
        foreach {option value} $args {
            if {![string equal $($this,$option) $value]} {
                $($this,_derived)::set$option $this [set ($this,$option) $value]
            }
        }
    }

    proc cget {this option} {
        if {[catch {set value $($this,$option)}]} {
            error "$($this,_derived): unknown option \"$option\""
        }
        return $value
    }

    proc description {this option} {
        foreach description [options $this] {
            if {[string equal [lindex $description 0] $option]} {
                if {[llength $description]<3} {
                    lappend description $($this,$option)
                    return $description
                } else {
                    return [lreplace $description 2 2 $($this,$option)]
                }
            }
        }
    }

    proc descriptions {this} {
        set descriptions {}
        foreach description [options $this] {
            if {[llength $description]<3} {
                lappend description $($this,[lindex $description 0])
                lappend descriptions $description
            } else {
                lappend descriptions [lreplace                    $description 2 2 $($this,[lindex $description 0])                ]
            }
        }
        return $descriptions
    }

}
        }
    }
    interp eval $interpreter "
        set ::global::debug $::global::debug
        set ::preferencesFile $::preferencesFile
    "
    interp eval $interpreter {
        proc bgerror {message} {
            if {$::global::debug} {
                writeLog $::errorInfo critical
            } else {
                writeLog $message critical
            }
        }
    }
    if {$global::database != 0} {
        interp eval $interpreter "set global::database $global::database"
        $interpreter alias $global::database object $global::database
    }
    interp eval $interpreter {



class record {

    proc record {this args} switched {$args} {
        switched::complete $this
    }

    proc ~record {this} {
        if {[info exists ($this,root)]} {
            dom::destroy $($this,root)
        }
    }

    proc options {this} {
        return [list            [list -file {} {}]        ]
    }

    proc set-file {this value} {}

if {$global::withGUI} {

    array set series {
        ::store,comments {} ::thresholds,addresses {} ::dataTable,columnwidths {} ::freeText,cellindices {}
        ::summaryTable,cellrows {} ::summaryTable,columns {} ::summaryTable,columnwidths {} ::data2DPieChart,cellcolors {}
        ::data3DPieChart,cellcolors {} ::dataGraph,cellcolors {} ::dataStackedGraph,cellcolors {} ::dataBarChart,cellcolors {}
        ::dataSideBarChart,cellcolors {} ::dataStackedBarChart,cellcolors {} ::dataOverlapBarChart,cellcolors {}
        ::formulas::table,cellindexes {} ::formulas::table,cells {} ::formulas::table,rows {}
    }

    proc write {this} {
        variable series

        if {[string length $switched::($this,-file)] == 0} {
            error {-file option undefined}
        }
        set document [dom::create]
        set root [dom::document createElement $document moodssConfiguration]
        dom::document createTextNode [dom::document createElement $root version] $global::applicationVersion
        set seconds [clock seconds]
        dom::document createTextNode [dom::document createElement $root date] [clock format $seconds -format %D]
        dom::document createTextNode [dom::document createElement $root time] [clock format $seconds -format %T]
        set node [dom::document createElement $root configuration]
        foreach name [configuration::variables 0] {
            if {[string equal $name viewerColors]} continue
            dom::element setAttribute $node $name [set ::global::$name]
        }
        nodeFromList $node viewerColors $::global::viewerColors
        dom::document createTextNode [dom::document createElement $root width] [winfo width $widget::($global::scroll,path)]
        dom::document createTextNode [dom::document createElement $root height] [winfo height $widget::($global::scroll,path)]
        dom::document createTextNode [dom::document createElement $root pollTime] $global::pollTime
        if {[info exists databaseInstances::singleton]} {
            set node [dom::document createElement $root databaseRange]
            foreach {from to} [databaseInstances::cursorsRange] {}
            dom::element setAttribute $node from $from
            dom::element setAttribute $node to $to
            set node [dom::document createElement $root databaseViewer]
            set path $widget::($databaseInstances::singleton,path)
            foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $path] {}
            foreach {xIcon yIcon} [canvasWindowManager::iconCoordinates $global::windowManager $path] {}
            dom::element setAttribute $node x $x; dom::element setAttribute $node y $y
            dom::element setAttribute $node width $width; dom::element setAttribute $node height $height
            dom::element setAttribute $node xIcon $xIcon; dom::element setAttribute $node yIcon $yIcon
        }
        set modules [dom::document createElement $root modules]
        foreach instance $modules::(instances) {
            if {[string equal $modules::instance::($instance,module) formulas]} {
                continue
            }
            set namespace $modules::instance::($instance,namespace)
            set module [dom::document createElement $modules module]
            dom::element setAttribute $module namespace $namespace
            dom::document createTextNode [dom::document createElement $module arguments] $modules::instance::($instance,arguments)
            set tables [dom::document createElement $module tables]
            foreach table $dataTable::(list) {
                if {![string equal $namespace [namespace qualifiers [composite::cget $table -data]]]} continue
                foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $widget::($table,path)] {}
                set level [canvasWindowManager::getStackLevel $global::windowManager $widget::($table,path)]
                foreach {xIcon yIcon} [canvasWindowManager::iconCoordinates $global::windowManager $widget::($table,path)] {}
                set node [dom::document createElement $tables table]
                dom::element setAttribute $node x $x; dom::element setAttribute $node y $y
                dom::element setAttribute $node width $width; dom::element setAttribute $node height $height
                dom::element setAttribute $node level $level
                dom::element setAttribute $node xIcon $xIcon; dom::element setAttribute $node yIcon $yIcon
                set list [dataTable::initializationConfiguration $table]
                if {[llength $list] > 0} {
                    set options [dom::document createElement $node configuration]
                    foreach {switch value} $list {
                        set switch [string trimleft $switch -]
                        if {[info exists series(::dataTable,$switch)]} {
                            nodeFromList $options $switch $value
                        } else {
                            dom::element setAttribute $options $switch $value
                        }
                    }
                }
            }
        }
        set viewers [dom::document createElement $root viewers]
        foreach viewer $viewer::(list) {
            if {![viewer::saved $viewer]} continue
            set node [dom::document createElement $viewers viewer]
            set class [classof $viewer]
            dom::element setAttribute $node class $class
            if {[viewer::manageable $viewer]} {
                foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $widget::($viewer,path)] {}
                set level [canvasWindowManager::getStackLevel $global::windowManager $widget::($viewer,path)]
                dom::element setAttribute $node x $x; dom::element setAttribute $node y $y
                dom::element setAttribute $node width $width; dom::element setAttribute $node height $height
                dom::element setAttribute $node level $level
                foreach {xIcon yIcon} [canvasWindowManager::iconCoordinates $global::windowManager $widget::($viewer,path)] {}
                if {[string length $xIcon] > 0} {
                    dom::element setAttribute $node xIcon $xIcon; dom::element setAttribute $node yIcon $yIcon
                }
            }
            nodeFromList $node cells [viewer::cells $viewer]
            set list [viewer::initializationConfiguration $viewer]
            if {[llength $list] > 0} {
                catch {unset configurationNode}
                foreach {switch value} $list {
                    set switch [string trimleft $switch -]
                    if {[string equal $switch configurations]} {
                        foreach sublist $value {
                            set options [dom::document createElement $node configurations]
                            foreach {switch value} $sublist {
                                set switch [string trimleft $switch -]
                                if {[info exists series($class,$switch)]} {
                                    nodeFromList $options $switch $value
                                } else {
                                    switch -glob [string tolower $switch] {
                                        *text {dom::document createTextNode [dom::document createElement $options $switch] $value}
                                        *data                                            {dom::document createCDATASection [dom::document createElement $options $switch] $value}
                                        default {dom::element setAttribute $options $switch $value}
                                    }
                                }
                            }
                        }
                    } else {
                        if {![info exists configurationNode]} {
                            set configurationNode [dom::document createElement $node configuration]
                        }
                        set options $configurationNode
                        if {[info exists series($class,$switch)]} {
                            nodeFromList $options $switch $value
                        } else {
                            switch -glob [string tolower $switch] {
                                *text {dom::document createTextNode [dom::document createElement $options $switch] $value}
                                *data {dom::document createCDATASection [dom::document createElement $options $switch] $value}
                                default {dom::element setAttribute $options $switch $value}
                            }
                        }
                    }
                }
            }
        }
        set images [dom::document createElement $root images]
        foreach {file format data} [images::values] {
            set node [dom::document createElement $images image]
            dom::element setAttribute $node file $file
            dom::element setAttribute $node format $format
            dom::document createCDATASection $node \n$data\n
        }
        set file [open $switched::($this,-file) w+]
        dom::document configure $document -encoding [fconfigure $file -encoding]
        set data [serialize $document]
        dom::destroy $root
        puts $file $data
        close $file
    }

}

    proc read {this} {
        if {[string length $switched::($this,-file)] == 0} {
            error {-file option undefined}
        }
        if {[catch {set file [open $switched::($this,-file)]} message]} {
            puts stderr $message
            exit 1
        }
        set line [gets $file]
        seek $file 0
        if {[catch {set ($this,root) [dom::parse [::read $file]]} message]} {
            puts stderr "file $switched::($this,-file) is not a valid moodss configuration file:\n$message"
            exit 1
        }
        close $file
        set ($this,convertNamespaces) [expr {[package vcompare [version $this] 19.0] < 0}]
    }

    proc modules {this} {
        set list {}
        foreach node [dom::selectNode $($this,root) /moodssConfiguration/modules/module] {
            set namespace [dom::element getAttribute $node namespace]
            if {$($this,convertNamespaces)} {
                foreach {name index} [modules::decoded $namespace] {}
                if {[string length $index] == 0} {append namespace <0>}
            }
            lappend list $namespace
        }
        return $list
    }

    proc modulesWithArguments {this {validateCommand {}}} {
        set list {}
        foreach node [dom::selectNode $($this,root) /moodssConfiguration/modules/module] {
            set namespace [dom::element getAttribute $node namespace]
            if {([string length $validateCommand] > 0) && ![uplevel #0 $validateCommand $namespace]} continue
            lappend list $namespace
            eval lappend list [dom::node stringValue [dom::selectNode $node arguments]]
        }
        return $list
    }

    proc pollTime {this} {
        return [dom::node stringValue [dom::selectNode $($this,root) /moodssConfiguration/pollTime]]
    }

    proc sizes {this} {
        return [list            [dom::node stringValue [dom::selectNode $($this,root) /moodssConfiguration/width]]            [dom::node stringValue [dom::selectNode $($this,root) /moodssConfiguration/height]]        ]
    }

    proc viewersData {this} {
        set list {}
        foreach viewerNode [dom::selectNode $($this,root) /moodssConfiguration/viewers/viewer] {
            set class [dom::element getAttribute $viewerNode class]
            if {$($this,convertNamespaces)} {
                set cells [convertedCells [listFromNode $viewerNode cells]]
            } else {
                set cells [listFromNode $viewerNode cells]
            }
            lappend list $class $cells [dom::element getAttribute $viewerNode x] [dom::element getAttribute $viewerNode y]                [dom::element getAttribute $viewerNode width] [dom::element getAttribute $viewerNode height]                [dom::element getAttribute $viewerNode level] [dom::element getAttribute $viewerNode xIcon]                [dom::element getAttribute $viewerNode yIcon]
            set options {}
            set node [dom::selectNode $viewerNode configuration]
            if {[string length $node] > 0} {
                foreach {name value} [array get [dom::node cget $node -attributes]] {
                    if {$($this,convertNamespaces)} {
                        switch $name totalcell - ymaximumcell {set value [converted $value]}
                    }
                    lappend options -$name $value
                }
                foreach node [dom::selectNode $node *] {
                    set name [dom::node cget $node -nodeName]
                    switch -glob [string tolower $name] {
                        *text - *data {lappend options -$name [dom::node stringValue $node]}
                        default {lappend options -$name [listFromNode $node]}
                    }
                }
            }
            set nodes [dom::selectNode $viewerNode configurations]
            if {[llength $nodes] > 0} {
                set lists {}
                foreach node $nodes {
                    set append {}
                    foreach {name value} [array get [dom::node cget $node -attributes]] {
                        lappend append -$name $value
                    }
                    foreach node [dom::selectNode $node *] {
                        set name [dom::node cget $node -nodeName]
                        switch -glob [string tolower $name] {
                            *text - *data {lappend append -$name [dom::node stringValue $node]}
                            default {
                                if {                                    $($this,convertNamespaces) &&                                    [string equal $class ::formulas::table] && [string equal $name cells]                                } {
                                    lappend append -$name [convertedCells [listFromNode $node]]
                                } else {
                                    lappend append -$name [listFromNode $node]
                                }
                            }
                        }
                    }
                    lappend lists $append
                }
                lappend options -configurations $lists
            }
            lappend list $options
        }
        return $list
    }

    proc tableNode {this namespace creationIndex} {
        if {$($this,convertNamespaces) && [string match *<0> $namespace]} {
            regsub {<0>$} $namespace {} namespace
        }
        set node [dom::selectNode $($this,root) /moodssConfiguration/modules/module\[@namespace=\"$namespace\"\]]
        if {[string length $node] == 0} {error {internal error: please report to author}}
        return [lindex [dom::selectNode $node tables/table] $creationIndex]
    }

    proc tableWindowManagerData {this namespace creationIndex} {
        if {[string length [set node [tableNode $this $namespace $creationIndex]]] == 0} {
            return {}
        }
        array set data [array get [dom::node cget $node -attributes]]
        return [list $data(x) $data(y) $data(width) $data(height) $data(level) $data(xIcon) $data(yIcon)]
    }

    proc tableOptions {this namespace creationIndex} {
        if {[string length [set node [tableNode $this $namespace $creationIndex]]] == 0} {
            return {}
        }
        set options {}
        set node [dom::selectNode $node configuration]
        if {[string length $node] > 0} {
            foreach {name value} [array get [dom::node cget $node -attributes]] {
                lappend options -$name $value
            }
            foreach node [dom::selectNode $node *] {
                lappend options -[dom::node cget $node -nodeName] [listFromNode $node]
            }
        }
        return $options
    }

    proc configurationData {this} {
        set node [dom::selectNode $($this,root) /moodssConfiguration/configuration]
        set list [array get [dom::node cget $node -attributes]]
        lappend list viewerColors [listFromNode $node viewerColors]
        return $list
    }

    proc version {this} {
        return [dom::node stringValue [dom::selectNode $($this,root) /moodssConfiguration/version]]
    }

    proc databaseRange {this} {
        set node [dom::selectNode $($this,root) /moodssConfiguration/databaseRange]
        if {[string length $node] == 0} {return {}}
        array set data [array get [dom::node cget $node -attributes]]
        return [list $data(from) $data(to)]
    }

    proc databaseViewerWindowManagerData {this} {
        set node [dom::selectNode $($this,root) /moodssConfiguration/databaseViewer]
        if {[string length $node] == 0} {return {}}
        array set data [array get [dom::node cget $node -attributes]]
        return [list $data(x) $data(y) $data(width) $data(height) $data(xIcon) $data(yIcon)]
    }

    proc converted {cell} {
        if {[string length $cell] == 0} {return {}}
        viewer::parse $cell array row column ignore
        set namespace [namespace qualifiers $array]
        foreach {name index} [modules::decoded $namespace] {}
        if {[string length $index] == 0} {
            set cell $namespace<0>::[namespace tail $array]($row,$column)
        }
        return $cell
    }
    proc convertedCells {list} {
        set cells {}
        foreach cell $list {lappend cells [converted $cell]}
        return $cells
    }

if {$global::withGUI} {

    proc imagesData {this} {
        set list {}
        foreach node [dom::selectNode $($this,root) /moodssConfiguration/images/image] {
            lappend list [dom::element getAttribute $node file] [string trim [dom::node stringValue $node]]
            dom::destroy $node
        }
        return $list
    }

    proc currentConfiguration {} {
        set root [new container]
        container::bind $root [set container [new container configuration]]
        foreach name [configuration::variables 0] {
            container::set $container $name [set ::global::$name]
        }
        container::set $root width [winfo width $widget::($global::scroll,path)]
        container::set $root height [winfo height $widget::($global::scroll,path)]
        container::set $root pollTime $global::pollTime
        if {[info exists databaseInstances::singleton]} {
            container::bind $root [set container [new container databaseRange]]
            foreach {from to} [databaseInstances::cursorsRange] {}
            container::set $container from $from
            container::set $container to $to
            container::bind $root [set container [new container databaseViewer]]
            set path $widget::($databaseInstances::singleton,path)
            foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $path] {}
            foreach {xIcon yIcon} [canvasWindowManager::iconCoordinates $global::windowManager $path] {}
            container::set $container x $x; container::set $container y $y
            container::set $container width $width; container::set $container height $height
            container::set $container xIcon $xIcon; container::set $container yIcon $yIcon
        }
        container::bind $root [set modules [new container modules]]
        foreach instance $modules::(instances) {
            set namespace $modules::instance::($instance,namespace)
            container::bind $modules [set module [new container module]]
            container::set $module namespace $namespace
            container::set $module arguments $modules::instance::($instance,arguments)
            container::bind $module [set tables [new container tables]]
            foreach table $dataTable::(list) {
                if {![string equal $namespace [namespace qualifiers [composite::cget $table -data]]]} continue
                foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $widget::($table,path)] {}
                set level [canvasWindowManager::getStackLevel $global::windowManager $widget::($table,path)]
                foreach {xIcon yIcon} [canvasWindowManager::iconCoordinates $global::windowManager $widget::($table,path)] {}
                container::bind $tables [set container [new container table]]
                container::set $container x $x; container::set $container y $y
                container::set $container width $width; container::set $container height $height
                container::set $container level $level
                container::set $container xIcon $xIcon; container::set $container yIcon $yIcon
                set list [dataTable::initializationConfiguration $table]
                if {[llength $list] > 0} {
                    container::bind $container [set options [new container configuration]]
                    foreach {switch value} $list {
                        container::set $options $switch $value
                    }
                }
            }
        }
        container::bind $root [set viewers [new container viewers]]
        foreach viewer $viewer::(list) {
            if {![viewer::saved $viewer]} continue
            container::bind $viewers [set container [new container viewer]]
            container::set $container class [classof $viewer]
            if {[viewer::manageable $viewer]} {
                foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $widget::($viewer,path)] {}
                set level [canvasWindowManager::getStackLevel $global::windowManager $widget::($viewer,path)]
                container::set $container x $x; container::set $container y $y
                container::set $container width $width; container::set $container height $height
                container::set $container level $level
                foreach {xIcon yIcon} [canvasWindowManager::iconCoordinates $global::windowManager $widget::($viewer,path)] {}
                if {[string length $xIcon] > 0} {
                    container::set $container xIcon $xIcon; container::set $container yIcon $yIcon
                }
            }
            container::set $container cells [viewer::cells $viewer]
            set list [viewer::initializationConfiguration $viewer]
            if {[llength $list] > 0} {
                container::bind $container [set options [new container configuration]]
                foreach {switch value} $list {
                    if {[string match -nocase *data $switch]} continue
                    if {[string equal $switch -configurations]} {
                        foreach list $value {
                            container::bind $options [set configurations [new container configurations]]
                            foreach {switch value} $list {
                                container::set $configurations $switch $value
                            }
                        }
                    } else {
                        container::set $options $switch $value
                    }
                }
            }
        }
        container::bind $root [set images [new container images]]
        foreach file [images::names] {
            container::bind $images [set container [new container image]]
            container::set $container file $file
        }
        return $root
    }

    proc snapshot {} {
        if {[info exists (data)]} {delete $(data)}
        set (data) [currentConfiguration]
    }

    proc changed {} {
        if {[info exists (data)]} {
            set container [currentConfiguration]
            set equal [container::equal $(data) [currentConfiguration]]
            delete $container
            return [expr {!$equal}]
        } else {
            return 0
        }
    }

}

}



class dataTrace {

    proc dataTrace {this} {error {dataTrace objects disallowed}}

    proc register {object array script {last 0}} {
        variable objects
        variable command
        variable count

        if {[info exists objects($array)]} {
            catch {ldelete objects($array) $object}
            if {$last} {
                lappend objects($array) $object
            } else {
                set objects($array) [linsert $objects($array) 0 $object]
            }
        } else {
            trace variable ${array}(updates) w "dataTrace::updated $array"
            set objects($array) $object
        }
        if {[catch {incr count($object,$array)}]} {
            set command($object,$array) $script
            set count($object,$array) 1
        }
    }

    proc unregister {object {array {}}} {
        variable objects
        variable command
        variable count

        if {[string length $array] == 0} {
            foreach array [array names objects] {
                if {[info exists count($object,$array)]} {
                    set count($object,$array) 0
                    unregister $object $array
                }
            }
            return
        }
        if {[incr count($object,$array) -1] <= 0} {
            ldelete objects($array) $object
            unset command($object,$array)
            unset count($object,$array)
        }
        if {[llength $objects($array)] == 0} {
            trace vdelete ${array}(updates) w "dataTrace::updated $array"
            unset objects($array)
        }
    }

    proc updated {array args} {
        variable objects
        variable command

        foreach object $objects($array) {
            uplevel #0 $command($object,$array)
        }
    }

}



class viewer {

    set (list) {}
if {$global::withGUI} {
    set (background) $widget::option(label,background)
    set (rightRedArrow) [image create photo -data {R0lGODlhBQAJAIAAAP8AAP8AACH5BAEKAAEALAAAAAAFAAkAAAIMRB5gp9v2YlJsJRQKADs=}]
    set (rightDarkGrayArrow) [image create photo -data {R0lGODlhBQAJAIAAAKCgoP///yH5BAEKAAEALAAAAAAFAAkAAAIMRB5gp9v2YlJsJRQKADs=}]
    set (limitAreaWidth) 40
    set (limitAreaHeight) 20
}

    proc viewer {this} {
        lappend (list) $this
    }

    proc ~viewer {this} {
        dataTrace::unregister $this
        if {[info exists ($this,drop)]} {
            delete $($this,drop)
        }
        ldelete (list) $this
if {$global::withGUI} {
        pages::monitorActiveCells
        thresholdLabel::monitorActiveCells
}
    }

    virtual proc supportedTypes {this}

    proc view {this cells} {
        set list {}
        foreach cell $cells {
            parse $cell array row column type
            if {![info exists $array]} continue
            if {[lsearch -exact [supportedTypes $this] $type] < 0} {
if {$global::withGUI} {
                wrongTypeMessage $type
}
                return 0
            }
            set update($array) {}
            lappend list $array $row $column
        }
        foreach {array row column} $list {
            monitorCell $this $array $row $column
if {$global::withGUI} {
            foreach {color level summary} [thresholds::cellData $array $row $column] {
                thresholdCondition $this $array $row $column $color $level $summary
            }
            setCellColor $this ${array}($row,$column) [cellThresholdColor $array $row $column]
}
        }
        foreach array [array names update] {
            update $this $array
        }
        return 1
    }

    virtual proc monitorCell {this array row column}

    proc parse {dataCell arrayName rowName columnName typeName} {
        upvar 1 $arrayName cellArray $rowName cellRow $columnName cellColumn $typeName cellType

        if {([scan $dataCell {%[^(](%lu,%u)} array row column] != 3) || ($column < 0)} {
            error "\"$dataCell\" is not a valid array cell"
        }
        set cellArray $array; set cellRow $row; set cellColumn $column; catch {set cellType [set ${array}($column,type)]}
    }

    proc updateInterval {value} {
        foreach viewer $(list) {
            catch {composite::configure $viewer -interval $value}
        }
    }

    proc label {array row column {identify {}}} {
        set label {}
        if {[string length $identify] == 0} {
            set identify $global::cellsLabelModuleHeader
        }
        if {$identify} {
            set identifier [modules::identifier $array]
            if {[string length $identifier] > 0} {
                regsub {<0>$} $identifier {} identifier
                set label "$identifier: "
            }
        }
        if {[catch {set ${array}(indexColumns)} columns]} {
            set columns 0
        }
        foreach index $columns {
            if {[catch {set ${array}($row,$index)} value]} {
                append label {? }
            } elseif {[string length $value] > 0} {
                append label "$value "
            }
        }
        append label [set ${array}($column,label)]
        return [list $label [string match {*\?*} $label]]
    }

    virtual proc update {this array}

    proc registerTrace {this array {last 0}} {
        dataTrace::register $this $array "viewer::update $this $array" $last
    }

    proc unregisterTrace {this array} {
        dataTrace::unregister $this $array
    }

    virtual proc cells {this}

if {$global::withGUI} {

    virtual proc initializationConfiguration {this} {
        return {}
    }

    proc setupDropSite {this path} {
        set ($this,drop) [new dropSite -path $path -formats {DATACELLS VIEWER KILL} -command "viewer::handleDrop $this"]
    }

    proc handleDrop {this} {
        if {![catch {set data $dragSite::data(DATACELLS)}]} {
            view $this $data
        } elseif {![catch {set data $dragSite::data(VIEWER)}]} {
            mutate $this $data
        } elseif {[info exists dragSite::data(KILL)]} {
            delete $this
        }
    }

    proc mutate {this class} {
        if {[string equal $class [classof $this]]} return
        set draggable [composite::cget $this -draggable]
        switch $class {
            ::currentValueTable {
                set viewer [new currentValueTable $global::canvas $global::pollTime -draggable $draggable]
            }
            ::canvas::iconic {
                if {[string length [set name [canvas::iconic::chooseFile]]] == 0} return
                set viewer [new $class $global::canvas -draggable $draggable -static $global::static -file $name]
            }
            default {
                set viewer [new $class $global::canvas -draggable $draggable]
            }
        }
        foreach list [composite::configure $viewer] {
            if {[string equal [lindex $list 0] -interval]} {
                composite::configure $viewer -interval $global::pollTime
                break
            }
        }
        set cells {}
        set count 0
        foreach cell [cells $this] {
            if {[info exists $cell]} {
                lappend cells $cell
            }
            incr count
        }
        if {[llength $cells] > 0} {
            view $viewer $cells
        }
        if {[llength $cells] < $count} {
            lifoLabel::flash $global::messenger [mc {some data cells no longer exist}]
        }
        if {[manageable $this]} {
            foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $widget::($this,path)] {}
            set level [canvasWindowManager::getStackLevel $global::windowManager $widget::($this,path)]
        } else {
            set x [composite::cget $this -x]; set y [composite::cget $this -y]
            set width {}; set height {}; set level {}
        }
        delete $this
        if {[manageable $viewer]} {
            manageViewer $viewer 1 -static $global::static -setx $x -sety $y -setwidth $width -setheight $height -level $level                -dragobject $viewer
        } else {
            composite::configure $viewer -x $x -y $y
        }
    }

    proc cellThresholdColor {array row column} {
        set manager [new thresholdsManager]
        set cell ${array}($row,$column)
        foreach {color level summary} [thresholds::cellData $array $row $column] {
            thresholdsManager::condition $manager $cell $color $level $summary
        }
        set color [lindex [lindex [thresholdsManager::colorsAndTexts $manager] 0] 0]
        delete $manager
        return $color
    }

    proc cellThresholdCondition {array row column color level summary} {
        set topColor [cellThresholdColor $array $row $column]
        foreach viewer $(list) {
            thresholdCondition $viewer $array $row $column $color $level $summary
            setCellColor $viewer ${array}($row,$column) $topColor
        }
    }


    virtual proc thresholdCondition {this array row column color level summary} {}
    virtual proc setCellColor {this cell color} {}

    virtual proc manageable {this} {return 1}

    proc monitoring {cell} {
        set viewers {}
        foreach viewer $(list) {
            if {[monitored $viewer $cell]} {
                lappend viewers $viewer
            }
        }
        return $viewers
    }

    virtual proc monitored {this cell}

    proc getDisplayColor {cell} {
        variable colorIndex
        variable usageCount

        if {![info exists colorIndex($cell)]} {
            set colors [llength $global::viewerColors]
            for {set index 0} {$index < $colors} {incr index} {
                set count($index) 0
            }
            foreach {name index} [array get colorIndex] {
                incr count($index)
            }
            set color 0
            set minimum $global::32BitIntegerMaximum
            for {set index 0} {$index < $colors} {incr index} {
                if {$count($index) < $minimum} {
                    set minimum $count($index)
                    set color $index
                }
            }
            set colorIndex($cell) $color
            set usageCount($cell) 0
        }
        incr usageCount($cell)
        return [lindex $global::viewerColors $colorIndex($cell)]
    }
    proc returnDisplayColor {cell} {
        variable colorIndex
        variable usageCount

        if {[catch {incr usageCount($cell) -1}]} return
        if {$usageCount($cell) == 0} {
            unset colorIndex($cell) usageCount($cell)
        }
    }

    proc limitEntry {this path anchor x y option name font command yCommand type} {
        set entry [entry $path.maximum -borderwidth 0 -highlightthickness 0 -width 10 -font $font]
        switch $type {
            float {setupEntryValidation $entry {{checkFloatingPoint %P}}; set type double}
            signed {setupEntryValidation $entry {{check32BitSignedInteger %P}}; set type integer}
            unsigned {setupEntryValidation $entry {{check31BitUnsignedInteger %P}}; set type integer}
            default error
        }
        lifoLabel::push $global::messenger            [format [mc {enter %s value (empty for automatic scale, Return to valid, Escape to abort)}] $name]
        foreach key {<KP_Enter> <Return>} {
            bind $entry $key "
                if {\[string is $type \[%W get\]\]} {
                    $command \[%W get\]
                    destroy %W
                    lifoLabel::pop $global::messenger
                }
            "
        }
        bind $entry <Escape> "destroy %W; lifoLabel::pop $global::messenger"
        $entry insert 0 [composite::cget $this $option]
        $entry selection range 0 end
        if {[string length $yCommand] > 0} {set y [uplevel #0 $yCommand]}
        place $entry -anchor $anchor -x $x -y $y
        focus $entry
        ::update idletasks
        grab $entry
    }

    proc wrongTypeMessage {type} {
        lifoLabel::flash $global::messenger [format [mc {cannot display data of type %s}] $type]
        bell
        if {![info exists (wrongTypeDrop)]} {
            set (wrongTypeDrop) {}
            tk_messageBox -title {moodss: drag and drop} -type ok -icon info -message [format [mc                {Some viewers only accept a limited set of data types (if this case, this viewer cannot display data of type %s)}            ] $type]
        }
    }

    proc createColorsMenu {parentPath command} {
        set menu [menu $parentPath.colorsMenu -tearoff 0]
        set spaces {   }
        if {[string equal $::tcl_platform(platform) windows]} {set spaces {      }}
        set rows 0
        set index 0
        foreach color $global::viewerColors {
            $menu add command -label $spaces -background $color -activebackground $color
            regsub -all %c $command $color string
            $menu entryconfigure $index -hidemargin 1 -command $string
            if {$rows >= 3} {
                $menu entryconfigure $index -columnbreak 1
                set rows 0
            }
            incr rows
            incr index
        }
        return $menu
    }

    virtual proc updateLabels {this} {}

}

    proc numericType {type} {
        switch $type {
            integer - real {return 1}
            default {return 0}
        }
    }

    virtual proc saved {this} {return 1}

}



class thresholds {

    variable levelColor
    array set levelColor {emergency red alert red critical red error red warning orange notice yellow info white debug blue}
    set (levels) {emergency alert critical error warning notice info debug}
    set (colors) {red orange yellow white green cyan blue ? {}}
    variable help
    variable translated

if {$global::withGUI} {

    set (default,button,background) $widget::option(button,background)
    variable cameraIcon [image create photo -data {
        R0lGODlhEgAQAMYAAAAAAB0dHWpqatfX1+Xl5eLi4tLS0t3d3SIiIszMzM3NzdDQ0NXV1dzc3OTk5OHh4bGxsQEBAbKyslVVVTY2NmdnZ8fHxxQUFIODgwgI
        CAQEBAwMDAoKCmxsbMnJydvb2+Pj47S0tBEREU5OTkVFRSoqKgMDA3BwcNPT097e3r6+vnx8fCQkJHp6eiEhIbe3t5GRkX19fUNDQyYmJgcHBx8fH3Nzc2Zm
        Zm1tbZubm4eHh39/f0dHRygoKAICAg4ODrCwsHFxcY2NjRgYGHZ2dicnJ6urqzU1NWVlZSsrKxAQEJOTkzAwMERERC0tLWBgYKCgoLW1tV5eXoWFhcrKyo+P
        j8HBwaenp1tbW0ZGRv//////////////////////////////////////////////////////////////////////////////////////////////////////
        /////////////////////////////////////////////////yH5BAEKAH8ALAAAAAASABAAAAfDgH8Ag4N/hoeIhgECAwQFhACJiAAGBwSXmIMIkgAJCgsM
        DQUOlw8QgxGHnQkJEhMUFRYFmASDF4KsGBkaGxccHR4fIJgGgwkhIhQjJCUXJicJKCkEKissnS0uLzAxMjM0NawJFjY31wk4NTk6Ozw9Pj/iQEHmnUJDAjtE
        RUMcFOJG6J1LQOIIkiRKfIhYAlAgoQQTZCRh0sSIuAQBzRki5OQJlCgeLmZkkQiSlClUWI2UtJFQFStXsDiZwXLSoCw9DAUCADs=
    }]

    variable mailIcon [image create photo -data {
        R0lGODlhCgAKAMIAAPgA+MDAwHh8ePj8+AAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAKAAoAAAMiCLoc/k8EMWqdJAxiQ84V52kgRkibI03siXbCScw0zdxAAgA7
    }]
    variable customMailIcon [image create photo -data {
        R0lGODlhCgAKAMIAAL+/YHt7Pvz7fgAAAP///////////////yH5BAEAAAQALAAAAAAKAAoAAAMiSLoM/i+AIGqdA4hhQc4V52kgNkibI03siXbBOcw0zdxEAgA7
    }]
    variable gearIcon [image create photo -data {
        R0lGODlhCgAKAKEAAPgA+MDAwHh8eAAAACH5BAEAAAAALAAAAAAKAAoAAAIhhBFyFoGaWJthnDZGRDjrKgiVF1pctnFiWBmCFWULIB8FADs=
    }]

}

    proc thresholds {this args} switched {$args} viewer {} {
        variable singleton
        variable thresholds {}

        if {[info exists singleton]} {
            error {only 1 thresholds object can exist}
        }
        switched::complete $this
    }

    proc ~thresholds {this} {
        error {not implemented}
    }

    proc options {this} {
        return [list [list -configurations {} {}]]
    }

if {$global::withGUI} {

    proc iconData {} {
        return {
            R0lGODdhJAAkAKUAAPj8+Hh4eHh8eHBIAPj0wAAAAPDssOjkqODgoPgAAODYmNjUkNDMiNDEgMjAeMC4cMC0aJicmLisYLCkWKigUKiYSKCUQJiMOICEgJiE
            MIiQiJCAKJCYkIh4IKCkoKisqLi8uMDEwMjQyNDY0ODk4Ojs6AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
            AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAJAAkAAAG/kCAcCgMEI/G4zBZVBKZSijy6RwKqgAp8bosCr7gsHhMHmuFXGdauT5bseujYEDPYgHxrZM+
            IBAGAkllg2N8focDBQGLVXlvAHQGkpOSgG5ocJAHm5ydlneOmJB8CKWmnwAJqqusra6rAwqys3yqfLe4ubkLvAsDvLiNWFADDMZ0x4GgQrddzA3QgHMNqIvW
            YgMO2g4D1gFz29wFc3SKjGoDD+rrA3jM7FdX0peQEPb39oD1+VxcEXZVBuAbCIEOPn3unH0LM0CCw4d0HkqUkKiMtSMDJmjcKC3jRo0IRTXBSKGkSWnMTJYM
            mXDkkAEVYsqswBJmTJYtARYoMMCCj8+fFhLtHMqzHNGjR8EMuMC0qbQxQwmFwUAVw4AMWDNIq8q1q1evGsKGHbChLCCxaNOqXcuhrdsBHaS5nUu3rl0PePN6
            oCNAr9+/gPV+GEx48JfCiBMrLgyisePHkCNLnhyisuXLmDNr3iyis+fPoEOLHj2itOnTqFOrXk2itevXsGPLnl2itu3buHPr3h0EADs=
        }
    }

}

    proc supportedTypes {this} {
        return $global::dataTypes
    }

    proc set-configurations {this value} {}

if {$global::withGUI} {

    proc edit {} {
        variable singleton
        variable thresholds
        variable cameraIcon
        variable number

        set this $singleton
        if {[info exists ($this,dialog)]} {
            raise $widget::($($this,dialog),path)
            return
        }
        set dialog [createDialog $this]
        set frame [frame $widget::($dialog,path).frame]

        set table [createTable $this $frame]
        grid $widget::($table,path) -row 0 -column 0 -sticky nsew

        set details [frame $frame.details]
        set ($this,initial) 0
        set ($this,initialButton) [checkbutton $details.initial            -font $font::(mediumBold) -text [mc {Initial condition}] -variable thresholds::($this,initial) -state disabled        ]
        lappend ($this,objects) [new widgetTip            -path $($this,initialButton) -text [mc {no action (even if condition is met) when application is started}]        ]
        grid $($this,initialButton) -row 0 -column 0 -columnspan 2 -sticky w -padx 5
        set ($this,emailsLabel) [label $details.emailsLabel -font $font::(mediumBold) -text [mc Emails:] -state disabled]
        grid $($this,emailsLabel) -row 0 -column 2 -sticky e
        set ($this,emails) [new listEntry $details -state disabled]
        grid $widget::($($this,emails),path) -row 0 -column 3 -rowspan 3 -sticky nsew
        set ($this,cellLabel) [label $details.cellLabel -font $font::(mediumBold) -text [mc {Original cell:}] -state disabled]
        grid $($this,cellLabel) -row 1 -column 0 -sticky w
        set ($this,cell) [label $details.cell -font $font::(mediumNormal) -relief sunken -width 20]
        grid $($this,cell) -row 1 -column 1 -columnspan 2 -sticky we -padx 5
        set ($this,currentLabel) [label $details.currentLabel -font $font::(mediumBold) -text [mc {Current value:}] -state disabled]
        grid $($this,currentLabel) -row 2 -column 0 -sticky w
        set ($this,current) [label $details.current -font $font::(mediumNormal) -relief sunken -width 20]
        grid $($this,current) -row 2 -column 1 -columnspan 2 -sticky we -padx 5
        set ($this,drag) [new dragSite -path $($this,current) -validcommand "thresholds::validateDrag $this"]
        dragSite::provide $($this,drag) DATACELLS "thresholds::dragData $this"
        grid columnconfigure $details 1 -weight 1
        grid columnconfigure $details 3 -weight 2
        grid $details -row 1 -column 0 -sticky ew

        set arrowSize [font metrics $font::(mediumBold) -ascent]

        set mailFrame [frame $frame.mailFrame]
        set ($this,mailLabel) [label $mailFrame.label -font $font::(mediumBold) -text [mc {Mail message}] -state disabled]
        grid $($this,mailLabel) -row 0 -column 0 -sticky w
        set arrow [new arrowButton $mailFrame -width $arrowSize -height $arrowSize]
        lappend ($this,objects) $arrow
        grid $widget::($arrow,path) -row 0 -column 1 -sticky w
        set ($this,default) 1
        set ($this,defaultButton) [checkbutton $mailFrame.default -command "thresholds::updateMailSection $this"            -font $font::(mediumBold) -text [mc Default] -variable thresholds::($this,default) -state disabled        ]
        lappend ($this,objects) [new widgetTip -path $($this,defaultButton)            -text [mc {use default subject and body for email message, as defined in preferences}]        ]
        grid $($this,defaultButton) -row 0 -column 2 -sticky e
        set partsFrame [frame $mailFrame.parts]
        set ($this,subjectLabel) [label $partsFrame.subjectLabel -font $font::(mediumBold) -text [mc Subject:] -state disabled]
        grid $($this,subjectLabel) -row 0 -column 0 -sticky w
        set ($this,subjectEntry) [entry $partsFrame.subjectEntry -font $font::(fixedNormal) -state disabled]
        grid $($this,subjectEntry) -row 0 -column 1 -sticky ew
        set ($this,bodyLabel) [label $partsFrame.bodyLabel -font $font::(mediumBold) -text [mc Body:] -state disabled]
        grid $($this,bodyLabel) -row 1 -column 0 -sticky nw
        set ($this,body) [new scroll text $partsFrame -height 80]
        set ($this,bodyText) $composite::($($this,body),scrolled,path)
        $($this,bodyText) configure -state disabled -background white -font $font::(fixedNormal)
        setupTextBindings $($this,bodyText)
        grid $widget::($($this,body),path) -row 1 -column 1 -rowspan 2 -sticky nsew
        set ($this,emailShot) 0
        set ($this,shot) [checkbutton $partsFrame.shot -image $cameraIcon -variable thresholds::($this,emailShot) -state disabled]
        lappend ($this,objects) [new widgetTip -path $($this,shot) -text [mc {attach screen shot to email message}]]
        grid $($this,shot) -row 2 -column 0
        composite::configure $arrow -command "thresholds::toggleGrid $arrow $partsFrame -row 1 -column 0 -columnspan 3 -sticky nsew"
        grid columnconfigure $partsFrame 1 -weight 1
        grid columnconfigure $mailFrame 1 -weight 1
        grid $mailFrame -row 2 -column 0 -sticky nsew

        set scriptFrame [frame $frame.scriptFrame]
        set ($this,scriptLabel) [label $scriptFrame.label -font $font::(mediumBold) -text [mc Script] -state disabled]
        grid $($this,scriptLabel) -row 0 -column 0 -sticky w
        set arrow [new arrowButton $scriptFrame -width $arrowSize -height $arrowSize]
        lappend ($this,objects) $arrow
        grid $widget::($arrow,path) -row 0 -column 1 -sticky w
        set panes [new panner $scriptFrame -panes 2]
        set ($this,script) [new scroll text $panner::($panes,frame1) -height 80]
        set ($this,scriptText) $composite::($($this,script),scrolled,path)
        $($this,scriptText) configure -state disabled -background white -font $font::(fixedNormal)
        setupTextBindings $($this,scriptText)
        pack $widget::($($this,script),path) -fill both -expand 1
        set ($this,testLabel) [label $panner::($panes,frame2).testLabel            -font $font::(mediumBold) -text [mc {Test trace:}] -state disabled        ]
        pack $($this,testLabel) -anchor nw
        set ($this,test) [new scroll text $panner::($panes,frame2) -height 120]
        set text $composite::($($this,test),scrolled,path)
        $text configure -state disabled -font $font::(fixedNormal)
        bind $text <Configure>            {foreach window [%W window names] {$window configure -width [expr {%w - $global::separatorCut}]}}
        set ($this,testText) $text
        pack $widget::($($this,test),path) -fill both -expand 1
        composite::configure $arrow            -command "thresholds::toggleGrid $arrow $widget::($panes,path) -row 1 -column 0 -columnspan 2 -sticky nsew"
        grid rowconfigure $scriptFrame 1 -weight 1
        grid columnconfigure $scriptFrame 1 -weight 1
        set ($this,panes) $panes
        grid $scriptFrame -row 3 -column 0 -sticky nsew

        grid rowconfigure $frame 0 -weight 1
        grid columnconfigure $frame 0 -weight 1

        foreach {string underline} [underlineAmpersand [mc &Test]] {}
        composite::configure $dialog test -text $string -underline $underline -command "thresholds::test $this" -state disabled
        set button $composite::($dialog,test,path)
        lappend ($this,objects) [new widgetTip -path $button -text [mc {test email and script}]]
        set ($this,testButton) $button
        foreach {string underline} [underlineAmpersand [mc &Delete]] {}
        composite::configure $dialog delete -text $string -underline $underline -command "thresholds::delete $this" -state disabled
        set button $composite::($dialog,delete,path)
        lappend ($this,objects) [new widgetTip -path $button -text [mc {delete selected entry}]]
        set ($this,deleteButton) $button

        dialogBox::display $dialog $frame
        set ($this,table) $table
        set ($this,dialog) $dialog
        foreach threshold [lsort -command threshold::comparison -decreasing $thresholds] {
            display $this $threshold
        }
        selectTable::refreshBorders $table
        selectTable::adjustTableColumns $table
    }

}

    proc monitorCell {this array row column} {
        variable thresholds

        viewer::registerTrace $this $array 1
        set cell ${array}($row,$column)
        if {[llength $switched::($this,-configurations)] > 0} {
            set index 0
            foreach configuration $switched::($this,-configurations) {
                catch {unset option}; array set option $configuration
                if {![info exists option(-cell)]} break
                if {[string equal $option(-cell) $cell]} {
                    unset option(-cell)
                    break
                }
                incr index
            }
            set threshold [eval new threshold $cell [array get option]]
            switched::configure $this -configurations [lrange $switched::($this,-configurations) [incr index] end]
        } else {
            set threshold [new threshold $cell]
            switched::configure $threshold -label $threshold::($threshold,cellLabel)
        }
        lappend thresholds $threshold
        if {[info exists ($this,dialog)]} {
            set (held,$threshold) {}
            display $this $threshold
            selectTable::refreshBorders $($this,table)
            selectTable::adjustTableColumns $($this,table)
        }
        set ($this,lastMonitored) $threshold
    }

if {$global::withGUI} {

    proc display {this threshold} {
        variable data
        variable number
        variable translated

        set table $($this,table)
        set path $selectTable::($table,tablePath)
        set row [selectTable::rows $table]
        selectTable::rows $table [expr {$row + 1}]
        set background [composite::cget $table -background]
        set data($row,$number(threshold)) $threshold
        selectTable::spans $table $row,$number(active) 0,$(hiddenColumns)
        set data($row,$number(active)) [switched::cget $threshold -active]
        set button $path.$threshold,active
        checkbutton $button            -activebackground $background -highlightthickness 0 -variable thresholds::data($row,$number(active)) -takefocus 0
        bind $button <ButtonRelease-1> "thresholds::select $this $threshold"
        selectTable::windowConfigure $table $row,$number(active) -window $button -padx 1 -pady 1 -sticky nsew
        set data($row,$number(type)) [switched::cget $threshold -type]
        set label $path.$threshold,type
        label $label -image [threshold::typeImage $data($row,$number(type))]
        bind $label <ButtonRelease-1> "
            thresholds::circleType $this $number(type) $label $threshold
            thresholds::select $this $threshold
        "
        selectTable::windowConfigure $table $row,$number(type) -window $label -relief sunken -padx 1 -pady 1
        set data($row,$number(once)) [switched::cget $threshold -actonce]
        set button $path.$threshold,once
        checkbutton $button            -activebackground $background -highlightthickness 0 -variable thresholds::data($row,$number(once)) -takefocus 0
        bind $button <ButtonRelease-1> "thresholds::select $this $threshold"
        selectTable::windowConfigure $table $row,$number(once) -window $button -padx 1 -pady 1 -sticky nsew
        if {![info exists translated(levels)]} {
            foreach level $(levels) {lappend translated(levels) [mc $level]}
        }
        set data($row,$number(level)) [switched::cget $threshold -level]
        set index [lsearch -exact $(levels) $data($row,$number(level))]; if {$index < 0} {set index 0}
        set menu [new optionMenu $path            -font $font::(tinyNormal) -choices $translated(levels) -text [lindex $translated(levels) $index] -takefocus 0            -popupcommand "thresholds::select $this $threshold"        ]
        composite::configure $menu base -highlightthickness 0
        selectTable::windowConfigure $table $row,$number(level) -window $widget::($menu,path) -padx 1 -pady 1 -sticky nsew
        lappend ($this,objects) $menu
        set data($row,$number(color)) [switched::cget $threshold -color]
        set button [createColorsMenuButton $this $path $threshold]
        bind $button <ButtonPress-1> "+ thresholds::select $this $threshold"
        selectTable::windowConfigure $table $row,$number(color) -window $button -padx 1 -pady 1 -sticky nsew
        composite::configure $menu -command "thresholds::updateLevel $this $threshold $button"
        set frame [frame $path.$threshold,actions]
        selectTable::windowConfigure $table $row,$number(actions) -window $frame -padx 1 -pady 1
        set cell $row,$number(value)
        set data($cell) [switched::cget $threshold -value]
        set entry $path.$threshold,value
        entry $entry -font $font::(mediumNormal) -textvariable thresholds::data($cell) -borderwidth 0 -highlightthickness 0            -width 10
        bind $entry <FocusIn> "thresholds::select $this $threshold"
        selectTable::windowConfigure $table $cell -window $entry -padx 1 -pady 1 -sticky nsew
        set cell $row,$number(source)
        regsub -all {\n} [switched::cget $threshold -label] { } data($cell)
        set entry $path.$threshold,source
        entry $entry -font $font::(mediumNormal) -textvariable thresholds::data($cell) -borderwidth 0 -highlightthickness 0 -width 1
        bind $entry <FocusIn> "thresholds::select $this $threshold"
        selectTable::windowConfigure $table $cell -window $entry -padx 1 -pady 1 -sticky nsew
        set data($row,$number(addresses)) [switched::cget $threshold -addresses]
        set data($row,$number(subject)) [set subject [switched::cget $threshold -subject]]
        set data($row,$number(body)) [set body [switched::cget $threshold -bodytext]]
        set data($row,$number(default)) [expr {([string length $subject] == 0) && ([string length $body] == 0)}]
        set data($row,$number(script)) [switched::cget $threshold -scripttext]
        set data($row,$number(label)) $threshold::($threshold,cellLabel)
        set data($row,$number(initial)) [switched::cget $threshold -initial]
        set data($row,$number(emailShot)) [switched::cget $threshold -emailshot]
        updateActions $this $row
        if {[string equal $::tcl_platform(platform) windows]} ::update
    }

}

    proc update {this array} {
        variable thresholds

        if {[info exists ($this,dialog)]} {
            if {[info exists ($this,selected)]} {
                updateCurrentValue $this $($this,selected)
            }
        } else {
            foreach threshold $thresholds {
                threshold::check $threshold $array
            }
        }
    }

if {$global::withGUI} {

    proc updateCurrentValue {this row} {
        variable data
        variable number

        set threshold $data($row,$number(threshold))
        set value ?
        catch {set value [set $threshold::($threshold,cell)]}
        $($this,current) configure -text $value
    }

    proc createDialog {this} {
        variable geometry

        set dialog [new dialogBox .            -buttons hoc -default o -title [mc {moodss: Thresholds}] -die 0 -grab release -enterreturn 0            -x [winfo pointerx .] -y [winfo pointery .] -helpcommand {generalHelpWindow #menus.edit.thresholds}            -command "thresholds::done $this 0" -deletecommand "thresholds::done $this 1" -otherbuttons {test delete}        ]
        set ($this,helpTip) [linkedHelpWidgetTip $composite::($dialog,help,path)]
        if {![info exists geometry]} {set geometry 600x550}
        wm geometry $widget::($dialog,path) $geometry
        bind $widget::($dialog,path) <Configure> "set thresholds::geometry \[wm geometry $widget::($dialog,path)\]"
        return $dialog
    }

    proc createTable {this parentPath} {
        variable data
        variable help
        variable number

        if {![info exists help]} {
            set help(active) [mc {whether the threshold condition is checked}]
            set help(type) [mc {threshold type (click for next type)}]
            set help(once) [mc {whether actions are taken only once when threshold condition is maintained over time (reset when condition disappears)}]
            set help(level) [mc {importance level (used by moomps for system logging and included in email alert)}]
            set help(color) [mc {color showing threshold condition occurred (click to edit)}]
            set help(actions) [mc {actions (email, script) taken when threshold condition occurs}]
            set help(value) [mc {threshold value}]
            set help(source) [mc {data description (can be edited)}]
        }
        set table [new selectTable $parentPath            -selectcommand "thresholds::selected $this" -followfocus 0 -variable thresholds::data -titlerows 1 -roworigin -1        ]
        set path $selectTable::($table,tablePath)
        set column 0
        foreach title {
            active threshold addresses script label initial default subject body emailShot
            type once level color actions value source
        } {
            set data(-1,$column) $title
            set number($title) $column
            incr column
        }
        composite::configure $table -columns [llength [array names data -1,*]]
        foreach {cell title} [array get data -1,*] {
            if {![info exists help($title)]} continue
            set label [label $path.$cell -font $font::(mediumBold) -text [mc $title]]
            selectTable::windowConfigure $table $cell -window $label -padx 1 -pady 1 -sticky nsew
            lappend ($this,objects) [new widgetTip -path $label -text $help($title)]
        }
        set (hiddenColumns) [expr {$number(type) - $number(active) - 1}]
        selectTable::spans $table -1,$number(active) 0,$(hiddenColumns)
        set ($this,drop) [new dropSite -path $path -formats DATACELLS -command "viewer::view $this \$dragSite::data(DATACELLS)"]
        return $table
    }

    proc done {this destroy} {
        variable data
        variable thresholds
        variable deleted
        variable number

        if {$destroy} {
            eval ::delete $($this,helpTip) $($this,objects) $($this,emails) $($this,body) $($this,script) $($this,test)                $($this,panes) $($this,table) $($this,drop) $($this,drag)
            unset ($this,dialog) ($this,helpTip) ($this,objects) ($this,emails) ($this,cell) ($this,current) ($this,body)                ($this,bodyText) ($this,script) ($this,scriptText) ($this,test) ($this,testText) ($this,panes) ($this,table)                ($this,drop) ($this,drag)
            catch {unset ($this,selected)}
            unset data
            foreach threshold $thresholds {
                if {[info exists (held,$threshold)]} {
                    viewer::unregisterTrace $this $threshold::($threshold,array)
                    ldelete thresholds $threshold
                    ::delete $threshold
                }
            }
            if {[info exists deleted]} {
                foreach threshold $deleted {
                    if {[info exists (held,$threshold)]} continue
                    lappend thresholds $threshold
                }
                unset deleted
            }
            array unset {} held,*
            set thresholds [lsort -command threshold::comparison $thresholds]
            pages::monitorActiveCells
            thresholdLabel::monitorActiveCells
        } else {
            if {[info exists ($this,selected)]} {
                set row $($this,selected)
                set data($row,$number(addresses)) [listEntry::get $($this,emails)]
                if {[string length [set errors [checkEmails $this $row]]] > 0} {
                    tk_messageBox -parent $widget::($($this,dialog),path)                        -title [mc {moodss: Email error}] -type ok -icon error -message $errors
                    return
                }
            }
            foreach {name threshold} [array get data "\[0-9\]*,$number(threshold)"] {
                scan $name %u row
                if {[info exists ($this,selected)] && ($row == $($this,selected))} {
                    set data($row,$number(addresses)) [listEntry::get $($this,emails)]
                    if {[set data($row,$number(default)) $($this,default)]} {
                        set data($row,$number(subject)) {}
                        set data($row,$number(body)) {}
                    } else {
                        set data($row,$number(subject)) [string trim [$($this,subjectEntry) get]]
                        set data($row,$number(body)) [string trim [$($this,bodyText) get 1.0 end]]
                    }
                    set data($row,$number(script)) [string trim [$($this,scriptText) get 1.0 end]]
                    set data($row,$number(initial)) $($this,initial)
                    set data($row,$number(emailShot)) $($this,emailShot)
                }
                switched::configure $threshold -active $data($row,$number(active)) -type $data($row,$number(type))                    -color $data($row,$number(color)) -level $data($row,$number(level)) -emailshot $data($row,$number(emailShot))                    -label $data($row,$number(source)) -addresses $data($row,$number(addresses)) -actonce $data($row,$number(once))                    -subject $data($row,$number(subject)) -bodytext $data($row,$number(body)) -value $data($row,$number(value))                    -initial $data($row,$number(initial)) -scripttext $data($row,$number(script))
            }
            if {[info exists deleted]} {
                foreach threshold $deleted {
                    viewer::unregisterTrace $this $threshold::($threshold,array)
                    ::delete $threshold
                }
                unset deleted
            }
            array unset {} held,*
            ::delete $($this,dialog)
        }
    }

    proc updateMailSection {this} {
        variable data
        variable number

        set entry $($this,subjectEntry)
        set text $($this,bodyText)
        if {$($this,default)} {
            $($this,subjectLabel) configure -state disabled
            $entry configure -state normal; $entry delete 0 end; $entry configure -state disabled
            $($this,bodyLabel) configure -state disabled
            $text configure -state normal; $text delete 1.0 end; $text configure -state disabled
        } else {
            $($this,subjectLabel) configure -state normal
            $entry configure -state normal
            $entry delete 0 end
            $($this,bodyLabel) configure -state normal
            $text configure -state normal
            $text delete 1.0 end
            if {[info exists ($this,selected)]} {
                set row $($this,selected)
                $entry insert 0 $data($row,$number(subject))
                $text insert 1.0 $data($row,$number(body))
            }
        }
    }

    proc toggleGrid {arrow path args} {
        if {[llength [grid info $path]] == 0} {
            composite::configure $arrow -direction right
            eval grid $path $args
        } else {
            composite::configure $arrow -direction down
            grid forget $path
        }
    }

}

    proc cells {this} {
        variable thresholds

        set cells {}
        foreach threshold $thresholds {
            lappend cells $threshold::($threshold,cell)
        }
        return $cells
    }

    proc initializationConfiguration {this} {
        variable thresholds

        set arguments {}
        foreach threshold $thresholds {
            set list [list -cell $threshold::($threshold,cell)]
            foreach configuration [switched::configure $threshold] {
                foreach {option default value} $configuration {}
                if {[string equal $option -script]} continue
                lappend list $option $value
            }
            lappend arguments $list
        }
        return [list -configurations $arguments]
    }

    proc manageable {this} {return 0}

if {$global::withGUI} {

    proc monitored {this cell} {
        variable thresholds

        foreach threshold $thresholds {
            if {[string equal $threshold::($threshold,cell) $cell]} {
                return 1
            }
        }
        return 0
    }

    proc test {this} {
        variable data
        variable number

        set emails [listEntry::get $($this,emails)]
        if {[string length [set errors [checkEmailAddresses $emails]]] > 0} {
            tk_messageBox -parent $widget::($($this,dialog),path)                -title [mc {moodss: Email error}] -type ok -icon error -message $errors
            return
        }
        set row $($this,selected)
        set threshold $data($row,$number(threshold))
        if {$($this,default)} {
            set subject {}
            set body {}
        } else {
            set subject [string trim [$($this,subjectEntry) get]]
            set body [string trim [$($this,bodyText) get 1.0 end]]
        }
        set script [string trim [$($this,scriptText) get 1.0 end]]
        set temporary [new threshold $threshold::($threshold,cell)            -active $data($row,$number(active)) -type $data($row,$number(type)) -color $data($row,$number(color))            -level $data($row,$number(level)) -value $data($row,$number(value)) -label $data($row,$number(source))            -addresses $emails -scripttext $script -emailshot $($this,emailShot) -initial 0 -actonce 0 -test 1            -subject $subject -bodytext $body        ]
        set output [threshold::test $temporary]
        if {[string length $script] > 0} {
            set text $($this,testText)
            $text configure -state normal
            $text insert end \n$output\n
            $text window create end -window [frame $text.$temporary                -relief sunken -borderwidth 1 -height 2 -width [expr {[winfo width $text] - $global::separatorCut}]            ]
            $text see end
            $text configure -state disabled
        }
        ::delete $temporary
    }

    proc delete {this} {
        variable thresholds
        variable deleted
        variable data
        variable number

        set table $($this,table)
        set path $selectTable::($table,tablePath)
        set row $($this,selected)
        deselect $this $row
        set threshold $data($row,$number(threshold))
        selectTable::delete $table $row
        ldelete thresholds $threshold
        lappend deleted $threshold
        for {} {$row < [llength $thresholds]} {incr row} {
            set threshold $data($row,$number(threshold))
            $path.$threshold,active configure -variable thresholds::data($row,$number(active))
            $path.$threshold,once configure -variable thresholds::data($row,$number(once))
            $path.$threshold,value configure -textvariable thresholds::data($row,$number(value))
            $path.$threshold,source configure -textvariable thresholds::data($row,$number(source))
        }
        array unset data [llength $thresholds],\[0-9\]*
        selectTable::clear $table
        selectTable::refreshBorders $table
        selectTable::adjustTableColumns $table
    }

    proc circleType {this column label threshold} {
        variable data

        set row [row $this $threshold]
        $label configure -image [threshold::typeImage [set data($row,$column) [threshold::nextType $data($row,$column)]]]
    }

    proc row {this threshold} {
        variable data
        variable number

        foreach {name value} [array get data "\[0-9\]*,$number(threshold)"] {
            if {$value == $threshold} {
                scan $name %u row
                return $row
            }
        }
        error "row not found for threshold $threshold"
    }

    proc select {this threshold} {
        return [selectTable::select $($this,table) [row $this $threshold]]
    }

    proc selected {this row} {
        variable data
        variable number

        set topPath $widget::($($this,dialog),path)
        catch {set selection [selection get]}
        if {[info exists ($this,selected)]} {
            set selected $($this,selected)
            set data($selected,$number(addresses)) [listEntry::get $($this,emails)]
            if {[set data($selected,$number(default)) $($this,default)]} {
                set data($selected,$number(subject)) {}
                set data($selected,$number(body)) {}
            } else {
                set data($selected,$number(subject)) [string trim [$($this,subjectEntry) get]]
                set data($selected,$number(body)) [string trim [$($this,bodyText) get 1.0 end]]
            }
            set data($selected,$number(script)) [string trim [$($this,scriptText) get 1.0 end]]
            set data($selected,$number(initial)) $($this,initial)
            set data($selected,$number(emailShot)) $($this,emailShot)
            updateActions $this $selected
        }
        if {[info exists selected] && ([string length [set errors [checkEmails $this $selected]]] > 0)} {
            focus $widget::($($this,emails),path)
            tk_messageBox -parent $topPath -title [mc {moodss: Email error}] -type ok -icon error -message $errors
            return 0
        }
        set ($this,selected) $row
        set button $($this,testButton)
        $button configure -state normal
        bind $topPath <Alt-KeyPress-t> "$button configure -relief sunken"
        bind $topPath <Alt-KeyRelease-t> "$button configure -relief raised; $button invoke"
        set button $($this,deleteButton)
        $button configure -state normal
        bind $topPath <Alt-KeyPress-d> "$button configure -relief sunken"
        bind $topPath <Alt-KeyRelease-d> "$button configure -relief raised; $button invoke"
        $($this,emailsLabel) configure -state normal
        composite::configure $($this,emails) -state normal
        $($this,initialButton) configure -state normal
        if {[string equal $::tcl_platform(platform) unix]} {
            $($this,shot) configure -state normal
        }
        listEntry::set $($this,emails) $data($row,$number(addresses))
        $($this,cellLabel) configure -state normal
        $($this,cell) configure -text $data($row,$number(label))
        $($this,currentLabel) configure -state normal
        $($this,mailLabel) configure -state normal
        $($this,defaultButton) configure -state normal
        set ($this,default) $data($row,$number(default))
        updateMailSection $this
        $($this,scriptLabel) configure -state normal
        $($this,scriptText) configure -state normal
        $($this,scriptText) delete 1.0 end
        $($this,scriptText) insert 1.0 $data($row,$number(script))
        $($this,testLabel) configure -state normal
        $($this,testText) configure -state normal
        $($this,testText) delete 1.0 end
        $($this,testText) configure -state disabled
        set ($this,initial) $data($row,$number(initial))
        set ($this,emailShot) $data($row,$number(emailShot))
        updateCurrentValue $this $row
        if {[info exists selection]} {
            clipboard clear
            clipboard append $selection
        }
        return 1
    }

    proc deselect {this row} {
        set topPath $widget::($($this,dialog),path)
        unset ($this,selected)
        composite::configure $($this,emails) -state disabled
        listEntry::set $($this,emails) {}
        $($this,cellLabel) configure -state disabled
        $($this,currentLabel) configure -state disabled
        $($this,emailsLabel) configure -state disabled
        $($this,mailLabel) configure -state disabled
        set ($this,default) 1
        $($this,defaultButton) configure -state disabled
        updateMailSection $this
        $($this,scriptLabel) configure -state disabled
        $($this,scriptText) delete 1.0 end
        $($this,scriptText) configure -state disabled
        $($this,testLabel) configure -state disabled
        $($this,testText) configure -state normal; $($this,testText) delete 1.0 end; $($this,testText) configure -state disabled
        $($this,testButton) configure -state disabled
        bind $topPath <Alt-KeyPress-t> {}; bind $topPath <Alt-KeyRelease-t> {}
        $($this,deleteButton) configure -state disabled
        bind $topPath <Alt-KeyPress-d> {}; bind $topPath <Alt-KeyRelease-d> {}
        $($this,cell) configure -text {}
        $($this,current) configure -text {}
        set ($this,initial) 0
        $($this,initialButton) configure -state disabled
        set ($this,emailShot) 0
        $($this,shot) configure -state disabled
    }

    proc chooseColor {this button row value} {
        variable data
        variable number

        switch $value {
            {} {
                set color $data($row,$number(color))
                if {[string length $color] == 0} {
                    set color $(default,button,background)
                }
                set color [tk_chooseColor -initialcolor $color -title [mc {Choose color}] -parent $widget::($($this,dialog),path)]
                if {[string length $color] == 0} return
                $button configure -text {} -background $color -activebackground $color
            }
            ? {
                $button configure -text ? -background $(default,button,background) -activebackground $(default,button,background)
                set color {}
            }
            default {
                $button configure -text {} -background $value -activebackground $value
                set color $value
            }
        }
        set data($row,$number(color)) $color
    }

    proc createColorsMenuButton {this parentPath threshold} {
        variable data
        variable number

        set button $parentPath.$threshold,color
        set row [row $this $threshold]
        set initialColor $data($row,$number(color))
        menubutton $button -relief raised -borderwidth 0 -highlightthickness 0 -indicatoron 1 -font $font::(mediumNormal)
        if {[string length $initialColor] == 0} {
            $button configure -text ? -background $(default,button,background) -activebackground $(default,button,background)
        } else {
            $button configure -text {} -background $initialColor -activebackground $initialColor
        }
        set menu [menu $button.menu -tearoff 0]
        set rows 0
        set index 0
        set spaces {   }
        if {[string equal $::tcl_platform(platform) windows]} {
            set spaces {      }
        }
        foreach color $(colors) {
            switch $color {
                {} {
                    $menu add command -label ...
                }
                ? {
                    $menu add command -label { ?}
                }
                default {
                    $menu add command -label $spaces -background $color -activebackground $color
                }
            }
            $menu entryconfigure $index -hidemargin 1 -command [list thresholds::chooseColor $this $button $row $color]
            if {$rows >= 3} {
                $menu entryconfigure $index -columnbreak 1
                set rows 0
            }
            incr rows
            incr index
        }
        $menu configure -postcommand "thresholds::updateMenu $this $menu $threshold"
        $button configure -menu $menu
        return $button
    }

    proc updateMenu {this menu threshold} {
        variable data
        variable number

        set color $data([row $this $threshold],$number(color))
        if {[string length $color] == 0} {
            set color $(default,button,background)
        }
        $menu entryconfigure end -background $color -activebackground $color
    }

    proc updateLevel {this threshold colorsMenu value} {
        variable data
        variable number
        variable levelColor
        variable translated

        set index [lsearch -exact $translated(levels) $value]; if {$index < 0} {set index 0}
        set value [lindex $(levels) $index]
        set row [row $this $threshold]
        if {[string equal $levelColor($data($row,$number(level))) $data($row,$number(color))]} {
            chooseColor $this $colorsMenu $row $levelColor($value)
        }
        set data($row,$number(level)) $value
    }

    proc updateActions {this row} {
        variable data
        variable number
        variable mailIcon
        variable customMailIcon
        variable gearIcon

        set threshold $data($row,$number(threshold))
        set path $selectTable::($($this,table),tablePath)
        set frame $path.$threshold,actions
        foreach label [winfo children $frame] {destroy $label}
        if {[llength $data($row,$number(addresses))] > 0} {
            if {$data($row,$number(default))} {
                pack [label $frame.mail -image $mailIcon] -side left
            } else {
                pack [label $frame.mail -image $customMailIcon] -side left
            }
        }
        if {[string length $data($row,$number(script))] > 0} {
            pack [label $frame.gear -image $gearIcon]
        }
    }

}

if {$global::withGUI} {

    proc cellData {array row column} {
        variable thresholds

        set list {}
        foreach threshold $thresholds {
            if {                ![switched::cget $threshold -active] || ![string equal $threshold::($threshold,array) $array] ||                ![string equal $threshold::($threshold,row) $row] || ![string equal $threshold::($threshold,column) $column]            } continue
            lappend list $switched::($threshold,-color) $switched::($threshold,-level)
            if {$threshold::($threshold,condition)} {
                lappend list [threshold::summary $threshold]
            } else {
                lappend list {}
            }
        }
        return $list
    }

    proc activeCells {} {
        variable thresholds

        foreach threshold $thresholds {
            if {[switched::cget $threshold -active]} {
                set active($threshold::($threshold,cell)) {}
            }
        }
        return [array names active]
    }

    proc validateDrag {this x y} {
        return [info exists ($this,selected)]
    }

    proc dragData {this format} {
        variable data
        variable number

        set threshold $data($($this,selected),$number(threshold))
        return $threshold::($threshold,cell)
    }

}

    proc reset {this} {
        variable thresholds

if {$global::withGUI} {
        if {[info exists ($this,dialog)]} {
            ::delete $($this,dialog)
        }
}
        foreach threshold $thresholds {
            viewer::unregisterTrace $this $threshold::($threshold,array)
            ldelete thresholds $threshold
            ::delete $threshold
        }
    }

    proc checkEmails {this row} {
        variable data
        variable number

        return [checkEmailAddresses $data($row,$number(addresses))]
    }

    proc checkEmailAddresses {list} {
        set errors {}
        foreach address $list {
            set message [emailAddressError $address]
            if {[string length $message] == 0} continue
            append errors "$address: $message\n"
        }
        return $errors
    }

    proc active {options} {
        array set value $options
        if {![info exists value(-configurations)]} {
            return [list 0 0]
        }
        set emails 0; set scripts 0
        foreach options $value(-configurations) {
            set list [threshold::active $options]
            incr emails [lindex $list 0]
            incr scripts [lindex $list end]
        }
        return [list $emails $scripts]
    }

    proc create {this array row column args} {
        viewer::view $this ${array}($row,$column)
        eval switched::configure $($this,lastMonitored) $args
        pages::monitorActiveCells
        thresholdLabel::monitorActiveCells
    }

    proc current {this array} {
        variable thresholds

        set list {}
        foreach threshold $thresholds {
            if {[string equal $threshold::($threshold,array) $array]} {
                lappend list $threshold
            }
        }
        return $list
    }


}

set ::thresholds::singleton [new thresholds]


class thresholds {

    class threshold {

if {$global::withGUI} {

        set (image,differ) [image create photo -data            R0lGODlhFAAKAKEAAPgA+AAAAHh8ePgAACH5BAEAAAAALAAAAAAUAAoAAAIjhBGnqW18mHANQkTV2E3YAIbbEJYhNXZXFS0Z5gJTtj7vnRUAOw==        ]
        set (image,down) [image create photo -data            R0lGODlhFAAKAPEAAP8A/wAAAPgAAHh8eCH5BAEAAAAALAAAAAAUAAoAAAIdhB2ny9i/EpyiwoAzrkL7x02TJIlKMJSmkaqmthQAOw==        ]
        set (image,equal) [image create photo -data            R0lGODlhFAAKAKEAAPgA+Hh8eAAAAPgAACH5BAEAAAAALAAAAAAUAAoAAAIdhI+pq8F/BDSjoiCN2HzX0YXMd2VTYp6Ho7auUQAAOw==        ]
        set (image,unknown) [image create photo -data            R0lGODlhFAAKAKEAAPgA+Hh8eAAAAPgAACH5BAEAAAAALAAAAAAUAAoAAAIghB+iG+euHojyUCiqtnm7pDTPQJalYqbb5bWuwb5TVxUAOw==        ]
        set (image,up) [image create photo -data            R0lGODlhFAAKAPEAAP8A/wAAAHh8ePgAACH5BAEAAAAALAAAAAAUAAoAAAIehI8QG+ku1psmRPqawmd4yoSBN4jhRHKJpiJsW8EFADs=        ]

}

        set (types) {differ down equal unknown up}

        proc threshold {this cell args} switched {$args} {
            set ($this,cell) $cell
            viewer::parse $cell ($this,array) ($this,row) ($this,column) ($this,cellType)
            set ($this,numeric) [viewer::numericType $($this,cellType)]
            set ($this,condition) 0
            set ($this,cellLabel) [lindex [viewer::label $($this,array) $($this,row) $($this,column) 1] 0]
            set ($this,checked) 0
            switched::complete $this
        }

        proc ~threshold {this} {
            if {$($this,condition)} {
                cellThresholdCondition $($this,array) $($this,row) $($this,column)                    $switched::($this,-color) $switched::($this,-level) {}
            }
        }

        proc options {this} {
            return [list                [list -active 0 0]                [list -actonce 0 0]                [list -addresses {} {}]                [list -bodytext {} {}]                [list -color white]                [list -emailshot 0 0]                [list -initial 0 0]                [list -label {} {}]                [list -level info info]                [list -script {} {}]                [list -scripttext {} {}]                [list -subject {} {}]                [list -type up up]                [list -test 0 0]                [list -value {} {}]            ]
        }

        proc set-active {this value} {
            if {!$switched::($this,complete)} return
            if {$value} {
                check $this $($this,array)
            } elseif {$($this,condition)} {
                cellThresholdCondition $($this,array) $($this,row) $($this,column)                    $switched::($this,-color) $switched::($this,-level) {}
                set ($this,condition) 0
            }
        }

        proc set-actonce {this value} {}

        proc set-addresses {this value} {}

        proc set-color {this value} {
            if {$switched::($this,complete) && $($this,condition)} {
                cellThresholdCondition $($this,array) $($this,row) $($this,column) $value $switched::($this,-level) [summary $this]
            }
        }

        proc set-emailshot {this value} {}

        proc set-initial {this value} {}

        proc set-label {this value} {}

        proc set-level {this value} {
            if {[lsearch -exact $thresholds::(levels) $value] < 0} {
                error {invalid level value}
            }
            if {$switched::($this,complete) && $($this,condition)} {
                cellThresholdCondition $($this,array) $($this,row) $($this,column) $switched::($this,-color) $value [summary $this]
            }
        }

        proc set-scripttext {this value} {}
        proc set-script {this value} {switched::configure $this -scripttext $value}

        proc set-test {this value} {}

        proc set-type {this value} {
            if {$switched::($this,complete)} {
                check $this $($this,array)
            }
        }

        proc set-value {this value} {
            if {$switched::($this,complete)} {
                check $this $($this,array)
            }
        }

        proc set-subject {this value} {}
        proc set-bodytext {this value} {}

        proc nextType {type} {
            set index [lsearch -exact $(types) $type]
            if {[incr index] >= [llength $(types)]} {
                set index 0
            }
            return [lindex $(types) $index]
        }

        proc typeImage {type} {
            return $(image,$type)
        }

        proc check {this array} {
            if {$switched::($this,-test) || ![string equal $array $($this,array)]} return
            set ($this,cellLabel) [lindex [viewer::label $array $($this,row) $($this,column) 1] 0]
            if {!$switched::($this,-active) || ([set ${array}(updates)] < 1)} return
            set threshold [string trim $switched::($this,-value)]
            catch {set value [set $($this,cell)]}
            set condition 0
            set act                [expr {(!$switched::($this,-actonce) || !$($this,condition)) && (!$switched::($this,-initial) || $($this,checked))}]
            if {![info exists value] || ([string equal $value ?] && $($this,numeric))} {
                if {[string equal $switched::($this,-type) unknown]} {
                    if {$act} {act $this {} ?}
                    set condition 1
                }
            } else {
                if {![string equal $switched::($this,-type) unknown] && [compare $this $threshold $value]} {
                    if {$act} {act $this $threshold $value}
                    set condition 1
                }
            }
            if {$condition} {
                set ($this,seconds) [clock seconds]
                set ($this,condition) 1
                cellThresholdCondition $($this,array) $($this,row) $($this,column)                    $switched::($this,-color) $switched::($this,-level) [summary $this]
if {$global::withGUI} {
                if {$global::traceThresholds && $act} {
                    if {![info exists value]} {if {$($this,numeric)} {set value ?} else {set value {}}}
                    modules::trace {} moodss(thresholds) [replacePercents $this $threshold $value $global::logMessage]
                }
}
            } elseif {$($this,condition)} {
                unset ($this,seconds)
                set ($this,condition) 0
                cellThresholdCondition $($this,array) $($this,row) $($this,column)                    $switched::($this,-color) $switched::($this,-level) {}
            }
            incr ($this,checked)
        }

if {$global::withGUI} {

        proc test {this} {
            if {[string equal $switched::($this,-type) unknown]} {
                act $this {} ?
                return $($this,output)
            }
            set threshold [string trim $switched::($this,-value)]
            switch $($this,cellType) {
                clock {
                    if {[catch {clock scan $threshold}]} {set threshold [clock format [clock seconds]]}
                }
                integer {
                    if {![string is integer -strict $threshold]} {set threshold 10}
                }
                real {
                    if {![string is double -strict $threshold]} {set threshold 10.0}
                }
            }
            if {[string equal $switched::($this,-type) equal]} {
                act $this $threshold $threshold
                return $($this,output)
            }
            switch $($this,cellType) {
                ascii - dictionary {
                    switch $switched::($this,-type) {
                        down {act $this $threshold {}}
                        differ - up {act $this $threshold ^${threshold}}
                    }
                }
                clock {
                    switch $switched::($this,-type) {
                        down {act $this $threshold [clock format [expr {[clock scan $threshold] - 1}]]}
                        differ - up {act $this $threshold [clock format [expr {[clock scan $threshold] + 1}]]}
                    }
                }
                integer - real {
                    switch $switched::($this,-type) {
                        down {act $this $threshold [expr {$threshold - 1}]}
                        differ - up {act $this $threshold [expr {$threshold + 1}]}
                    }
                }
            }
            return $($this,output)
        }

}

        proc replacePercents {this threshold value text} {
            regsub -all %% $text \001 text
            regsub -all %A $text $global::applicationName text
            regsub -all %c $text $($this,cellLabel) text
            regsub -all %l $text $switched::($this,-level) text
            regsub -all %s $text $switched::($this,-label) text
            regsub -all %t $text $threshold text
            regsub -all %T $text $switched::($this,-type) text
            regsub -all %v $text $value text
            regsub -all \001 $text % text
            return $text
        }

        proc compare {this threshold value} {
            return [compare-$($this,cellType) $switched::($this,-type) $threshold $value]
        }

        proc compare-ascii {type threshold value} {
            switch $type {
                differ {return [string compare -nocase $value $threshold]}
                down {return [expr {[string compare -nocase $value $threshold] < 0}]}
                equal {return [string equal -nocase $value $threshold]}
                up {return [expr {[string compare -nocase $value $threshold] > 0}]}
            }
        }

        proc compare-clock {type threshold value} {
            if {[catch {set threshold [clock scan $threshold -base 0]}] || [catch {set value [clock scan $value -base 0]}]} {
                return 0
            }
            switch $type {
                differ {return [expr {$value != $threshold}]}
                down {return [expr {$value < $threshold}]}
                equal {return [expr {$value == $threshold}]}
                up {return [expr {$value > $threshold}]}
            }
        }

        proc compare-dictionary {type threshold value} {
            switch $type {
                differ {return [string compare $value $threshold]}
                down {return [lindex [lindex [lsort -dictionary -index 0 [list [list $value 0] [list $threshold 1]]] 1] 1]}
                equal {return [string equal $value $threshold]}
                up {return [lindex [lindex [lsort -dictionary -index 0 [list [list $value 0] [list $threshold 1]]] 0] 1]}
            }
        }

        proc compareNumbers {type threshold value} {
            if {![string is double -strict $threshold] || ![string is double -strict $value]} {
                return [compare-dictionary $type $threshold $value]
            }
            switch $type {
                differ {return [expr {$value != $threshold}]}
                down {return [expr {$value < $threshold}]}
                equal {return [expr {$value == $threshold}]}
                up {return [expr {$value > $threshold}]}
            }
        }

        proc compare-integer {type threshold value} {
            return [compareNumbers $type $threshold $value]
        }

        proc compare-real {type threshold value} {
            return [compareNumbers $type $threshold $value]
        }

        proc act {this threshold value} {
            set ($this,output) {}
            if {[string length $switched::($this,-scripttext)] > 0} {
                set script [replacePercents $this $threshold $value $switched::($this,-scripttext)]
                if {[string equal $::tcl_platform(platform) unix]} {
                    if {![info exists ::env(SHELL)]} {set ::env(SHELL) sh}
                    set error [catch {exec 2>@ stdout $::env(SHELL) -c $script} ($this,output)]
                } else {
                    if {![info exists ::env(COMSPEC)]} {set ::env(COMSPEC) cmd}
                    set error [catch {eval exec [list $::env(COMSPEC)] /c $script} ($this,output)]
                }
                if {$error} {
                    set message "$switched::($this,-label): $($this,output)"
                    if {$global::withGUI} {
                        modules::trace {} moodss(thresholds) $message
                    } else {
                        writeLog $message error
                    }
                }
            }
            if {!$global::withGUI} {
                writeLog "($switched::($this,-level)) [replacePercents $this $threshold $value $global::logMessage]"                    $switched::($this,-level)
            }
            if {[llength $switched::($this,-addresses)] > 0} {
                if {[llength $global::smtpServers] == 0} {
                    set message {no SMTP servers defined}
                    if {$global::withGUI} {
                        modules::trace {} moodss(thresholds) [mc $message]
                    } else {
                        writeLog $message error
                    }
                } else {
                    set noDefault [string length $switched::($this,-subject)]
                    if {!$noDefault && ([string length $switched::($this,-bodytext)] == 0)} {
                        set body [replacePercents $this $threshold $value $global::mailBody]
                    } else {
                        set body [replacePercents $this $threshold $value $switched::($this,-bodytext)]
                    }
                    if {$switched::($this,-emailshot) && $global::withGUI} {
                        set shot [print::createTemporaryCanvasShot]
                        set token [mime::initialize -canonical multipart/mixed -parts [list                            [mime::initialize -canonical text/plain -string $body]                            [mime::initialize -canonical image/gif -file $shot]                        ]]
                    } else {
                        set token [mime::initialize -canonical text/plain -string $body]
                    }
                    lappend headers -servers [list $global::smtpServers]
                    lappend headers -header [list From $global::fromAddress]
                    foreach address $switched::($this,-addresses) {
                        lappend headers -header [list To $address]
                    }
                    if {$noDefault} {
                        set subject $switched::($this,-subject)
                    } else {
                        set subject $global::mailSubject
                    }
                    lappend headers -header [list Subject [replacePercents $this $threshold $value $subject]]
                    if {[catch {eval smtp::sendmessage $token $headers} error]} {
                        set message "SMTP error: $error"
                        if {[string length $($this,output)] > 0} {
                            append ($this,output) \n
                        }
                        append ($this,output) $message
                        if {$global::withGUI} {
                            modules::trace {} moodss(thresholds) $message
                        } else {
                            writeLog $message error
                        }
                    } else {
                        foreach list $error {
                            foreach {address code message} $list {
                                set message "$switched::($this,-label): on \"$address\", SMTP $code error: $message"
                                if {[string length $($this,output)] > 0} {
                                    append ($this,output) \n
                                }
                                append ($this,output) $message
                                if {$global::withGUI} {
                                    modules::trace {} moodss(thresholds) $message
                                } else {
                                    writeLog $message error
                                }
                            }
                        }
                    }
                    mime::finalize $token -subordinates all
                    if {[info exists shot]} {
                        file delete $shot
                    }
                }
            }
        }

        proc initializeLevelsMapping {} {
            variable level

            if {![info exists level]} {
                set index 0
                foreach name $thresholds::(levels) {
                    set level($name) $index
                    incr index
                }
            }
        }

if {$global::withGUI} {

        proc compareLevels {level1 level2} {
            variable level

            initializeLevelsMapping
            return [expr {$level($level2) - $level($level1)}]
        }

}

        proc comparison {threshold1 threshold2} {
            variable level

            initializeLevelsMapping
            set level1 $level($switched::($threshold1,-level))
            set level2 $level($switched::($threshold2,-level))
            if {$level1 == $level2} {
                if {                    [string equal $($threshold1,cell) $($threshold2,cell)] &&                    [string equal $switched::($threshold1,-type) $switched::($threshold2,-type)]                } {
                    set value1 [string trim $switched::($threshold1,-value)]
                    set value2 [string trim $switched::($threshold2,-value)]
                    if {[compare $threshold1 $value2 $value1]} {
                        return 1
                    } elseif {[compare $threshold1 $value1 $value2]} {
                        return -1
                    }
                }
                return 0
            } elseif {$level1 < $level2} {
                return 1
            } else {
                return -1
            }
        }

        proc summary {this} {
            if {$($this,condition)} {
                set threshold [string trim $switched::($this,-value)]
                set value ?
                catch {set value [set $($this,cell)]}
                return            "[clock format $($this,seconds) -format {%d %b %Y %T}]: [replacePercents $this $threshold $value $global::logMessage]"
            } else {
                return {}
            }
        }

        proc active {options} {
            array set value $options
            if {$value(-active)} {
                return [list [llength $value(-addresses)] [expr {[llength $value(-scripttext)] > 0}]]
            } else {
                return [list 0 0]
            }
        }

    }

}



class viewTable {

if {$global::withGUI} {
    set (monitorInstanceCellsMessage) [mc {in database history mode, can only monitor cells from a module instance data table}]
}

    proc viewTable {this args} {
        set ($this,nextRow) 0
    }

    proc ~viewTable {this} {
        variable ${this}cellRow

        catch {unset ${this}cellRow}
if {$global::withGUI} {
        delete $($this,dataTable)
}
        set dataName $($this,dataName)
        incr ${dataName}(updates)
        unset $dataName
    }

if {$global::withGUI} {

    proc createTable {this dataName dragDataCommand} {
        if {[info exists ($this,dataTable)]} {
            delete $($this,dataTable)
            unset ($this,dataTable)
        }
        set table [new dataTable $widget::($this,path)            -data $dataName -draggable $composite::($this,-draggable) -background $viewer::(background)        ]
        viewer::setupDropSite $this $dataTable::($table,tablePath)
        if {$composite::($this,-draggable)} {
            dragSite::provide $dataTable::($table,drag) OBJECTS $dragDataCommand
            dragSite::provide $dataTable::($table,drag) DATACELLS $dragDataCommand
        }
        pack $widget::($table,path) -fill both -expand 1
        set ($this,dataTable) $table
        set ($this,dataName) $dataName
    }

} else {

    proc setDataName {this name} {
        set ($this,dataName) $name
    }

}

    proc cells {this} {
        variable ${this}cellRow

        set lists {}
        foreach {cell row} [array get ${this}cellRow] {
            lappend lists [list $row $cell]
        }
        set cells {}
        foreach list [lsort -integer -index 0 $lists] {
            lappend cells [lindex $list end]
        }
        return $cells
    }

    proc setCellRows {this rows} {
        set ($this,cellRows) $rows
        set ($this,cellRowIndex) 0
    }

    proc row {this cell} {
        variable ${this}cellRow

        set row {}
        catch {set row [set ${this}cellRow($cell)]}
        return $row
    }

    proc register {this cell array} {
        variable ${this}cellRow

        viewer::registerTrace $this $array
        if {[info exists ($this,cellRowIndex)]} {
            set row [lindex $($this,cellRows) $($this,cellRowIndex)]
            if {[string length $row] == 0} {
                unset ($this,cellRowIndex) ($this,cellRows)
                set row $($this,nextRow)
            } else {
                incr ($this,cellRowIndex)
                if {$($this,nextRow) < $row} {set ($this,nextRow) $row}
            }
        } else {
            set row $($this,nextRow)
        }
        set ${this}cellRow($cell) $row
        incr ($this,nextRow)
        return $row
    }

    proc cellsAndRows {this} {
        variable ${this}cellRow

        return [array get ${this}cellRow]
    }

if {$global::withGUI} {

    proc dragCells {this} {
        variable ${this}cellRow

        foreach {cell row} [array get ${this}cellRow] {
            set original($row) $cell
        }
        set cells {}
        foreach cell [dataTable::dragData $($this,dataTable) DATACELLS] {
            viewer::parse $cell array row column type
            if {$column == 1} {
                lappend cells $original($row)
            } else {
                lappend cells $cell
            }
        }
        return $cells
    }

    proc deleteRow {this cell} {
        variable ${this}cellRow

        viewer::parse $cell array ignore ignore ignore
        viewer::unregisterTrace $this $array
        set row [set ${this}cellRow($cell)]
        unset ${this}cellRow($cell)
        return $row
    }

    proc initializationConfiguration {this} {
        variable ${this}cellRow

        scan [namespace tail $($this,dataName)] %u index
        set list [list -dataindex $index]
        foreach cell [cells $this] {
            lappend rows [set ${this}cellRow($cell)]
        }
        if {[info exists rows]} {
            lappend list -cellrows $rows
        }
        return $list
    }

    proc numberOfRows {this} {
        variable ${this}cellRow

        return [array size ${this}cellRow]
    }

    proc monitored {this cell} {
        variable ${this}cellRow

        return [expr {[info exists ${this}cellRow($cell)] || [dataTable::monitored $($this,dataTable) $cell]}]
    }

    proc setCellColor {this source color} {
        variable ${this}cellRow

        foreach {cell row} [array get ${this}cellRow] {
            if {[string equal $cell $source]} {
                dataTable::setCellColor $($this,dataTable) $row 1 $color
                return
            }
        }
    }

    proc selectedRows {this format} {
        foreach cell [dataTable::dragData $($this,dataTable) $format] {
            regexp {\(([^,]+)} $cell dummy row
            set selected($row) {}
        }
        return [array names selected]
    }

    proc update {this} {
        dataTable::update $($this,dataTable)
    }

    proc updateLabels {this} {
        variable ${this}cellRow

        set dataName $($this,dataName)
        foreach {cell row} [array get ${this}cellRow] {
            viewer::parse $cell array cellRow cellColumn ignore
            set ${dataName}($row,0) [lindex [viewer::label $array $cellRow $cellColumn] 0]
        }
        incr ${dataName}(updates)
    }

    proc updateTitleLabels {this} {
        dataTable::updateTitleLabels $($this,dataTable)
    }

}

}



class summaryTable {

if {$global::withGUI} {

    proc summaryTable {this parentPath args} composite {[new frame $parentPath] $args} viewTable {} viewer {} {
        composite::complete $this
        constructor $this
    }

} else {

    proc summaryTable {this args} switched {$args} viewTable {} viewer {} {
        switched::complete $this
        constructor $this
    }

}

    proc constructor {this} {
        set dataName ::summaryTable::$(nextDataIndex)data
        incr (nextDataIndex)
        catch {unset $dataName}
        array set $dataName [list            updates 0            0,label [mc data] 0,type ascii 0,message [mc {data cell description}]            1,label [mc current] 1,type real 1,message [mc {current value}]            2,label [mc average] 2,type real                2,message [mc {average value (since viewer creation in real time mode or for range in database mode)}]            3,label [mc minimum] 3,type real                3,message [mc {minimum value (since viewer creation in real time mode or for range in database mode)}]            4,label [mc maximum] 4,type real                4,message [mc {maximum value (since viewer creation in real time mode or for range in database mode)}]            5,label [mc deviation] 5,type real                5,message [mc {standard deviation (since viewer creation in real time mode or for range in database mode)}]            indexColumns 0            sort {0 increasing}        ]
if {$global::withGUI} {
        viewTable::createTable $this $dataName "summaryTable::dragData $this"
        updateMessage $this
} else {
        viewTable::setDataName $this $dataName
}
    }

    proc ~summaryTable {this} {
if {$global::withGUI} {
        variable ${this}cellRange

        foreach {name wish} [array get {} $this,rowLastWish,*] {
            delete $wish
        }
        catch {unset ${this}cellRange}
        if {[string length $composite::($this,-deletecommand)] > 0} {
            uplevel #0 $composite::($this,-deletecommand)
        }
} else {
        if {[string length $switched::($this,-deletecommand)] > 0} {
            uplevel #0 $switched::($this,-deletecommand)
        }
}
    }

if {$global::withGUI} {

    proc iconData {} {
        return {
            R0lGODdhJAAkAOMAAPj8+Hh4eAAAAHh8eNjc2ICEgIiQiJCYkKCkoKisqLi8uMDEwMjQyNDY0ODk4Ojs6CwAAAAAJAAkAAAE/hDIKQO99s5cNeUaiH2aYJ5o
            qqZbFQyDQBDDbN/1jRMmDIMymm43nNUEg84lmCs2h8ckQARA+q7YLBapDLxiAGF4TAjXyOSj9UeRAZLl+BiOLie505JZzj/z93hUa1qEWYEuMExFRotCPT5A
            jItPOlFKbZJOjZZ5S4WfW1IZXol7daZ/joNSEm50f69od6J6Yql+dZyCoLwxtFNfipObPKuYQsPDh0uZUMTLbb2gyyy2uamAKleup3bdb1VZBeMFAqjX3VHk
            4wbtBqvSoe7tB/UHwprKA/b1CP4I+Jzp++cvgcEEASs9G3DQoIKHClZInNgD4sMFGDHGA5URI4OPIyBDihxJsmSDkyhTqlzJsqWDlzBjypxJs+aDmzhz6tzJ
            s2cEADs=
        }
    }

}

    proc options {this} {
if {$global::withGUI} {
        set font $font::(mediumBold)
} else {
        set font {}
}
        return [list            [list -cellrows {} {}]            [list -dataindex {}]            [list -deletecommand {} {}]            [list -draggable 0 0]            [list -interval 0 0]        ]
    }

    proc set-cellrows {this value} {
if {$global::withGUI} {
        set complete $composite::($this,complete)
} else {
        set complete $switched::($this,complete)
}
        if {$complete} {
            error {option -cellrows cannot be set dynamically}
        }
        viewTable::setCellRows $this $value
    }

    set (nextDataIndex) 0
    proc reset {} {
        set (nextDataIndex) 0
    }
    proc set-dataindex {this value} {
if {$global::withGUI} {
        set complete $composite::($this,complete)
} else {
        set complete $switched::($this,complete)
}
        if {$complete} {
            error {option -dataindex cannot be set dynamically}
        }
        if {[string length $value] > 0} {
            if {$value < $(nextDataIndex)} {
                error "specified data index ($value) is lower than internal summary table index"
            }
            set (nextDataIndex) $value
        }
    }

    proc set-deletecommand {this value} {}

    proc set-draggable {this value} {
if {$global::withGUI} {
        set complete $composite::($this,complete)
} else {
        set complete $switched::($this,complete)
}
        if {$complete} {
            error {option -draggable cannot be set dynamically}
        }
    }

    proc set-interval {this value} {}

    proc supportedTypes {this} {
        return $global::numericDataTypes
    }

    proc monitorCell {this array row column} {
if {$global::withGUI} {
        variable ${this}cellRange
}

        set cell ${array}($row,$column)
        if {[string length [viewTable::row $this $cell]] > 0} return
if {$global::withGUI} {
        if {($composite::($this,-interval) == 0) && ![string equal [lindex [modules::decoded $array] 0] instance]} {
            lifoLabel::flash $global::messenger $viewTable::(monitorInstanceCellsMessage)
            return
        }
}
        foreach {label incomplete} [viewer::label $array $row $column] {}
        set row [viewTable::register $this $cell $array]
        set dataName $viewTable::($this,dataName)
        set ${dataName}($row,0) $label
        set current ?
        catch {set current [set $cell]}
        set ${dataName}($row,1) $current
        array set $dataName [list $row,2 ? $row,3 ? $row,4 ? $row,5 ?]
        set ${dataName}($row,updates) 0
        set ${dataName}($row,sum) 0.0
        set ${dataName}($row,squares) 0.0
if {$global::withGUI} {
        set ${this}cellRange($cell,start) 0
        set ${this}cellRange($cell,end) 0
        set ($this,rowLastWish,$row) [new lastWish "summaryTable::deleteRow $this $cell"]
}
        if {$incomplete} {
            set ($this,relabel,$row) {}
        }
        incr ${dataName}(updates)
if {$global::withGUI} {
        updateMessage $this
}
    }

    proc update {this array} {
        set dataName $viewTable::($this,dataName)
        set updated 0
        foreach {cell row} [viewTable::cellsAndRows $this] {
            if {[string first $array $cell] != 0} continue
            if {[catch {set current [set $cell]}] || [string equal $current ?]} {
                set ${dataName}($row,1) ?
                if {$global::withGUI && ($composite::($this,-interval) == 0)} {
                    processHistory $this $row $cell
                }
            } else {
                set ${dataName}($row,1) $current
                if {[string is double -strict $current]} {updateCalculations $this $row $cell}
            }
            if {[info exists ($this,relabel,$row)] && [info exists $cell]} {
                viewer::parse $cell ignore cellRow cellColumn type
                foreach [list ${dataName}($row,0) incomplete] [viewer::label $array $cellRow $cellColumn] {}
                if {!$incomplete} {
                    unset ($this,relabel,$row)
                }
            }
            set updated 1
        }
        if {$updated} {incr ${dataName}(updates)}
    }

    proc cells {this} {
        return [viewTable::cells $this]
    }

    proc updateCalculations {this row cell} {
        if {$global::withGUI && ($composite::($this,-interval) == 0)} {
            processHistory $this $row $cell
        } else {
            set dataName $viewTable::($this,dataName)
            set current [set ${dataName}($row,1)]
            set sum [expr {[set ${dataName}($row,sum)] + $current}]
            set updates [incr ${dataName}($row,updates)]
            set average [expr {$sum / $updates}]
            set ${dataName}($row,2) [format %.2f $average]
            set value [set ${dataName}($row,3)]
            if {[string equal $value ?] || ($current < $value)} {
                set ${dataName}($row,3) $current
            }
            set value [set ${dataName}($row,4)]
            if {[string equal $value ?] || ($current > $value)} {
                set ${dataName}($row,4) $current
            }
            set squares [expr {[set ${dataName}($row,squares)] + ($current * $current)}]
            set value 0
            catch {set value [expr {sqrt(($squares + ($updates * $average * $average) - (2 * $average * $sum)) / ($updates - 1))}]}
            set ${dataName}($row,5) [format %.2f $value]
            set ${dataName}($row,sum) $sum
            set ${dataName}($row,squares) $squares
        }
    }

if {$global::withGUI} {

    proc processHistory {this row cell} {
        variable ${this}cellRange

        set dataName $viewTable::($this,dataName)
        foreach {start end} [databaseInstances::range $cell] {}
        if {[string length $start] == 0} {
            set ${this}cellRange($cell,start) 0
            set ${this}cellRange($cell,end) 0
            set ${dataName}($row,2) ?
            set ${dataName}($row,3) ?
            set ${dataName}($row,4) ?
            set ${dataName}($row,5) ?
            return
        }
        if {([set ${this}cellRange($cell,start)] == $start) && ([set ${this}cellRange($cell,end)] == $end)} {
            return
        }
        blt::vector create values
        set start 0
        foreach {stamp value} [databaseInstances::history $cell] {
            if {$start == 0} {set start $stamp}
            if {[string length $value] == 0} continue
            values append $value
        }
        if {[info exists stamp]} {
            set ${this}cellRange($cell,start) $start
            set ${this}cellRange($cell,end) $stamp
        }
        if {[values length] > 0} {
            blt::vector create result
            result expr {mean(values)}
            set ${dataName}($row,2) [format %.2f [result index 0]]
            result expr {min(values)}
            regsub {\.0$} [result index 0] {} ${dataName}($row,3)
            result expr {max(values)}
            regsub {\.0$} [result index 0] {} ${dataName}($row,4)
            result expr {sdev(values)}
            set ${dataName}($row,5) [format %.2f [result index 0]]
            blt::vector destroy result
        } else {
            set ${dataName}($row,2) ?
            set ${dataName}($row,3) ?
            set ${dataName}($row,4) ?
            set ${dataName}($row,5) ?
        }
        blt::vector destroy values
    }

    proc dragData {this format} {
        switch $format {
            OBJECTS {
                set lastWishes {}
                foreach row [viewTable::selectedRows $this $format] {
                    lappend lastWishes $($this,rowLastWish,$row)
                }
                if {[llength $lastWishes] == 0} {
                    return $this
                } else {
                    return $lastWishes
                }
            }
            DATACELLS {
                return [viewTable::dragCells $this]
            }
        }
    }

    proc deleteRow {this cell} {
        variable ${this}cellRange

        set dataName $viewTable::($this,dataName)
        set row [viewTable::deleteRow $this $cell]
        unset ${dataName}($row,0) ${dataName}($row,1) ${dataName}($row,2) ${dataName}($row,3) ${dataName}($row,4)            ${dataName}($row,5) ($this,rowLastWish,$row) ${dataName}($row,updates) ${dataName}($row,sum) ${dataName}($row,squares)
        catch {unset ${this}cellRange($cell,start) ${this}cellRange($cell,end)}
        viewTable::update $this
        updateMessage $this
    }

    proc initializationConfiguration {this} {
        return [viewTable::initializationConfiguration $this]
    }

    proc monitored {this cell} {
        return [viewTable::monitored $this $cell]
    }

    proc setCellColor {this source color} {
        viewTable::setCellColor $this $source $color
    }

    proc updateMessage {this} {
        if {[viewTable::numberOfRows $this]} {
            centerMessage $widget::($this,path) {}
        } else {
            centerMessage $widget::($this,path)                [mc "statistics table:\ndrop data cell(s)"] $viewer::(background) $global::viewerMessageColor
        }
    }

    proc updateLabels {this} {
        viewTable::updateLabels $this
    }

}

}



class currentValueTable {

if {$global::withGUI} {

    proc currentValueTable {this parentPath realTime args} composite {[new frame $parentPath] $args} viewTable {} viewer {} {
        composite::complete $this
        constructor $this $realTime
    }

} else {

    proc currentValueTable {this args} switched {$args} viewTable {} viewer {} {
        switched::complete $this
        constructor $this
    }

}

    proc constructor {this {realTime {}}} {
        set dataName ::currentValueTable::$(nextDataIndex)data
        incr (nextDataIndex)
        catch {unset $dataName}
        array set $dataName [list            updates 0            0,label [mc data] 0,type ascii 0,message [mc {data cell description}]            1,label [mc current] 1,type real 1,message [mc {current value}]            indexColumns 0            sort {0 increasing}        ]
if {$global::withGUI} {
        if {!$realTime} {
            array set $dataName [list                0,label [mc instant] 0,type clock 0,message [mc {record date and time (empty to show start of truncation)}]            ]
            resetValueColumn $this $dataName
            set ($this,archived) {}
            composite::configure $this -draggable 0
        }
        viewTable::createTable $this $dataName "currentValueTable::dragData $this"
        updateMessage $this
} else {
        viewTable::setDataName $this $dataName
}
    }

    proc ~currentValueTable {this} {
if {$global::withGUI} {
        variable ${this}cellRange

        foreach {name wish} [array get {} $this,rowLastWish,*] {
            delete $wish
        }
        catch {unset ${this}cellRange}
        if {[info exists ($this,cell)]} {
            viewer::parse $($this,cell) array ignore ignore ignore
            viewer::unregisterTrace $this $array
        }
        if {[string length $composite::($this,-deletecommand)] > 0} {
            uplevel #0 $composite::($this,-deletecommand)
        }
} else {
        if {[string length $switched::($this,-deletecommand)] > 0} {
            uplevel #0 $switched::($this,-deletecommand)
        }
}
    }

if {$global::withGUI} {

    proc iconData {} {
        return {
            R0lGODdhJAAkAOMAAPj8+Hh4eHh8eAAAANjc2ICEgIiQiJCYkKCkoKisqLi8uMDEwMjQyNDY0ODk4Ojs6CwAAAAAJAAkAAAE/hDIKQO99s5cNeUaiH3eVgIi
            aaJB675wLLtCnXblje+ejp6g22BILBIFxuQA16ohCdBoVAAgVK/WbHXoFA2kYIF2jAUMqEKwlEpun3+as3NOr9PfmWbtq4ayy25yAl59fm2AZmgefH1/h1l4
            i3aTlJEsToxqjoiQglQUmWGPZZYXoWucgKWghQRiqVqWekiUtXeepq2bj6sTp1OjsYpxurBYlkm2ykhGd8XBW3QF09O/hsZWZ9QFBt3d1q7Y0d4GB+bm4K/Q
            Z+cHCO/vSvLzXPAICfj4B8vL+QkKAAMKHEiwoMEFCBMqXMiwoUMGECNKnEixosUGGDNq3Mixo0cHEiBDihxJsqTJByhTqlzJsqXLCAA7
        }
    }

}

    proc options {this} {
if {$global::withGUI} {
        set font $font::(mediumBold)
} else {
        set font {}
}
        return [list            [list -cellrows {} {}]            [list -dataindex {}]            [list -deletecommand {} {}]            [list -draggable 0 0]            [list -interval 0 0]        ]
    }

    proc set-cellrows {this value} {
if {$global::withGUI} {
        set complete $composite::($this,complete)
} else {
        set complete $switched::($this,complete)
}
        if {$complete} {
            error {option -cellrows cannot be set dynamically}
        }
        viewTable::setCellRows $this $value
    }

    set (nextDataIndex) 0
    proc reset {} {
        set (nextDataIndex) 0
    }
    proc set-dataindex {this value} {
if {$global::withGUI} {
        set complete $composite::($this,complete)
} else {
        set complete $switched::($this,complete)
}
        if {$complete} {
            error {option -dataindex cannot be set dynamically}
        }
        if {[string length $value] > 0} {
            if {$value < $(nextDataIndex)} {
                error "specified data index ($value) is lower than internal values table index"
            }
            set (nextDataIndex) $value
        }
    }

    proc set-deletecommand {this value} {}

    proc set-draggable {this value} {
if {$global::withGUI} {
        set noChange [expr {$composite::($this,complete) && ![info exists ($this,archived)]}]
} else {
        set noChange $switched::($this,complete)
}
        if {$noChange} {
            error {option -draggable cannot be set dynamically}
        }
    }

    proc set-interval {this value} {}

    proc supportedTypes {this} {
        return $global::dataTypes
    }

    proc monitorCell {this array row column} {
if {$global::withGUI} {
        variable ${this}cellRange
}

        set cell ${array}($row,$column)
        if {[string length [viewTable::row $this $cell]] > 0} return
if {$global::withGUI} {
        if {[info exists ($this,archived)] && ![string equal [lindex [modules::decoded $array] 0] instance]} {
            lifoLabel::flash $global::messenger $viewTable::(monitorInstanceCellsMessage)
            return
        }
}
        foreach {label incomplete} [viewer::label $array $row $column] {}
        set dataName $viewTable::($this,dataName)
        if {[info exists ($this,archived)]} {
            resetValueColumn $this $dataName
            set ${dataName}(1,label) $label
            foreach {ignore type message ignore} [databaseInstances::entryData $cell] {}
            catch {
                set ${dataName}(1,type) $type
                set ${dataName}(1,message) $message
            }
            clearData $this
            viewTable::createTable $this $dataName "currentValueTable::dragData $this"
            updateMessage $this 1
            set ${this}cellRange($cell,start) 0
            set ${this}cellRange($cell,end) 0
            if {![info exists ($this,cell)]} {
                viewer::registerTrace $this $array
            }
            set ($this,cell) $cell
            return
        }
        set row [viewTable::register $this $cell $array]
        set ${dataName}($row,0) $label
        set current ?
        catch {set current [set $cell]}
        set ${dataName}($row,1) $current
if {$global::withGUI} {
        set ($this,rowLastWish,$row) [new lastWish "currentValueTable::deleteRow $this $cell"]
}
        if {$incomplete} {
            set ($this,relabel,$row) {}
        }
        incr ${dataName}(updates)
if {$global::withGUI} {
        updateMessage $this
}
    }

    proc update {this array} {
        if {[info exists ($this,archived)]} {
            if {[info exists ($this,cell)]} {
                processHistory $this $($this,cell)
            }
        } else {
            set dataName $viewTable::($this,dataName)
            set updated 0
            foreach {cell row} [viewTable::cellsAndRows $this] {
                if {[string first $array $cell] != 0} continue
                if {[catch {set current [set $cell]}] || [string equal $current ?]} {
                    set ${dataName}($row,1) ?
                } else {
                    set ${dataName}($row,1) $current
                }
                if {[info exists ($this,relabel,$row)] && [info exists $cell]} {
                    viewer::parse $cell ignore cellRow cellColumn type
                    foreach [list ${dataName}($row,0) incomplete] [viewer::label $array $cellRow $cellColumn] {}
                    if {!$incomplete} {
                        unset ($this,relabel,$row)
                    }
                }
                set updated 1
            }
            if {$updated} {incr ${dataName}(updates)}
        }
    }

    proc cells {this} {
        set list {}
        if {[info exists ($this,archived)]} {
            catch {set list $($this,cell)}
        } else {
            set list [viewTable::cells $this]
        }
        return $list
    }

if {$global::withGUI} {

    proc clearData {this} {
        array unset $viewTable::($this,dataName) {[0-9]*,[0-9]*}
    }

    proc processHistory {this cell} {
        variable ${this}cellRange

        set dataName $viewTable::($this,dataName)
        foreach {start end} [databaseInstances::range $cell] {}
        if {[string length $start] == 0} {
            clearData $this
            set ${this}cellRange($cell,start) 0
            set ${this}cellRange($cell,end) 0
            incr ${dataName}(updates)
            return
        }
        if {([set ${this}cellRange($cell,start)] == $start) && ([set ${this}cellRange($cell,end)] == $end)} {
            return
        }
        if {[viewer::numericType [set ${dataName}(1,type)]]} {set void ?} else {set void {}}
        clearData $this
        set row 0
        set list [databaseInstances::history $cell]
        if {[llength $list] > (2 * $global::currentValueTableRows)} {
            array set $dataName [list $row,0 {} $row,1 $void]
            incr row
        }
        set start 0
        foreach {stamp value} [lrange $list end-[expr {2 * $global::currentValueTableRows} - 1] end] {
            if {$start == 0} {set start $stamp}
            if {[string length $value] == 0} {
                set value $void
            }
            array set $dataName [list $row,0 $stamp $row,1 $value]
            incr row
        }
        if {[info exists stamp]} {
            set ${this}cellRange($cell,start) $start
            set ${this}cellRange($cell,end) $stamp
        }
        incr ${dataName}(updates)
    }

    proc dragData {this format} {
        switch $format {
            OBJECTS {
                set lastWishes {}
                foreach row [viewTable::selectedRows $this OBJECTS] {
                    lappend lastWishes $($this,rowLastWish,$row)
                }
                if {[llength $lastWishes] == 0} {
                    return $this
                } else {
                    return $lastWishes
                }
            }
            DATACELLS {
                return [viewTable::dragCells $this]
            }
        }
    }

    proc deleteRow {this cell} {
        set dataName $viewTable::($this,dataName)
        set row [viewTable::deleteRow $this $cell]
        unset ${dataName}($row,0) ${dataName}($row,1) ($this,rowLastWish,$row)
        viewTable::update $this
        updateMessage $this
    }

    proc initializationConfiguration {this} {
        return [viewTable::initializationConfiguration $this]
    }

    proc monitored {this cell} {
        return [viewTable::monitored $this $cell]
    }

    proc setCellColor {this source color} {
        viewTable::setCellColor $this $source $color
    }

    proc updateMessage {this {forceEmpty 0}} {
        if {[viewTable::numberOfRows $this] || $forceEmpty} {
            centerMessage $widget::($this,path) {}
        } else {
            centerMessage $widget::($this,path)                [mc "values table:\ndrop data cell(s)"] $viewer::(background) $global::viewerMessageColor
        }
    }

    proc resetValueColumn {this dataName} {
        array set $dataName [list 1,label ? 1,type dictionary 1,message [mc {archived data name}]]
    }

    proc updateLabels {this} {
        if {[info exists ($this,archived)]} {
            viewer::parse $($this,cell) array row column ignore
            set dataName $viewTable::($this,dataName)
            set ${dataName}(1,label) [lindex [viewer::label $array $row $column] 0]
            viewTable::updateTitleLabels $this
        } else {
            viewTable::updateLabels $this
        }
    }

}

}



namespace eval formulas {

if {$global::withGUI} {
    set (existingMessage) [mc {identical expression found in existing formula "%s"}]
}

    class table {

if {$global::withGUI} {

        proc table {this parentPath args} composite {[new frame $parentPath] $args} viewer {} {
            composite::complete $this
            constructor $this $composite::($this,-object) $composite::($this,-category)
            set table [new dataTable $widget::($this,path)                -data $($this,dataName) -draggable $composite::($this,-draggable) -background $viewer::(background)            ]
            pack $widget::($table,path) -fill both -expand 1
            set tablePath $dataTable::($table,tablePath)
            if {!$global::readOnly} {
                set menu [menu $tablePath.menu -tearoff 0]
                set ($this,help) [new menuContextHelp $menu]
                $menu add command -label [mc Edit]... -command "formulasDialog $this \$($this,pointed)"
                menuContextHelp::set $($this,help) 0 [mc {edit formulas in this table}]
                bindtags $tablePath [concat [bindtags $tablePath] PopupMenu$this]
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    bind PopupMenu$this <ButtonPress-3> "
                        if {\[string length \$::tkPriv(popup)\] == 0} {
                            set ($this,pointed) \[formulas::table::pointed $this %x %y\]
                            tk_popup $menu %X %Y
                        }
                    "
                } else {
                    bind PopupMenu$this <ButtonPress-3> "
                        if {\[string length \$::tk::Priv(popup)\] == 0} {
                            set ($this,pointed) \[formulas::table::pointed $this %x %y\]
                            tk_popup $menu %X %Y
                        }
                    "
                }
            }
            set ($this,drop) [new dropSite -path $tablePath -formats {FORMULAS KILL} -command "formulas::table::handleDrop $this"]
            set bindings [new bindings $tablePath end]
            bindings::set $bindings <Enter> "formulas::table::enter $this %x %y"
            bindings::set $bindings <Leave> "formulas::table::leave $this"
            set ($this,bindings) $bindings
            set ($this,tablePath) $tablePath
            set ($this,table) $table
            set configurations $composite::($this,-configurations); set rows $composite::($this,-rows)
            if {[llength $configurations] != [llength $rows]} {
                error "fatal dashboard file error: [llength $configurations] configurations but [llength $rows] rows"
            }
            set formulas [createFormulas $this $configurations $rows]
            if {[llength $formulas] == 0} {
                set label [centerMessage $tablePath                    [mc "formulas table:\ndrop or edit formulas"] $viewer::(background) $global::viewerMessageColor                ]
                if {!$global::readOnly} {
                    bindtags $label [concat [bindtags $label] PopupMenu$this]
                }
            } else {
                manage $this $formulas
            }
            set ($this,constructed) {}
            set-state $this $composite::($this,-state)
        }

} else {

        proc table {this args} switched {$args} viewer {} {
            switched::complete $this
            constructor $this $switched::($this,-object) $switched::($this,-category)
            set formulas [createFormulas $this $switched::($this,-configurations) $switched::($this,-rows)]
            if {[llength $formulas] > 0} {
                manage $this $formulas
            }
        }

}

        proc constructor {this object category} {
            set ($this,nextRow) 0
            set dataName ::formulas::table::$(nextDataIndex)data
            catch {unset $dataName}
            array set $dataName [list                updates 0                0,label [mc formula] 0,type ascii                1,label [mc value] 1,type real                indexColumns 0                sort {0 increasing}            ]
            set ($this,dataName) $dataName
            set instance [modules::loadFormulasModule $(nextDataIndex) $object $category]
            set ($this,namespace) $modules::instance::($instance,namespace)
            foreach [list ${dataName}(0,message) ${dataName}(1,message)] [$($this,namespace)::messages] {}
            set ($this,instance) $instance
            incr (nextDataIndex)
        }

        proc createFormulas {this configurations rows} {
            set formulas {}
            foreach options $configurations row $rows {
                set formula [eval new formulas::formula $options]
                set ($this,row,$formula) $row
                if {$row >= $($this,nextRow)} {set ($this,nextRow) [expr {$row + 1}]}
                lappend formulas $formula
            }
            return $formulas
        }

        proc ~table {this} {
            variable ${this}count

            foreach formula [formulas $this] {delete $formula}
            catch {unset ${this}count}
if {$global::withGUI} {
            catch {delete $($this,tip)}
            delete $($this,drop) $($this,bindings) $($this,table)
            if {[info exists ($this,help)]} {delete $($this,help)}
}
            set dataName $($this,dataName)
            incr ${dataName}(updates)
            unset $dataName
            modules::unload $($this,instance)
if {$global::withGUI} {
            if {[string length $composite::($this,-deletecommand)] > 0} {
                uplevel #0 $composite::($this,-deletecommand)
            }
} else {
            if {[string length $switched::($this,-deletecommand)] > 0} {
                uplevel #0 $switched::($this,-deletecommand)
            }
}
        }

        proc options {this} {
            return [list                [list -category {} {}]                [list -configurations {} {}]                [list -dataindex {}]                [list -deletecommand {} {}]                [list -draggable 0 0]                [list -object {} {}]                [list -rows {} {}]                [list -state normal]            ]
        }

        set (nextDataIndex) 0
        proc reset {} {
            set (nextDataIndex) 0
        }
        proc set-dataindex {this value} {
if {$global::withGUI} {
            set complete $composite::($this,complete)
} else {
            set complete $switched::($this,complete)
}
            if {$complete} {
                error {option -dataindex cannot be set dynamically}
            }
            if {[string length $value] > 0} {
                if {$value < $(nextDataIndex)} {
                    error "specified data index ($value) is lower than internal formulas table index"
                }
                set (nextDataIndex) $value
            }
        }

        proc set-deletecommand {this value} {}

        proc set-draggable {this value} {
if {$global::withGUI} {
            set complete $composite::($this,complete)
} else {
            set complete $switched::($this,complete)
}
            if {$complete} {
                error {option -draggable cannot be set dynamically}
            }
        }

        proc set-configurations {this value} {}

        proc set-rows {this value} {}

        proc set-category {this value} {
if {$global::withGUI} {
            set complete $composite::($this,complete)
} else {
            set complete $switched::($this,complete)
}
            if {$complete} {
                error {option -category cannot be set dynamically}
            }
        }

        proc set-object {this value} {
if {$global::withGUI} {
            set complete $composite::($this,complete)
} else {
            set complete $switched::($this,complete)
}
            if {$complete} {
                error {option -object cannot be set dynamically}
            }
        }

if {$global::withGUI} {

        proc set-state {this value} {
            if {![info exists ($this,constructed)]} return
            switch $value {
                disabled {
                    if {$composite::($this,-draggable)} {
                        set drag $dataTable::($($this,table),drag)
                        dragSite::provide $drag FORMULAS {}
                        dragSite::provide $drag OBJECTS {}
                        dragSite::provide $drag DATACELLS {}
                    }
                    switched::configure $($this,drop) -state disabled
                }
                normal {
                    if {$composite::($this,-draggable)} {
                        set drag $dataTable::($($this,table),drag)
                        dragSite::provide $drag FORMULAS "formulas::table::dragData $this"
                        dragSite::provide $drag OBJECTS "formulas::table::dragData $this"
                        dragSite::provide $drag DATACELLS "formulas::table::dragData $this"
                    }
                    switched::configure $($this,drop) -state normal
                }
                default {
                    error "bad state value \"$value\": must be normal or disabled"
                }
            }
        }

} else {

        proc set-state {this value} {}

}

        proc cells {this} {
            return {}
        }

        proc manage {this formulas {update 0}} {
            variable ${this}count

if {$global::withGUI} {
            if {[llength $formulas] > 0} {
                centerMessage $($this,tablePath) {}
            }
}
            set dataName $($this,dataName)
            set anyConstant 0
            set anyNameChange 0
            foreach formula $formulas {
                switched::configure $formula -deletecommand "formulas::table::deleted $this $formula"
                set name [switched::cget $formula -name]
                if {[info exists ($this,row,$formula)]} {
                    set row $($this,row,$formula)
                    if {[info exists ${dataName}($row,0)] && ![string equal [set ${dataName}($row,0)] $name]} {
                        set anyNameChange 1
                    }
                } else {
                    $($this,namespace)::new [set row [set ($this,row,$formula) $($this,nextRow)]]
                    incr ($this,nextRow)
                }
                set ${dataName}($row,0) $name
                set ${dataName}($row,1) ?
                set cells [switched::cget $formula -cells]
                if {[llength $cells] == 0} {
                    set ${this}count($formula,) 1
                    catch {set ${dataName}($row,1) [formulas::formula::value $formula]}
                    set anyConstant 1
                } else {
                    array unset ${this}count $formula,*
                    foreach cell $cells {
                        viewer::parse $cell array ignore ignore ignore
                        if {![catch {set asynchronous [modules::asynchronous $array]}] && $asynchronous} {
                            viewer::registerTrace $this $array
                        }
                        if {![info exists ${this}count($formula,$array)]} {set ${this}count($formula,$array) 0}
                        incr ${this}count($formula,$array)
                        set arrays($array) {}
                    }
                }
                $($this,namespace)::name $row [set ${dataName}($row,0)]
                $($this,namespace)::value $row [set ${dataName}($row,1)]
                set managed($formula) {}
            }
            if {$update} {
                foreach formula [formulas $this] {
                    if {![info exists managed($formula)]} {
                        delete $formula
                    }
                }
            }
            if {$anyConstant} {
                $($this,namespace)::update
if {$global::withGUI} {
                dataTable::update $($this,table)
}
            }
            foreach array [array names arrays] {
                update $this $array
            }
            return $anyNameChange
        }

        proc update {this {array *}} {
            variable ${this}count

            foreach name [array names ${this}count "\[0-9\]*,$array"] {
                set update([lindex [split $name ,] 0]) {}
            }
            set dataName $($this,dataName)
            set updated 0
            foreach name [array names update] {
                set formula [lindex [split $name ,] 0]
                set value ?; catch {set value [formulas::formula::value $formula]}
                set row $($this,row,$formula)
                $($this,namespace)::value $row [set ${dataName}($row,1) $value]
                set updated 1
            }
            if {$updated} {
                incr ${dataName}(updates)
                $($this,namespace)::update
            }
        }

        proc deleted {this formula} {
            variable ${this}count

            set cells [switched::cget $formula -cells]
            if {[llength $cells] == 0} {
                if {[incr ${this}count($formula,) -1] == 0} {unset ${this}count($formula,)}
            } else {
                foreach cell [switched::cget $formula -cells] {
                    viewer::parse $cell array ignore ignore ignore
                    if {![catch {set asynchronous [modules::asynchronous $array]}] && $asynchronous}  {
                        viewer::unregisterTrace $this $array
                    }
                    if {[incr ${this}count($formula,$array) -1] == 0} {unset ${this}count($formula,$array)}
                }
            }
            set row $($this,row,$formula)
            set dataName $($this,dataName)
            unset ${dataName}($row,0) ${dataName}($row,1) ($this,row,$formula)
            $($this,namespace)::delete $row
            $($this,namespace)::update
if {$global::withGUI} {
            dataTable::update $($this,table)
}
        }

        proc formulas {this} {
            set list {}
            foreach name [array names {} $this,row,*] {
                lappend list [lindex [split $name ,] end]
            }
            return [lsort -integer $list]
        }

if {$global::withGUI} {

        proc initializationConfiguration {this} {
            scan [namespace tail $($this,dataName)] %u index
            set arguments {}
            set rows {}
            foreach formula [formulas $this] {
                set list {}
                foreach option {cellindexes cells commenttext name text} {
                    lappend list -$option [switched::cget $formula -$option]
                }
                lappend rows $($this,row,$formula)
                lappend arguments $list
            }
            return [list                -dataindex $index -rows $rows -object $composite::($this,-object) -category $composite::($this,-category)                -configurations $arguments            ]
        }

        proc handleDrop {this} {
            if {![catch {set formulas $dragSite::data(FORMULAS)}]} {
                foreach formula $formulas {
                    set identical 0
                    foreach existing [formulas $this] {
                        if {[formulas::formula::equal $existing $formula]} {set identical $existing; break}
                    }
                    if {$identical > 0} {
                        lifoLabel::flash $global::messenger [format $formulas::(existingMessage) [switched::cget $identical -name]]
                        continue
                    }
                    manage $this [new $formula]
                }
            } elseif {[info exists dragSite::data(KILL)]} {
                delete $this
            }
        }

        proc dragData {this format} {
            set cells [dataTable::dragData $($this,table) DATACELLS]
            switch $format {
                FORMULAS - OBJECTS {
                    foreach cell $cells {
                        regexp {\(([^,]+)} $cell dummy row
                        foreach {name value} [array get {} $this,row,*] {
                            if {$value == $row} {
                                set formulas([lindex [split $name ,] end]) {}
                                break
                            }
                        }
                    }
                    set objects [array names formulas]
                    if {([llength $objects] == 0) && [string equal $format OBJECTS]} {
                        return $this
                    } else {
                        return $objects
                    }
                }
                DATACELLS {
                    set namespace $($this,namespace)
                    set list {}
                    foreach cell $cells {
                        regexp {\((.+)\)$} $cell dummy coordinates
                        lappend list ${namespace}::data($coordinates)
                    }
                    return $list
                }
            }
        }

        proc pointed {this x y} {
            set row [dataTable::dataRow $($this,table) [$($this,tablePath) index @$x,$y row]]
            if {[string length $row] > 0} {
                foreach {name value} [array get {} $this,row,*] {
                    if {$value == $row} {return [lindex [split $name ,] end]}
                }
            }
            return 0
        }

        proc enter {this x y} {
            raiseExistingFormulasDialog
            bindings::set $($this,bindings) <Motion> "formulas::table::motion $this %x %y"
            set ($this,cell) [$($this,tablePath) index @$x,$y]
            in $this $($this,cell) $x $y
        }

        proc leave {this} {
            bindings::set $($this,bindings) <Motion> {}
            catch {unset ($this,cell)}
        }

        proc motion {this x y} {
            set cell [$($this,tablePath) index @$x,$y]
            if {![info exists ($this,cell)]} {set ($this,cell) cell}
            if {[string equal $cell $($this,cell)]} return
            in $this [set ($this,cell) $cell] $x $y
        }

        proc in {this cell x y} {
            scan $cell %d,%d row column
            if {($row < 0) || ($column != 0)} return
            set formula [pointed $this $x $y]
            if {$formula == 0} return
            foreach {left top width height} [$($this,tablePath) bbox $cell] {}
            if {![info exists height]} return
            catch {delete $($this,tip)}
            set ($this,tip) [new widgetTip                -path $($this,tablePath) -text [switched::cget $formula -commenttext]                -rectangle [list $left $top [expr {$left + $width}] [expr {$top + $height}]] -ephemeral 1            ]
        }

        proc monitored {this cell} {
            return [dataTable::monitored $($this,table) $cell]
        }

        proc setCellColor {this source color} {
            if {![string equal [namespace qualifiers $source] $($this,namespace)]} return
            scan $source {%*[^(](%lu,%u)} row column
            dataTable::setCellColor $($this,table) $row $column $color
        }

        proc title {this} {
            regsub {<0>$} $modules::instance::($($this,instance),identifier) {} title
            return $title
        }

}

    }


    class formula {

        proc formula {this args} switched {$args} {
            if {![info exists (interpreter)]} {set (interpreter) [interpreter $this]}
            switched::complete $this
        }

        proc formula {this copy} switched {} {
            if {![info exists (interpreter)]} {set (interpreter) [interpreter $this]}
            switched::complete $this
            copyOptions $this $copy
        }

        proc ~formula {this} {
            variable ${this}cell
            variable ${this}last

            catch {unset ${this}cell}
            catch {unset ${this}last}
            if {[string length $switched::($this,-deletecommand)] > 0} {
                uplevel #0 $switched::($this,-deletecommand)
            }
        }

        proc interpreter {this} {
            set interpreter [interp create -safe]
            foreach variable [$interpreter eval {info globals}] {
                $interpreter eval "unset $variable"
            }
            foreach command [$interpreter eval {info commands}] {
                switch $command {expr - rename continue}
                $interpreter eval "rename $command {}"
            }
            $interpreter eval {rename rename {}}
            interp recursionlimit $interpreter 1
            return $interpreter
        }

        proc copyOptions {to from} {
            switched::configure $to -cellindexes [switched::cget $from -cellindexes] -cells [switched::cget $from -cells]                -commenttext [switched::cget $from -commenttext] -name [switched::cget $from -name]                -text [switched::cget $from -text] -deletecommand [switched::cget $from -deletecommand]
        }

        proc options {this} {
            return [list                [list -cellindexes {} {}]                [list -cells {} {}]                [list -commenttext {} {}]                [list -deletecommand {} {}]                [list -name {} {}]                [list -text {} {}]            ]
        }

        proc set-cellindexes {this value} {
            catch {unset ($this,expression)}
        }
        proc set-cells {this value} {
            catch {unset ($this,expression)}
        }
        proc set-text {this value} {
            catch {unset ($this,expression)}
        }

        proc set-commenttext {this value} {}

        proc set-deletecommand {this value} {}

        proc set-name {this value} {}

        proc expression {this} {
            variable ${this}cell
            variable ${this}last

            catch {unset ${this}cell}
            catch {unset ${this}last}
            set text $switched::($this,-text)
            set offset(0) 0
            set length 0; set index 0
            foreach line [split $text \n] {
                incr length [string length $line]
                set offset([incr index]) [incr length]
            }
            set indexes {}
            foreach value $switched::($this,-cellindexes) {
                foreach {line index} [split $value .] {}
                incr line -1
                lappend indexes [expr {$offset($line) + $index}]
            }
            set expression {}
            set first 0
            foreach index $indexes cell $switched::($this,-cells) {
                viewer::parse $cell array row column ignore
                set key $array,$row,$column
                set ${this}cell($key) $cell
                set string [string range $text $first [expr {$index - 1}]]
                switch -regexp -- $string {
                    {delta\s*\(\s*$} {
                        regsub {delta\s*\(\s*$} $string {} string
                        append expression $string \( int(\${$cell}-\${formulas::formula::${this}last($key)})
                        set last($key) {}
                    }
                    {diff\s*\(\s*$} {
                        regsub {diff\s*\(\s*$} $string {} string
                        append expression $string \( double(\${$cell})-\${formulas::formula::${this}last($key)}
                        set last($key) {}
                    }
                    {last\s*\(\s*$} {
                        regsub {last\s*\(\s*$} $string {} string
                        append expression $string \( \${formulas::formula::${this}last($key)}
                        set last($key) {}
                    }
                    default {
                        append expression $string \${$cell}
                    }
                }
                set first [expr {$index + 1}]
            }
            append expression [string range $text $first end]
            set ($this,last) [array names last]
            return $expression
        }

        proc value {this} {
            variable ${this}cell
            variable ${this}last

            check $this
            if {![info exists ($this,expression)]} {
                set ($this,expression) [expression $this]
            }
            set error 0
            set now [expr {[clock clicks -milliseconds] / 1000.0}]
            set seconds ?; catch {set seconds [expr {$now - $($this,seconds)}]}
            set ($this,seconds) $now
            set pattern {diff\s*\(\s*time\s*\)}
            if {([regsub -all $pattern $($this,expression) $seconds expression] > 0) && [string equal $seconds ?]} {
                set result {diff(time) not yet available}
                set error 1
            } else {
                foreach key $($this,last) {
                    if {![info exists ${this}last($key)]} {
                        foreach {array row column} [split $key ,] break
                        set result "[lindex [viewer::label $array $row $column] 0] data not yet available"
                        set error 1
                        break
                    }
                }
            }
            if {!$error} {
                set error [catch {$(interpreter) eval expr [list [subst -nobackslashes -nocommands $expression]]} result]
            }
            foreach {key cell} [array get ${this}cell] {
                catch {set ${this}last($key) [set $cell]}
            }
            foreach key [array names ${this}last] {
                if {![info exists ${this}cell($key)]} {unset ${this}last($key)}
            }
            if {$error} {
                error $result
            } else {
                return $result
            }
        }

        proc check {this} {
            foreach function [list delta diff last] {
                set text $switched::($this,-text)
                while {[string length $text] > 0} {
                    set expression "$function\\s*\\((\[^\)\]*)\\)"
                    if {![regexp $expression $text ignore argument]} break
                    switch [string trim $argument] {
                        \$ {}
                        time {
                            if {![string equal $function diff]} {
                                error "${function}(time) should be diff(time)"
                            }
                        }
                        default {
                            regsub -all {\$} $argument value argument
                            if {[string equal $function diff]} {
                                set message "${function}() takes one argument (data cell or \"time\")"
                            } else {
                                set message "${function}() takes one data cell argument"
                            }
                            if {[string length [string trim $argument]] > 0} {append message ", not: $argument"}
                            error $message
                        }
                    }
                    regexp -indices $expression $text indexes
                    set text [string range $text [expr {[lindex $indexes end] + 1}] end]
                }
            }
        }

        proc equal {formula1 formula2} {
            regsub -all {\s} [expression $formula1] {} expression1
            regsub -all {\s} [expression $formula2] {} expression2
            return [string equal $expression1 $expression2]
        }

    }


}



class module {

    proc module {this name index args} switched {$args} {
        if {[string length $index] == 0} {
            set index [newIndex $name]
        } else {
            addIndex $name $index
        }
        set ($this,name) $name
        set ($this,index) $index
        switched::complete $this
    }

    proc ~module {this} {
        if {$($this,terminate)} {
            ::$($this,namespace)::terminate
        }
        if {[info exists ($this,interpreter)]} {
            switch $($this,type) {
                perl {
                    perl::interp delete $($this,interpreter)
                }
                python {
                    python::interp delete $($this,interpreter)
                }
                default {
                    interp delete $($this,interpreter)
                }
            }
        }
        if {[info exists ($this,namespace)]} {
            namespace delete ::$($this,namespace)
        }
        deleteIndex $this
    }

    proc options {this} {
        return [list            [list -state {} {}]        ]
    }

    proc set-state {this value} {
if {$global::withGUI} {
        switch $value {
            {} {
                return
            }
            busy - idle {}
            error {
                set ($this,errorTime) [clock seconds]
            }
            default error
        }
        displayModuleState $($this,namespace) $value
}
    }

    proc newIndex {name} {
        variable indices

        if {![info exists indices($name)]} {
            set indices($name) {}
        }
        set new 0
        foreach index $indices($name) {
            if {$index != $new} break
            incr new
        }
        set indices($name) [lsort -integer [concat $indices($name) $new]]
        return $new
    }

    proc addIndex {name index} {
        variable indices

        if {![info exists indices($name)]} {
            set indices($name) $index
            return
        }
        if {[lsearch -exact $indices($name) $index] >= 0} {
            error "trying to add an existing index: $index"
        }
        set indices($name) [lsort -integer [concat $indices($name) $index]]
    }

    proc deleteIndex {this} {
        variable indices

        set name $($this,name)
        ldelete indices($name) $($this,index)
        if {[llength $indices($name)] == 0} {
            unset indices($name)
        }
    }

    proc load {this} {
        set name $($this,name)
        set namespace ${name}<$($this,index)>
        set directory [pwd]
        cd $::package(directory,$name)
        set interpreter [interp create]
if {$global::withGUI} {
        $interpreter eval {
            proc bgerror {error} {
                puts stderr $::errorInfo
                exit 1
            }
        }
} else {
        $interpreter alias writeLog writeLog
        interp eval $interpreter "namespace eval global {set debug $::global::debug}"
        $interpreter eval {
            proc bgerror {message} {
                if {$::global::debug} {
                    writeLog $::errorInfo critical
                } else {
                    writeLog $message critical
                }
            }
        }
}
        $interpreter eval "set auto_path [list $::auto_path]"
        catch {$interpreter eval {package require {}}}
        $interpreter eval {rename source _source}; $interpreter alias source ::module::source $this $interpreter
        namespace eval ::$namespace {}
        set ($this,namespace) $namespace
        set ($this,terminate) 0
        set ::${namespace}::data(updates) $global::32BitIntegerMinimum
        set ::${namespace}::data(identifier) $namespace
        if {[info exists ::package(exact,$name)]} {
           $interpreter eval "package require -exact $name $::package(version,$name)"
        } else {
           $interpreter eval "package require $name"
        }
        switch $($this,type) {
            perl - python {
                interp delete $interpreter
                validateColumnTitles $this
            }
            default {
                set ($this,interpreter) $interpreter
                loadTcl $this
            }
        }
        cd $directory
    }

    proc loadTcl {this} {
        set name $($this,name)
        set interpreter $($this,interpreter)
        set namespace $($this,namespace)
        switch $name {
            formulas {
                namespace eval ::$namespace "proc messages {} {$interpreter eval ::formulas::messages}"
                namespace eval ::$namespace "proc new {row} {$interpreter eval ::formulas::new \$row}"
                namespace eval ::$namespace "proc name {row string} {$interpreter eval ::formulas::name \$row \[list \$string\]}"
                namespace eval ::$namespace "proc value {row value} {$interpreter eval ::formulas::value \$row \[list \$value\]}"
                namespace eval ::$namespace "proc delete {row} {$interpreter eval ::formulas::delete \$row}"
                namespace eval ::$namespace "proc update {} {$interpreter eval ::formulas::update}"
            }
            trace {
                namespace eval ::$namespace "proc update {args} {$interpreter eval ::trace::update \$args}"
            }
            default {
if {$global::withGUI} {
                set message [mc {%s data update...}]
                namespace eval ::$namespace [subst -nocommands {
                    proc update {} {
                        ::variable data

                        switched::configure $this -state busy
                        lifoLabel::push $global::messenger [::format {$message} \$data(identifier)]
                        $interpreter eval ::${name}::update
                        lifoLabel::pop $global::messenger
                    }
                }]
} else {
                namespace eval ::$namespace "proc update {} {$interpreter eval ::${name}::update}"
}
            }
        }
        set ($this,initialize) [procedureExists $this initialize]
        if {$($this,initialize)} {
            namespace eval ::$namespace [subst -nocommands {
                proc initialize {arguments} {
                    $interpreter eval "
                        ::array set _options [list \$arguments]
                        ::${name}::initialize _options
                        ::unset _options
                    "
                }
            }]
        }
        set ($this,terminate) [procedureExists $this terminate]
        if {$($this,terminate)} {
            proc ::${namespace}::terminate {} "$interpreter eval ${name}::terminate"
        }
        set ($this,version) [$interpreter eval "package provide $name"]
        synchronize $this
        validateColumnTitles $this
        $interpreter alias exit exit
        $interpreter alias _updated ::module::updated $this
        $interpreter eval "trace variable ::${name}::data(updates) w _updated"
        $interpreter alias pushMessage ::modules::pushMessage $name $namespace
        $interpreter alias popMessage ::modules::popMessage
        $interpreter alias flashMessage ::modules::flashMessage $name $namespace
        $interpreter alias traceMessage ::modules::trace $name $namespace
        $interpreter alias createThreshold ::thresholds::create $thresholds::singleton ${namespace}::data
        $interpreter alias currentThresholds ::thresholds::current $thresholds::singleton ${namespace}::data
if {$global::withGUI} {
        if {[string equal $name instance]} {
            $interpreter alias cellHistory ::databaseInstances::cellHistory
            proc ::${namespace}::mapping {row column} "return \[$interpreter eval ${name}::mapping \$row \$column\]"
        }
}
    }

    proc updated {this args} {
        set namespace $($this,namespace)
        set updates [$($this,interpreter) eval "::set ::$($this,name)::data(updates)"]
        if {$updates <= [set ::${namespace}::data(updates)]} return
        set asynchronous [asynchronous $this]
if {$global::withGUI} {
        set trace [string equal $($this,name) trace]
        if {$asynchronous && !$trace} {
            lifoLabel::push $global::messenger [format [mc {%s data update...}] [set ::${namespace}::data(identifier)]]
        }
}
        array unset ::${namespace}::data {[0-9]*,[0-9]*}
        synchronize $this {[0-9]*,[0-9]*}
        set ::${namespace}::data(updates) $updates
if {$global::withGUI} {
        if {!$trace} {
            updateState $this
            if {$asynchronous} {
                lifoLabel::pop $global::messenger
            }
        }
}
    }

    proc asynchronous {this} {
        if {[info exists ($this,asynchronous)]} {return $($this,asynchronous)}
        set namespace $($this,namespace)
        set ($this,asynchronous) [expr {[lindex [set ::${namespace}::data(pollTimes)] 0] <= 0}]
    }

    proc updateState {this} {
if {$global::withGUI} {
        if {            ![string equal $switched::($this,-state) error] ||            ([asynchronous $this] && ($($this,errorTime) < ([clock seconds] - 1)))        } {
            switched::configure $this -state idle
        }
}
    }

    proc clear {this} {
        set namespace $($this,namespace)
        array unset ::${namespace}::data {[0-9]*,[0-9]*}
        set ::${namespace}::data(updates) [set ::${namespace}::data(updates)]
    }

    proc synchronize {this {pattern *}} {
        set namespace $($this,namespace)
        set interpreter $($this,interpreter)
        set name $($this,name)
        switch $($this,type) {
            perl {
                array set ::${namespace}::data [$interpreter eval ::hash_string(%${name}::data)]
            }
            python {
                array set ::${namespace}::data [$interpreter eval formstring($name.form)]
            }
            default {
                array set ::${namespace}::data [$interpreter eval "array get ::${name}::data {$pattern}"]
            }
        }
    }

    proc validateColumnTitles {this} {
        foreach {name label} [array get ::$($this,namespace)::data *,label] {
            if {[string first ? $label] >= 0} {
                scan $name %u column
                puts stderr "in $($this,namespace) module, column $column label contains a ? character: \"$label\""
                exit 1
            }
        }
    }

    proc procedureExists {this name} {
        return [$($this,interpreter) eval            [subst -nocommands {expr {[string length [namespace eval ::$($this,name) {::info proc $name}]] > 0}}]        ]
    }

    proc source {this interpreter file} {
        switch [file extension $file] {
            .pm {
                set ($this,type) perl
                loadPerl $this $file
                $interpreter eval "package provide $($this,name) $($this,version)"
            }
            .py {
                set ($this,type) python
                loadPython $this $file
                $interpreter eval "package provide $($this,name) $($this,version)"
            }
            default {
                set ($this,type) tcl
                $interpreter eval _source [list $file]
            }
        }
    }

    proc loadPerl {this file} {
        set name $($this,name)
        set namespace $($this,namespace)
        if {[catch {package require tclperl 3} message] && [catch {package require tclperl 2} message]} {
            error "$message\nis the tclperl package installed?"
        }
        set interpreter [perl::interp new]
        set ($this,interpreter) $interpreter
        $interpreter eval "use $name"
        $interpreter eval $perl::utilities
        array set ::${namespace}::data [$interpreter eval ::hash_string(%${name}::data)]
if {$global::withGUI} {
        set message [mc {%s data update...}]
        proc ::${namespace}::update {} "
            variable data

            switched::configure $this -state busy
            lifoLabel::push $global::messenger \[format {$message} \$data(identifier)\]
            $interpreter eval ${name}::update()
            lifoLabel::pop $global::messenger
        "
} else {
        proc ::${namespace}::update {} "$interpreter eval ${name}::update()"
}
        proc ::${namespace}::updated {} "
            variable data

            $interpreter eval {
                if (defined(&${name}::updated)) {${name}::updated();}
            }
            set updates \[$interpreter eval \\$${name}::data{updates}\]
            if {\$updates > \$data(updates)} {
                array unset data {\[0-9\]*,\[0-9\]*}
                array set data \[$interpreter eval ::array_string(@${name}::data)\]
                set data(updates) \$updates
            }
            module::updateState $this
        "
        set threaded [$interpreter eval int(defined(&threads::new))]
        if {$threaded} {
            if {![info exists ::tcl_platform(threaded)] || !$::tcl_platform(threaded)} {
                error "Tcl core with multithreading enabled required with $name module using Perl threads"
            }
            if {[catch {package require tclperl 3.1} message]} {
                error "$message\nversion 3.1 or above required with $name module using Perl threads"
            }
            $interpreter eval "
                sub ${name}::yield(\$) {
                    my \$function = shift;
                    if (\$function ne 'updated') {
                        die(\"only 'updated' is supported as yield() argument at this time\\n\");
                    }
                    \$Tcl::parent->eval(\"::${namespace}::\$function\");                              # synchronize via thread event
                }
            "
        } else {
            $interpreter eval "tie($${name}::data{updates}, 'moodss::Updated', '${namespace}::updated');"
        }
        set ($this,initialize) [$interpreter eval int(defined(&${name}::initialize))]
        if {[info exists ${namespace}::data(switches)]} {
            array set argumentRequired [set ${namespace}::data(switches)]
        }
        if {$($this,initialize)} {
            if {![info exists argumentRequired]} {
                puts stderr "in $name module, initialize subroutine requires switches to be defined"
                exit 1
            }
            proc ::${namespace}::initialize {arguments} "
                array set argumentRequired [list [array get argumentRequired]]
                set argument {}
                foreach {name value} \$arguments {
                    if {!\$argumentRequired(\$name)} {
                        set value 1
                    } else {
                        regsub -all {\\\\} \$value {\\\\\\\\} value
                        regsub -all ' \$value {\\\\\\'} value
                    }
                    if {\[string length \$argument\] > 0} {append argument ,}
                    append argument '\$name','\$value'
                }
                $interpreter eval ${name}::initialize(\$argument)
            "
        }
        set ($this,terminate) [$interpreter eval int(defined(&${name}::terminate))]
        if {$($this,terminate)} {
            proc ::${namespace}::terminate {} "$interpreter eval ${name}::terminate()"
        }
        $interpreter eval "
            sub ${name}::flashMessage(\$;\$) {
                my (\$message, \$seconds) = @_;
                \$Tcl::parent->eval(\"modules::flashMessage $name $namespace [list \$message] \$seconds\");
            }
            sub ${name}::pushMessage(\$) {
                my \$message = shift;
                \$Tcl::parent->eval(\"modules::pushMessage $name $namespace [list \$message]\");
            }
            sub ${name}::popMessage() {\$Tcl::parent->eval('modules::popMessage');}
            sub ${name}::traceMessage(\$) {
                my \$message = shift;
                \$Tcl::parent->eval(\"modules::trace $name $namespace [list \$message]\");
            }
            sub ${name}::after(\$\$) {
                my \$milliseconds = shift;
                my \$script = shift;
                \$Tcl::parent->eval(\"after \$milliseconds [list $interpreter eval [list \$script]]\");
            }
        "
        set ($this,version) [$interpreter eval \$${name}::VERSION]
    }

    proc loadPython {this file} {
        set name $($this,name)
        set namespace $($this,namespace)
        if {[catch {package require tclpython 3} message]} {
            error "$message\nis the tclpython package installed?"
        }
        set interpreter [python::interp new]
        set ($this,interpreter) $interpreter
        $interpreter exec "import sys\nsys.path.insert(0, '.')"
        $interpreter exec {from types import FunctionType}
        $interpreter exec {import re}
        $interpreter exec "import $name"
        $interpreter exec $python::utilityFunctions
        $interpreter exec "import signal\nsignal.signal(2, signal.SIG_DFL)"
        array set ::${namespace}::data [$interpreter eval formstring($name.form)]
if {$global::withGUI} {
        set message [mc {%s data update...}]
        proc ::${namespace}::update {} "
            variable data

            lifoLabel::push $global::messenger \[format {$message} \$data(identifier)\]
            $interpreter exec $name.update()
            set updates \[$interpreter eval {$name.form\['updates'\]}]
            if {\$updates > \$data(updates)} {
                array unset data {\[0-9\]*,\[0-9\]*}
                array set data \[$interpreter eval datastring($name.data)\]
                set data(updates) \$updates
            }
            lifoLabel::pop $global::messenger
        "
} else {
        proc ::${namespace}::update {} "
            variable data

            $interpreter exec $name.update()
            set updates \[$interpreter eval {$name.form\['updates'\]}]
            if {\$updates > \$data(updates)} {
                array unset data {\[0-9\]*,\[0-9\]*}
                array set data \[$interpreter eval datastring($name.data)\]
                set data(updates) \$updates
            }
        "
}
        $interpreter exec "try: result = (type($name.initialize) == FunctionType)\nexcept: result = 0"
        set ($this,initialize) [$interpreter eval result]
        if {[info exists ${namespace}::data(switches)]} {
            array set argumentRequired [set ${namespace}::data(switches)]
        }
        if {$($this,initialize)} {
            if {![info exists argumentRequired]} {
                puts stderr "in $name module, initialize subroutine requires switches to be defined"
                exit 1
            }
            proc ::${namespace}::initialize {arguments} "
                array set argumentRequired [list [array get argumentRequired]]
                set argument {}
                foreach {name value} \$arguments {
                    if {!\$argumentRequired(\$name)} {
                        set value 1
                    } else {
                        regsub -all {\\\\} \$value {\\\\\\\\} value
                        regsub -all ' \$value {\\\\\\'} value
                    }
                    if {\[string length \$argument\] > 0} {append argument ,}
                    append argument '\$name':'\$value'
                }
                $interpreter exec $name.initialize({\$argument})
            "
        }
        $interpreter exec "try: result = (type($name.terminate) == FunctionType)\nexcept: result = 0"
        set ($this,terminate) [$interpreter eval result]
        if {$($this,terminate)} {
            proc ::${namespace}::terminate {} "$interpreter exec $name.terminate()"
        }
        set ($this,version) [$interpreter eval $name.__version__]
    }

}



namespace eval module::perl {

    variable utilities {

        sub array_string {                                     # return string usable by Tcl array set command, from Perl data array
            my @data = @_;
            my $string = '';
            for my $row (0 .. $#data) {
                for my $column (0 .. $#{$data[$row]}) {
                    my $value = qq($data[$row][$column]);
                    $value =~ s/"/\\"/g;                                      # embedded quotes allowed in value but must be escaped
                    $string .= " $row,$column \"$value\"";
                }
            }
            return $string;
        }

        sub hash_string {                                       # return string usable by Tcl array set command, from Perl data hash
            my %data = @_;
            my $string = '';
            while (my ($key, $value) = each %data) {
                if ($key =~ /^(pollTimes|indices|indexColumns)$/) {                         # Perl arrays transformed into Tcl lists
                    $string .= " $key {@{$value}}";
                } elsif ($key eq 'columns') {
                    for my $column (0 .. $#{$value}) {
                        while (my ($key, $value) = each %{$$value[$column]}) {
                            $value =~ s/"/\\"/g;                            # embedded quotes allowed in message but must be escaped
                            $string .= " $column,$key \"$value\"";
                        }
                    }
                } elsif ($key eq 'views') {
                    $string .= ' views {';
                    for my $view (0 .. $#{$value}) {
                        $string .= ' {';
                        while (my ($key, $value) = each %{$$value[$view]}) {
                            $string .= " $key";
                            if ($key eq 'swap') {                                                                   # simple boolean
                                $string .= " $value";
                            } elsif ($key eq 'sort') {                                                                   # sort hash
                                my ($key, $value) = %$value;                                                 # keep first entry only
                                $string .= " {$key $value}";
                            } else {                                                                                 # indices array
                                $string .= " {@{$value}}";
                            }
                        }
                        $string .= '}';
                    }
                    $string .= '}';
                } elsif ($key eq 'sort') {                                                                               # sort hash
                    $string .= " $key {";
                    my ($key, $value) = %$value;                                                             # keep first entry only
                    $string .= "$key $value";
                    $string .= '}';
                } elsif ($key eq 'switches') {                                # Perl hash transformed into Tcl array compatible list
                    $string .= " $key {";
                    while (my ($key, $value) = each %$value) {
                        $string .= " $key $value";
                    }
                    $string .= '}';
                } else {
                    $value =~ s/"/\\"/g;                                      # embedded quotes allowed in value but must be escaped
                    $string .= " $key \"$value\"";
                }
            }
            return $string;
        }

        {
            package moodss::Updated;
            sub TIESCALAR {
                my $class = shift;
                my $command = shift;
                return bless {value => undef, command => $command}, $class;
            }
            sub FETCH {
                my $self = shift;
                return $self->{value};
            }
            sub STORE {
                my $self = shift;
                my $value = shift;
                $self->{value} = $value;
                $Tcl::parent->eval($self->{command});
                return $value;
            }
        }

    }

}



namespace eval module::python {

variable utilityFunctions {

import string

def columnstring(dictionary, index):
    "return a Tcl array compatible initialization list for column data"
    pairs = ''
    for (key, value) in dictionary.items():
        pairs = pairs + ' ' + str(index) + ',' + str(key) + ' "' + string.replace(str(value), '"', '\\"') + '"'
    return pairs

def liststring(list):
    "return a Tcl list from a python list (values must contain alphanumeric characters only)"
    string = ''
    for index in range(len(list)):
        string = string + ' ' + str(list[index])
    return string

def viewsstring(list):
    "return a Tcl array compatible initialization list for views data"
    pairs = ''
    for index in range(len(list)):
        pairs = pairs + ' {'
        for (key, value) in list[index].items():
            pairs = pairs + ' ' + str(key)
            if key == 'swap':                                                                                       # simple boolean
                pairs = pairs + ' ' + str(value)
            elif key == 'sort':
                for (column, direction) in value.items():
                    pairs = pairs + ' {' + str(column) + ' ' + str(direction) + '}'
                    break                                                                                    # keep first entry only
            else:                                                                                                     # indices list
                pairs = pairs + ' {' + liststring(value) + '}'
        pairs = pairs + '}'
    return pairs

def dictionarystring(dictionary):
    "return a Tcl array compatible initialization list from a python dictionary"
    "(keys and values must contain alphanumeric characters only)"
    pairs = ''
    for (key, value) in dictionary.items():
        pairs = pairs + ' ' + str(key) + ' ' + str(value)
    return pairs

def formstring(dictionary):
    "return a Tcl array compatible initialization list from module form dictionary"
    pairs = ''
    for (key, value) in dictionary.items():
        if key == 'columns':
            for index in range(len(value)):
                pairs = pairs + columnstring(value[index], index)
        elif re.match('^(indexColumns|indices|pollTimes)$', key):
            pairs = pairs + ' ' + key + ' {' + liststring(value) + '}'
        elif key == 'sort':
            for (column, direction) in value.items():
                pairs = pairs + ' sort {' + str(column) + ' ' + str(direction) + '}'
                break                                                                                        # keep first entry only
        elif key == 'switches':
            pairs = pairs + ' ' + key + ' {' + dictionarystring(value) + '}'
        elif key == 'views':
            pairs = pairs + ' ' + key + ' {' + viewsstring(value) + '}'
        else:
            pairs = pairs + ' "' + str(key) + '" "' + string.replace(str(value), '"', '\\"') + '"'
    return pairs

def datastring(list):
    "return a Tcl array compatible initialization list from module data list of lists"
    pairs = ''
    for row in range(len(list)):
        for column in range(len(list[row])):
            pairs = pairs + ' ' + str(row) + ',' + str(column) + ' "' + string.replace(str(list[row][column]), '"', '\\"') + '"'
    return pairs

}

}



class modules {

    class instance {

        proc instance {this module index} {
            set ($this,module) $module
            set ($this,loaded) [new module $module $index]
        }

        proc ~instance {this} {
            delete $($this,loaded)
        }

        proc load {this} {
            set loaded $($this,loaded)
            module::load $loaded
            set namespace $module::($loaded,namespace)
            set ($this,namespace) $namespace
            if {[info exists ::${namespace}::data(switches)]} {
                array set switch [set ::${namespace}::data(switches)]
                if {[info exists switch(--daemon)] && ($switch(--daemon) != 0)} {
                    error {--daemon option must not take any argument}
                }
                set ($this,switches) [set ::${namespace}::data(switches)]
            }
            set ($this,initialize) $module::($loaded,initialize)
            set ($this,version) $module::($loaded,version)
            initialize $this
        }

        proc initialize {this} {
            set namespace $($this,namespace)
            set ($this,identifier) [set ${namespace}::data(identifier)]
            if {![modules::validName $($this,identifier)]} {
                foreach {name index} [modules::decoded $namespace] {}
                puts stderr "\"$name\" module identifier: \"$($this,identifier)\" contains invalid characters"
                exit 1
            }
            catch {set ($this,times) [set ${namespace}::data(pollTimes)]}
            catch {set ($this,views) [set ${namespace}::data(views)]}
        }

        proc synchronize {this} {
            module::synchronize $($this,loaded)
            initialize $this
        }

        proc empty {this} {
            module::clear $($this,loaded)
        }

    }


    set (instances) {}

    proc modules {this} error

    proc source {interpreter package file} {
        switch [file extension $file] {
            .py {
                if {[catch {package require tclpython 3}]} return
                set python [python::interp new]
                set code [catch {
                    $python exec "import sys\nsys.path.insert(0, '.')"
                    $python exec {import re}
                    $python exec "import $package"
                    $python exec $module::python::utilityFunctions
                    array set data [$python eval formstring($package.form)]
                    foreach name {helpText switches updates} {
                        catch {$interpreter eval [list namespace eval $package [list set data($name) $data($name)]]}
                    }
                    $interpreter eval "package provide $package [$python eval $package.__version__]"
                } message]
                python::interp delete $python
                if {$code} {
                    error $message $::errorInfo $code
                }
            }
            .pm {
                if {[catch {package require tclperl 3}] && [catch {package require tclperl 2}]} return
                set perl [perl::interp new]
                set code [catch {
                    $perl eval "use $package"
                    $perl eval $module::perl::utilities
                    array set data [$perl eval hash_string(%${package}::data)]
                    foreach name {helpText switches updates} {
                        catch {$interpreter eval [list namespace eval $package [list set data($name) $data($name)]]}
                    }
                    $interpreter eval "package provide $package [$perl eval \$${package}::VERSION]"
                } message]
                perl::interp delete $perl
                if {$code} {
                    error $message $::errorInfo $code
                }
            }
            default {
                $interpreter eval _source [list $file]
            }
        }
    }

    proc available {{command {}} {scanCommand {}}} {
        set directory [pwd]
        set packages {}
        foreach package [package names] {
            if {[string match *::* $package]} continue
            if {![info exists ::package(directory,$package)]} continue
            switch $package {instance - formulas continue}
            if {!$global::debug && ![string match *moodss* $::package(directory,$package)]} {
                continue
            }
            if {[string length $scanCommand] > 0} {
                regsub -all %M $scanCommand $package string
                uplevel #0 $string
            }
            cd $::package(directory,$package)
            set interpreter [interp create]
            $interpreter eval "set auto_path [list $::auto_path]"
            catch {$interpreter eval {package require {}}}
            $interpreter eval {rename source _source}; $interpreter alias source ::modules::source $interpreter $package
            if {[info exists ::package(exact,$package)]} {
                set error [catch {$interpreter eval "package require -exact $package $::package(version,$package)"}]
            } else {
                set error [catch {$interpreter eval "package require $package"}]
            }
            if {!$error && [$interpreter eval info exists ::${package}::data(updates)]} {
                lappend packages $package
                set switches {}
                catch {set switches [$interpreter eval "set ::${package}::data(switches)"]}
                set switches [list $switches]
                if {[string length $command] > 0} {
                    regsub -all %M $command $package string
                    regsub -all %S $string $switches string
                    uplevel #0 $string
                }
            }
            interp delete $interpreter
        }
        cd $directory
        return [lsort $packages]
    }

    proc printAvailable {} {
        puts {searching for module packages, please wait...}
        foreach package [available] {
            puts -nonewline "$package: possibly in"
            set count 0
            foreach directory $::auto_path {
                if {[file readable [file join $directory $package pkgIndex.tcl]]} {
                    if {$count > 0} {
                        puts -nonewline ,
                    }
                    puts -nonewline " [file join $directory $package]"
                    incr count
                }
            }
            puts {}
        }
    }

    proc parse {arguments} {
        if {[llength $arguments] == 0} return
        set name [lindex $arguments 0]
        set arguments [lrange $arguments 1 end]
        foreach {name index} [decoded $name] {}
        if {![info exists ::package(directory,$name)]} {
            error "error: \"$name\" is not a valid moodss module name"
        }
        if {![validName $name]} {
            error "\"$name\" module name contains invalid characters"
        }
        switch $name formulas - thresholds {
            error "\"$name\" is a reserved module name"
        }
        if {$global::withGUI} {
            lifoLabel::push $global::messenger [format [mc {loading %s...}] $name]
        } elseif {$global::debug} {
            writeLog "loading $name..."
        }
        set instance [new instance $name $index]
        if {[catch {instance::load $instance} message]} {
            if {$global::debug} {set information $::errorInfo}
            if {$global::withGUI} {
                lifoLabel::pop $global::messenger
            }
            delete $instance
            if {$global::debug} {
                error $information
            } else {
                error "module \"$name\" load error:\n$message"
            }
        }
        if {$global::withGUI} {
            lifoLabel::pop $global::messenger
        }
        set help [expr {[lsearch -exact $arguments --help] >= 0}]
        if {[info exists instance::($instance,switches)]} {
            if {[llength $instance::($instance,switches)] == 0} {
                error "module \"$name\" switches are empty"
            }
            if {$help} {
                displayHelpMessage $name $instance::($instance,switches)
                exit
            }
            if {[catch {set next [parseCommandLineArguments $instance::($instance,switches) $arguments options]} message]} {
                delete $instance
                error "module \"$name\" options error: $message"
            }
            if {!$instance::($instance,initialize)} {
                error "module \"$name\" has no initialize procedure"
            }
            set instance::($instance,options) [array get options]
            set instance::($instance,arguments) [lrange $arguments 0 [expr {[llength $arguments] - [llength $next] - 1}]]
            set arguments $next
        } else {
            if {$help} {
                displayHelpMessage $name
                exit
            }
            set instance::($instance,arguments) {}
        }
        lappend (instances) $instance
        parse $arguments
        if {$global::withGUI} {
            update idletasks
        }
    }

    proc helpHTMLData {name} {
        set noHelpText [mc {no help available}]
        foreach instance $(instances) {
            set namespace $instance::($instance,namespace)
            foreach {module index} [decoded $namespace] {}
            if {[string compare $module $name]} continue
            if {![info exists text]} {
                set text $noHelpText
                catch {set text [set ${namespace}::data(helpText)]}
                set version $instance::($instance,version)
                break
            }
        }
        if {![info exists text]} {
            foreach {version text} [versionAndHelpText $name] {}
            if {[string length $text] == 0} {
                set text $noHelpText
            }
        }
        set header [format [mc {<b>%s</b> module version <i>%s</i>}] $name $version]
        append header <br><br>
        if {[regsub -nocase <body> $text <body>$header text] > 0} {
            regsub -nocase {<title>.*</title>} $text {} text
            return $text
        } else {
            regsub -all \n $text <br> text
            return ${header}$text
        }
    }

    proc versionAndHelpText {name} {
        set directory [pwd]
        cd $::package(directory,$name)
        set interpreter [interp create]
        $interpreter eval "set auto_path [list $::auto_path]"
        catch {$interpreter eval {package require {}}}
        $interpreter eval {rename source _source}; $interpreter alias source ::modules::source $interpreter $name
        $interpreter eval "package require $name"
        set version [$interpreter eval "package provide $name"]
        set text {}
        catch {set text [$interpreter eval "namespace eval $name {set data(helpText)}"]}
        interp delete $interpreter
        cd $directory
        return [list $version $text]
    }

    proc initialize {{daemon 0} {errorCommand {}}} {
        foreach instance $(instances) {
            set namespace $instance::($instance,namespace)
            set error 0
            if {$instance::($instance,initialize)} {
                regsub {<0>$} $namespace {} string
                if {$global::withGUI} {
                    lifoLabel::push $global::messenger [format [mc {initializing %s...}] $string]
                } elseif {$global::debug} {
                    writeLog "initializing $string module..."
                }
                catch {unset options}
                catch {array set options $instance::($instance,options)}
                if {$daemon && [info exists instance::($instance,switches)]} {
                    array set switch $instance::($instance,switches)
                    if {![info exists option(--daemon)] && [info exists switch(--daemon)]} {
                        set options(--daemon) {}
                    }
                    unset switch
                }
                if {[info exists options]} {
                    if {[catch {::${namespace}::initialize [array get options]} message]} {
                        if {$global::debug} {set information $::errorInfo}
                        set error 1
                    }
                } else {
                    if {[catch ::${namespace}::initialize message]} {
                        if {$global::debug} {set information $::errorInfo}
                        set error 1
                    }
                }
                if {$global::withGUI} {
                    lifoLabel::pop $global::messenger
                }
            }
            if {!$error} {
                instance::synchronize $instance
                set 64BitsName ::${namespace}::data(64Bits)
                if {([package vcompare $::tcl_version 8.4] < 0) && [info exists $64BitsName] && [set $64BitsName]} {
                    set message {Tcl/Tk core version 8.4 or above is required for 64 bits support}
                    set information $message
                    set error 1
                }
            }
            if {$error} {
                unload $instance
                regsub {<0>$} $namespace {} namespace
                set message "module \"$namespace\" initialize error:\n$message"
                if {$global::debug} {
                    error $information
                } elseif {[string length $errorCommand] > 0} {
                    uplevel #0 $errorCommand $namespace [list $message]
                } else {
                    error $message
                }
            }
            set instance::($instance,initialize) 0
        }
        if {$global::withGUI} {
            update idletasks
        }
    }

    proc setPollTimes {{override {}}} {
        if {[llength $(instances)] == 0} {
            set global::pollTimes {}
            set global::pollTime 0
            return
        }
        set default 0
        set minimum 0
        foreach instance $(instances) {
            set times $instance::($instance,times)
            if {[llength $times] == 0} {
                error "module $instance::($instance,namespace) poll times list is empty"
            }
            set time [lindex $times 0]
            if {$time < 0} {
                set intervals($time) {}
                continue
            }
            if {$time > $default} {
                set default $time
            }
            set times [lsort -integer $times]
            set time [lindex $times 0]
            if {$time > $minimum} {
                set minimum $time
                set minimumModule $instance::($instance,namespace)
            }
            foreach time $times {
                set data($time) {}
            }
        }
        set global::pollTimes [lsort -integer [array names data]]
        set global::pollTimes [lrange $global::pollTimes [lsearch -exact $global::pollTimes $minimum] end]
        if {$global::pollTime < $default} {
            set global::pollTime $default
        }
        if {[string length $override] > 0} {
            if {$override < $minimum} {
                puts stderr "$::argv0: minimum poll time is $minimum seconds for module $minimumModule"
                exit 1
            }
            set global::pollTime $override
        }
        if {($global::pollTime == 0) && [info exists intervals]} {
            set sum 0
            set number 0
            foreach interval [array names intervals] {
                incr sum $interval
                incr number
            }
            set global::pollTime [expr {round(double($sum) / -$number)}]
        }
    }

    proc identifier {array} {
        set namespace [namespaceFromArray $array]
        foreach instance $(instances) {
            if {[string equal $namespace $instance::($instance,namespace)]} {
                return $instance::($instance,identifier)
            }
        }
        return {}
    }

    proc asynchronous {array} {
        set namespace [namespaceFromArray $array]
        foreach instance $(instances) {
            if {[string equal $namespace $instance::($instance,namespace)]} {
                return [expr {[lindex $instance::($instance,times) 0] < 0}]
            }
        }
        error "could not find module instance for array $array"
    }

    proc instanceData {array} {
        variable instanceData

        set namespace [namespaceFromArray $array]
        foreach identifier $(instances) {
            if {[string equal $namespace $instance::($identifier,namespace)]} {
                set instance $identifier
                break
            }
        }
        if {![info exists instance]} {
            return {}
        }
        if {[info exists instanceData($instance)]} {
            return $instanceData($instance)
        }
        foreach {data(module) dummy} [modules::decoded $namespace] {}
        set data(identifier) $instance::($instance,identifier)
        set data(version) $instance::($instance,version)
        catch {set data(options) $instance::($instance,options)}
        upvar 1 ::${namespace}::data module
        set columns {}
        foreach name [array names module *,label] {
            if {[scan $name %u column] > 0} {lappend columns $column}
        }
        set list {}
        foreach column [lsort -integer $columns] {
            lappend list $module($column,label) $module($column,type) $module($column,message)
            if {[catch {lappend list $module($column,anchor)}]} {lappend list {}}
        }
        set data(data) $list
        set data(indexColumns) 0; catch {set data(indexColumns) $module(indexColumns)}
        return [set instanceData($instance) [array get data]]
    }

    proc decoded {name} {
        set index {}
        scan $name {%[^<]<%u>} name index
        return [list $name $index]
    }

    proc validName {string} {
        return [regexp {^[\w ,<>@%&*()=+:.-]+$} $string]
    }

    proc displayHelpMessage {name {switches {}}} {
        puts -nonewline "$name module usage:"
        if {[llength $switches] == 0} {
            puts -nonewline { <no arguments allowed>}
        } else {
            foreach {switch argument} $switches {
                puts -nonewline " \[$switch"
                if {$argument} {
                    puts -nonewline { argument}
                }
                puts -nonewline \]
            }
        }
        puts {}
    }

    proc loaded {} {
        if {[llength $(instances)] == 0} {
            return {}
        }
        foreach instance $(instances) {
            lappend list [list $instance $instance::($instance,namespace)]
        }
        set return {}
        foreach list [lsort -dictionary -index 1 $list] {
            foreach {instance namespace} $list {}
            lappend return $namespace $instance::($instance,identifier)
            set switches {}
            catch {set switches $instance::($instance,switches)}
            if {[llength $switches] == 0} {
                lappend return {}
            } else {
                set arguments $instance::($instance,arguments)
                set list {}
                foreach {switch required} $switches {
                    lappend list $switch $required
                    set index [lsearch -exact $arguments $switch]
                    if {$required} {
                        if {$index < 0} {
                            lappend list {}
                        } else {
                            lappend list [lindex $arguments [incr index]]
                        }
                    } else {
                        lappend list [expr {$index >= 0}]
                    }
                }
                lappend return $list
            }
        }
        return $return
    }

    proc instancesWithout {{modules {}}} {
        foreach module $modules {set skip($module) {}}
        set instances {}
        foreach instance $(instances) {
            if {[info exists skip($instance::($instance,module))]} continue
            lappend instances $instance
        }
        return $instances
    }

    proc namesWithout {modules} {
        set list {}
        foreach instance [instancesWithout $modules] {
            set module $instance::($instance,module)
            if {[lsearch -exact $list $module] < 0} {
                lappend list $module
            }
        }
        return $list
    }

    proc unload {instance} {
        ldelete (instances) $instance
        delete $instance
        if {$global::withGUI} {
            pages::monitorActiveCells
            thresholdLabel::monitorActiveCells
        }
    }

    proc loadedNamespace {string} {
        foreach instance $(instances) {
            if {[string equal $string $instance::($instance,namespace)]} {
                return 1
            }
        }
        return 0
    }

    proc namespaceFromArray {name} {
        return [string trimleft [namespace qualifiers [namespace which -variable $name]] :]
    }

    proc loadResidentTraceModule {} {
        if {[info exists (trace)]} {error {trying to load several resident trace modules}}
        set (trace) [new instance trace {}]
        instance::load $(trace)
        set namespace $instance::($(trace),namespace)
        ::${namespace}::initialize [list --rows $global::traceNumberOfRows]
    }

    proc trace {module identifier message} {
        regsub {<0>$} $identifier {} identifier
        set namespace $instance::($(trace),namespace)
        ::${namespace}::update $module $identifier $message
        foreach instance $(instances) {
            if {[string equal $instance::($instance,module) trace]} {
                set namespace $instance::($instance,namespace)
                ::${namespace}::update $module $identifier $message
            }
        }
    }

    proc loadFormulasModule {index object category} {
        set instance [new instance formulas $index]
        instance::load $instance
        set namespace $instance::($instance,namespace)
        set options {}
        if {[string length $object] > 0} {lappend options --object $object}
        if {[string length $category] > 0} {lappend options --category $category}
        set instance::($instance,options) $options
        ::${namespace}::initialize $options
        set instance::($instance,initialize) 0
        set instance::($instance,arguments) {}
        instance::synchronize $instance
        lappend (instances) $instance
        return $instance
    }

    proc flashMessage {module namespace message {seconds 1}} {
        regsub {<0>$} [set ::${namespace}::data(identifier)] {} identifier
        if {$global::withGUI} {
            ::lifoLabel::flash $::global::messenger "$identifier: $message" $seconds
            switched::configure [moduleFromNamespace $namespace] -state error
        } else {
            writeLog "$identifier: $message"
        }
        trace $module $identifier $message
    }

    proc pushMessage {module namespace message} {
        regsub {<0>$} [set ::${namespace}::data(identifier)] {} identifier
        if {$global::withGUI} {
            ::lifoLabel::push $::global::messenger "$identifier: $message"
        } else {
            writeLog "$identifier: $message"
        }
        trace $module $identifier $message
    }

    proc popMessage {} {
        if {$global::withGUI} {
            ::lifoLabel::pop $::global::messenger
        }
    }

    proc moduleFromNamespace {string} {
        foreach instance $(instances) {
            if {[string equal $instance::($instance,namespace) $string]} {
                return $instance::($instance,loaded)
            }
        }
        return 0
    }

}
# uri.tcl --
#
#	URI parsing and fetch
#
# Copyright (c) 2000 Zveno Pty Ltd
# Steve Ball, http://www.zveno.com/
# Derived from urls.tcl by Andreas Kupries
#
# TODO:
#	Handle www-url-encoding details
#
# CVS: $Id: uri.tcl,v 1.27 2004/05/03 22:56:25 andreas_kupries Exp $

package require Tcl 8.2

namespace eval ::uri {

    namespace export split join
    namespace export resolve isrelative
    namespace export geturl
    namespace export canonicalize
    namespace export register

    variable file:counter 0

    # extend these variable in the coming namespaces
    variable schemes       {}
    variable schemePattern ""
    variable url           ""
    variable url2part
    array set url2part     {}

    # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # basic regular expressions used in URL syntax.

    namespace eval basic {
	variable	loAlpha		{[a-z]}
	variable	hiAlpha		{[A-Z]}
	variable	digit		{[0-9]}
	variable	alpha		{[a-zA-Z]}
	variable	safe		{[$_.+-]}
	variable	extra		{[!*'(,)]}
	# danger in next pattern, order important for []
	variable	national	{[][|\}\{\^~`]}
	variable	punctuation	{[<>#%"]}	;#" fake emacs hilit
	variable	reserved	{[;/?:@&=]}
	variable	hex		{[0-9A-Fa-f]}
	variable	alphaDigit	{[A-Za-z0-9]}
	variable	alphaDigitMinus	{[A-Za-z0-9-]}

	# next is <national | punctuation>
	variable	unsafe		{[][<>"#%\{\}|\\^~`]} ;#" emacs hilit
	variable	escape		"%${hex}${hex}"

	#	unreserved	= alpha | digit | safe | extra
	#	xchar		= unreserved | reserved | escape

	variable	unreserved	{[a-zA-Z0-9$_.+!*'(,)-]}
	variable	uChar		"(${unreserved}|${escape})"
	variable	xCharN		{[a-zA-Z0-9$_.+!*'(,);/?:@&=-]}
	variable	xChar		"(${xCharN}|${escape})"
	variable	digits		"${digit}+"

	variable	toplabel			"(${alpha}${alphaDigitMinus}*${alphaDigit}|${alpha})"
	variable	domainlabel			"(${alphaDigit}${alphaDigitMinus}*${alphaDigit}|${alphaDigit})"

	variable	hostname			"((${domainlabel}\\.)*${toplabel})"
	variable	hostnumber			"(${digits}\\.${digits}\\.${digits}\\.${digits})"

	variable	host		"(${hostname}|${hostnumber})"

	variable	port		$digits
	variable	hostOrPort	"${host}(:${port})?"

	variable	usrCharN	{[a-zA-Z0-9$_.+!*'(,);?&=-]}
	variable	usrChar		"(${usrCharN}|${escape})"
	variable	user		"${usrChar}*"
	variable	password	$user
	variable	login		"(${user}(:${password})?@)?${hostOrPort}"
    } ;# basic {}
}


# ::uri::register --
#
#	Register a scheme (and aliases) in the package. The command
#	creates a namespace below "::uri" with the same name as the
#	scheme and executes the script declaring the pattern variables
#	for this scheme in the new namespace. At last it updates the
#	uri variables keeping track of overall scheme information.
#
#	The script has to declare at least the variable "schemepart",
#	the pattern for an url of the registered scheme after the
#	scheme declaration. Not declaring this variable is an error.
#
# Arguments:
#	schemeList	Name of the scheme to register, plus aliases
#       script		Script declaring the scheme patterns
#
# Results:
#	None.

proc ::uri::register {schemeList script} {
    variable schemes
    variable schemePattern
    variable url
    variable url2part

    # Check scheme and its aliases for existence.
    foreach scheme $schemeList {
	if {[lsearch -exact $schemes $scheme] >= 0} {
	    return -code error 		    "trying to register scheme (\"$scheme\") which is already known"
	}
    }

    # Get the main scheme
    set scheme  [lindex $schemeList 0]

    if {[catch {namespace eval $scheme $script} msg]} {
	catch {namespace delete $scheme}
	return -code error 	    "error while evaluating scheme script: $msg"
    }

    if {![info exists ${scheme}::schemepart]} {
	namespace delete $scheme
	return -code error 	    "Variable \"schemepart\" is missing."
    }

    # Now we can extend the variables which keep track of the registered schemes.

    eval [linsert $schemeList 0 lappend schemes]
    set schemePattern	"([::join $schemes |]):"

    foreach s schemeList {
	# FRINK: nocheck
	set url2part($s) "${s}:[set ${scheme}::schemepart]"
	# FRINK: nocheck
	append url "(${s}:[set ${scheme}::schemepart])|"
    }
    set url [string trimright $url |]
    return
}

# ::uri::split --
#
#	Splits the given <a url> into its constituents.
#
# Arguments:
#	url	the URL to split
#
# Results:
#	Tcl list containing constituents, suitable for 'array set'.

proc ::uri::split {url {defaultscheme http}} {

    set url [string trim $url]
    set scheme {}

    # RFC 1738:	scheme = 1*[ lowalpha | digit | "+" | "-" | "." ]
    regexp -- {^([a-z0-9+.-][a-z0-9+.-]*):} $url dummy scheme

    if {$scheme == {}} {
	set scheme $defaultscheme
    }

    # ease maintenance: dynamic dispatch, able to handle all schemes
    # added in future!

    if {[::info procs Split[string totitle $scheme]] == {}} {
	error "unknown scheme '$scheme' in '$url'"
    }

    regsub -- "^${scheme}:" $url {} url

    set       parts(scheme) $scheme
    array set parts [Split[string totitle $scheme] $url]

    # should decode all encoded characters!

    return [array get parts]
}

proc ::uri::SplitFtp {url} {
    # @c Splits the given ftp-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    # general syntax:
    # //<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
    #
    # additional rules:
    #
    # <user>:<password> are optional, detectable by presence of @.
    # <password> is optional too.
    #
    # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
    #	<cwd1> "/" ..."/" <cwdN> "/" <name> [";type=" <typecode>]

    upvar \#0 [namespace current]::ftp::typepart ftptype

    array set parts {user {} pwd {} host {} port {} path {} type {}}

    # slash off possible type specification

    if {[regexp -indices -- "${ftptype}$" $url dummy ftype]} {

	set from	[lindex $ftype 0]
	set to		[lindex $ftype 1]

	set parts(type)	[string range   $url $from $to]

	set from	[lindex $dummy 0]
	set url		[string replace $url $from end]
    }

    # Handle user, password, host and port

    if {[string match "//*" $url]} {
	set url [string range $url 2 end]

	array set parts [GetUPHP url]
    }

    set parts(path) [string trimleft $url /]

    return [array get parts]
}

proc ::uri::JoinFtp args {
    array set components {
	user {} pwd {} host {} port {}
	path {} type {}
    }
    array set components $args

    set userPwd {}
    if {[string length $components(user)] || [string length $components(pwd)]} {
	set userPwd $components(user)[expr {[string length $components(pwd)] ? ":$components(pwd)" : {}}]@
    }

    set port {}
    if {[string length $components(port)]} {
	set port :$components(port)
    }

    set type {}
    if {[string length $components(type)]} {
	set type \;type=$components(type)
    }

    return ftp://${userPwd}$components(host)${port}/[string trimleft $components(path) /]$type
}

proc ::uri::SplitHttps {url} {
    uri::SplitHttp $url
}

proc ::uri::SplitHttp {url} {
    # @c Splits the given http-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    # general syntax:
    # //<host>:<port>/<path>?<searchpart>
    #
    #   where <host> and <port> are as described in Section 3.1. If :<port>
    #   is omitted, the port defaults to 80.  No user name or password is
    #   allowed.  <path> is an HTTP selector, and <searchpart> is a query
    #   string. The <path> is optional, as is the <searchpart> and its
    #   preceding "?". If neither <path> nor <searchpart> is present, the "/"
    #   may also be omitted.
    #
    #   Within the <path> and <searchpart> components, "/", ";", "?" are
    #   reserved.  The "/" character may be used within HTTP to designate a
    #   hierarchical structure.
    #
    # path == <cwd1> "/" ..."/" <cwdN> "/" <name> ["#" <fragment>]

    upvar #0 [namespace current]::http::search  search
    upvar #0 [namespace current]::http::segment segment

    array set parts {host {} port {} path {} query {}}

    set searchPattern   "\\?(${search})\$"
    set fragmentPattern "#(${segment})\$"

    # slash off possible query

    if {[regexp -indices -- $searchPattern $url match query]} {
	set from [lindex $query 0]
	set to   [lindex $query 1]

	set parts(query) [string range $url $from $to]

	set url [string replace $url [lindex $match 0] end]
    }

    # slash off possible fragment

    if {[regexp -indices -- $fragmentPattern $url match fragment]} {
	set from [lindex $fragment 0]
	set to   [lindex $fragment 1]

	set parts(fragment) [string range $url $from $to]

	set url [string replace $url [lindex $match 0] end]
    }

    if {[string match "//*" $url]} {
	set url [string range $url 2 end]

	array set parts [GetUPHP url]
    }

    set parts(path) [string trimleft $url /]

    return [array get parts]
}

proc ::uri::JoinHttp {args} {
    eval [linsert $args 0 uri::JoinHttpInner http 80]
}

proc ::uri::JoinHttps {args} {
    eval [linsert $args 0 uri::JoinHttpInner https 443]
}

proc ::uri::JoinHttpInner {scheme defport args} {
    array set components [list 	host {} port $defport path {} query {}     ]
    array set components $args

    set port {}
    if {[string length $components(port)] && $components(port) != $defport} {
	set port :$components(port)
    }

    set query {}
    if {[string length $components(query)]} {
	set query ?$components(query)
    }

    regsub -- {^/} $components(path) {} components(path)

    if { [info exists components(fragment)] && $components(fragment) != "" } {
	set components(fragment) "#$components(fragment)"
    } else {
	set components(fragment) ""
    }

    return $scheme://$components(host)$port/$components(path)$components(fragment)$query
}

proc ::uri::SplitFile {url} {
    # @c Splits the given file-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    upvar #0 [namespace current]::basic::hostname	hostname
    upvar #0 [namespace current]::basic::hostnumber	hostnumber

    if {[string match "//*" $url]} {
	set url [string range $url 2 end]

	set hostPattern "^($hostname|$hostnumber)"
	switch -exact -- $::tcl_platform(platform) {
	    windows {
		# Catch drive letter
		append hostPattern :?
	    }
	    default {
		# Proceed as usual
	    }
	}

	if {[regexp -indices -- $hostPattern $url match host]} {
	    set fh	[lindex $host 0]
	    set th	[lindex $host 1]

	    set parts(host)	[string range $url $fh $th]

	    set  matchEnd   [lindex $match 1]
	    incr matchEnd

	    set url	[string range $url $matchEnd end]
	}
    }

    set parts(path) $url

    return [array get parts]
}

proc ::uri::JoinFile args {
    array set components {
	host {} port {} path {}
    }
    array set components $args

    switch -exact -- $::tcl_platform(platform) {
	windows {
	    if {[string length $components(host)]} {
		return file://$components(host):$components(path)
	    } else {
		return file://$components(path)
	    }
	}
	default {
	    return file://$components(host)$components(path)
	}
    }
}

proc ::uri::SplitMailto {url} {
    # @c Splits the given mailto-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    if {[string match "*@*" $url]} {
	set url [::split $url @]
	return [list user [lindex $url 0] host [lindex $url 1]]
    } else {
	return [list user $url]
    }
}

proc ::uri::JoinMailto args {
    array set components {
	user {} host {}
    }
    array set components $args

    return mailto:$components(user)@$components(host)
}

proc ::uri::SplitNews {url} {
    if { [string first @ $url] >= 0 } {
	return [list message-id $url]
    } else {
	return [list newsgroup-name $url]
    }
}

proc ::uri::JoinNews args {
    array set components {
	message-id {} newsgroup-name {}
    }
    array set components $args
    return news:$components(message-id)$components(newsgroup-name)
}

proc ::uri::GetUPHP {urlvar} {
    # @c Parse user, password host and port out of the url stored in
    # @c variable <a urlvar>.
    # @d Side effect: The extracted information is removed from the given url.
    # @r List containing the extracted information in a format suitable for
    # @r 'array set'.
    # @a urlvar: Name of the variable containing the url to parse.

    upvar \#0 [namespace current]::basic::user		user
    upvar \#0 [namespace current]::basic::password	password
    upvar \#0 [namespace current]::basic::hostname	hostname
    upvar \#0 [namespace current]::basic::hostnumber	hostnumber
    upvar \#0 [namespace current]::basic::port		port

    upvar $urlvar url

    array set parts {user {} pwd {} host {} port {}}

    # syntax
    # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
    # "//" already cut off by caller

    set upPattern "^(${user})(:(${password}))?@"

    if {[regexp -indices -- $upPattern $url match theUser c d thePassword]} {
	set fu	[lindex $theUser 0]
	set tu	[lindex $theUser 1]

	set fp	[lindex $thePassword 0]
	set tp	[lindex $thePassword 1]

	set parts(user)	[string range $url $fu $tu]
	set parts(pwd)	[string range $url $fp $tp]

	set  matchEnd   [lindex $match 1]
	incr matchEnd

	set url	[string range $url $matchEnd end]
    }

    set hpPattern "^($hostname|$hostnumber)(:($port))?"

    if {[regexp -indices -- $hpPattern $url match theHost c d e f g h thePort]} {
	set fh	[lindex $theHost 0]
	set th	[lindex $theHost 1]

	set fp	[lindex $thePort 0]
	set tp	[lindex $thePort 1]

	set parts(host)	[string range $url $fh $th]
	set parts(port)	[string range $url $fp $tp]

	set  matchEnd   [lindex $match 1]
	incr matchEnd

	set url	[string range $url $matchEnd end]
    }

    return [array get parts]
}

proc ::uri::GetHostPort {urlvar} {
    # @c Parse host and port out of the url stored in variable <a urlvar>.
    # @d Side effect: The extracted information is removed from the given url.
    # @r List containing the extracted information in a format suitable for
    # @r 'array set'.
    # @a urlvar: Name of the variable containing the url to parse.

    upvar #0 [namespace current]::basic::hostname	hostname
    upvar #0 [namespace current]::basic::hostnumber	hostnumber
    upvar #0 [namespace current]::basic::port		port

    upvar $urlvar url

    set pattern "^(${hostname}|${hostnumber})(:(${port}))?"

    if {[regexp -indices -- $pattern $url match host c d e f g h thePort]} {
	set fromHost	[lindex $host 0]
	set toHost	[lindex $host 1]

	set fromPort	[lindex $thePort 0]
	set toPort	[lindex $thePort 1]

	set parts(host)	[string range $url $fromHost $toHost]
	set parts(port)	[string range $url $fromPort $toPort]

	set  matchEnd   [lindex $match 1]
	incr matchEnd

	set url [string range $url $matchEnd end]
    }

    return [array get parts]
}

# ::uri::resolve --
#
#	Resolve an arbitrary URL, given a base URL
#
# Arguments:
#	base	base URL (absolute)
#	url	arbitrary URL
#
# Results:
#	Returns a URL

proc ::uri::resolve {base url} {
    if {[string length $url]} {
	if {[isrelative $url]} {

	    array set baseparts [split $base]

	    switch -- $baseparts(scheme) {
		http -
		https -
		ftp -
		file {
		    array set relparts [split $url]
		    if { [string match /* $url] } {
			catch { set baseparts(path) $relparts(path) }
		    } elseif { [string match */ $baseparts(path)] } {
			set baseparts(path) "$baseparts(path)$relparts(path)"
		    } else {
			if { [string length $relparts(path)] > 0 } {
			    set path [lreplace [::split $baseparts(path) /] end end]
			    set baseparts(path) "[::join $path /]/$relparts(path)"
			}
		    }
		    catch { set baseparts(query) $relparts(query) }
		    catch { set baseparts(fragment) $relparts(fragment) }
            return [eval [linsert [array get baseparts] 0 join]]
		}
		default {
		    return -code error "unable to resolve relative URL \"$url\""
		}
	    }

	} else {
	    return $url
	}
    } else {
	return $base
    }
}

# ::uri::isrelative --
#
#	Determines whether a URL is absolute or relative
#
# Arguments:
#	url	URL to check
#
# Results:
#	Returns 1 if the URL is relative, 0 otherwise

proc ::uri::isrelative url {
    return [expr {![regexp -- {^[a-z0-9+-.][a-z0-9+-.]*:} $url]}]
}

# ::uri::geturl --
#
#	Fetch the data from an arbitrary URL.
#
#	This package provides a handler for the file:
#	scheme, since this conflicts with the file command.
#
# Arguments:
#	url	address of data resource
#	args	configuration options
#
# Results:
#	Depends on scheme

proc ::uri::geturl {url args} {
    array set urlparts [split $url]

    switch -- $urlparts(scheme) {
	file {
        return [eval [linsert $args 0 file_geturl $url]]
	}
	default {
	    # Load a geturl package for the scheme first and only if
	    # that fails the scheme package itself. This prevents
	    # cyclic dependencies between packages.
	    if {[catch {package require $urlparts(scheme)::geturl}]} {
		package require $urlparts(scheme)
	    }
        return [eval [linsert $args 0 $urlparts(scheme)::geturl $url]]
	}
    }
}

# ::uri::file_geturl --
#
#	geturl implementation for file: scheme
#
# TODO:
#	This is an initial, basic implementation.
#	Eventually want to support all options for geturl.
#
# Arguments:
#	url	URL to fetch
#	args	configuration options
#
# Results:
#	Returns data from file

proc ::uri::file_geturl {url args} {
    variable file:counter

    set var [namespace current]::file[incr file:counter]
    upvar #0 $var state
    array set state {data {}}

    array set parts [split $url]

    set ch [open $parts(path)]
    # Could determine text/binary from file extension,
    # except on Macintosh
    # fconfigure $ch -translation binary
    set state(data) [read $ch]
    close $ch

    return $var
}

# ::uri::join --
#
#	Format a URL
#
# Arguments:
#	args	components, key-value format
#
# Results:
#	A URL

proc ::uri::join args {
    array set components $args

    return [eval [linsert $args 0 Join[string totitle $components(scheme)]]]
}

# ::uri::canonicalize --
#
#	Canonicalize a URL
#
# Acknowledgements:
#	Andreas Kupries <andreas_kupries@users.sourceforge.net>
#
# Arguments:
#	uri	URI (which contains a path component)
#
# Results:
#	The canonical form of the URI

proc ::uri::canonicalize uri {

    # Make uri canonical with respect to dots (path changing commands)
    #
    # Remove single dots (.)  => pwd not changing
    # Remove double dots (..) => gobble previous segment of path
    #
    # Fixes for this command:
    #
    # * Ignore any url which cannot be split into components by this
    #   module. Just assume that such urls do not have a path to
    #   canonicalize.
    #
    # * Ignore any url which could be split into components, but does
    #   not have a path component.
    #
    # In the text above 'ignore' means
    # 'return the url unchanged to the caller'.

    if {[catch {array set u [uri::split $uri]}]} {
	return $uri
    }
    if {![info exists u(path)]} {
	return $uri
    }

    set uri $u(path)

    # Remove leading "./" "../" "/.." (and "/../")
    regsub -all -- {^(\./)+}    $uri {}  uri
    regsub -all -- {^/(\.\./)+} $uri {/} uri
    regsub -all -- {^(\.\./)+}  $uri {}  uri

    # Remove inner /./ and /../
    while {[regsub -all -- {/\./}         $uri {/} uri]} {}
    while {[regsub -all -- {/[^/]+/\.\./} $uri {/} uri]} {}
    while {[regsub -all -- {^[^/]+/\.\./} $uri {}  uri]} {}
    # Munge trailing /..
    while {[regsub -all -- {/[^/]+/\.\.} $uri {/} uri]} {}
    if { $uri == ".." } { set uri "/" }

    set u(path) $uri
    set uri [eval [linsert [array get u] 0 uri::join]]

    return $uri
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# regular expressions covering various url schemes

# Currently known URL schemes:
#
# (RFC 1738)
# ------------------------------------------------
# scheme	basic syntax of scheme specific part
# ------------------------------------------------
# ftp		//<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
#
# http		//<host>:<port>/<path>?<searchpart>
#
# gopher	//<host>:<port>/<gophertype><selector>
#				<gophertype><selector>%09<search>
#		<gophertype><selector>%09<search>%09<gopher+_string>
#
# mailto	<rfc822-addr-spec>
# news		<newsgroup-name>
#		<message-id>
# nntp		//<host>:<port>/<newsgroup-name>/<article-number>
# telnet	//<user>:<password>@<host>:<port>/
# wais		//<host>:<port>/<database>
#		//<host>:<port>/<database>?<search>
#		//<host>:<port>/<database>/<wtype>/<wpath>
# file		//<host>/<path>
# prospero	//<host>:<port>/<hsoname>;<field>=<value>
# ------------------------------------------------
#
# (RFC 2111)
# ------------------------------------------------
# scheme	basic syntax of scheme specific part
# ------------------------------------------------
# mid	message-id
#		message-id/content-id
# cid	content-id
# ------------------------------------------------

# FTP
uri::register ftp {
    variable escape [set [namespace parent [namespace current]]::basic::escape]
    variable login  [set [namespace parent [namespace current]]::basic::login]

    variable	charN	{[a-zA-Z0-9$_.+!*'(,)?:@&=-]}
    variable	char	"(${charN}|${escape})"
    variable	segment	"${char}*"
    variable	path	"${segment}(/${segment})*"

    variable	type		{[AaDdIi]}
    variable	typepart	";type=(${type})"
    variable	schemepart			    "//${login}(/${path}(${typepart})?)?"

    variable	url		"ftp:${schemepart}"
}

# FILE
uri::register file {
    variable	host [set [namespace parent [namespace current]]::basic::host]
    variable	path [set [namespace parent [namespace current]]::ftp::path]

    variable	schemepart	"//(${host}|localhost)?/${path}"
    variable	url		"file:${schemepart}"
}

# HTTP
uri::register http {
    variable	escape         [set [namespace parent [namespace current]]::basic::escape]
    variable	hostOrPort	        [set [namespace parent [namespace current]]::basic::hostOrPort]

    variable	charN		{[a-zA-Z0-9$_.+!*'(,);:@&=-]}
    variable	char		"($charN|${escape})"
    variable	segment		"${char}*"

    variable	path		"${segment}(/${segment})*"
    variable	search		$segment
    variable	schemepart		    "//${hostOrPort}(/${path}(\\?${search})?)?"

    variable	url		"http:${schemepart}"
}

# GOPHER
uri::register gopher {
    variable	xChar         [set [namespace parent [namespace current]]::basic::xChar]
    variable	hostOrPort         [set [namespace parent [namespace current]]::basic::hostOrPort]
    variable	search         [set [namespace parent [namespace current]]::http::search]

    variable	type		$xChar
    variable	selector	"$xChar*"
    variable	string		$selector
    variable	schemepart		    "//${hostOrPort}(/(${type}(${selector}(%09${search}(%09${string})?)?)?)?)?"
    variable	url		"gopher:${schemepart}"
}

# MAILTO
uri::register mailto {
    variable xChar [set [namespace parent [namespace current]]::basic::xChar]
    variable host  [set [namespace parent [namespace current]]::basic::host]

    variable schemepart	"$xChar+(@${host})?"
    variable url	"mailto:${schemepart}"
}

# NEWS
uri::register news {
    variable escape [set [namespace parent [namespace current]]::basic::escape]
    variable alpha  [set [namespace parent [namespace current]]::basic::alpha]
    variable host   [set [namespace parent [namespace current]]::basic::host]

    variable	aCharN		{[a-zA-Z0-9$_.+!*'(,);/?:&=-]}
    variable	aChar		"($aCharN|${escape})"
    variable	gChar		{[a-zA-Z0-9$_.+-]}
    variable	newsgroup-name	"${alpha}${gChar}*"
    variable	message-id	"${aChar}+@${host}"
    variable	schemepart	"\\*|${newsgroup-name}|${message-id}"
    variable	url		"news:${schemepart}"
}

# WAIS
uri::register wais {
    variable	uChar         [set [namespace parent [namespace current]]::basic::xChar]
    variable	hostOrPort         [set [namespace parent [namespace current]]::basic::hostOrPort]
    variable	search         [set [namespace parent [namespace current]]::http::search]

    variable	db		"${uChar}*"
    variable	type		"${uChar}*"
    variable	path		"${uChar}*"

    variable	database	"//${hostOrPort}/${db}"
    variable	index		"//${hostOrPort}/${db}\\?${search}"
    variable	doc		"//${hostOrPort}/${db}/${type}/${path}"

    #variable	schemepart	"${doc}|${index}|${database}"

    variable	schemepart 	    "//${hostOrPort}/${db}((\\?${search})|(/${type}/${path}))?"

    variable	url		"wais:${schemepart}"
}

# PROSPERO
uri::register prospero {
    variable	escape         [set [namespace parent [namespace current]]::basic::escape]
    variable	hostOrPort         [set [namespace parent [namespace current]]::basic::hostOrPort]
    variable	path         [set [namespace parent [namespace current]]::ftp::path]

    variable	charN		{[a-zA-Z0-9$_.+!*'(,)?:@&-]}
    variable	char		"(${charN}|$escape)"

    variable	fieldname	"${char}*"
    variable	fieldvalue	"${char}*"
    variable	fieldspec	";${fieldname}=${fieldvalue}"

    variable	schemepart	"//${hostOrPort}/${path}(${fieldspec})*"
    variable	url		"prospero:$schemepart"
}

package provide uri 1.1.4
        package provide xml 2.6
        package provide dom 2.6
        package provide dom::tcl 2.6
        package provide dom::tclgeneric 2.6
        namespace eval ::xml {}
# 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.6 2002/08/30 07:52:16 balls Exp $

package require Tcl 8.1

package provide sgml 1.9

namespace eval sgml {

    # Convenience routine
    proc cl x {
	return "\[$x\]"
    }

    # Define various regular expressions

    # Character classes
    variable Char \t\n\r\ -\uD7FF\uE000-\uFFFD\u10000-\u10FFFF
    variable BaseChar \u0041-\u005A\u0061-\u007A\u00C0-\u00D6\u00D8-\u00F6\u00F8-\u00FF\u0100-\u0131\u0134-\u013E\u0141-\u0148\u014A-\u017E\u0180-\u01C3\u01CD-\u01F0\u01F4-\u01F5\u01FA-\u0217\u0250-\u02A8\u02BB-\u02C1\u0386\u0388-\u038A\u038C\u038E-\u03A1\u03A3-\u03CE\u03D0-\u03D6\u03DA\u03DC\u03DE\u03E0\u03E2-\u03F3\u0401-\u040C\u040E-\u044F\u0451-\u045C\u045E-\u0481\u0490-\u04C4\u04C7-\u04C8\u04CB-\u04CC\u04D0-\u04EB\u04EE-\u04F5\u04F8-\u04F9\u0531-\u0556\u0559\u0561-\u0586\u05D0-\u05EA\u05F0-\u05F2\u0621-\u063A\u0641-\u064A\u0671-\u06B7\u06BA-\u06BE\u06C0-\u06CE\u06D0-\u06D3\u06D5\u06E5-\u06E6\u0905-\u0939\u093D\u0958-\u0961\u0985-\u098C\u098F-\u0990\u0993-\u09A8\u09AA-\u09B0\u09B2\u09B6-\u09B9\u09DC-\u09DD\u09DF-\u09E1\u09F0-\u09F1\u0A05-\u0A0A\u0A0F-\u0A10\u0A13-\u0A28\u0A2A-\u0A30\u0A32-\u0A33\u0A35-\u0A36\u0A38-\u0A39\u0A59-\u0A5C\u0A5E\u0A72-\u0A74\u0A85-\u0A8B\u0A8D\u0A8F-\u0A91\u0A93-\u0AA8\u0AAA-\u0AB0\u0AB2-\u0AB3\u0AB5-\u0AB9\u0ABD\u0AE0\u0B05-\u0B0C\u0B0F-\u0B10\u0B13-\u0B28\u0B2A-\u0B30\u0B32-\u0B33\u0B36-\u0B39\u0B3D\u0B5C-\u0B5D\u0B5F-\u0B61\u0B85-\u0B8A\u0B8E-\u0B90\u0B92-\u0B95\u0B99-\u0B9A\u0B9C\u0B9E-\u0B9F\u0BA3-\u0BA4\u0BA8-\u0BAA\u0BAE-\u0BB5\u0BB7-\u0BB9\u0C05-\u0C0C\u0C0E-\u0C10\u0C12-\u0C28\u0C2A-\u0C33\u0C35-\u0C39\u0C60-\u0C61\u0C85-\u0C8C\u0C8E-\u0C90\u0C92-\u0CA8\u0CAA-\u0CB3\u0CB5-\u0CB9\u0CDE\u0CE0-\u0CE1\u0D05-\u0D0C\u0D0E-\u0D10\u0D12-\u0D28\u0D2A-\u0D39\u0D60-\u0D61\u0E01-\u0E2E\u0E30\u0E32-\u0E33\u0E40-\u0E45\u0E81-\u0E82\u0E84\u0E87-\u0E88\u0E8A\u0E8D\u0E94-\u0E97\u0E99-\u0E9F\u0EA1-\u0EA3\u0EA5\u0EA7\u0EAA-\u0EAB\u0EAD-\u0EAE\u0EB0\u0EB2-\u0EB3\u0EBD\u0EC0-\u0EC4\u0F40-\u0F47\u0F49-\u0F69\u10A0-\u10C5\u10D0-\u10F6\u1100\u1102-\u1103\u1105-\u1107\u1109\u110B-\u110C\u110E-\u1112\u113C\u113E\u1140\u114C\u114E\u1150\u1154-\u1155\u1159\u115F-\u1161\u1163\u1165\u1167\u1169\u116D-\u116E\u1172-\u1173\u1175\u119E\u11A8\u11AB\u11AE-\u11AF\u11B7-\u11B8\u11BA\u11BC-\u11C2\u11EB\u11F0\u11F9\u1E00-\u1E9B\u1EA0-\u1EF9\u1F00-\u1F15\u1F18-\u1F1D\u1F20-\u1F45\u1F48-\u1F4D\u1F50-\u1F57\u1F59\u1F5B\u1F5D\u1F5F-\u1F7D\u1F80-\u1FB4\u1FB6-\u1FBC\u1FBE\u1FC2-\u1FC4\u1FC6-\u1FCC\u1FD0-\u1FD3\u1FD6-\u1FDB\u1FE0-\u1FEC\u1FF2-\u1FF4\u1FF6-\u1FFC\u2126\u212A-\u212B\u212E\u2180-\u2182\u3041-\u3094\u30A1-\u30FA\u3105-\u312C\uAC00-\uD7A3  
    variable Ideographic \u4E00-\u9FA5\u3007\u3021-\u3029
    variable CombiningChar \u0300-\u0345\u0360-\u0361\u0483-\u0486\u0591-\u05A1\u05A3-\u05B9\u05BB-\u05BD\u05BF\u05C1-\u05C2\u05C4\u064B-\u0652\u0670\u06D6-\u06DC\u06DD-\u06DF\u06E0-\u06E4\u06E7-\u06E8\u06EA-\u06ED\u0901-\u0903\u093C\u093E-\u094C\u094D\u0951-\u0954\u0962-\u0963\u0981-\u0983\u09BC\u09BE\u09BF\u09C0-\u09C4\u09C7-\u09C8\u09CB-\u09CD\u09D7\u09E2-\u09E3\u0A02\u0A3C\u0A3E\u0A3F\u0A40-\u0A42\u0A47-\u0A48\u0A4B-\u0A4D\u0A70-\u0A71\u0A81-\u0A83\u0ABC\u0ABE-\u0AC5\u0AC7-\u0AC9\u0ACB-\u0ACD\u0B01-\u0B03\u0B3C\u0B3E-\u0B43\u0B47-\u0B48\u0B4B-\u0B4D\u0B56-\u0B57\u0B82-\u0B83\u0BBE-\u0BC2\u0BC6-\u0BC8\u0BCA-\u0BCD\u0BD7\u0C01-\u0C03\u0C3E-\u0C44\u0C46-\u0C48\u0C4A-\u0C4D\u0C55-\u0C56\u0C82-\u0C83\u0CBE-\u0CC4\u0CC6-\u0CC8\u0CCA-\u0CCD\u0CD5-\u0CD6\u0D02-\u0D03\u0D3E-\u0D43\u0D46-\u0D48\u0D4A-\u0D4D\u0D57\u0E31\u0E34-\u0E3A\u0E47-\u0E4E\u0EB1\u0EB4-\u0EB9\u0EBB-\u0EBC\u0EC8-\u0ECD\u0F18-\u0F19\u0F35\u0F37\u0F39\u0F3E\u0F3F\u0F71-\u0F84\u0F86-\u0F8B\u0F90-\u0F95\u0F97\u0F99-\u0FAD\u0FB1-\u0FB7\u0FB9\u20D0-\u20DC\u20E1\u302A-\u302F\u3099\u309A
    variable Digit \u0030-\u0039\u0660-\u0669\u06F0-\u06F9\u0966-\u096F\u09E6-\u09EF\u0A66-\u0A6F\u0AE6-\u0AEF\u0B66-\u0B6F\u0BE7-\u0BEF\u0C66-\u0C6F\u0CE6-\u0CEF\u0D66-\u0D6F\u0E50-\u0E59\u0ED0-\u0ED9\u0F20-\u0F29
    variable Extender \u00B7\u02D0\u02D1\u0387\u0640\u0E46\u0EC6\u3005\u3031-\u3035\u309D-\u309E\u30FC-\u30FE
    variable Letter $BaseChar|$Ideographic

    # white space
    variable Wsp " \t\r\n"
    variable noWsp [cl ^$Wsp]

    # Various XML names
    variable NameChar \[-$Letter$Digit._:$CombiningChar$Extender\]
    variable Name \[_:$BaseChar$Ideographic\]$NameChar*
    variable Names ${Name}(?:$Wsp$Name)*
    variable Nmtoken $NameChar+
    variable Nmtokens ${Nmtoken}(?:$Wsp$Nmtoken)*

    # table of predefined entities for XML

    variable EntityPredef
    array set EntityPredef {
	lt <   gt >   amp &   quot \"   apos '
    }

}

# These regular expressions are defined here once for better performance

namespace eval sgml {
    variable Wsp

    # Watch out for case-sensitivity

    set attlist_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#REQUIRED|#IMPLIED)
    set attlist_enum_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*\\(([cl ^)]*)\\)[cl $Wsp]*("([cl ^")]*)")? ;# "
    set attlist_fixed_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#FIXED)[cl $Wsp]*([cl ^$Wsp]+)

    set param_entity_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^"$Wsp]*)[cl $Wsp]*"([cl ^"]*)"

    set notation_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(.*)

}

### Utility procedures

# sgml::noop --
#
#	A do-nothing proc
#
# Arguments:
#	args	arguments
#
# Results:
#	Nothing.

proc sgml::noop args {
    return 0
}

# sgml::identity --
#
#	Identity function.
#
# Arguments:
#	a	arbitrary argument
#
# Results:
#	$a

proc sgml::identity a {
    return $a
}

# sgml::Error --
#
#	Throw an error
#
# Arguments:
#	args	arguments
#
# Results:
#	Error return condition.

proc sgml::Error args {
    uplevel return -code error [list $args]
}

### Following procedures are based on html_library

# sgml::zapWhite --
#
#	Convert multiple white space into a single space.
#
# Arguments:
#	data	plain text
#
# Results:
#	As above

proc sgml::zapWhite data {
    regsub -all "\[ \t\r\n\]+" $data { } data
    return $data
}

proc sgml::Boolean value {
    regsub {1|true|yes|on} $value 1 value
    regsub {0|false|no|off} $value 0 value
    return $value
}

# 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-2003 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.13 2003/02/25 04:09:22 balls Exp $

package require Tcl 8.1

package provide xmldefs 2.6

package require sgml 1.8

namespace eval xml {

    namespace export qnamesplit

    # Convenience routine
    proc cl x {
	return "\[$x\]"
    }

    # Define various regular expressions

    # Characters
    variable Char $::sgml::Char

    # white space
    variable Wsp " \t\r\n"
    variable allWsp [cl $Wsp]*
    variable noWsp [cl ^$Wsp]

    # Various XML names and tokens

    variable NameChar $::sgml::NameChar
    variable Name $::sgml::Name
    variable Names $::sgml::Names
    variable Nmtoken $::sgml::Nmtoken
    variable Nmtokens $::sgml::Nmtokens

    # XML Namespaces names

    # NCName ::= Name - ':'
    variable NCName $::sgml::Name
    regsub -all : $NCName {} NCName
    variable QName (${NCName}:)?$NCName		;# (Prefix ':')? LocalPart

    # The definition of the Namespace URI for XML Namespaces themselves.
    # The prefix 'xml' is automatically bound to this URI.
    variable xmlnsNS http://www.w3.org/XML/1998/namespace

    # table of predefined entities

    variable EntityPredef
    array set EntityPredef {
	lt <   gt >   amp &   quot \"   apos '
    }

    # Expressions for pulling things apart
    variable tokExpr <(/?)([::xml::cl ^$::xml::Wsp>/]+)([::xml::cl $::xml::Wsp]*[::xml::cl ^>]*)>
    variable substExpr "\}\n{\\2} {\\1} {\\3} \{"

}

###
###	Exported procedures
###

# xml::qnamesplit --
#
#	Split a QName into its constituent parts:
#	the XML Namespace prefix and the Local-name
#
# Arguments:
#	qname	XML Qualified Name (see XML Namespaces [6])
#
# Results:
#	Returns prefix and local-name as a Tcl list.
#	Error condition returned if the prefix or local-name
#	are not valid NCNames (XML Name)

proc xml::qnamesplit qname {
    variable NCName
    variable Name

    set prefix {}
    set localname $qname
    if {[regexp : $qname]} {
	if {![regexp ^($NCName)?:($NCName)\$ $qname discard prefix localname]} {
	    return -code error "name \"$qname\" is not a valid QName"
	}
    } elseif {![regexp ^$Name\$ $qname]} {
	return -code error "name \"$qname\" is not a valid Name"
    }

    return [list $prefix $localname]
}

###
###	General utility procedures
###

# xml::noop --
#
# A do-nothing proc

proc xml::noop args {}

### Following procedures are based on html_library

# xml::zapWhite --
#
#	Convert multiple white space into a single space.
#
# Arguments:
#	data	plain text
#
# Results:
#	As above

proc xml::zapWhite data {
    regsub -all "\[ \t\r\n\]+" $data { } data
    return $data
}

# sgmlparser.tcl --
#
#	This file provides the generic part of a parser for SGML-based
#	languages, namely HTML and XML.
#
#	NB.  It is a misnomer.  There is no support for parsing
#	arbitrary SGML as such.
#
#	See sgml.tcl for variable definitions.
#
# Copyright (c) 1998-2003 Zveno Pty Ltd
# http://www.zveno.com/
#
# 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.30 2003/02/25 04:09:20 balls Exp $

package require sgml 1.9

package require uri 1.1

package provide sgmlparser 1.0

namespace eval sgml {
    namespace export tokenise parseEvent

    namespace export parseDTD

    # NB. Most namespace variables are defined in sgml-8.[01].tcl
    # to account for differences between versions of Tcl.
    # This especially includes the regular expressions used.

    variable ParseEventNum
    if {![info exists ParseEventNum]} {
	set ParseEventNum 0
    }
    variable ParseDTDnum
    if {![info exists ParseDTDNum]} {
	set ParseDTDNum 0
    }

    variable declExpr [cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*)
    variable EntityExpr [cl $::sgml::Wsp]*(%[cl $::sgml::Wsp])?[cl $::sgml::Wsp]*($::sgml::Name)[cl $::sgml::Wsp]+(.*)

    #variable MarkupDeclExpr <([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*)>
    #variable MarkupDeclSub "} {\\1} {\\2} {\\3} {"
    variable MarkupDeclExpr <[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^>]*)>
    variable MarkupDeclSub "\} {\\1} {\\2} \{"

    variable ExternalEntityExpr ^(PUBLIC|SYSTEM)[cl $::sgml::Wsp]+("|')(.*?)\\2([cl $::sgml::Wsp]+("|')(.*?)\\2)?([cl $::sgml::Wsp]+NDATA[cl $::sgml::Wsp]+($::xml::Name))?\$

    variable StdOptions
    array set StdOptions [list 	-elementstartcommand		[namespace current]::noop		-elementendcommand		[namespace current]::noop		-characterdatacommand		[namespace current]::noop		-processinginstructioncommand	[namespace current]::noop		-externalentitycommand		{}					-xmldeclcommand			[namespace current]::noop		-doctypecommand			[namespace current]::noop		-commentcommand			[namespace current]::noop		-entitydeclcommand		[namespace current]::noop		-unparsedentitydeclcommand	[namespace current]::noop		-parameterentitydeclcommand	[namespace current]::noop		-notationdeclcommand		[namespace current]::noop		-elementdeclcommand		[namespace current]::noop		-attlistdeclcommand		[namespace current]::noop		-paramentityparsing		1					-defaultexpandinternalentities	1					-startdoctypedeclcommand	[namespace current]::noop		-enddoctypedeclcommand		[namespace current]::noop		-entityreferencecommand		{}					-warningcommand			[namespace current]::noop		-errorcommand			[namespace current]::Error		-final				1					-validate			0					-baseurl			{}					-name				{}					-emptyelement			[namespace current]::EmptyElement		-parseattributelistcommand	[namespace current]::noop		-parseentitydeclcommand		[namespace current]::noop		-normalize			1					-internaldtd			{}					-reportempty			0					-ignorewhitespace		0				    ]
}

# sgml::tokenise --
#
#	Transform the given HTML/XML text into a Tcl list.
#
# Arguments:
#	sgml		text to tokenize
#	elemExpr	RE to recognise tags
#	elemSub		transform for matched tags
#	args		options
#
# Valid Options:
#       -internaldtdvariable
#	-final		boolean		True if no more data is to be supplied
#	-statevariable	varName		Name of a variable used to store info
#
# Results:
#	Returns a Tcl list representing the document.

proc sgml::tokenise {sgml elemExpr elemSub args} {
    array set options {-final 1}
    array set options $args
    set options(-final) [Boolean $options(-final)]

    # If the data is not final then there must be a variable to store
    # unused data.
    if {!$options(-final) && ![info exists options(-statevariable)]} {
	return -code error {option "-statevariable" required if not final}
    }

    # Pre-process stage
    #
    # Extract the internal DTD subset, if any

    catch {upvar #0 $options(-internaldtdvariable) dtd}
    if {[regexp {<!DOCTYPE[^[<]+\[([^]]+)\]} $sgml discard dtd]} {
	regsub {(<!DOCTYPE[^[<]+)(\[[^]]+\])} $sgml {\1\&xml:intdtd;} sgml
    }

    # Protect Tcl special characters
    regsub -all {([{}\\])} $sgml {\\\1} sgml

    # Do the translation

    if {[info exists options(-statevariable)]} {
	# Mats: Several rewrites here to handle -final 0 option.
	# If any cached unparsed xml (state(leftover)), prepend it.
	upvar #0 $options(-statevariable) state
	if {[string length $state(leftover)]} {
	    regsub -all $elemExpr $state(leftover)$sgml $elemSub sgml
	    set state(leftover) {}
	} else {
	    regsub -all $elemExpr $sgml $elemSub sgml
	}
	set sgml "{} {} {} \{$sgml\}"

	# Performance note (Tcl 8.0):
	#	Use of lindex, lreplace will cause parsing to list object

	# This RE only fixes chopped inside tags, not chopped text.
	if {[regexp {^([^<]*)(<[^>]*$)} [lindex $sgml end] x text rest]} {
	    set sgml [lreplace $sgml end end $text]
	    # Mats: unmatched stuff means that it is chopped off. Cache it for next round.
	    set state(leftover) $rest
	}

	# Patch from bug report #596959, Marshall Rose
	if {[string compare [lindex $sgml 4] ""]} {
	    set sgml [linsert $sgml 0 {} {} {} {} {}]
	}

    } else {

	# Performance note (Tcl 8.0):
	#	In this case, no conversion to list object is performed

	# Mats: This fails if not -final and $sgml is chopped off right in a tag.	
	regsub -all $elemExpr $sgml $elemSub sgml
	set sgml "{} {} {} \{$sgml\}"
    }

    return $sgml

}

# sgml::parseEvent --
#
#	Produces an event stream for a XML/HTML document,
#	given the Tcl list format returned by tokenise.
#
#	This procedure checks that the document is well-formed,
#	and throws an error if the document is found to be not
#	well formed.  Warnings are passed via the -warningcommand script.
#
#	The procedure only check for well-formedness,
#	no DTD is required.  However, facilities are provided for entity expansion.
#
# Arguments:
#	sgml		Instance data, as a Tcl list.
#	args		option/value pairs
#
# Valid Options:
#	-final			Indicates end of document data
#	-validate		Boolean to enable validation
#	-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
#	-ignorewhitespace	whether to automatically strip whitespace
#
# Results:
#	The various callback scripts are invoked.
#	Returns empty string.
#
# BUGS:
#	If command options are set to empty string then they should not be invoked.

proc sgml::parseEvent {sgml args} {
    variable Wsp
    variable noWsp
    variable Nmtoken
    variable Name
    variable ParseEventNum
    variable StdOptions

    array set options [array get StdOptions]
    catch {array set options $args}

    # Mats:
    # If the data is not final then there must be a variable to persistently store the parse state.
    if {!$options(-final) && ![info exists options(-statevariable)]} {
	return -code error {option "-statevariable" required if not final}
    }
    
    foreach {opt value} [array get options *command] {
	if {[string compare $opt "-externalentitycommand"] && ![string length $value]} {
	    set options($opt) [namespace current]::noop
	}
    }

    if {![info exists options(-statevariable)]} {
	set options(-statevariable) [namespace current]::ParseEvent[incr ParseEventNum]
    }
    if {![info exists options(entities)]} {
	set options(entities) [namespace current]::Entities$ParseEventNum
	array set $options(entities) [array get [namespace current]::EntityPredef]
    }
    if {![info exists options(extentities)]} {
	set options(extentities) [namespace current]::ExtEntities$ParseEventNum
    }
    if {![info exists options(parameterentities)]} {
	set options(parameterentities) [namespace current]::ParamEntities$ParseEventNum
    }
    if {![info exists options(externalparameterentities)]} {
	set options(externalparameterentities) [namespace current]::ExtParamEntities$ParseEventNum
    }
    if {![info exists options(elementdecls)]} {
	set options(elementdecls) [namespace current]::ElementDecls$ParseEventNum
    }
    if {![info exists options(attlistdecls)]} {
	set options(attlistdecls) [namespace current]::AttListDecls$ParseEventNum
    }
    if {![info exists options(notationdecls)]} {
	set options(notationdecls) [namespace current]::NotationDecls$ParseEventNum
    }
    if {![info exists options(namespaces)]} {
	set options(namespaces) [namespace current]::Namespaces$ParseEventNum
    }

    # 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)
		    PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$cdata1]
		    set text [subst -novariable -nocommand $text]
		    set tag {}
		    unset state(cdata)
		    set state(mode) normal
		} elseif {[regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $param discard cdata1]} {
		    # end of CDATA (in attributes)
		    PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$tag$cdata1]
		    set text [subst -novariable -nocommand $text]
		    set tag {}
		    set param {}
		    unset state(cdata)
		    set state(mode) normal
		} elseif {[regexp (.*)\]\][cl $Wsp]*>(.*) $text discard cdata1 text]} {
		    # end of CDATA (in text)
		    PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$tag$param>$cdata1]
		    set text [subst -novariable -nocommand $text]
		    set tag {}
		    set param {}
		    set close {}
		    unset state(cdata)
		    set state(mode) normal
		} else {
		    # CDATA continues
		    append state(cdata) [subst -nocommand -novariable <$close$tag$param>$text]
		    continue
		}
	    }
	    continue {
		# We're skipping elements looking for the close tag
		switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close {
		    0,* {
			continue
		    }
		    *,0, {
			if {![string compare $tag $state(continue:tag)]} {
			    set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]
			    if {![string length $empty]} {
				incr state(continue:level)
			    }
			}
			continue
		    }
		    *,0,/ {
			if {![string compare $tag $state(continue:tag)]} {
			    incr state(continue:level) -1
			}
			if {!$state(continue:level)} {
			    unset state(continue:tag)
			    unset state(continue:level)
			    set state(mode) {}
			}
		    }
		    default {
			continue
		    }
		}
	    }
	    default {
		# The trailing slash on empty elements can't be automatically separated out
		# in the RE, so we must do it here.
		regexp (.*)(/)[cl $Wsp]*$ $param discard param empty
	    }
	}

	# default: normal mode

	# Bug: if the attribute list has a right angle bracket then the empty
	# element marker will not be seen

	set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]

	switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close,$empty {

	    0,0,, {
		# Ignore empty tag - dealt with non-normal mode above
	    }
	    *,0,, {

		# Start tag for an element.

		# Check if the internal DTD entity is in an attribute value
		regsub -all &xml:intdtd\; $param \[$options(-internaldtd)\] param

		set code [catch {ParseEvent:ElementOpen $tag $param [array get options]} msg]
		set state(haveDocElement) 1
		switch $code {
		    0 {# OK}
		    3 {
			# break
			return {}
		    }
		    4 {
			# continue
			# Remember this tag and look for its close
			set state(continue:tag) $tag
			set state(continue:level) 1
			set state(mode) continue
			continue
		    }
		    default {
			return -code $code -errorinfo $::errorInfo $msg
		    }
		}

	    }

	    *,0,/, {

		# End tag for an element.

		set code [catch {ParseEvent:ElementClose $tag [array get options]} msg]
		switch $code {
		    0 {# OK}
		    3 {
			# break
			return {}
		    }
		    4 {
			# continue
			# skip sibling nodes
			set state(continue:tag) [lindex $state(stack) end]
			set state(continue:level) 1
			set state(mode) continue
			continue
		    }
		    default {
			return -code $code -errorinfo $::errorInfo $msg
		    }
		}

	    }

	    *,0,,/ {

		# Empty element

		# The trailing slash sneaks through into the param variable
		regsub -all /[cl $::sgml::Wsp]*\$ $param {} param

		set code [catch {ParseEvent:ElementOpen $tag $param [array get options] -empty 1} msg]
		set state(haveDocElement) 1
		switch $code {
		    0 {# OK}
		    3 {
			# break
			return {}
		    }
		    4 {
			# continue
			# Pretty useless since it closes straightaway
		    }
		    default {
			return -code $code -errorinfo $::errorInfo $msg
		    }
		}
		set code [catch {ParseEvent:ElementClose $tag [array get options] -empty 1} msg]
		switch $code {
		    0 {# OK}
		    3 {
			# break
			return {}
		    }
		    4 {
			# continue
			# skip sibling nodes
			set state(continue:tag) [lindex $state(stack) end]
			set state(continue:level) 1
			set state(mode) continue
			continue
		    }
		    default {
			return -code $code -errorinfo $::errorInfo $msg
		    }
		}

	    }

	    *,1,* {
		# Processing instructions or XML declaration
		switch -glob -- $tag {

		    {\?xml} {
			# XML Declaration
			if {$state(haveXMLDecl)} {
			    uplevel #0 $options(-errorcommand) [list illegalcharacter "unexpected characters \"<$tag\" around line $state(line)"]
			} elseif {![regexp {\?$} $param]} {
			    uplevel #0 $options(-errorcommand) [list missingcharacters "XML Declaration missing characters \"?>\" around line $state(line)"]
			} else {

			    # We can do the parsing in one step with Tcl 8.1 RE's
			    # This has the benefit of performing better WF checking

			    set adv_re [format {^[%s]*version[%s]*=[%s]*("|')(-+|[a-zA-Z0-9_.:]+)\1([%s]+encoding[%s]*=[%s]*("|')([A-Za-z][-A-Za-z0-9._]*)\4)?([%s]*standalone[%s]*=[%s]*("|')(yes|no)\7)?[%s]*\?$} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp]

			    if {[catch {regexp $adv_re $param discard delimiter version discard delimiter encoding discard delimiter standalone} matches]} {
				# Otherwise we must fallback to 8.0.
				# This won't detect certain well-formedness errors

				# Get the version number
				if {[regexp [format {[%s]*version[%s]*=[%s]*"(-+|[a-zA-Z0-9_.:]+)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard version] || [regexp [format {[%s]*version[%s]*=[%s]*'(-+|[a-zA-Z0-9_.:]+)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard version]} {
				    if {[string compare $version "1.0"]} {
					# Should we support future versions?
					# At least 1.X?
					uplevel #0 $options(-errorcommand) [list versionincompatibility "document XML version \"$version\" is incompatible with XML version 1.0"]
				    }
				} else {
				    uplevel #0 $options(-errorcommand) [list missingversion "XML Declaration missing version information around line $state(line)"]
				}

				# Get the encoding declaration
				set encoding {}
				regexp [format {[%s]*encoding[%s]*=[%s]*"([A-Za-z]([A-Za-z0-9._]|-)*)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard encoding
				regexp [format {[%s]*encoding[%s]*=[%s]*'([A-Za-z]([A-Za-z0-9._]|-)*)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard encoding

				# Get the standalone declaration
				set standalone {}
				regexp [format {[%s]*standalone[%s]*=[%s]*"(yes|no)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard standalone
				regexp [format {[%s]*standalone[%s]*=[%s]*'(yes|no)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard standalone

				# Invoke the callback
				uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone]

			    } elseif {$matches == 0} {
				uplevel #0 $options(-errorcommand) [list illformeddeclaration "XML Declaration not well-formed around line $state(line)"]
			    } else {

				# Invoke the callback
				uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone]

			    }

			}

		    }

		    {\?*} {
			# Processing instruction
			set tag [string range $tag 1 end]
			if {[regsub {\?$} $tag {} tag]} {
			    if {[string length [string trim $param]]} {
				uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$param\" in processing instruction around line $state(line)"]
			    }
			} elseif {![regexp ^$Name\$ $tag]} {
			    uplevel #0 $options(-errorcommand) [list illegalcharacter "illegal character in processing instruction target \"$tag\""]
			} elseif {[regexp {^[xX][mM][lL]$} $tag]} {
			    uplevel #0 $options(-errorcommand) [list illegalcharacters "characters \"xml\" not permitted in processing instruction target \"$tag\""]
			} elseif {![regsub {\?$} $param {} param]} {
			    uplevel #0 $options(-errorcommand) [list missingquestion "PI: expected '?' character around line $state(line)"]
			}
			set code [catch {uplevel #0 $options(-processinginstructioncommand) [list $tag [string trimleft $param]]} msg]
			switch $code {
			    0 {# OK}
			    3 {
				# break
				return {}
			    }
			    4 {
				# continue
				# skip sibling nodes
				set state(continue:tag) [lindex $state(stack) end]
				set state(continue:level) 1
				set state(mode) continue
				continue
			    }
			    default {
				return -code $code -errorinfo $::errorInfo $msg
			    }
			}
		    }

		    !DOCTYPE {
			# External entity reference
			# This should move into xml.tcl
			# Parse the params supplied.  Looking for Name, ExternalID and MarkupDecl
			set matched [regexp ^[cl $Wsp]*($Name)[cl $Wsp]*(.*) $param x state(doc_name) param]
			set state(doc_name) [Normalize $state(doc_name) $options(-normalize)]
			set externalID {}
			set pubidlit {}
			set systemlit {}
			set externalID {}
			if {[regexp -nocase ^[cl $Wsp]*(SYSTEM|PUBLIC)(.*) $param x id param]} {
			    switch [string toupper $id] {
				SYSTEM {
				    if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
					set externalID [list SYSTEM $systemlit] ;# "
				    } else {
					uplevel #0 $options(-errorcommand) {syntaxerror {syntax error: SYSTEM identifier not followed by literal}}
				    }
				}
				PUBLIC {
				    if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x pubidlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x pubidlit param]} {
					if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
					    set externalID [list PUBLIC $pubidlit $systemlit]
					} else {
					    uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: PUBLIC identifier not followed by system literal around line $state(line)"]
					}
				    } else {
					uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: PUBLIC identifier not followed by literal around line $state(line)"]
				    }
				}
			    }
			    if {[regexp -nocase ^[cl $Wsp]+NDATA[cl $Wsp]+($Name)(.*) $param x notation param]} {
				lappend externalID $notation
			    }
			}

			set state(inDTD) 1

			ParseEvent:DocTypeDecl [array get options] $state(doc_name) $pubidlit $systemlit $options(-internaldtd)

			set state(inDTD) 0

		    }

		    !--* {

			# Start of a comment
			# See if it ends in the same tag, otherwise change the
			# parsing mode

			regexp {!--(.*)} $tag discard comm1
			if {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $comm1 discard comm1_1]} {
			    # processed comment (end in tag)
			    uplevel #0 $options(-commentcommand) [list $comm1_1]
			} elseif {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $param discard comm2]} {
			    # processed comment (end in attributes)
			    uplevel #0 $options(-commentcommand) [list $comm1$comm2]
			} elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm2 text]} {
			    # processed comment (end in text)
			    uplevel #0 $options(-commentcommand) [list $comm1$param$empty>$comm2]
			} else {
			    # start of comment
			    set state(mode) comment
			    set state(commentdata) "$comm1$param$empty>$text"
			    continue
			}
		    }

		    {!\[CDATA\[*} {

			regexp {!\[CDATA\[(.*)} $tag discard cdata1
			if {[regexp {(.*)]]$} $cdata1 discard cdata2]} {
			    # processed CDATA (end in tag)
			    PCDATA [array get options] [subst -novariable -nocommand $cdata2]
			    set text [subst -novariable -nocommand $text]
			} elseif {[regexp {(.*)]]$} $param discard cdata2]} {
			    # processed CDATA (end in attribute)
			    # Backslashes in param are quoted at this stage
			    PCDATA [array get options] $cdata1[subst -novariable -nocommand $cdata2]
			    set text [subst -novariable -nocommand $text]
			} elseif {[regexp {(.*)]]>(.*)} $text discard cdata2 text]} {
			    # processed CDATA (end in text)
			    # Backslashes in param and text are quoted at this stage
			    PCDATA [array get options] $cdata1[subst -novariable -nocommand $param]$empty>[subst -novariable -nocommand $cdata2]
			    set text [subst -novariable -nocommand $text]
			} else {
			    # start CDATA
			    set state(cdata) "$cdata1$param>$text"
			    set state(mode) cdata
			    continue
			}

		    }

		    !ELEMENT -
		    !ATTLIST -
		    !ENTITY -
		    !NOTATION {
			uplevel #0 $options(-errorcommand) [list illegaldeclaration "[string range $tag 1 end] declaration not expected in document instance around line $state(line)"]
		    }

		    default {
			uplevel #0 $options(-errorcommand) [list unknowninstruction "unknown processing instruction \"<$tag>\" around line $state(line)"]
		    }
		}
	    }
	    *,1,* -
	    *,0,/,/ {
		# Syntax error
	    	uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: closed/empty tag: tag $tag param $param empty $empty close $close around line $state(line)"]
	    }
	}

	# Process character data

	if {$state(haveDocElement) && [llength $state(stack)]} {

	    # Check if the internal DTD entity is in the text
	    regsub -all &xml:intdtd\; $text \[$options(-internaldtd)\] text

	    # Look for entity references
	    if {([array size entities] || 		    [string length $options(-entityreferencecommand)]) && 		    $options(-defaultexpandinternalentities) && 		    [regexp {&[^;]+;} $text]} {

		# protect Tcl specials
		# NB. braces and backslashes may already be protected
		regsub -all {\\({|}|\\)} $text {\1} text
		regsub -all {([][$\\{}])} $text {\\\1} text

		# Mark entity references
		regsub -all {&([^;]+);} $text [format {%s; %s {\1} ; %s %s} \}\} [namespace code [list Entity [array get options] $options(-entityreferencecommand) [namespace code [list PCDATA [array get options]]] $options(entities)]] [namespace code [list DeProtect [namespace code [list PCDATA [array get options]]]]] \{\{] text
		set text "uplevel #0 [namespace code [list DeProtect1 [namespace code [list PCDATA [array get options]]]]] {{$text}}"
		eval $text
	    } else {

		# Restore protected special characters
		regsub -all {\\([][{}\\])} $text {\1} text
		PCDATA [array get options] $text
	    }
	} elseif {[string length [string trim $text]]} {
	    uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\" in document prolog around line $state(line)"]
	}

    }

    # If this is the end of the document, close all open containers
    if {$options(-final) && [llength $state(stack)]} {
	eval $options(-errorcommand) [list unclosedelement "element [lindex $state(stack) end] remains unclosed around line $state(line)"]
    }

    return {}
}

# sgml::DeProtect --
#
#	Invoke given command after removing protecting backslashes
#	from given text.
#
# Arguments:
#	cmd	Command to invoke
#	text	Text to deprotect
#
# Results:
#	Depends on command

proc sgml::DeProtect1 {cmd text} {
    if {[string compare {} $text]} {
	regsub -all {\\([]$[{}\\])} $text {\1} text
	uplevel #0 $cmd [list $text]
    }
}
proc sgml::DeProtect {cmd text} {
    set text [lindex $text 0]
    if {[string compare {} $text]} {
	regsub -all {\\([]$[{}\\])} $text {\1} text
	uplevel #0 $cmd [list $text]
    }
}

# sgml::ParserDelete --
#
#	Free all memory associated with parser
#
# Arguments:
#	var	global state array
#
# Results:
#	Variables unset

proc sgml::ParserDelete var {
    upvar #0 $var state

    if {![info exists state]} {
	return -code error "unknown parser"
    }

    catch {unset $state(entities)}
    catch {unset $state(parameterentities)}
    catch {unset $state(elementdecls)}
    catch {unset $state(attlistdecls)}
    catch {unset $state(notationdecls)}
    catch {unset $state(namespaces)}

    unset state

    return {}
}

# sgml::ParseEvent:ElementOpen --
#
#	Start of an element.
#
# Arguments:
#	tag	Element name
#	attr	Attribute list
#	opts	Options
#	args	further configuration options
#
# Options:
#	-empty boolean
#		indicates whether the element was an empty element
#
# Results:
#	Modify state and invoke callback

proc sgml::ParseEvent:ElementOpen {tag attr opts args} {
    variable Name
    variable Wsp

    array set options $opts
    upvar #0 $options(-statevariable) state
    array set cfg {-empty 0}
    array set cfg $args
    set handleEmpty 0

    if {$options(-normalize)} {
	set tag [string toupper $tag]
    }

    # Update state
    lappend state(stack) $tag

    # Parse attribute list into a key-value representation
    if {[string compare $options(-parseattributelistcommand) {}]} {
	if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $opts $attr]} attr]} {
	    if {[string compare [lindex $attr 0] "unterminated attribute value"]} {
		uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
		set attr {}
	    } else {

		# It is most likely that a ">" character was in an attribute value.
		# This manifests itself by ">" appearing in the element's text.
		# In this case the callback should return a three element list;
		# the message "unterminated attribute value", the attribute list it
		# did manage to parse and the remainder of the attribute list.

		foreach {msg attlist brokenattr} $attr break

		upvar text elemText
		if {[string first > $elemText] >= 0} {

		    # Now piece the attribute list back together
		    regexp [cl $Wsp]*($Name)[cl $Wsp]*=[cl $Wsp]*("|')(.*) $brokenattr discard attname delimiter attvalue
		    regexp (.*)>([cl ^>]*)\$ $elemText discard remattlist elemText
		    regexp ([cl ^$delimiter]*)${delimiter}(.*) $remattlist discard remattvalue remattlist

		    # Gotcha: watch out for empty element syntax
		    if {[string match */ [string trimright $remattlist]]} {
			set remattlist [string range $remattlist 0 end-1]
			set handleEmpty 1
			set cfg(-empty) 1
		    }

		    append attvalue >$remattvalue
		    lappend attlist $attname $attvalue

		    # Complete parsing the attribute list
		    if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $options(-statevariable) $remattlist]} attr]} {
			uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
			set attr {}
			set attlist {}
		    } else {
			eval lappend attlist $attr
		    }

		    set attr $attlist

		} else {
		    uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
		    set attr {}
		}
	    }
	}
    }

    set empty {}
    if {$cfg(-empty) && $options(-reportempty)} {
	set empty {-empty 1}
    }

    # Check for namespace declarations
    upvar #0 $options(namespaces) namespaces
    set nsdecls {}
    if {[llength $attr]} {
	array set attrlist $attr
	foreach {attrName attrValue} [array get attrlist xmlns*] {
	    unset attrlist($attrName)
	    set colon [set prefix {}]
	    if {[regexp {^xmlns(:(.+))?$} $attrName discard colon prefix]} {
		switch -glob [string length $colon],[string length $prefix] {
		    0,0 {
			# default NS declaration
			lappend state(defaultNSURI) $attrValue
			lappend state(defaultNS) [llength $state(stack)]
			lappend nsdecls $attrValue {}
		    }
		    0,* {
			# Huh?
		    }
		    *,0 {
			# Error
			uplevel #0 $state(-warningcommand) "no prefix specified for namespace URI \"$attrValue\" in element \"$tag\""
		    }
		    default {
			set namespaces($prefix,[llength $state(stack)]) $attrValue
			lappend nsdecls $attrValue $prefix
		    }
		}
	    }
	}
	if {[llength $nsdecls]} {
	    set nsdecls [list -namespacedecls $nsdecls]
	}
	set attr [array get attrlist]
    }

    # Check whether this element has an expanded name
    set ns {}
    if {[regexp {([^:]+):(.*)$} $tag discard prefix tag]} {
	set nsspec [lsort -dictionary -decreasing [array names namespaces $prefix,*]]
	if {[llength $nsspec]} {
	    set nsuri $namespaces([lindex $nsspec 0])
	    set ns [list -namespace $nsuri]
	} else {
	    uplevel #0 $options(-errorcommand) [list namespaceundeclared "no namespace declared for prefix \"$prefix\" in element $tag"]
	}
    } elseif {[llength $state(defaultNSURI)]} {
	set ns [list -namespace [lindex $state(defaultNSURI) end]]
    }

    # Invoke callback
    set code [catch {uplevel #0 $options(-elementstartcommand) [list $tag $attr] $empty $ns $nsdecls} msg]

    # Sometimes empty elements must be handled here (see above)
    if {$code == 0 && $handleEmpty} {
	ParseEvent:ElementClose $tag $opts -empty 1
    }

    return -code $code -errorinfo $::errorInfo $msg
}

# sgml::ParseEvent:ElementClose --
#
#	End of an element.
#
# Arguments:
#	tag	Element name
#	opts	Options
#	args	further configuration options
#
# Options:
#	-empty boolean
#		indicates whether the element as an empty element
#
# Results:
#	Modify state and invoke callback

proc sgml::ParseEvent:ElementClose {tag opts args} {
    array set options $opts
    upvar #0 $options(-statevariable) state
    array set cfg {-empty 0}
    array set cfg $args

    # WF check
    if {[string compare $tag [lindex $state(stack) end]]} {
	uplevel #0 $options(-errorcommand) [list illegalendtag "end tag \"$tag\" does not match open element \"[lindex $state(stack) end]\" around line $state(line)"]
	return
    }

    # Check whether this element has an expanded name
    upvar #0 $options(namespaces) namespaces
    set ns {}
    if {[regexp {([^:]+):(.*)$} $tag discard prefix tag]} {
	set nsuri $namespaces([lindex [lsort -dictionary -decreasing [array names namespaces $prefix,*]] 0])
	set ns [list -namespace $nsuri]
    } elseif {[llength $state(defaultNSURI)]} {
	set ns [list -namespace [lindex $state(defaultNSURI) end]]
    }

    # Pop namespace stacks, if any
    if {[llength $state(defaultNS)]} {
	if {[llength $state(stack)] == [lindex $state(defaultNS) end]} {
	    set state(defaultNS) [lreplace $state(defaultNS) end end]
	}
    }
    foreach nsspec [array names namespaces *,[llength $state(stack)]] {
	unset namespaces($nsspec)
    }

    # Update state
    set state(stack) [lreplace $state(stack) end end]

    set empty {}
    if {$cfg(-empty) && $options(-reportempty)} {
	set empty {-empty 1}
    }

    # Invoke callback
    # Mats: Shall be same as sgml::ParseEvent:ElementOpen to handle exceptions in callback.
    set code [catch {uplevel #0 $options(-elementendcommand) [list $tag] $empty $ns} msg]
    return -code $code -errorinfo $::errorInfo $msg
}

# sgml::PCDATA --
#
#	Process PCDATA before passing to application
#
# Arguments:
#	opts	options
#	pcdata	Character data to be processed
#
# Results:
#	Checks that characters are legal,
#	checks -ignorewhitespace setting.

proc sgml::PCDATA {opts pcdata} {
    array set options $opts

    if {$options(-ignorewhitespace) && 	    ![string length [string trim $pcdata]]} {
	return {}
    }

    if {![regexp ^[cl $::sgml::Char]*\$ $pcdata]} {
	upvar \#0 $options(-statevariable) state
	uplevel \#0 $options(-errorcommand) [list illegalcharacters "illegal, non-Unicode characters found in text \"$pcdata\" around line $state(line)"]
    }

    uplevel \#0 $options(-characterdatacommand) [list $pcdata]
}

# sgml::Normalize --
#
#	Perform name normalization if required
#
# Arguments:
#	name	name to normalize
#	req	normalization required
#
# Results:
#	Name returned as upper-case if normalization required

proc sgml::Normalize {name req} {
    if {$req} {
	return [string toupper $name]
    } else {
	return $name
    }
}

# sgml::Entity --
#
#	Resolve XML entity references (syntax: &xxx;).
#
# Arguments:
#	opts		options
#	entityrefcmd	application callback for entity references
#	pcdatacmd	application callback for character data
#	entities	name of array containing entity definitions.
#	ref		entity reference (the "xxx" bit)
#
# Results:
#	Returns substitution text for given entity.

proc sgml::Entity {opts entityrefcmd pcdatacmd entities ref} {
    array set options $opts
    upvar #0 $options(-statevariable) state

    if {![string length $entities]} {
	set entities [namespace current]::EntityPredef
    }

    switch -glob -- $ref {
	%* {
	    # Parameter entity - not recognised outside of a DTD
	}
	#x* {
	    # Character entity - hex
	    if {[catch {format %c [scan [string range $ref 2 end] %x tmp; set tmp]} char]} {
		return -code error "malformed character entity \"$ref\""
	    }
	    uplevel #0 $pcdatacmd [list $char]

	    return {}

	}
	#* {
	    # Character entity - decimal
	    if {[catch {format %c [scan [string range $ref 1 end] %d tmp; set tmp]} char]} {
		return -code error "malformed character entity \"$ref\""
	    }
	    uplevel #0 $pcdatacmd [list $char]

	    return {}

	}
	default {
	    # General entity
	    upvar #0 $entities map
	    if {[info exists map($ref)]} {

		if {![regexp {<|&} $map($ref)]} {

		    # Simple text replacement - optimise
		    uplevel #0 $pcdatacmd [list $map($ref)]

		    return {}

		}

		# Otherwise an additional round of parsing is required.
		# This only applies to XML, since HTML doesn't have general entities

		# Must parse the replacement text for start & end tags, etc
		# This text must be self-contained: balanced closing tags, and so on

		set tokenised [tokenise $map($ref) $::xml::tokExpr $::xml::substExpr]
		set options(-final) 0
		eval parseEvent [list $tokenised] [array get options]

		return {}

	    } elseif {[string compare $entityrefcmd "::sgml::noop"]} {

		set result [uplevel #0 $entityrefcmd [list $ref]]

		if {[string length $result]} {
		    uplevel #0 $pcdatacmd [list $result]
		}

		return {}

	    } else {

		# Reconstitute entity reference

		uplevel #0 $options(-errorcommand) [list illegalentity "undefined entity reference \"$ref\""]

		return {}

	    }
	}
    }

    # If all else fails leave the entity reference untouched
    uplevel #0 $pcdatacmd [list &$ref\;]

    return {}
}

####################################
#
# DTD parser for SGML (XML).
#
# This DTD actually only handles XML DTDs.  Other language's
# DTD's, such as HTML, must be written in terms of a XML DTD.
#
####################################

# sgml::ParseEvent:DocTypeDecl --
#
#	Entry point for DTD parsing
#
# Arguments:
#	opts	configuration options
#	docEl	document element name
#	pubId	public identifier
#	sysId	system identifier (a URI)
#	intSSet	internal DTD subset

proc sgml::ParseEvent:DocTypeDecl {opts docEl pubId sysId intSSet} {
    array set options {}
    array set options $opts

    set code [catch {uplevel #0 $options(-doctypecommand) [list $docEl $pubId $sysId $intSSet]} err]
    switch $code {
	3 {
	    # break
	    return {}
	}
	0 -
	4 {
	    # continue
	}
	default {
	    return -code $code $err
	}
    }

    # Otherwise we'll parse the DTD and report it piecemeal

    # The internal DTD subset is processed first (XML 2.8)
    # During this stage, parameter entities are only allowed
    # between markup declarations

    ParseDTD:Internal [array get options] $intSSet

    # The external DTD subset is processed last (XML 2.8)
    # During this stage, parameter entities may occur anywhere

    # We must resolve the external identifier to obtain the
    # DTD data.  The application may supply its own resolver.

    if {[string length $pubId] || [string length $sysId]} {
	uplevel #0 $options(-externalentitycommand) [list $options(-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) [list elementdeclared "element \"$name\" already declared"]
    } else {
	switch -- $modspec {
	    EMPTY {
	    	set elements($name) {}
		uplevel #0 $options(-elementdeclcommand) $name {{}}
	    }
	    ANY {
	    	set elements($name) *
		uplevel #0 $options(-elementdeclcommand) $name *
	    }
	    default {
		# Don't parse the content model for now,
		# just pass the model to the application
		if {0 && [regexp [format {^\([%s]*#PCDATA[%s]*(\|([^)]+))?[%s]*\)*[%s]*$} $Wsp $Wsp $Wsp $Wsp] discard discard mtoks]} {
		    set cm($name) [list MIXED [split $mtoks |]]
		} elseif {0} {
		    if {[catch {CModelParse $state(state) $value} result]} {
			eval $options(-errorcommand) [list element? $result]
		    } else {
			set cm($id) [list ELEMENT $result]
		    }
		} else {
		    set elements($name) $modspec
		    uplevel #0 $options(-elementdeclcommand) $name [list $modspec]
		}
	    }
	}
    }
}

# sgml::CModelParse --
#
#	Parse an element content model (non-mixed).
#	A syntax tree is constructed.
#	A transition table is built next.
#
#	This is going to need alot of work!
#
# Arguments:
#	state	state array variable
#	value	the content model data
#
# Results:
#	A Tcl list representing the content model.

proc sgml::CModelParse {state value} {
    upvar #0 $state var

    # First build syntax tree
    set syntaxTree [CModelMakeSyntaxTree $state $value]

    # Build transition table
    set transitionTable [CModelMakeTransitionTable $state $syntaxTree]

    return [list $syntaxTree $transitionTable]
}

# sgml::CModelMakeSyntaxTree --
#
#	Construct a syntax tree for the regular expression.
#
#	Syntax tree is represented as a Tcl list:
#	rep {:choice|:seq {{rep list1} {rep list2} ...}}
#	where:	rep is repetition character, *, + or ?. {} for no repetition
#		listN is nested expression or Name
#
# Arguments:
#	spec	Element specification
#
# Results:
#	Syntax tree for element spec as nested Tcl list.
#
#	Examples:
#	(memo)
#		{} {:seq {{} memo}}
#	(front, body, back?)
#		{} {:seq {{} front} {{} body} {? back}}
#	(head, (p | list | note)*, div2*)
#		{} {:seq {{} head} {* {:choice {{} p} {{} list} {{} note}}} {* div2}}
#	(p | a | ul)+
#		+ {:choice {{} p} {{} a} {{} ul}}

proc sgml::CModelMakeSyntaxTree {state spec} {
    upvar #0 $state var
    variable Wsp
    variable name

    # Translate the spec into a Tcl list.

    # None of the Tcl special characters are allowed in a content model spec.
    if {[regexp {\$|\[|\]|\{|\}} $spec]} {
	return -code error "illegal characters in specification"
    }

    regsub -all [format {(%s)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $name $Wsp $Wsp] $spec [format {%sCModelSTname %s {\1} {\2} {\3}} \n $state] spec
    regsub -all {\(} $spec "\nCModelSTopenParen $state " spec
    regsub -all [format {\)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $Wsp $Wsp] $spec [format {%sCModelSTcloseParen %s {\1} {\2}} \n $state] spec

    array set var {stack {} state start}
    eval $spec

    # Peel off the outer seq, its redundant
    return [lindex [lindex $var(stack) 1] 0]
}

# sgml::CModelSTname --
#
#	Processes a name in a content model spec.
#
# Arguments:
#	state	state array variable
#	name	name specified
#	rep	repetition operator
#	cs	choice or sequence delimiter
#
# Results:
#	See CModelSTcp.

proc sgml::CModelSTname {state name rep cs args} {
    if {[llength $args]} {
	return -code error "syntax error in specification: \"$args\""
    }

    CModelSTcp $state $name $rep $cs
}

# sgml::CModelSTcp --
#
#	Process a content particle.
#
# Arguments:
#	state	state array variable
#	name	name specified
#	rep	repetition operator
#	cs	choice or sequence delimiter
#
# Results:
#	The content particle is added to the current group.

proc sgml::CModelSTcp {state cp rep cs} {
    upvar #0 $state var

    switch -glob -- [lindex $var(state) end]=$cs {
	start= {
	    set var(state) [lreplace $var(state) end end end]
	    # Add (dummy) grouping, either choice or sequence will do
	    CModelSTcsSet $state ,
	    CModelSTcpAdd $state $cp $rep
	}
	:choice= -
	:seq= {
	    set var(state) [lreplace $var(state) end end end]
	    CModelSTcpAdd $state $cp $rep
	}
	start=| -
	start=, {
	    set var(state) [lreplace $var(state) end end [expr {$cs == "," ? ":seq" : ":choice"}]]
	    CModelSTcsSet $state $cs
	    CModelSTcpAdd $state $cp $rep
	}
	:choice=| -
	:seq=, {
	    CModelSTcpAdd $state $cp $rep
	}
	:choice=, -
	:seq=| {
	    return -code error "syntax error in specification: incorrect delimiter after \"$cp\", should be \"[expr {$cs == "," ? "|" : ","}]\""
	}
	end=* {
	    return -code error "syntax error in specification: no delimiter before \"$cp\""
	}
	default {
	    return -code error "syntax error"
	}
    }
    
}

# sgml::CModelSTcsSet --
#
#	Start a choice or sequence on the stack.
#
# Arguments:
#	state	state array
#	cs	choice oir sequence
#
# Results:
#	state is modified: end element of state is appended.

proc sgml::CModelSTcsSet {state cs} {
    upvar #0 $state var

    set cs [expr {$cs == "," ? ":seq" : ":choice"}]

    if {[llength $var(stack)]} {
	set var(stack) [lreplace $var(stack) end end $cs]
    } else {
	set var(stack) [list $cs {}]
    }
}

# sgml::CModelSTcpAdd --
#
#	Append a content particle to the top of the stack.
#
# Arguments:
#	state	state array
#	cp	content particle
#	rep	repetition
#
# Results:
#	state is modified: end element of state is appended.

proc sgml::CModelSTcpAdd {state cp rep} {
    upvar #0 $state var

    if {[llength $var(stack)]} {
	set top [lindex $var(stack) end]
    	lappend top [list $rep $cp]
	set var(stack) [lreplace $var(stack) end end $top]
    } else {
	set var(stack) [list $rep $cp]
    }
}

# sgml::CModelSTopenParen --
#
#	Processes a '(' in a content model spec.
#
# Arguments:
#	state	state array
#
# Results:
#	Pushes stack in state array.

proc sgml::CModelSTopenParen {state args} {
    upvar #0 $state var

    if {[llength $args]} {
	return -code error "syntax error in specification: \"$args\""
    }

    lappend var(state) start
    lappend var(stack) [list {} {}]
}

# sgml::CModelSTcloseParen --
#
#	Processes a ')' in a content model spec.
#
# Arguments:
#	state	state array
#	rep	repetition
#	cs	choice or sequence delimiter
#
# Results:
#	Stack is popped, and former top of stack is appended to previous element.

proc sgml::CModelSTcloseParen {state rep cs args} {
    upvar #0 $state var

    if {[llength $args]} {
	return -code error "syntax error in specification: \"$args\""
    }

    set cp [lindex $var(stack) end]
    set var(stack) [lreplace $var(stack) end end]
    set var(state) [lreplace $var(state) end end]
    CModelSTcp $state $cp $rep $cs
}

# sgml::CModelMakeTransitionTable --
#
#	Given a content model's syntax tree, constructs
#	the transition table for the regular expression.
#
#	See "Compilers, Principles, Techniques, and Tools",
#	Aho, Sethi and Ullman.  Section 3.9, algorithm 3.5.
#
# Arguments:
#	state	state array variable
#	st	syntax tree
#
# Results:
#	The transition table is returned, as a key/value Tcl list.

proc sgml::CModelMakeTransitionTable {state st} {
    upvar #0 $state var

    # Construct nullable, firstpos and lastpos functions
    array set var {number 0}
    foreach {nullable firstpos lastpos} [		TraverseDepth1st $state $st {
	    # Evaluated for leaf nodes
	    # Compute nullable(n)
	    # Compute firstpos(n)
	    # Compute lastpos(n)
	    set nullable [nullable leaf $rep $name]
	    set firstpos [list {} $var(number)]
	    set lastpos [list {} $var(number)]
	    set var(pos:$var(number)) $name
	} {
	    # Evaluated for nonterminal nodes
	    # Compute nullable, firstpos, lastpos
	    set firstpos [firstpos $cs $firstpos $nullable]
	    set lastpos  [lastpos  $cs $lastpos  $nullable]
	    set nullable [nullable nonterm $rep $cs $nullable]
	}	    ] break

    set accepting [incr var(number)]
    set var(pos:$accepting) #

    # var(pos:N) maps from position to symbol.
    # Construct reverse map for convenience.
    # NB. A symbol may appear in more than one position.
    # var is about to be reset, so use different arrays.

    foreach {pos symbol} [array get var pos:*] {
	set pos [lindex [split $pos :] 1]
	set pos2symbol($pos) $symbol
	lappend sym2pos($symbol) $pos
    }

    # Construct the followpos functions
    catch {unset var}
    followpos $state $st $firstpos $lastpos

    # Construct transition table
    # Dstates is [union $marked $unmarked]
    set unmarked [list [lindex $firstpos 1]]
    while {[llength $unmarked]} {
	set T [lindex $unmarked 0]
	lappend marked $T
	set unmarked [lrange $unmarked 1 end]

	# Find which input symbols occur in T
	set symbols {}
	foreach pos $T {
	    if {$pos != $accepting && [lsearch $symbols $pos2symbol($pos)] < 0} {
		lappend symbols $pos2symbol($pos)
	    }
	}
	foreach a $symbols {
	    set U {}
	    foreach pos $sym2pos($a) {
		if {[lsearch $T $pos] >= 0} {
		    # add followpos($pos)
	    	    if {$var($pos) == {}} {
	    	    	lappend U $accepting
	    	    } else {
	    	    	eval lappend U $var($pos)
	    	    }
		}
	    }
	    set U [makeSet $U]
	    if {[llength $U] && [lsearch $marked $U] < 0 && [lsearch $unmarked $U] < 0} {
		lappend unmarked $U
	    }
	    set Dtran($T,$a) $U
	}
	
    }

    return [list [array get Dtran] [array get sym2pos] $accepting]
}

# sgml::followpos --
#
#	Compute the followpos function, using the already computed
#	firstpos and lastpos.
#
# Arguments:
#	state		array variable to store followpos functions
#	st		syntax tree
#	firstpos	firstpos functions for the syntax tree
#	lastpos		lastpos functions
#
# Results:
#	followpos functions for each leaf node, in name/value format

proc sgml::followpos {state st firstpos lastpos} {
    upvar #0 $state var

    switch -- [lindex [lindex $st 1] 0] {
	:seq {
	    for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
	    	followpos $state [lindex [lindex $st 1] $i]						[lindex [lindex $firstpos 0] [expr $i - 1]]				[lindex [lindex $lastpos 0] [expr $i - 1]]
	    	foreach pos [lindex [lindex [lindex $lastpos 0] [expr $i - 1]] 1] {
		    eval lappend var($pos) [lindex [lindex [lindex $firstpos 0] $i] 1]
		    set var($pos) [makeSet $var($pos)]
	    	}
	    }
	}
	:choice {
	    for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
		followpos $state [lindex [lindex $st 1] $i]						[lindex [lindex $firstpos 0] [expr $i - 1]]				[lindex [lindex $lastpos 0] [expr $i - 1]]
	    }
	}
	default {
	    # No action at leaf nodes
	}
    }

    switch -- [lindex $st 0] {
	? {
	    # We having nothing to do here ! Doing the same as
	    # for * effectively converts this qualifier into the other.
	}
	* {
	    foreach pos [lindex $lastpos 1] {
		eval lappend var($pos) [lindex $firstpos 1]
		set var($pos) [makeSet $var($pos)]
	    }
	}
    }

}

# sgml::TraverseDepth1st --
#
#	Perform depth-first traversal of a tree.
#	A new tree is constructed, with each node computed by f.
#
# Arguments:
#	state	state array variable
#	t	The tree to traverse, a Tcl list
#	leaf	Evaluated at a leaf node
#	nonTerm	Evaluated at a nonterminal node
#
# Results:
#	A new tree is returned.

proc sgml::TraverseDepth1st {state t leaf nonTerm} {
    upvar #0 $state var

    set nullable {}
    set firstpos {}
    set lastpos {}

    switch -- [lindex [lindex $t 1] 0] {
	:seq -
	:choice {
	    set rep [lindex $t 0]
	    set cs [lindex [lindex $t 1] 0]

	    foreach child [lrange [lindex $t 1] 1 end] {
		foreach {childNullable childFirstpos childLastpos} 			[TraverseDepth1st $state $child $leaf $nonTerm] break
		lappend nullable $childNullable
		lappend firstpos $childFirstpos
		lappend lastpos  $childLastpos
	    }

	    eval $nonTerm
	}
	default {
	    incr var(number)
	    set rep [lindex [lindex $t 0] 0]
	    set name [lindex [lindex $t 1] 0]
	    eval $leaf
	}
    }

    return [list $nullable $firstpos $lastpos]
}

# sgml::firstpos --
#
#	Computes the firstpos function for a nonterminal node.
#
# Arguments:
#	cs		node type, choice or sequence
#	firstpos	firstpos functions for the subtree
#	nullable	nullable functions for the subtree
#
# Results:
#	firstpos function for this node is returned.

proc sgml::firstpos {cs firstpos nullable} {
    switch -- $cs {
	:seq {
	    set result [lindex [lindex $firstpos 0] 1]
	    for {set i 0} {$i < [llength $nullable]} {incr i} {
	    	if {[lindex [lindex $nullable $i] 1]} {
	    	    eval lappend result [lindex [lindex $firstpos [expr $i + 1]] 1]
		} else {
		    break
		}
	    }
	}
	:choice {
	    foreach child $firstpos {
		eval lappend result $child
	    }
	}
    }

    return [list $firstpos [makeSet $result]]
}

# sgml::lastpos --
#
#	Computes the lastpos function for a nonterminal node.
#	Same as firstpos, only logic is reversed
#
# Arguments:
#	cs		node type, choice or sequence
#	lastpos		lastpos functions for the subtree
#	nullable	nullable functions forthe subtree
#
# Results:
#	lastpos function for this node is returned.

proc sgml::lastpos {cs lastpos nullable} {
    switch -- $cs {
	:seq {
	    set result [lindex [lindex $lastpos end] 1]
	    for {set i [expr [llength $nullable] - 1]} {$i >= 0} {incr i -1} {
		if {[lindex [lindex $nullable $i] 1]} {
		    eval lappend result [lindex [lindex $lastpos $i] 1]
		} else {
		    break
		}
	    }
	}
	:choice {
	    foreach child $lastpos {
		eval lappend result $child
	    }
	}
    }

    return [list $lastpos [makeSet $result]]
}

# sgml::makeSet --
#
#	Turn a list into a set, ie. remove duplicates.
#
# Arguments:
#	s	a list
#
# Results:
#	A set is returned, which is a list with duplicates removed.

proc sgml::makeSet s {
    foreach r $s {
	if {[llength $r]} {
	    set unique($r) {}
	}
    }
    return [array names unique]
}

# sgml::nullable --
#
#	Compute the nullable function for a node.
#
# Arguments:
#	nodeType	leaf or nonterminal
#	rep		repetition applying to this node
#	name		leaf node: symbol for this node, nonterm node: choice or seq node
#	subtree		nonterm node: nullable functions for the subtree
#
# Results:
#	Returns nullable function for this branch of the tree.

proc sgml::nullable {nodeType rep name {subtree {}}} {
    switch -glob -- $rep:$nodeType {
	:leaf -
	+:leaf {
	    return [list {} 0]
	}
	\\*:leaf -
	\\?:leaf {
	    return [list {} 1]
	}
	\\*:nonterm -
	\\?:nonterm {
	    return [list $subtree 1]
	}
	:nonterm -
	+:nonterm {
	    switch -- $name {
		:choice {
		    set result 0
		    foreach child $subtree {
			set result [expr $result || [lindex $child 1]]
		    }
		}
		:seq {
		    set result 1
		    foreach child $subtree {
			set result [expr $result && [lindex $child 1]]
		    }
		}
	    }
	    return [list $subtree $result]
	}
    }
}

# sgml::DTD:ATTLIST --
#
#	<!ATTLIST ...> defines an attribute list.
#
# Arguments:
#	opts	configuration opions
#	name	Element GI
#	attspec	unparsed attribute definitions
#
# Results:
#	Attribute list variables are modified.

proc sgml::DTD:ATTLIST {opts name attspec} {
    variable attlist_exp
    variable attlist_enum_exp
    variable attlist_fixed_exp

    array set options $opts

    # Parse the attribute list.  If it were regular, could just use foreach,
    # but some attributes may have values.
    regsub -all {([][$\\])} $attspec {\\\1} attspec
    regsub -all $attlist_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {} \{" attspec
    regsub -all $attlist_enum_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {} {\\4} \{" attspec
    regsub -all $attlist_fixed_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {\\4} \{" attspec

    eval "noop \{$attspec\}"

    return {}
}

# sgml::DTDAttribute --
#
#	Parse definition of a single attribute.
#
# Arguments:
#	callback	attribute defn callback
#	name	element name
#	var	array variable
#	att	attribute name
#	type	type of this attribute
#	default	default value of the attribute
#	value	other information
#	text	other text (should be empty)
#
# Results:
#	Attribute defn added to array, unless it already exists

proc sgml::DTDAttribute args {
    # BUG: Some problems with parameter passing - deal with it later
    foreach {callback name var att type default value text} $args break

    upvar #0 $var atts

    if {[string length [string trim $text]]} {
	return -code error "unexpected text \"$text\" in attribute definition"
    }

    # What about overridden attribute defns?
    # A non-validating app may want to know about them
    # (eg. an editor)
    if {![info exists atts($name/$att)]} {
	set atts($name/$att) [list $type $default $value]
	uplevel #0 $callback [list $name $att $type $default $value]
    }

    return {}
}

# sgml::DTD:ENTITY --
#
#	<!ENTITY ...> declaration.
#
#	Callbacks:
#	-entitydeclcommand for general entity declaration
#	-unparsedentitydeclcommand for unparsed external entity declaration
#	-parameterentitydeclcommand for parameter entity declaration
#
# Arguments:
#	opts	configuration options
#	name	name of entity being defined
#	param	whether a parameter entity is being defined
#	value	unparsed replacement text
#
# Results:
#	Modifies the caller's entities array variable

proc sgml::DTD:ENTITY {opts name param value} {

    array set options $opts

    if {[string compare % $param]} {
	# Entity declaration - general or external
	upvar #0 $options(entities) ents
	upvar #0 $options(extentities) externals

	if {[info exists ents($name)] || [info exists externals($name)]} {
	    eval $options(-warningcommand) entity [list "entity \"$name\" already declared"]
	} else {
	    if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} {
		return -code error "unable to parse entity declaration due to \"$value\""
	    }
	    switch -glob [lindex $value 0],[lindex $value 3] {
		internal, {
		    set ents($name) [EntitySubst [array get options] [lindex $value 1]]
		    uplevel #0 $options(-entitydeclcommand) [list $name $ents($name)]
		}
		internal,* {
		    return -code error "unexpected NDATA declaration"
		}
		external, {
		    set externals($name) [lrange $value 1 2]
		    uplevel #0 $options(-entitydeclcommand) [eval list $name [lrange $value 1 2]]
		}
		external,* {
		    set externals($name) [lrange $value 1 3]
		    uplevel #0 $options(-unparsedentitydeclcommand) [eval list $name [lrange $value 1 3]]
		}
		default {
		    return -code error "internal error: unexpected parser state"
		}
	    }
	}
    } else {
	# Parameter entity declaration
	upvar #0 $options(parameterentities) PEnts
	upvar #0 $options(externalparameterentities) ExtPEnts

	if {[info exists PEnts($name)] || [info exists ExtPEnts($name)]} {
	    eval $options(-warningcommand) parameterentity [list "parameter entity \"$name\" already declared"]
	} else {
	    if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} {
		return -code error "unable to parse parameter entity declaration due to \"$value\""
	    }
	    if {[string length [lindex $value 3]]} {
		return -code error "NDATA illegal in parameter entity declaration"
	    }
	    switch [lindex $value 0] {
		internal {
		    # Substitute character references and PEs (XML: 4.5)
		    set value [EntitySubst [array get options] [lindex $value 1]]

		    set PEnts($name) $value
		    uplevel #0 $options(-parameterentitydeclcommand) [list $name $value]
		}
		external -
		default {
		    # Get the replacement text now.
		    # Could wait until the first reference, but easier
		    # to just do it now.

		    set token [uri::geturl [uri::resolve $options(-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) [list notationvalue "notation value \"$value\" incorrectly specified"]
    }
}

# sgml::ResolveEntity --
#
#	Default entity resolution routine
#
# Arguments:
#	name	name of parent parser
#	base	base URL for relative URLs
#	sysId	system identifier
#	pubId	public identifier

proc sgml::ResolveEntity {name base sysId pubId} {
    variable ParseEventNum

    if {[catch {uri::resolve $base $sysId} url]} {
	return -code error "unable to resolve system identifier \"$sysId\""
    }
    if {[catch {uri::geturl $url} token]} {
	return -code error "unable to retrieve external entity \"$url\" for system identifier \"$sysId\""
    }

    upvar #0 $token data

    set parser [uplevel #0 $name entityparser]

    $parser parse $data(body) -dtdsubset external
    #$parser free

    return {}
}
# 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-2003 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.12 2003/02/25 04:09:22 balls Exp $

package provide xml::tcl 2.6

#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
	    uplevel 1 [list rename $name {}]
	}

	get {
	    eval $classinfo(-getcommand) [list $name] $args
	}

	parse {
	    if {[llength $args] < 1} {
		return -code error "wrong number of arguments, should be $name parse xml ?options?"
	    }
	    eval $classinfo(-parsecommand) [list $name] $args
	}

	reset {
	    eval $classinfo(-resetcommand) [list $name]
	}

	default {
	    return -code error "unknown method"
	}
    }

    return {}
}

# xml::noop --
#
#	Do nothing utility proc
#
# Arguments:
#	args	whatever
#
# Results:
#	Nothing happens

proc xml::noop args {}
# tclparser-8.1.tcl --
#
#	This file provides a Tcl implementation of a XML parser.
#	This file supports Tcl 8.1.
#
#	See xml-8.[01].tcl for definitions of character sets and
#	regular expressions.
#
# Copyright (c) 1998-2003 Zveno Pty Ltd
# http://www.zveno.com/
# 
# 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.23 2003/02/25 04:09:21 balls Exp $

package require Tcl 8.1

package provide xml::tclparser 2.6

package require xmldefs 2.6

package require sgmlparser 1.0

namespace eval xml::tclparser {

    namespace export create createexternal externalentity parse configure get delete

    # Tokenising expressions

    variable tokExpr $::xml::tokExpr
    variable substExpr $::xml::substExpr

    # Register this parser class

    ::xml::parserclass create tcl 	    -createcommand [namespace code create] 	    -createentityparsercommand [namespace code createentityparser] 	    -parsecommand [namespace code parse] 	    -configurecommand [namespace code configure] 	    -deletecommand [namespace code delete] 	    -resetcommand [namespace code reset]
}

# xml::tclparser::create --
#
#	Creates XML parser object.
#
# Arguments:
#	name	unique identifier for this instance
#
# Results:
#	The state variable is initialised.

proc xml::tclparser::create name {

    # Initialise state variable
    upvar \#0 [namespace current]::$name parser
    array set parser [list -name $name				-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       -defaultcommand -unknownencodingcommand -notstandalonecommand       -startcdatasectioncommand -endcdatasectioncommand       -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 -ignorewhitespace] 	    [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:
#	opts	parser options
#	attrs	attribute string given in a tag
#
# Results:
#	Returns a Tcl list representing the name-value pairs in the 
#	attribute string
#
#	A ">" occurring in the attribute list causes problems when parsing
#	the XML.  This manifests itself by an unterminated attribute value
#	and a ">" appearing the element text.
#	In this case return a three element list;
#	the message "unterminated attribute value", the attribute list it
#	did manage to parse and the remainder of the attribute list.

proc xml::tclparser::ParseAttrs {opts attrs} {

    set result {}

    while {[string length [string trim $attrs]]} {
	if {[regexp [::sgml::cl $::xml::Wsp]*($::xml::Name)[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')([::sgml::cl ^<]*?)\\2(.*) $attrs discard attrName delimiter value attrs]} {
	    lappend result $attrName [NormalizeAttValue $opts $value]
	} elseif {[regexp [::sgml::cl $::xml::Wsp]*$::xml::Name[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')[::sgml::cl ^<]*\$ $attrs]} {
	    return -code error [list {unterminated attribute value} $result $attrs]
	} else {
	    return -code error "invalid attribute list"
	}
    }

    return $result
}

# xml::tclparser::NormalizeAttValue --
#
#	Perform attribute value normalisation.  This involves:
#	. character references are appended to the value
#	. entity references are recursively processed and replacement value appended
#	. whitespace characters cause a space to be appended
#	. other characters appended as-is
#
# Arguments:
#	opts	parser options
#	value	unparsed attribute value
#
# Results:
#	Normalised value returned.

proc xml::tclparser::NormalizeAttValue {opts value} {

    # sgmlparser already has backslashes protected
    # Protect Tcl specials
    regsub -all {([][$])} $value {\\\1} value

    # Deal with white space
    regsub -all "\[$::xml::Wsp\]" $value { } value

    # Find entity refs
    regsub -all {&([^;]+);} $value {[NormalizeAttValue:DeRef $opts {\1}]} value

    return [subst $value]
}

# xml::tclparser::NormalizeAttValue:DeRef --
#
#	Handler to normalize attribute values
#
# Arguments:
#	opts	parser options
#	ref	entity reference
#
# Results:
#	Returns character

proc xml::tclparser::NormalizeAttValue:DeRef {opts ref} {

    switch -glob -- $ref {
	#x* {
	    scan [string range $ref 2 end] %x value
	    set char [format %c $value]
	    # Check that the char is legal for XML
	    if {[regexp [format {^[%s]$} $::xml::Char] $char]} {
		return $char
	    } else {
		return -code error "illegal character"
	    }
	}
	#* {
	    scan [string range $ref 1 end] %d value
	    set char [format %c $value]
	    # Check that the char is legal for XML
	    if {[regexp [format {^[%s]$} $::xml::Char] $char]} {
		return $char
	    } else {
		return -code error "illegal character"
	    }
	}
	lt -
	gt -
	amp -
	quot -
	apos {
	    array set map {lt < gt > amp & quot \" apos '}
	    return $map($ref)
	}
	default {
	    # A general entity.  Must resolve to a text value - no element structure.

	    array set options $opts
	    upvar #0 $options(entities) map

	    if {[info exists map($ref)]} {

		if {[regexp < $map($ref)]} {
		    return -code error "illegal character \"<\" in attribute value"
		}

		if {![regexp & $map($ref)]} {
		    # Simple text replacement
		    return $map($ref)
		}

		# There are entity references in the replacement text.
		# Can't use child entity parser since must catch element structures

		return [NormalizeAttValue $opts $map($ref)]

	    } elseif {[string compare $options(-entityreferencecommand) "::sgml::noop"]} {

		set result [uplevel #0 $options(-entityreferencecommand) [list $ref]]

		return $result

	    } else {
		return -code error "unable to resolve entity reference \"$ref\""
	    }
	}
    }
}

# xml::tclparser::ParseEntity --
#
#	Parse general entity declaration
#
# Arguments:
#	data	text to parse
#
# Results:
#	Tcl list containing entity declaration

proc xml::tclparser::ParseEntity data {
    set data [string trim $data]
    if {[regexp $::sgml::ExternalEntityExpr $data discard type delimiter1 id1 discard delimiter2 id2 optNDATA ndata]} {
	switch $type {
	    PUBLIC {
		return [list external $id2 $id1 $ndata]
	    }
	    SYSTEM {
		return [list external $id1 {} $ndata]
	    }
	}
    } elseif {[regexp {^("|')(.*?)\1$} $data discard delimiter value]} {
	return [list internal $value]
    } else {
	return -code error "badly formed entity declaration"
    }
}

# xml::tclparser::delete --
#
#	Destroy parser data
#
# Arguments:
#	name	parser object
#
# Results:
#	Parser data structure destroyed

proc xml::tclparser::delete name {
    upvar \#0 [namespace current]::$name parser
    catch {::sgml::ParserDelete $parser(-statevariable)}
    catch {unset parser}
    return {}
}

# xml::tclparser::get --
#
#	Retrieve additional information from the parser
#
# Arguments:
#	name	parser object
#	method	info to retrieve
#	args	additional arguments for method
#
# Results:
#	Depends on method

proc xml::tclparser::get {name method args} {
    upvar #0 [namespace current]::$name parser

    switch -- $method {

	elementdecl {
	    switch [llength $args] {

		0 {
		    # Return all element declarations
		    upvar #0 $parser(elementdecls) elements
		    return [array get elements]
		}

		1 {
		    # Return specific element declaration
		    upvar #0 $parser(elementdecls) elements
		    if {[info exists elements([lindex $args 0])]} {
			return [array get elements [lindex $args 0]]
		    } else {
			return -code error "element \"[lindex $args 0]\" not declared"
		    }
		}

		default {
		    return -code error "wrong number of arguments: should be \"elementdecl ?element?\""
		}
	    }
	}

	attlist {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments: should be \"get attlist element\""
	    }

	    upvar #0 $parser(attlistdecls)

	    return {}
	}

	entitydecl {
	}

	parameterentitydecl {
	}

	notationdecl {
	}

	default {
	    return -code error "unknown method \"$method\""
	}
    }

    return {}
}

# xml::tclparser::ExternalEntity --
#
#	Resolve and parse external entity
#
# Arguments:
#	name	parser object
#	base	base URL
#	sys	system identifier
#	pub	public identifier
#
# Results:
#	External entity is fetched and parsed

proc xml::tclparser::ExternalEntity {name base sys pub} {
}

# xml::tclparser:: --
#
#	Reset a parser instance, ready to parse another document
#
# Arguments:
#	name	parser object
#
# Results:
#	Variables unset

proc xml::tclparser::reset {name} {
    upvar \#0 [namespace current]::$name parser

    # Has this parser object been properly initialised?
    if {![info exists parser] || 	    ![info exists parser(-name)]} {
	return [create $name]
    }

    array set parser {
	-final 1
	depth 0
	leftover {}
    }

    foreach var {Entities ExtEntities PEntities ExtPEntities ElDecls AttlistDecls NotDecls} {
	catch {unset [namespace current]::${var}$name}
    }

    # Initialise entities with predefined set
    array set [namespace current]::Entities$name [array get ::sgml::EntityPredef]

    return {}
}
# xpath.tcl --
#
#	Provides an XPath parser for Tcl,
#	plus various support procedures
#
# Copyright (c) 2000-2002 Zveno Pty Ltd
#
# $Id: xpath.tcl,v 1.7 2002/06/14 12:16:23 balls Exp $

package provide xpath 1.0

# We need the XML package for definition of Names
package require xml

namespace eval xpath {
    namespace export split join createnode

    variable axes {
	ancestor
	ancestor-or-self
	attribute
	child
	descendant
	descendant-or-self
	following
	following-sibling
	namespace
	parent
	preceding
	preceding-sibling
	self
    }

    variable nodeTypes {
	comment
	text
	processing-instruction
	node
    }

    # NB. QName has parens for prefix

    variable nodetestExpr ^(${::xml::QName})${::xml::allWsp}(\\(${::xml::allWsp}(("|')(.*?)\\5)?${::xml::allWsp}\\))?${::xml::allWsp}(.*)

    variable nodetestExpr2 ((($::xml::QName)${::xml::allWsp}(\\(${::xml::allWsp}(("|')(.*?)\\7)?${::xml::allWsp}\\))?)|${::xml::allWsp}(\\*))${::xml::allWsp}(.*)
}

# xpath::split --
#
#	Parse an XPath location path
#
# Arguments:
#	locpath	location path
#
# Results:
#	A Tcl list representing the location path.
#	The list has the form: {{axis node-test {predicate predicate ...}} ...}
#	Where each list item is a location step.

proc xpath::split locpath {
    set leftover {}

    set result [InnerSplit $locpath leftover]

    if {[string length [string trim $leftover]]} {
	return -code error "unexpected text \"$leftover\""
    }

    return $result
}

proc xpath::InnerSplit {locpath leftoverVar} {
    upvar $leftoverVar leftover

    variable axes
    variable nodetestExpr
    variable nodetestExpr2

    # First determine whether we have an absolute location path
    if {[regexp {^/(.*)} $locpath discard locpath]} {
	set path {{}}
    } else {
	set path {}
    }

    while {[string length [string trimleft $locpath]]} {
	if {[regexp {^\.\.(.*)} $locpath discard locpath]} {
	    # .. abbreviation
	    set axis parent
	    set nodetest *
	} elseif {[regexp {^/(.*)} $locpath discard locpath]} {
	    # // abbreviation
	    set axis descendant-or-self
	    if {[regexp ^$nodetestExpr2 [string trimleft $locpath] discard discard discard nodetest discard typetest discard discard literal wildcard locpath]} {
		set nodetest [ResolveWildcard $nodetest $typetest $wildcard $literal]
	    } else {
		set leftover $locpath
		return $path
	    }
	} elseif {[regexp ^\\.${::xml::allWsp}(.*) $locpath discard locpath]} {
	    # . abbreviation
	    set axis self
	    set nodetest *
	} elseif {[regexp ^@($::xml::QName)${::xml::allWsp}=${::xml::allWsp}"(\[^"\])"(.*) $locpath discard attrName discard attrValue locpath]} {
	    # @ abbreviation
	    set axis attribute
	    set nodetest $attrName
	} elseif {[regexp ^@($::xml::QName)${::xml::allWsp}=${::xml::allWsp}'(\[^'\])'(.*) $locpath discard attrName discard attrValue locpath]} {
	    # @ abbreviation
	    set axis attribute
	    set nodetest $attrName
	} elseif {[regexp ^@($::xml::QName)(.*) $locpath discard attrName discard2 locpath]} {
	    # @ abbreviation
	    set axis attribute
	    set nodetest $attrName
	} elseif {[regexp ^((${::xml::QName})${::xml::allWsp}::${::xml::allWsp})?\\*(.*) $locpath discard discard axis discard locpath]} {
	    # wildcard specified
	    set nodetest *
	    if {![string length $axis]} {
		set axis child
	    }
	} elseif {[regexp ^((${::xml::QName})${::xml::allWsp}::${::xml::allWsp})?$nodetestExpr2 $locpath discard discard axis discard discard discard nodetest discard typetest discard discard literal wildcard locpath]} {
	    # nodetest, with or without axis
	    if {![string length $axis]} {
		set axis child
	    }
	    set nodetest [ResolveWildcard $nodetest $typetest $wildcard $literal]
	} else {
	    set leftover $locpath
	    return $path
	}

	# ParsePredicates
	set predicates {}
	set locpath [string trimleft $locpath]
	while {[regexp {^\[(.*)} $locpath discard locpath]} {
	    if {[regexp {^([0-9]+)(\].*)} [string trim $locpath] discard posn locpath]} {
		set predicate [list = {function position {}} [list number $posn]]
	    } else {
		set leftover2 {}
		set predicate [ParseExpr $locpath leftover2]
		set locpath $leftover2
		unset leftover2
	    }

	    if {[regexp {^\](.*)} [string trimleft $locpath] discard locpath]} {
		lappend predicates $predicate
	    } else {
		return -code error "unexpected text in predicate \"$locpath\""
	    }
	}

	set axis [string trim $axis]
	set nodetest [string trim $nodetest]

	# This step completed
	if {[lsearch $axes $axis] < 0} {
	    return -code error "invalid axis \"$axis\""
	}
	lappend path [list $axis $nodetest $predicates]

	# Move to next step

	if {[string length $locpath] && ![regexp ^/(.*) $locpath discard locpath]} {
            set leftover $locpath
	    return $path
	}

    }

    return $path
}

# xpath::ParseExpr --
#
#	Parse one expression in a predicate
#
# Arguments:
#	locpath	location path to parse
#	leftoverVar	Name of variable in which to store remaining path
#
# Results:
#	Returns parsed expression as a Tcl list

proc xpath::ParseExpr {locpath leftoverVar} {
    upvar $leftoverVar leftover
    variable nodeTypes

    set expr {}
    set mode expr
    set stack {}

    while {[string index [string trimleft $locpath] 0] != "\]"} {
	set locpath [string trimleft $locpath]
	switch $mode {
	    expr {
		# We're looking for a term
		if {[regexp ^-(.*) $locpath discard locpath]} {
		    # UnaryExpr
		    lappend stack "-"
		} elseif {[regexp ^\\\$({$::xml::QName})(.*) $locpath discard varname discard locpath]} {
		    # VariableReference
		    lappend stack [list varRef $varname]
		    set mode term
		} elseif {[regexp {^\((.*)} $locpath discard locpath]} {
		    # Start grouping
		    set leftover2 {}
		    lappend stack [list group [ParseExpr $locpath leftover2]]
		    set locpath $leftover2
		    unset leftover2

		    if {[regexp {^\)(.*)} [string trimleft $locpath] discard locpath]} {
			set mode term
		    } else {
			return -code error "unexpected text \"$locpath\", expected \")\""
		    }

		} elseif {[regexp {^"([^"]*)"(.*)} $locpath discard literal locpath]} {
		    # Literal (" delimited)
		    lappend stack [list literal $literal]
		    set mode term
		} elseif {[regexp {^'([^']*)'(.*)} $locpath discard literal locpath]} {
		    # Literal (' delimited)
		    lappend stack [list literal $literal]
		    set mode term
		} elseif {[regexp {^([0-9]+(\.[0-9]+)?)(.*)} $locpath discard number discard locpath]} {
		    # Number
		    lappend stack [list number $number]
		    set mode term
		} elseif {[regexp {^(\.[0-9]+)(.*)} $locpath discard number locpath]} {
		    # Number
		    lappend stack [list number $number]
		    set mode term
		} elseif {[regexp ^(${::xml::QName})\\(${::xml::allWsp}(.*) $locpath discard functionName discard locpath]} {
		    # Function call start or abbreviated node-type test

		    if {[lsearch $nodeTypes $functionName] >= 0} {
			# Looking like a node-type test
			if {[regexp ^\\)${::xml::allWsp}(.*) $locpath discard locpath]} {
			    lappend stack [list path [list child [list $functionName ()] {}]]
			    set mode term
			} else {
			    return -code error "invalid node-type test \"$functionName\""
			}
		    } else {
			if {[regexp ^\\)${::xml::allWsp}(.*) $locpath discard locpath]} {
			    set parameters {}
			} else {
			    set leftover2 {}
			    set parameters [ParseExpr $locpath leftover2]
			    set locpath $leftover2
			    unset leftover2
			    while {[regexp {^,(.*)} $locpath discard locpath]} {
				set leftover2 {}
				lappend parameters [ParseExpr $locpath leftover2]
				set locpath $leftover2
				unset leftover2
			    }

			    if {![regexp ^\\)${::xml::allWsp}(.*) [string trimleft $locpath] discard locpath]} {
				return -code error "unexpected text \"locpath\" - expected \")\""
			    }
		        }

			lappend stack [list function $functionName $parameters]
			set mode term
		    }

		} else {
		    # LocationPath
		    set leftover2 {}
		    lappend stack [list path [InnerSplit $locpath leftover2]]
		    set locpath $leftover2
		    unset leftover2
		    set mode term
		}
	    }
	    term {
		# We're looking for an expression operator
		if {[regexp ^-(.*) $locpath discard locpath]} {
		    # UnaryExpr
		    set stack [linsert $stack 0 expr "-"]
		    set mode expr
		} elseif {[regexp ^(and|or|\\=|!\\=|<|>|<\\=|>\\=|\\||\\+|\\-|\\*|div|mod)(.*) $locpath discard exprtype locpath]} {
		    # AndExpr, OrExpr, EqualityExpr, RelationalExpr or UnionExpr
		    set stack [linsert $stack 0 $exprtype]
		    set mode expr
		} else {
		    return -code error "unexpected text \"$locpath\", expecting operator"
		}
	    }
	    default {
		# Should never be here!
		return -code error "internal error"
	    }
	}
    }

    set leftover $locpath
    return $stack
}

# xpath::ResolveWildcard --

proc xpath::ResolveWildcard {nodetest typetest wildcard literal} {
    variable nodeTypes

    switch -glob -- [string length $nodetest],[string length $typetest],[string length $wildcard],[string length $literal] {
	0,0,0,* {
	    return -code error "bad location step (nothing parsed)"
	}
	0,0,* {
	    # Name wildcard specified
	    return *
	}
	*,0,0,* {
	    # Element type test - nothing to do
	    return $nodetest
	}
	*,0,*,* {
	    # Internal error?
	    return -code error "bad location step (found both nodetest and wildcard)"
	}
	*,*,0,0 {
	    # Node type test
	    if {[lsearch $nodeTypes $nodetest] < 0} {
		return -code error "unknown node type \"$typetest\""
	    }
	    return [list $nodetest $typetest]
	}
	*,*,0,* {
	    # Node type test
	    if {[lsearch $nodeTypes $nodetest] < 0} {
		return -code error "unknown node type \"$typetest\""
	    }
	    return [list $nodetest $literal]
	}
	default {
	    # Internal error?
	    return -code error "bad location step"
	}
    }
}

# xpath::join --
#
#	Reconstitute an XPath location path from a
#	Tcl list representation.
#
# Arguments:
#	spath	split path
#
# Results:
#	Returns an Xpath location path

proc xpath::join spath {
    return -code error "not yet implemented"
}

        namespace eval ::dom {variable strictDOM 0}
# dom.tcl --
#
#	This file implements the Tcl language binding for the DOM -
#	the Document Object Model.  Support for the core specification
#	is given here.  Layered support for specific languages, 
#	such as HTML, will be in separate modules.
#
# Copyright (c) 1998-2003 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.
#
# $Id: domimpl.tcl,v 1.18 2003/03/09 11:12:49 balls Exp $

# We need the xml package, so that we get Name defined

package require xml 2.6

# NB. DOM generic layer should be loaded before sourceing this script.
if {[catch {package require dom::generic 2.6}]} {
    package require dom::tclgeneric 2.6
}

package provide dom::tcl 2.6

namespace eval dom::tcl {
    namespace export DOMImplementation
    namespace export hasFeature createDocument create createDocumentType
    namespace export createNode destroy isNode parse selectNode serialize
    namespace export trim

    namespace export document documentFragment node
    namespace export element textNode attribute
    namespace export processingInstruction
    namespace export event

}

# Define generic constants here, since this package
# is always loaded.

namespace eval dom {
    # DOM Level 2 Event defaults
    variable bubbles
    array set bubbles {
	DOMFocusIn 1
	DOMFocusOut 1
	DOMActivate 1
	click 1
	mousedown 1
	mouseup 1
	mouseover 1
	mousemove 1
	mouseout 1
	DOMSubtreeModified 1
	DOMNodeInserted 1
	DOMNodeRemoved 1
	DOMNodeInsertedIntoDocument 0
	DOMNodeRemovedFromDocument 0
	DOMAttrModified 1
	DOMAttrRemoved 1
	DOMCharacterDataModified 1
    }
    variable cancelable
    array set cancelable {
	DOMFocusIn 0
	DOMFocusOut 0
	DOMActivate 1
	click 1
	mousedown 1
	mouseup 1
	mouseover 1
	mousemove 0
	mouseout 1
	DOMSubtreeModified 0
	DOMNodeInserted 0
	DOMNodeRemoved 0
	DOMNodeInsertedIntoDocument 0
	DOMNodeRemovedFromDocument 0
	DOMAttrModified 0
	DOMAttrRemoved 0
	DOMCharacterDataModified 0
    }
}

# Data structure
#
# Documents are stored in an array within the dom namespace.
# Each element of the array is indexed by a unique identifier.
# Each element of the array is a key-value list with at least
# the following fields:
#	id docArray
#	node:parentNode node:childNodes node:nodeType
# Nodes of a particular type may have additional fields defined.
# Note that these fields in many circumstances are configuration options
# for a node type.
#
# "Live" data objects are stored as a separate Tcl variable.
# Lists, such as child node lists, are Tcl list variables (ie scalar)
# and keyed-value lists, such as attribute lists, are Tcl array
# variables.  The accessor function returns the variable name,
# which the application should treat as a read-only object.
#
# A token is a FQ array element reference for a node.

# dom::tcl::DOMImplementation --
#
#	Implementation-dependent functions.
#	Most importantly, this command provides a function to
#	create a document instance.
#
# Arguments:
#	method	method to invoke
#	token	token for node
#	args	arguments for method
#
# Results:
#	Depends on method used.

namespace eval dom::tcl {
    variable DOMImplementationOptions {}
    variable DOMImplementationCounter 0
}

proc dom::tcl::DOMImplementation {method args} {
    variable DOMImplementationOptions
    variable DOMImplementationCounter

    switch -- $method {

	hasFeature {

	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    # Later on, could use Tcl package facility
	    if {[regexp {create|destroy|parse|query|serialize|trim|Events|UIEvents|isNode} [lindex $args 0]]} {
		if {![string compare [lindex $args 1] "1.0"]} {
		    return 1
		} else {
		    return 0
		}
	    } else {
		return 0
	    }

	}

	createDocument {
	    # createDocument introduced in DOM Level 2

	    if {[llength $args] != 3} {
		return -code error "wrong # arguments: should be DOMImplementation nsURI name doctype"
	    }

	    set doc [DOMImplementation create]

	    document createElementNS $doc [lindex $args 0] [lindex $args 1]

	    if {[string length [lindex $args 2]]} {
		document configure -doctype [lindex $args 2]
	    }

	    return $doc
	}

	create {

	    # Non-standard method (see createDocument)
	    # Bootstrap a document instance

	    switch [llength $args] {
		0 {
		    # Allocate unique document array name
	    	    set name [namespace current]::document[incr DOMImplementationCounter]
		}
		1 {
		    # Use array name provided.  Should check that it is safe.
		    set name [lindex $args 0]
		    catch {unset $name}
		}
		default {
		    return -code error "wrong number of arguments"
		}
	    }

	    set varPrefix ${name}var
	    set arrayPrefix ${name}arr

	    array set $name [list counter 1 		node1 [list id node1 docArray $name					node:nodeType documentFragment					node:parentNode {}						node:nodeName #document						node:nodeValue {}						node:childNodes ${varPrefix}1					documentFragment:masterDoc node1				document:implementation [namespace current]::DOMImplementation					document:xmldecl {version 1.0}					document:documentElement {}					document:doctype {}					]]

	    # Initialise child node list
	    set ${varPrefix}1 {}

	    # Return the new toplevel node
	    return ${name}(node1)

	}

	createDocumentType {
	    # Introduced in DOM Level 2

	    # Patch from c.l.t., Richard Calmbach (rc@hnc.com )

	    if {[llength $args] != 5} {
		return -code error "wrong number of arguments, should be: DOMImplementation createDocumentType token name publicid systemid internaldtd"
	    }

	    return [CreateDocType [lindex $args 0] [lindex $args 1] [lrange $args 2 3] [lindex $args 4]]
	}

	createNode {
	    # Non-standard method
	    # Creates node(s) in the given document given an XPath expression

	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    package require xpath

	    return [XPath:CreateNode [lindex $args 0] [lindex $args 1]]
	}

	destroy {

	    # Free all memory associated with a node

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }
	    array set node [set [lindex $args 0]]

	    switch $node(node:nodeType) {

		document -
		documentFragment {

		    if {[string length $node(node:parentNode)]} {
			unset $node(node:childNodes)

			# Dispatch events
			event postMutationEvent $node(node:parentNode) DOMSubtreeModified

			return {}
		    }

		    # else this is the root document node,
		    # and we can optimize the cleanup.
		    # No need to dispatch events.

		    # Patch from Gerald Lester

		    ##
		    ## First release all the associated variables
		    ##
		    upvar #0 $node(docArray) docArray
		    for {set i 0} {$i <= $docArray(counter)} {incr i} {
			catch {unset $node(docArray)var$i}
			catch {unset $node(docArray)arr$i}
			catch {unset $node(docArray)search$i}
		    }
             
		    ##
		    ## Then release the main document array
		    ##
		    if {[catch {unset $node(docArray)}]} {
			return -code error "unable to destroy document"
		    }

		}

		element {
		    # First make sure the node is removed from the tree
		    if {[string length $node(node:parentNode)]} {
			node removeChild $node(node:parentNode) [lindex $args 0]
		    }
		    unset $node(node:childNodes)
		    unset $node(element:attributeList)
		    unset [lindex $args 0]

		    # Don't dispatch events here -
		    # already done by removeChild
		}

		event {
		    unset [lindex $args 0]
		}

		default {
		    # First make sure the node is removed from the tree
		    if {[string length $node(node:parentNode)]} {
			node removeChild $node(node:parentNode) [lindex $args 0]
		    }
		    unset [lindex $args 0]

		    # Dispatch events
		    event postMutationEvent $node(node:parentNode) DOMSubtreeModified

		}

	    }

	    return {}

	}

	isNode {
	    # isNode - non-standard method
	    # Sometimes it is useful to check if an arbitrary string
	    # refers to a DOM node

	    if {![info exists [lindex $args 0]]} {
		return 0
	    } elseif {[catch {array set node [set [lindex $args 0]]}]} {
		return 0
	    } elseif {[info exists node(node:nodeType)]} {
		return 1
	    } else {
		return 0
	    }
	}

	parse {

	    # This implementation uses TclXML version 2.0.
	    # TclXML can choose the best installed parser.

	    if {[llength $args] < 1} {
		return -code error "wrong number of arguments"
	    }

	    array set opts {-parser {} -progresscommand {} -chunksize 8196}
	    if {[catch {array set opts [lrange $args 1 end]}]} {
		return -code error "bad configuration options"
	    }

	    # Create a state array for this parse session
	    set state [namespace current]::parse[incr DOMImplementationCounter]
	    array set $state [array get opts -*]
	    array set $state [list progCounter 0]
	    set errorCleanup {}

	    if {[string length $opts(-parser)]} {
		set parserOpt [list -parser $opts(-parser)]
	    } else {
		set parserOpt {}
	    }
	    if {[catch {package require xml} version]} {
		eval $errorCleanup
		return -code error "unable to load XML parsing package"
	    }
	    set parser [eval xml::parser $parserOpt]

	    $parser configure 		-elementstartcommand [namespace code [list ParseElementStart $state]]			-elementendcommand [namespace code [list ParseElementEnd $state]]			-characterdatacommand [namespace code [list ParseCharacterData $state]] 		-processinginstructioncommand [namespace code [list ParseProcessingInstruction $state]] 		-commentcommand [namespace code [list ParseComment $state]] 		-entityreferencecommand [namespace code [list ParseEntityReference $state]] 		-xmldeclcommand [namespace code [list ParseXMLDeclaration $state]] 		-doctypecommand [namespace code [list ParseDocType $state]] 		-final 1

	    # Create top-level document
	    array set $state [list docNode [DOMImplementation create]]
	    array set $state [list current [lindex [array get $state docNode] 1]]

	    # Parse data
	    # Bug in TclExpat - doesn't handle non-final inputs
	    if {0 && [string length $opts(-progresscommand)]} {
		$parser configure -final false
		while {[string length [lindex $args 0]]} {
		    $parser parse [string range [lindex $args 0] 0 $opts(-chunksize)]
		    set args [lreplace $args 0 0 			[string range [lindex $args 0] $opts(-chunksize) end]]
		    uplevel #0 $opts(-progresscommand)
		}
		$parser configure -final true
	    } elseif {[catch {$parser parse [lindex $args 0]} err]} {
		catch {rename $parser {}}
		catch {unset $state}
		puts stderr $::errorInfo
		return -code error $err
	    }

	    # Free data structures which are no longer required
	    $parser free
	    catch {rename $parser {}}

	    set doc [lindex [array get $state docNode] 1]
	    unset $state
	    return $doc

	}

	query {
	    # Either: query token string
	    # or: query token ?-tagname string? ?-attrname string? ?-attrvalue string? ?-text string? ?-comment string? ?-pitarget string? ?-pidata string?

	    switch [llength $args] {
		0 -
		1 {
		    return -code error "wrong number of arguments"
		}

		2 {
		    # The query applies to the entire document
		    return [Query [lindex $args 0] -tagname [lindex $args 1] 			-attrname [lindex $args 1] -attrvalue [lindex $args 1] 			-text [lindex $args 1] -comment [lindex $args 1] 			-pitarget [lindex $args 1] -pidata [lindex $args 1]]
		}

		default {
		    # Configuration options have been specified to constrain the search
		    if {[llength [lrange $args 1 end]] % 2} {
			return -code error "no value given for option \"[lindex $args end]\""
		    }
		    set startnode [lindex $args 0]
		    foreach {opt value} [lrange $args 1 end] {
			switch -- $opt {
			    -tagname - -attrname - -attrvalue - -text - 
			    -comment - -pitarget - -pidata {}
			    default {
				return -code error "unknown query option \"$opt\""
			    }
			}
		    }

		    return [eval Query [list $startnode] [lrange $args 1 end]]

		}

	    }

	}

	selectNode {
	    # Non-standard method
	    # Returns nodeset in the given document matching an XPath expression

	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    package require xpath

	    return [XPath:SelectNode [lindex $args 0] [lindex $args 1]]
	}

	serialize {

	    if {[llength $args] < 1} {
		return -code error "wrong number of arguments"
	    }

	    array set node [set [lindex $args 0]]
	    return [eval [list Serialize:$node(node:nodeType)] $args]

	}

	trim {

	    # Removes textNodes that only contain white space

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    Trim [lindex $args 0]

	    # Dispatch DOMSubtreeModified event once here?

	    return {}

	}

	default {
	    return -code error "unknown method \"$method\""
	}

    }

    return {}
}

namespace eval dom::tcl {
    foreach method {hasFeature createDocument create createDocumentType createNode destroy isNode parse selectNode serialize trim} {
	proc $method args "eval [namespace current]::DOMImplementation $method \$args"
    }
}

# dom::tcl::document --
#
#	Functions for a document node.
#
# Arguments:
#	method	method to invoke
#	token	token for node
#	args	arguments for method
#
# Results:
#	Depends on method used.

namespace eval dom::tcl {
    variable documentOptionsRO doctype|implementation|documentElement
    variable documentOptionsRW actualEncoding|encoding|standalone|version
}

proc dom::tcl::document {method token args} {
    variable documentOptionsRO
    variable documentOptionsRW

    array set node [set $token]

    set result {}

    switch -- $method {
	cget {
	    if {[llength $args] != 1} {
		return -code error "too many arguments"
	    }
	    if {[regexp [format {^-(%s)$} $documentOptionsRO] [lindex $args 0] discard option]} {
		return $node(document:$option)
	    } elseif {[regexp [format {^-(%s)$} $documentOptionsRW] [lindex $args 0] discard option]} {
		switch -- $option {
		    encoding -
		    version -
		    standalone {
			array set xmldecl $node(document:xmldecl)
			return $xmldecl($option)
		    }
		    default {
			return $node(document:$option)
		    }
		}
	    } else {
		return -code error "unknown option \"[lindex $args 0]\""
	    }
	}
	configure {
	    if {[llength $args] == 1} {
		return [document cget $token [lindex $args 0]]
	    } elseif {[expr [llength $args] % 2]} {
		return -code error "no value specified for option \"[lindex $args end]\""
	    } else {
		foreach {option value} $args {
		    if {[regexp [format {^-(%s)$} $documentOptionsRW] $option discard opt]} {
			switch -- $opt {
			    encoding {
				catch {unset xmldecl}
				array set xmldecl $node(document:xmldecl)
				set xmldecl(encoding) $value
				set node(document:xmldecl) [array get xmldecl]
			    }
			    standalone {
				if {[string is boolean]} {
				    catch {unset xmldecl}
				    array set xmldecl $node(document:xmldecl)
				    if {[string is true $value]} {
					set xmldecl(standalone) yes
				    } else {
					set xmldecl(standalone) no
				    }
				    set node(document:xmldecl) [array get xmldecl]
				} else {
				    return -code error "unsupported value for option \"$option\" - must be boolean"
				}
			    }
			    version {
				if {$value == "1.0"} {
				    catch {unset xmldecl}
				    array set xmldecl $node(document:xmldecl)
				    set xmldecl(version) $value
				    set node(document:xmldecl) [array get xmldecl]
				} else {
				    return -code error "unsupported value for option \"$option\""
				}
			    }
			    default {
				set node(document:$opt) $value
			    }
			}
		    } elseif {[regexp [format {^-(%s)$} $documentOptionsRO] $option discard opt]} {
			return -code error "attribute \"$option\" is read-only"
		    } else {
			return -code error "unknown option \"$option\""
		    }
		}
	    }

	    set $token [array get node]

	}

	createElement {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    # Check that the element name is kosher
	    if {![regexp ^$::xml::Name\$ [lindex $args 0]]} {
		return -code error "invalid element name \"[lindex $args 0]\""
	    }

	    # Invoke internal factory function
	    set result [CreateElement $token [lindex $args 0] {}]

	}
	createDocumentFragment {
	    if {[llength $args]} {
		return -code error "wrong number of arguments"
	    }

	    set result [CreateGeneric $token node:nodeType documentFragment node:nodeName #document-fragment node:nodeValue {}]
	}
	createTextNode {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    set result [CreateTextNode $token [lindex $args 0]]
	}
	createComment {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    set result [CreateGeneric $token node:nodeType comment node:nodeName #comment node:nodeValue [lindex $args 0]]
	}
	createCDATASection {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    set result [CreateTextNode $token [lindex $args 0]]
	    node configure $result -cdatasection 1
	}
	createProcessingInstruction {
	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    set result [CreateGeneric $token node:nodeType processingInstruction 		    node:nodeName [lindex $args 0] node:nodeValue [lindex $args 1]]
	}
	createAttribute {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    # Check that the attribute name is kosher
	    if {![regexp ^$::xml::Name\$ [lindex $args 0]]} {
		return -code error "invalid attribute name \"[lindex $args 0]\""
	    }

	    set result [CreateGeneric $token node:nodeType attribute node:nodeName [lindex $args 0]]
	}
	createEntity {
	    set result [CreateGeneric $token node:nodeType entity]
	}
	createEntityReference {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }
	    set result [CreateGeneric $token node:nodeType entityReference node:nodeName [lindex $args 0]]
	}

	createDocTypeDecl {
	    # This is not a standard DOM 1.0 method
	    # Deprecated - see DOMImplementation createDocumentType

	    if {[llength $args] < 1 || [llength $args] > 5} {
		return -code error "wrong number of arguments"
	    }

	    foreach {name extid dtd entities notations} $args break
	    set result [CreateDocType $token $name $extid]
	    document configure $token -doctype $result
	    documenttype configure $result -internalsubset $dtd
	    documenttype configure $result -entities $entities
	    documenttype configure $result -notations $notations
	}

	importNode {
	    # Introduced in DOM Level 2

	    return -code error "not yet implemented"
	}

	createElementNS {
	    # Introduced in DOM Level 2

	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments, should be: createElementNS nsuri qualname"
	    }

	    # Check that the qualified name is kosher
	    if {[catch {foreach {prefix localname} [::xml::qnamesplit [lindex $args 1]]  break} err]} {
		return -code error "invalid qualified name \"[lindex $args 1]\" due to \"$err\""
	    }

	    # Invoke internal factory function
	    set result [CreateElement $token [lindex $args 1] {} -prefix $prefix -namespace [lindex $args 0] -localname $localname]
	}

	createAttributeNS {
	    # Introduced in DOM Level 2

	    return -code error "not yet implemented"
	}

	getElementsByTagNameNS {
	    # Introduced in DOM Level 2

	    return -code error "not yet implemented"
	}

	getElementsById {
	    # Introduced in DOM Level 2

	    return -code error "not yet implemented"
	}

	createEvent {
	    # Introduced in DOM Level 2

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    set result [CreateEvent $token [lindex $args 0]]

	}

	getElementsByTagName {
	    if {[llength $args] < 1} {
		return -code error "wrong number of arguments"
	    }

	    return [eval Element:GetByTagName [list $token [lindex $args 0]] 		    [lrange $args 1 end]]
	}

	default {
	    return -code error "unknown method \"$method\""
	}

    }

    # Dispatch events

    # Node insertion events are generated here instead of the
    # internal factory procedures.  This is because the factory
    # procedures are meant to be mean-and-lean during the parsing
    # phase, and dispatching events at that time would be an
    # excessive overhead.  The factory methods here are pretty
    # heavyweight anyway.

    if {[string match create* $method] && [string compare $method "createEvent"]} {

	event postMutationEvent $result DOMNodeInserted -relatedNode $token
	event postMutationEvent $result DOMNodeInsertedIntoDocument
	event postMutationEvent $token DOMSubtreeModified

    }

    return $result
}

###	Factory methods
###
### These are lean-and-mean for fastest possible tree building

# dom::tcl::CreateElement --
#
#	Append an element to the given (parent) node (if any)
#
# Arguments:
#	token	parent node
#	name	element name (no checking performed here)
#	aList	attribute list
#	args	configuration options
#
# Results:
#	New node created, parent optionally modified

proc dom::tcl::CreateElement {token name aList args} {
    array set opts $args

    if {[string length $token]} {
	array set parent [set $token]
	upvar #0 $parent(docArray) docArray
	set docArrayName $parent(docArray)
    } else {
	upvar #0 $opts(-docarray) docArray
	set docArrayName $opts(-docarray)
    }

    set id node[incr docArray(counter)]
    set child ${docArrayName}($id)

    # Create the new node
    # NB. normally we'd use Node:create here,
    # but inline it instead for performance
    set docArray($id) [list id $id docArray $docArrayName 	    node:parentNode $token			    node:childNodes ${docArrayName}var$docArray(counter)		    node:nodeType element			    node:nodeName $name				    node:namespaceURI {}			    node:prefix {}				    node:localName $name			    node:nodeValue {}				    element:attributeList ${docArrayName}arr$docArray(counter) 	    element:attributeNodes {}		    ]

    catch {lappend docArray($id) node:namespaceURI $opts(-namespace)}
    catch {lappend docArray($id) node:localName $opts(-localname)}
    catch {lappend docArray($id) node:prefix $opts(-prefix)}

    # Initialise associated variables
    set ${docArrayName}var$docArray(counter) {}
    array set ${docArrayName}arr$docArray(counter) $aList
    catch {
	foreach {ns nsAttrList} $opts(-namespaceattributelists) {
	    foreach {attrName attrValue} $nsAttrList {
		array set ${docArrayName}arr$docArray(counter) [list $ns^$attrName $attrValue]
	    }
	}
    }

    # Update parent record

    # Does this element qualify as the document element?
    # If so, then has a document element already been set?

    if {[string length $token]} {

	if {![string compare $parent(node:nodeType) documentFragment]} {
	    if {$parent(id) == $parent(documentFragment:masterDoc)} {
		if {[info exists parent(document:documentElement)] && 		    [string length $parent(document:documentElement)]} {
		    unset docArray($id)
		    return -code error "document element already exists"
		} else {

		    # Check against document type decl
		    if {[string length $parent(document:doctype)]} {
			array set doctypedecl [set $parent(document:doctype)]
			if {[string compare $name $doctypedecl(doctype:name)]} {
			    return -code error "mismatch between root element type in document type declaration \"$doctypedecl(doctype:name)\" and root element \"$name\""
			}

		    } else {
			# Synthesize document type declaration
			CreateDocType $token $name {} {}
			# Resynchronise parent record
			array set parent [set $token]
		    }

		    set parent(document:documentElement) $child
		    set $token [array get parent]
		}
	    }
	}

	lappend $parent(node:childNodes) $child

    }

    return $child
}

# dom::tcl::CreateTextNode --
#
#	Append a textNode node to the given (parent) node (if any).
#
#	This factory function can also be performed by
#	CreateGeneric, but text nodes are created so often
#	that this specific factory procedure speeds things up.
#
# Arguments:
#	token	parent node
#	text	initial text
#	args	additional configuration options
#
# Results:
#	New node created, parent optionally modified

proc dom::tcl::CreateTextNode {token text args} {
    if {[string length $token]} {
	array set parent [set $token]
	upvar #0 $parent(docArray) docArray
	set docArrayName $parent(docArray)
    } else {
	array set opts $args
	upvar #0 $opts(-docarray) docArray
	set docArrayName $opts(-docarray)
    }

    set id node[incr docArray(counter)]
    set child ${docArrayName}($id)

    # Create the new node
    # NB. normally we'd use Node:create here,
    # but inline it instead for performance

    # Text nodes never have children, so don't create a variable

    set docArray($id) [list id $id docArray $docArrayName 	    node:parentNode $token			    node:childNodes {}				    node:nodeType textNode			    node:nodeValue $text			    node:nodeName #text				    node:cdatasection 0			    ]

    if {[string length $token]} {
	# Update parent record
	lappend $parent(node:childNodes) $child
	set $token [array get parent]
    }

    return $child
}

# dom::tcl::CreateGeneric --
#
#	This is a template used for type-specific factory procedures
#
# Arguments:
#	token	parent node
#	args	optional values
#
# Results:
#	New node created, parent modified

proc dom::tcl::CreateGeneric {token args} {
    if {[string length $token]} {
	array set parent [set $token]
	upvar #0 $parent(docArray) docArray
	set docArrayName $parent(docArray)
    } else {
	array set opts $args
	upvar #0 $opts(-docarray) docArray
	set docArrayName $opts(-docarray)
	array set tmp [array get opts]
	foreach opt [array names tmp -*] {
	    unset tmp($opt)
	}
	set args [array get tmp]
    }

    set id node[incr docArray(counter)]
    set child ${docArrayName}($id)

    # Create the new node
    # NB. normally we'd use Node:create here,
    # but inline it instead for performance
    set docArray($id) [eval list [list id $id docArray $docArrayName		    node:parentNode $token						    node:childNodes ${docArrayName}var$docArray(counter)]		    $args
    ]
    set ${docArrayName}var$docArray(counter) {}

    catch {unset opts}
    array set opts $args
    switch -glob -- [string length $token],$opts(node:nodeType) {
	0,* -
	*,attribute -
	*,namespace {
	    # These type of nodes are not children of their parent
	}

	default {
	    # Update parent record
	    lappend $parent(node:childNodes) $child
	    set $token [array get parent]
	}
    }

    return $child
}

### Specials

# dom::tcl::CreateDocType --
#
#	Create a Document Type Declaration node.
#
# Arguments:
#	token	node id for the document node
#	name	root element type
#	extid	external entity id
#	dtd	internal DTD subset
#
# Results:
#	Returns node id of the newly created node.

proc dom::tcl::CreateDocType {token name {extid {}} {dtd {}} {entities {}} {notations {}}} {
    array set doc [set $token]
    upvar #0 $doc(docArray) docArray

    set id node[incr docArray(counter)]
    set child $doc(docArray)($id)

    if {[llength $dtd] == 1 && [string length [lindex $dtd 0]] == 0} {
	set dtd {}
    }

    set docArray($id) [list 	    id $id docArray $doc(docArray) 	    node:parentNode $token 	    node:childNodes {} 	    node:nodeType docType 	    node:nodeName {} 	    node:nodeValue {} 	    doctype:name $name 	    doctype:entities {} 	    doctype:notations {} 	    doctype:externalid $extid 	    doctype:internaldtd $dtd     ]
    # NB. externalid and internaldtd are not standard DOM 1.0 attributes

    # Update parent

    set doc(document:doctype) $child

    # BUG: The doc type is NOT a child of the document node.
    # This behaviour has been removed.
    ##Add this node to the parent's child list
    ## This must come before the document element,
    ## so this implementation may be buggy
    #lappend $doc(node:childNodes) $child

    set $token [array get doc]

    return $child
}

# dom::tcl::node --
#
#	Functions for a general node.
#
#	Implements EventTarget Interface - introduced in DOM Level 2
#
# Arguments:
#	method	method to invoke
#	token	token for node
#	args	arguments for method
#
# Results:
#	Depends on method used.

namespace eval dom::tcl {
    variable nodeOptionsRO nodeType|parentNode|childNodes|firstChild|lastChild|previousSibling|nextSibling|attributes|namespaceURI|prefix|localName|ownerDocument
    variable nodeOptionsRW nodeValue|cdatasection

    # Allowing nodeName to be rw is not standard DOM.
    # A validating implementation would have to be very careful
    # in allowing this feature
    if {$::dom::strictDOM} {
	append nodeOptionsRO |nodeName
    } else {
	append nodeOptionsRW |nodeName
    }
}
# NB. cdatasection is not a standard DOM option

proc dom::tcl::node {method token args} {
    variable nodeOptionsRO
    variable nodeOptionsRW

    if {[catch {array set node [set $token]}]} {
	return -code error "token not found"
    }

    set result {}

    switch -glob -- $method {
	cg* {
	    # cget

	    # Some read-only configuration options are computed
	    if {[llength $args] != 1} {
		return -code error "too many arguments"
	    }
	    if {[regexp [format {^-(%s)$} $nodeOptionsRO] [lindex $args 0] discard option]} {
		switch $option {
		    nodeName {
			set result $node(node:nodeName)
			switch $node(node:nodeType) {
			    textNode {
				catch {set result [expr {$node(node:cdatasection) ? "#cdata-section" : $node(node:nodeName)}]}
			    }
			    default {
			    }
			}
		    }
		    childNodes {
			# How are we going to handle documentElement?
			set result $node(node:childNodes)
		    }
		    firstChild {
			upvar #0 $node(node:childNodes) children
			switch $node(node:nodeType) {
			    documentFragment {
				set result [lindex $children 0]
				catch {set result $node(document:documentElement)}
			    }
			    default {
				set result [lindex $children 0]
			    }
			}
		    }
		    lastChild {
			upvar #0 $node(node:childNodes) children
			switch $node(node:nodeType) {
			    documentFragment {
				set result [lindex $children end]
				catch {set result $node(document:documentElement)}
			    }
			    default {
				set result [lindex $children end]
			    }
			}
		    }
		    previousSibling {
			# BUG: must take documentElement into account
			# Find the parent node
			array set parent [set $node(node:parentNode)]
			upvar #0 $parent(node:childNodes) children
			set idx [lsearch $children $token]
			if {$idx >= 0} {
			    set sib [lindex $children [incr idx -1]]
			    if {[llength $sib]} {
				set result $sib
			    } else {
				set result {}
			    }
			} else {
			    set result {}
			}
		    }
		    nextSibling {
			# BUG: must take documentElement into account
			# Find the parent node
			array set parent [set $node(node:parentNode)]
			upvar #0 $parent(node:childNodes) children
			set idx [lsearch $children $token]
			if {$idx >= 0} {
			    set sib [lindex $children [incr idx]]
			    if {[llength $sib]} {
				set result $sib
			    } else {
				set result {}
			    }
			} else {
			    set result {}
			}
		    }
		    attributes {
			if {[string compare $node(node:nodeType) element]} {
			    set result {}
			} else {
			    set result $node(element:attributeList)
			}
		    }
		    ownerDocument {
			if {[string compare $node(node:parentNode) {}]} {
			    return $node(docArray)(node1)
			} else {
			    return $token
			}
		    }
		    default {
			return [GetField node(node:$option)]
		    }
		}
	    } elseif {[regexp [format {^-(%s)$} $nodeOptionsRW] [lindex $args 0] discard option]} {
		return [GetField node(node:$option)]
	    } else {
		return -code error "unknown option \"[lindex $args 0]\""
	    }
	}
	co* {
	    # configure

	    if {[llength $args] == 1} {
		return [node cget $token [lindex $args 0]]
	    } elseif {[expr [llength $args] % 2]} {
		return -code error "wrong \# args: should be \"::dom::node configure node option\""
	    } else {
		foreach {option value} $args {
		    if {[regexp [format {^-(%s)$} $nodeOptionsRW] $option discard opt]} {

			switch $opt,$node(node:nodeType) {
			    nodeValue,textNode -
			    nodeValue,processingInstruction {
				# Dispatch event
				set evid [CreateEvent $token DOMCharacterDataModified]
				event initMutationEvent $evid DOMCharacterDataModified 1 0 {} $node(node:nodeValue) $value {}
				set node(node:nodeValue) $value
				node dispatchEvent $token $evid
				DOMImplementation destroy $evid
			    }
			    default {
				set node(node:$opt) $value
			    }
			}

		    } elseif {[regexp [format {^-(%s)$} $nodeOptionsRO] $option discard opt]} {
			return -code error "attribute \"$option\" is read-only"
		    } else {
			return -code error "unknown option \"$option\""
		    }
		}
	    }
	}

	in* {

	    # insertBefore

	    # Previous and next sibling relationships are OK, 
	    # because they are dynamically determined

	    if {[llength $args] < 1 || [llength $args] > 2} {
		return -code error "wrong number of arguments"
	    }

	    array set newChild [set [lindex $args 0]]
	    if {[string compare $newChild(docArray) $node(docArray)]} {
		return -code error "new node must be in the same document"
	    }

	    switch [llength $args] {
		1 {
		    # Append as the last node
		    if {[string length $newChild(node:parentNode)]} {
			node removeChild $newChild(node:parentNode) [lindex $args 0]
		    }
		    lappend $node(node:childNodes) [lindex $args 0]
		    set newChild(node:parentNode) $token
		}
		2 {

		    array set refChild [set [lindex $args 1]]
		    if {[string compare $refChild(docArray) $newChild(docArray)]} {
			return -code error "nodes must be in the same document"
		    }
		    set idx [lsearch [set $node(node:childNodes)] [lindex $args 1]]
		    if {$idx < 0} {
			return -code error "no such reference child"
		    } else {

			# Remove from previous parent
			if {[string length $newChild(node:parentNode)]} {
			    node removeChild $newChild(node:parentNode) [lindex $args 0]
			}

			# Insert into new node
			set $node(node:childNodes) 				[linsert [set $node(node:childNodes)] $idx [lindex $args 0]]
			set newChild(node:parentNode) $token
		    }
		}
	    }
	    set [lindex $args 0] [array get newChild]

	    event postMutationEvent [lindex $args 0] DOMNodeInserted -relatedNode $token
	    FireNodeInsertedEvents [lindex $args 0]
	    event postMutationEvent $token DOMSubtreeModified

	}

	rep* {

	    # replaceChild

	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    array set newChild [set [lindex $args 0]]
	    array set oldChild [set [lindex $args 1]]

	    # Find where to insert new child
	    set idx [lsearch [set $node(node:childNodes)] [lindex $args 1]]
	    if {$idx < 0} {
		return -code error "no such old child"
	    }

	    # Remove new child from current parent
	    if {[string length $newChild(node:parentNode)]} {
		node removeChild $newChild(node:parentNode) [lindex $args 0]
	    }

	    set $node(node:childNodes) 		[lreplace [set $node(node:childNodes)] $idx $idx [lindex $args 0]]
	    set newChild(node:parentNode) $token

	    # Update old child to reflect lack of parentage
	    set oldChild(node:parentNode) {}

	    set [lindex $args 1] [array get oldChild]
	    set [lindex $args 0] [array get newChild]

	    set result [lindex $args 0]

	    event postMutationEvent [lindex $args 0] DOMNodeInserted -relatedNode $token
	    FireNodeInsertedEvents [lindex $args 0]
	    event postMutationEvent $token DOMSubtreeModified

	}

	rem* {

	    # removeChild

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }
	    array set oldChild [set [lindex $args 0]]
	    if {$oldChild(docArray) != $node(docArray)} {
		return -code error "node \"[lindex $args 0]\" is not a child"
	    }

	    # Remove the child from the parent
	    upvar #0 $node(node:childNodes) myChildren
	    if {[set idx [lsearch $myChildren [lindex $args 0]]] < 0} {
		return -code error "node \"[lindex $args 0]\" is not a child"
	    }
	    set myChildren [lreplace $myChildren $idx $idx]

	    # Update the child to reflect lack of parentage
	    set oldChild(node:parentNode) {}
	    set [lindex $args 0] [array get oldChild]

	    set result [lindex $args 0]

	    # Event propagation has a problem here:
	    # Nodes that until recently were ancestors may
	    # want to capture the event, but we've just removed
	    # the parentage information.  They get a DOMSubtreeModified
	    # instead.
	    event postMutationEvent [lindex $args 0] DOMNodeRemoved -relatedNode $token
	    FireNodeRemovedEvents [lindex $args 0]
	    event postMutationEvent $token DOMSubtreeModified

	}

	ap* {

	    # appendChild

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    # Add to new parent
	    node insertBefore $token [lindex $args 0]

	}

	hasChildNodes {
	    set result [Min 1 [llength [set $node(node:childNodes)]]]
	}

	isSameNode {
	    # Introduced in DOM Level 3
	    switch [llength $args] {
		1 {
		    return [expr {$token == [lindex $args 0]}]
		}
		default {
		    return -code error "wrong # arguments: should be dom::node isSameNode token ref"
		}
	    }
	}

	cl* {
	    # cloneNode

	    # May need to pay closer attention to generation of events here

	    set deep 0
	    switch [llength $args] {
		0 {
		}
		1 {
		    set deep [Boolean [lindex $args 0]]
		}
		default {
		    return -code error "too many arguments"
		}
	    }

	    switch $node(node:nodeType) {
		element {
		    set result [CreateElement {} $node(node:nodeName) [array get $node(element:attributeList)] -docarray $node(docArray)]
		    if {$deep} {
			foreach child [set $node(node:childNodes)] {
			    node appendChild $result [node cloneNode $child]
			}
		    }
		}
		textNode {
		    set result [CreateTextNode {} $node(node:nodeValue) -docarray $node(docArray)]
		}
		document -
		documentFragment -
		default {
		    set result [CreateGeneric {} node:nodeType $node(node:nodeType) -docarray $node(docArray)]
		    if {$deep} {
			foreach child [set $node(node:childNodes)] {
			    node appendChild $result [node cloneNode $child]
			}
		    }
		}
	    }

	}

	ch* {
	    # children -- non-standard method

	    # If this is a textNode, then catch the error
	    set result {}
	    catch {set result [set $node(node:childNodes)]}

	}

	par* {
	    # parent -- non-standard method

	    return $node(node:parentNode)

	}

	pat* {
	    # path -- non-standard method

	    for {
		set ancestor $token
		set result {}
		catch {unset ancNode}
		array set ancNode [set $ancestor]
	    } {[string length $ancNode(node:parentNode)]} {
		set ancestor $ancNode(node:parentNode)
		catch {unset ancNode}
		array set ancNode [set $ancestor]
	    } {
		set result [linsert $result 0 $ancestor]
	    }
	    # The last node is the document node
	    set result [linsert $result 0 $ancestor]

	}

	createNode {
	    # createNode -- non-standard method

	    # Creates node(s) in this document given an XPath expression.
	    # Relative location paths have this node as their initial context.

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    package require xpath

	    return [XPath:CreateNode $token [lindex $args 0]]
	}

	selectNode {
	    # selectNode -- non-standard method

	    # Returns nodeset in this document matching an XPath expression.
	    # Relative location paths have this node as their initial context.

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    package require xpath

	    return [XPath:SelectNode $token [lindex $args 0]]
	}

	stringValue {
	    # stringValue -- non-standard method
	    # Returns string value of a node, as defined by XPath Rec.

	    switch $node(node:nodeType) {
		document -
		documentFragment -
		element {
		    set value {}
		    foreach child [set $node(node:childNodes)] {
			switch [node cget $child -nodeType] {
			    element -
			    textNode {
				append value [node stringValue $child]
			    }
			    default {
				# Other nodes are not considered
			    }
			}
		    }
		    return $value
		}
		attribute -
		textNode -
		processingInstruction -
		comment {
		    return $node(node:nodeValue)
		}
		default {
		    return {}
		}
	    }

	}

	addEv* {
	    # addEventListener -- introduced in DOM Level 2

	    if {[llength $args] < 2} {
		return -code error "wrong number of arguments"
	    }

	    set type [string tolower [lindex $args 0]]
	    set listener [lindex $args 1]
	    array set opts {-usecapture 0}
	    array set opts [lrange $args 2 end]
	    set opts(-usecapture) [Boolean $opts(-usecapture)]
	    set listenerType [expr {$opts(-usecapture) ? "capturer" : "listener"}]

	    if {![info exists node(event:$type:$listenerType)] || 		 [lsearch $node(event:$type:$listenerType) $listener] < 0} {
		lappend node(event:$type:$listenerType) $listener
	    }
	    # else avoid registering same listener twice

	}

	removeEv* {
	    # removeEventListener -- introduced in DOM Level 2

	    if {[llength $args] < 2} {
		return -code error "wrong number of arguments"
	    }

	    set type [string tolower [lindex $args 0]]
	    set listener [lindex $args 1]
	    array set opts {-usecapture 0}
	    array set opts [lrange $args 2 end]
	    set opts(-usecapture) [Boolean $opts(-usecapture)]
	    set listenerType [expr {$opts(-usecapture) ? "capturer" : "listener"}]

	    set idx [lsearch $node(event:$type:$listenerType) $listener]
	    if {$idx >= 0} {
		set node(event:$type:$listenerType) [lreplace $node(event:$type:$listenerType) $idx $idx]
	    }

	}

	disp* {
	    # dispatchEvent -- introduced in DOM Level 2

	    # This is where the fun happens!
	    # Check to see if there one or more event listener,
	    # if so trigger the listener(s).
	    # Then pass the event up to the ancestor.
	    # This may be modified by event capturing and bubbling.

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    set eventId [lindex $args 0]
	    array set event [set $eventId]
	    set type $event(type)

	    if {![string length $event(eventPhase)]} {

		# This is the initial dispatch of the event.
		# First trigger any capturing event listeners
		# Starting from the root, proceed downward

		set event(eventPhase) capturing_phase
		set event(target) $token
		set $eventId [array get event]

		# DOM L2 specifies that the ancestors are determined
		# at the moment of event dispatch, so using a static
		# list is the correct thing to do

		foreach ancestor [lreplace [node path $token] end end] {
		    array get event [set $eventId]
		    set event(currentNode) $ancestor
		    set $eventId [array get event]

		    catch {unset ancNode}
		    array set ancNode [set $ancestor]

		    if {[info exists ancNode(event:$type:capturer)]} {
			foreach capturer $ancNode(event:$type:capturer) {
			    if {[catch {uplevel #0 $capturer [list $eventId]} capturerError]} {
				bgerror "error in capturer \"$capturerError\""
			    }
			}

			# A listener may stop propagation,
			# but we check here to let all of the
			# listeners at that level complete

			array set event [set $eventId]
			if {$event(cancelable) && $event(stopPropagation)} {
			    break
			}
		    }
		}

		# Prepare for next phase
		set event(eventPhase) at_target

	    }

	    set event(currentNode) $token
	    set $eventId [array get event]

	    if {[info exists node(event:$type:listener)]} {
		foreach listener $node(event:$type:listener) {
		    if {[catch {uplevel #0 $listener [list $eventId]} listenerError]} {
			bgerror "error in listener \"$listenerError\""
		    }
		}
	    }

	    array set event [set $eventId]
	    set event(eventPhase) bubbling_phase
	    set $eventId [array get event]

	    # Now propagate the event
	    if {$event(cancelable) && $event(stopPropagation)} {
		# Event has been cancelled
	    } elseif {[llength $node(node:parentNode)]} {
		# Go ahead and propagate
		node dispatchEvent $node(node:parentNode) $eventId
	    }

	    set event(dispatched) 1
	    set $eventId [array get event]

	}

	default {
	    return -code error "unknown method \"$method\""
	}

    }

    set $token [array get node]

    return $result
}

# dom::tcl::Node:create --
#
#	Generic node creation.
#	See also CreateElement, CreateTextNode, CreateGeneric.
#
# Arguments:
#	pVar	array in caller which contains parent details
#	args	configuration options
#
# Results:
#	New child node created.

proc dom::tcl::Node:create {pVar args} {
    upvar $pVar parent

    array set opts {-name {} -value {}}
    array set opts $args

    upvar #0 $parent(docArray) docArray

    # Create new node
    if {![info exists opts(-id)]} {
	set opts(-id) node[incr docArray(counter)]
    }
    set docArray($opts(-id)) [list id $opts(-id) 	    docArray $parent(docArray)			    node:parentNode $opts(-parent)		    node:childNodes $parent(docArray)var$docArray(counter)		    node:nodeType $opts(-type)			    node:nodeName $opts(-name)			    node:nodeValue $opts(-value)		    element:attributeList $parent(docArray)arr$docArray(counter)     ]
    set $parent(docArray)var$docArray(counter) {}
    array set $parent(docArray)arr$docArray(counter) {}

    # Update parent node
    if {![info exists parent(document:documentElement)]} {
	lappend parent(node:childNodes) [list [lindex $opts(-parent) 0] $opts(-id)]
    }

    return $parent(docArray)($opts(-id))

}

# dom::tcl::Node:set --
#
#	Generic node update
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	Node modified.

proc dom::tcl::Node:set {token args} {
    upvar $token node

    foreach {key value} $args {
	set node($key) $value
    }

    set $token [array get node]

    return {}
}

# dom::tcl::FireNodeInsertedEvents --
#
#	Recursively descend the tree triggering DOMNodeInserted
#	events as we go.
#
# Arguments:
#	nodeid	Node ID
#
# Results:
#	DOM L2 DOMNodeInserted events posted

proc dom::tcl::FireNodeInsertedEvents nodeid {
    event postMutationEvent $nodeid DOMNodeInsertedIntoDocument
    foreach child [node children $nodeid] {
	FireNodeInsertedEvents $child
    }

    return {}
}

# dom::tcl::FireNodeRemovedEvents --
#
#	Recursively descend the tree triggering DOMNodeRemoved
#	events as we go.
#
# Arguments:
#	nodeid	Node ID
#
# Results:
#	DOM L2 DOMNodeRemoved events posted

proc dom::tcl::FireNodeRemovedEvents nodeid {
    event postMutationEvent $nodeid DOMNodeRemovedFromDocument
    foreach child [node children $nodeid] {
	FireNodeRemovedEvents $child
    }

    return {}
}

# dom::tcl::element --
#
#	Functions for an element.
#
# Arguments:
#	method	method to invoke
#	token	token for node
#	args	arguments for method
#
# Results:
#	Depends on method used.

namespace eval dom::tcl {
    variable elementOptionsRO tagName|empty
    variable elementOptionsRW {}
}

proc dom::tcl::element {method token args} {
    variable elementOptionsRO
    variable elementOptionsRW

    array set node [set $token]

    if {[string compare $node(node:nodeType) "element"]} {
	return -code error "not an element type node"
    }
    set result {}

    switch -- $method {

	cget {
	    # Some read-only configuration options are computed
	    if {[llength $args] != 1} {
		return -code error "too many arguments"
	    }
	    if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} {
		switch $option {
		    tagName {
			set result [lindex $node(node:nodeName) 0]
		    }
		    empty {
			if {![info exists node(element:empty)]} {
			    return 0
			} else {
			    return $node(element:empty)
			}
		    }
		    default {
			return $node(node:$option)
		    }
		}
	    } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} {
		return $node(node:$option)
	    } else {
		return -code error "unknown option \"[lindex $args 0]\""
	    }
	}
	configure {
	    if {[llength $args] == 1} {
		return [document cget $token [lindex $args 0]]
	    } elseif {[expr [llength $args] % 2]} {
		return -code error "no value specified for option \"[lindex $args end]\""
	    } else {
		foreach {option value} $args {
		    if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} {
			return -code error "attribute \"$option\" is read-only"
		    } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} {
			return -code error "not implemented"
		    } else {
			return -code error "unknown option \"$option\""
		    }
		}
	    }
	}

	getAttribute {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    set result {}

	    upvar #0 $node(element:attributeList) attrList
	    catch {set result $attrList([lindex $args 0])}

	    return $result

	}

	setAttribute {
	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    # Check that the attribute name is kosher
	    if {![regexp ^$::xml::Name\$ [lindex $args 0]]} {
		return -code error "invalid attribute name \"[lindex $args 0]\""
	    }

	    upvar #0 $node(element:attributeList) attrList
	    set evid [CreateEvent $token DOMAttrModified]
	    set oldValue {}
	    catch {set oldValue $attrList([lindex $args 0])}
	    event initMutationEvent $evid DOMAttrModified 1 0 $token $oldValue [lindex $args 1] [lindex $args 0]
	    set result [set attrList([lindex $args 0]) [lindex $args 1]]
	    node dispatchEvent $token $evid
	    DOMImplementation destroy $evid

	}

	removeAttribute {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    upvar #0 $node(element:attributeList) attrList
	    catch {unset attrList([lindex $args 0])}

	    event postMutationEvent $token DOMAttrRemoved -attrName [lindex $args 0]

	}

	getAttributeNS {
	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    set result {}
	    upvar #0 $node(element:attributeList) attrList
	    catch {set result $attrList([lindex $args 0]^[lindex $args 1])}

	    return $result

	}

	setAttributeNS {
	    if {[llength $args] != 3} {
		return -code error "wrong number of arguments"
	    }

	    # Check that the attribute name is kosher
	    if {![regexp ^$::xml::QName\$ [lindex $args 1] discard prefix localName]} {
		return -code error "invalid qualified attribute name \"[lindex $args 1]\""
	    }

	    # BUG: At the moment the prefix is ignored

	    upvar #0 $node(element:attributeList) attrList
	    set evid [CreateEvent $token DOMAttrModified]
	    set oldValue {}
	    catch {set oldValue $attrList([lindex $args 0]^$localName)}
	    event initMutationEvent $evid DOMAttrModified 1 0 $token $oldValue [lindex $args 2] [lindex $args 0]^localName
	    set result [set attrList([lindex $args 0]^$localName) [lindex $args 2]]
	    node dispatchEvent $token $evid
	    DOMImplementation destroy $evid

	}

	removeAttributeNS {
	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    upvar #0 $node(element:attributeList) attrList
	    catch {unset attrList([lindex $args 0]^[lindex $args 1])}

	    event postMutationEvent $token DOMAttrRemoved -attrName [lindex $args 0]^[lindex $args 1]

	}

	getAttributeNode {
	    array set tmp [array get $node(element:attributeList)]
	    if {![info exists tmp([lindex $args 0])]} {
		return {}
	    }

	    # Synthesize an attribute node if one doesn't already exist
	    array set attrNodes $node(element:attributeNodes)
	    if {[catch {set result $attrNodes([lindex $args 0])}]} {
		set result [CreateGeneric $token node:nodeType attribute node:nodeName [lindex $args 0] node:nodeValue $tmp([lindex $args 0])]
		lappend node(element:attributeNodes) [lindex $args 0] $result
	    }
	}

	setAttributeNode -
	removeAttributeNode -
	getAttributeNodeNS -
	setAttributeNodeNS -
	removeAttributeNodeNS {
	    return -code error "not yet implemented"
	}

	getElementsByTagName {
	    if {[llength $args] < 1} {
		return -code error "wrong number of arguments"
	    }

	    return [eval Element:GetByTagName [list $token [lindex $args 0]] 		    [lrange $args 1 end]]
	}

	normalize {
	    if {[llength $args]} {
		return -code error "wrong number of arguments"
	    }

	    Element:Normalize node [set $node(node:childNodes)]
	}

	default {
	    return -code error "unknown method \"$method\""
	}

    }

    set $token [array get node]

    return $result
}

# dom::tcl::Element:GetByTagName --
#
#	Search for (child) elements
#
#	This used to be non-recursive, but then I read the DOM spec
#	properly and discovered that it should recurse.  The -deep
#	option allows for backward-compatibility, and defaults to the
#	DOM-specified value of true.
#
# Arguments:
#	token	parent node
#	name	element type to search for
#	args	configuration options
#
# Results:
#	The name of the variable containing the list of matching node tokens

proc dom::tcl::Element:GetByTagName {token name args} {
    array set node [set $token]
    upvar \#0 $node(docArray) docArray

    array set cfg {-deep 1}
    array set cfg $args
    set cfg(-deep) [Boolean $cfg(-deep)]

    # Guard against arbitrary glob characters
    # Checking that name is a legal XML Name does this
    # However, '*' is permitted
    if {![regexp ^$::xml::Name\$ $name] && [string compare $name "*"]} {
	return -code error "invalid element name"
    }

    # Allocate variable name for this search
    set searchVar $node(docArray)search[incr docArray(counter)]
    upvar \#0 $searchVar search

    # Make list live by interposing on variable reads
    # I don't think we need to interpose on unsets,
    # and writing to this variable by the application is
    # not permitted.

    trace variable $searchVar w [namespace code Element:GetByTagName:Error]

    if {[string compare $node(node:nodeType) "documentFragment"]} {
	trace variable $searchVar r [namespace code [list Element:GetByTagName:Search [set $node(node:childNodes)] $name $cfg(-deep)]]
    } elseif {[llength $node(document:documentElement)]} {
	# Document Element must exist and must be an element type node
	trace variable $searchVar r [namespace code [list Element:GetByTagName:Search $node(document:documentElement) $name $cfg(-deep)]]
    }

    return $searchVar
}

# dom::tcl::Element:GetByTagName:Search --
#
#	Search for elements.  This does the real work.
#	Because this procedure is invoked everytime
#	the variable is read, it returns the live list.
#
# Arguments:
#	tokens	nodes to search (inclusive)
#	name	element type to search for
#	deep	whether to search recursively
#	name1	#	name2	 > appended by trace command
#	op	/
#
# Results:
#	List of matching node tokens

proc dom::tcl::Element:GetByTagName:Search {tokens name deep name1 name2 op} {
    set result {}

    foreach tok $tokens {
	catch {unset nodeInfo}
	array set nodeInfo [set $tok]
	switch -- $nodeInfo(node:nodeType) {
	    element {
		if {[string match $name [GetField nodeInfo(node:nodeName)]]} {
		    lappend result $tok
		}
		if {$deep} {
		    set childResult [Element:GetByTagName:Search [set $nodeInfo(node:childNodes)] $name $deep {} {} {}]
		    if {[llength $childResult]} {
			eval lappend result $childResult
		    }
		}
	    }
	}
    }

    if {[string length $name1]} {
	set $name1 $result
	return {}
    } else {
	return $result
    }
}

# dom::tcl::Element:GetByTagName:Error --
#
#	Complain about the application writing to a variable
#	that this package maintains.
#
# Arguments:
#	name1	#	name2	 > appended by trace command
#	op	/
#
# Results:
#	Error code returned.

proc dom::tcl::Element:GetByTagName:Error {name1 name2 op} {
    return -code error "dom: Read-only variable"
}

# dom::tcl::Element:Normalize --
#
#	Normalize the text nodes
#
# Arguments:
#	pVar	parent array variable in caller
#	nodes	list of node tokens
#
# Results:
#	Adjacent text nodes are coalesced

proc dom::tcl::Element:Normalize {pVar nodes} {
    upvar $pVar parent

    set textNode {}

    foreach n $nodes {
	array set child [set $n]
	set cleanup {}

	switch $child(node:nodeType) {
	    textNode {
		if {[llength $textNode]} {

		    # Coalesce into previous node
		    set evid [CreateEvent $n DOMCharacterDataModified]
		    event initMutationEvent $evid DOMCharacterDataModified 1 0 {} $text(node:nodeValue) $text(node:nodeValue)$child(node:nodeValue) {}
		    append text(node:nodeValue) $child(node:nodeValue)
		    node dispatchEvent $n $evid
		    DOMImplementation destroy $evid

		    # Remove this child
		    upvar #0 $parent(node:childNodes) childNodes
		    set idx [lsearch $childNodes $n]
		    set childNodes [lreplace $childNodes $idx $idx]
		    unset $n
		    set cleanup [list event postMutationEvent [node parent $n] DOMSubtreeModified]
		    event postMutationEvent $n DOMNodeRemoved

		    set $textNode [array get text]
		} else {
		    set textNode $n
		    catch {unset text}
		    array set text [array get child]
		}
	    }
	    element -
	    document -
	    documentFragment {
		set textNode {}
		Element:Normalize child [set $child(node:childNodes)]
	    }
	    default {
		set textNode {}
	    }
	}

	eval $cleanup
    }

    return {}
}

# dom::tcl::processinginstruction --
#
#	Functions for a processing intruction.
#
# Arguments:
#	method	method to invoke
#	token	token for node
#	args	arguments for method
#
# Results:
#	Depends on method used.

namespace eval dom::tcl {
    variable piOptionsRO target
    variable piOptionsRW data
}

proc dom::tcl::processinginstruction {method token args} {
    variable piOptionsRO
    variable piOptionsRW

    array set node [set $token]

    set result {}

    switch -- $method {

	cget {
	    # Some read-only configuration options are computed
	    if {[llength $args] != 1} {
		return -code error "too many arguments"
	    }
	    if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} {
		switch $option {
		    target {
			set result [lindex $node(node:nodeName) 0]
		    }
		    default {
			return $node(node:$option)
		    }
		}
	    } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} {
		switch $option {
		    data {
			return $node(node:nodeValue)
		    }
		    default {
			return $node(node:$option)
		    }
		}
	    } else {
		return -code error "unknown option \"[lindex $args 0]\""
	    }
	}
	configure {
	    if {[llength $args] == 1} {
		return [document cget $token [lindex $args 0]]
	    } elseif {[expr [llength $args] % 2]} {
		return -code error "no value specified for option \"[lindex $args end]\""
	    } else {
		foreach {option value} $args {
		    if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} {
			return -code error "attribute \"$option\" is read-only"
		    } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} {
			switch $opt {
			    data {
				set evid [CreateEvent $token DOMCharacterDataModified]
				event initMutationEvent $evid DOMCharacterModified 1 0 {} $node(node:nodeValue) $value {}
				set node(node:nodeValue) $value
				node dispatchEvent $token $evid
				DOMImplementation destroy $evid
			    }
			    default {
				set node(node:$opt) $value
			    }
			}
		    } else {
			return -code error "unknown option \"$option\""
		    }
		}
	    }
	}

	default {
	    return -code error "unknown method \"$method\""
	}

    }

    set $token [array get node]

    return $result
}

#################################################
#
# DOM Level 2 Interfaces
#
#################################################

# dom::tcl::event --
#
#	Implements Event Interface
#
#	Subclassed Interfaces are also defined here,
#	such as UIEvents.
#
# Arguments:
#	method	method to invoke
#	token	token for event
#	args	arguments for method
#
# Results:
#	Depends on method used.

namespace eval dom::tcl {
    variable eventOptionsRO type|target|currentNode|eventPhase|bubbles|cancelable|timeStamp|detail|view|screenX|screenY|clientX|clientY|ctrlKey|shiftKey|altKey|metaKey|button|relatedNode|prevValue|newValue|attrName
    variable eventOptionsRW {}

    # Issue: should the attributes belonging to the subclassed Interface
    # be separated out?

    variable uieventOptionsRO detail|view
    variable uieventOptionsRW {}

    variable mouseeventOptionsRO screenX|screenY|clientX|clientY|ctrlKey|shiftKey|altKey|metaKey|button|relatedNode
    variable mouseeventOptionsRW {}

    variable mutationeventOptionsRO relatedNode|prevValue|newValue|attrName
    variable mutationeventOptionsRW {}
}

proc dom::tcl::event {method token args} {
    variable eventOptionsRO
    variable eventOptionsRW

    array set event [set $token]

    set result {}

    switch -glob -- $method {

	cg* {
	    # cget

	    if {[llength $args] != 1} {
		return -code error "too many arguments"
	    }
	    if {[regexp [format {^-(%s)$} $eventOptionsRO] [lindex $args 0] discard option]} {
		return $event($option)
	    } elseif {[regexp [format {^-(%s)$} $eventOptionsRW] [lindex $args 0] discard option]} {
		return $event($option)
	    } else {
		return -code error "unknown option \"[lindex $args 0]\""
	    }
	}

	co* {
	    # configure

	    if {[llength $args] == 1} {
		return [event cget $token [lindex $args 0]]
	    } elseif {[expr [llength $args] % 2]} {
		return -code error "no value specified for option \"[lindex $args end]\""
	    } else {
		foreach {option value} $args {
		    if {[regexp [format {^-(%s)$} $eventOptionsRW] $option discard opt]} {
			set event($opt) $value
		    } elseif {[regexp [format {^-(%s)$} $eventOptionsRO] $option discard opt]} {
			return -code error "attribute \"$option\" is read-only"
		    } else {
			return -code error "unknown option \"$option\""
		    }
		}
	    }

	    set $token [array get event]

	}

	st* {
	    # stopPropagation

	    set event(stopPropagation) 1
	    set $token [array get event]

	}

	pr* {
	    # preventDefault

	    set event(preventDefault) 1
	    set $token [array get event]

	}

	initE* {
	    # initEvent

	    if {[llength $args] != 3} {
		return -code error "wrong number of arguments"
	    }

	    if {$event(dispatched)} {
		return -code error "event has been dispatched"
	    }

	    foreach {event(type) event(bubbles) event(cancelable)} $args break
	    set event(type) [string tolower $event(type)]

	    set $token [array get event]

	}

	initU* {
	    # initUIEvent

	    if {[llength $args] < 4 || [llength $args] > 5} {
		return -code error "wrong number of arguments"
	    }

	    if {$event(dispatched)} {
		return -code error "event has been dispatched"
	    }

	    set event(detail) 0
	    foreach {event(type) event(bubbles) event(cancelable) event(view) event(detail)} $args break
	    set event(type) [string tolower $event(type)]

	    set $token [array get event]

	}

	initMo* {
	    # initMouseEvent

	    if {[llength $args] != 15} {
		return -code error "wrong number of arguments"
	    }

	    if {$event(dispatched)} {
		return -code error "event has been dispatched"
	    }

	    set event(detail) 1
	    foreach {event(type) event(bubbles) event(cancelable) event(view) event(detail) event(screenX) event(screenY) event(clientX) event(clientY) event(ctrlKey) event(altKey) event(shiftKey) event(metaKey) event(button) event(relatedNode)} $args break
	    set event(type) [string tolower $event(type)]

	    set $token [array get event]

	}

	initMu* {
	    # initMutationEvent

	    if {[llength $args] != 7} {
		return -code error "wrong number of arguments"
	    }

	    if {$event(dispatched)} {
		return -code error "event has been dispatched"
	    }

	    foreach {event(type) event(bubbles) event(cancelable) event(relatedNode) event(prevValue) event(newValue) event(attrName)} $args break
	    set event(type) [string tolower $event(type)]

	    set $token [array get event]

	}

	postUI* {
	    # postUIEvent, non-standard convenience method

	    set evType [lindex $args 0]
	    array set evOpts [list 		    -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType)			    -view {}					    -detail {}				    ]
	    array set evOpts [lrange $args 1 end]

	    set evid [CreateEvent $token $evType]
	    event initUIEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-view) $evOpts(-detail)
	    node dispatchEvent $token $evid
	    DOMImplementation destroy $evid

	}

	postMo* {
	    # postMouseEvent, non-standard convenience method

	    set evType [lindex $args 0]
	    array set evOpts [list 		    -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType)			    -view {}					    -detail {}					    -screenX {}					    -screenY {}					    -clientX {}					    -clientY {}					    -ctrlKey {}					    -altKey {}					    -shiftKey {}				    -metaKey {}					    -button {}					    -relatedNode {}			    ]
	    array set evOpts [lrange $args 1 end]

	    set evid [CreateEvent $token $evType]
	    event initMouseEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-view) $evOpts(-detail) $evOpts(-screenX) $evOpts(-screenY) $evOpts(-clientX) $evOpts(-clientY) $evOpts(-ctrlKey) $evOpts(-altKey) $evOpts(-shiftKey) $evOpts(-metaKey) $evOpts(-button) $evOpts(-relatedNode)
	    node dispatchEvent $token $evid
	    DOMImplementation destroy $evid

	}

	postMu* {
	    # postMutationEvent, non-standard convenience method

	    set evType [lindex $args 0]
	    array set evOpts [list 		    -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType)			    -relatedNode {}					    -prevValue {} -newValue {}				    -attrName {}				    ]
	    array set evOpts [lrange $args 1 end]

	    set evid [CreateEvent $token $evType]
	    event initMutationEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-relatedNode) $evOpts(-prevValue) $evOpts(-newValue) $evOpts(-attrName)
	    node dispatchEvent $token $evid
	    DOMImplementation destroy $evid

	}

	default {
	    return -code error "unknown method \"$method\""
	}
    }

    return $result
}

# dom::tcl::CreateEvent --
#
#	Create an event object
#
# Arguments:
#	token	parent node
#	type	event type
#	args	configuration options
#
# Results:
#	Returns event token

proc dom::tcl::CreateEvent {token type args} {
    if {[string length $token]} {
	array set parent [set $token]
	upvar #0 $parent(docArray) docArray
	set docArrayName $parent(docArray)
    } else {
	array set opts $args
	upvar #0 $opts(-docarray) docArray
	set docArrayName $opts(-docarray)
    }

    set id event[incr docArray(counter)]
    set child ${docArrayName}($id)

    # Create the event
    set docArray($id) [list id $id docArray $docArrayName 	    node:nodeType event		    type $type			    cancelable 1		    stopPropagation 0		    preventDefault 0		    dispatched 0		    bubbles 1			    eventPhase {}		    timeStamp [clock clicks -milliseconds]		    ]

    return $child
}

#################################################
#
# Serialisation
#
#################################################

# dom::tcl::Serialize:documentFragment --
#
#	Produce text for documentFragment.
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:documentFragment {token args} {
    array set node [set $token]

    if {[string compare "node1" $node(documentFragment:masterDoc)]} {
	return [eval [list Serialize:node $token] $args]
    } else {
	if {[string compare {} [GetField node(document:documentElement)]]} {
	    return [eval Serialize:document [list $token] $args]
	} else {
	    return -code error "document has no document element"
	}
    }

}

# dom::tcl::Serialize:document --
#
#	Produce text for document.
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:document {token args} {
    array set node [set $token]
    array set opts {
	-showxmldecl 1
	-showdoctypedecl 1
    }
    array set opts $args

    if {![info exists node(document:documentElement)]} {
	return -code error "document has no document element"
    } elseif {![string length node(document:doctype)]} {
	return -code error "no document type declaration given"
    } else {

	array set doctype [set $node(document:doctype)]

	# Bug fix: can't use Serialize:attributeList for XML declaration,
	# since attributes must occur in a given order (XML 2.8 [23])

	set result {}

	if {$opts(-showxmldecl)} {
	    append result <?xml[Serialize:XMLDecl version $node(document:xmldecl)][Serialize:XMLDecl encoding $node(document:xmldecl)][Serialize:XMLDecl standalone $node(document:xmldecl)]?>\n
	}
	if {$opts(-showdoctypedecl)} {
	    # Is document element in an XML Namespace?
	    # If so then include prefix in doctype decl
	    foreach {prefix localName} [::xml::qnamesplit $doctype(doctype:name)] break
	    if {![string length $prefix]} {
		# The prefix may not have been allocated yet
		array set docel [set $node(document:documentElement)]
		if {[info exists docel(node:namespaceURI)] && 			[string length $docel(node:namespaceURI)]} {
		    set declPrefix [GetNamespacePrefix $node(document:documentElement) $docel(node:namespaceURI)]
		    set docelName $declPrefix:$doctype(doctype:name)
		} else {
		    set docelName $doctype(doctype:name)
		}
	    } else {
		set docelName $doctype(doctype:name)
	    }
	    # Applied patch by Marco Gonnelli, bug #590914
	    append result <!DOCTYPE\ $docelName[Serialize:ExternalID $doctype(doctype:externalid)][expr {[string length $doctype(doctype:internaldtd)] ? " \[[string trim $doctype(doctype:internaldtd) \{\} ]\]" : {}}]>\n
	}

	# BUG #525505: Want to serialize all children including the
	# document element.

	foreach child [set $node(node:childNodes)] {
	    append result [eval Serialize:[node cget $child -nodeType] [list $child] $args]
	}

	return $result
    }

}

# dom::tcl::Serialize:ExternalID --
#
#	Returned appropriately quoted external identifiers
#
# Arguments:
#	id	external indentifiers
#
# Results:
#	text

proc dom::tcl::Serialize:ExternalID id {
    set publicid {}
    set systemid {}
    foreach {publicid systemid} $id break

    switch -glob -- [string length $publicid],[string length $systemid] {
	0,0 {
	    return {}
	}
	0,* {
	    return " SYSTEM \"$systemid\""
	}
	*,* {
	    # Patch from c.l.t., Richard Calmbach (rc@hnc.com )
	    return " PUBLIC \"$publicid\" \"$systemid\""
	}
    }

    return {}
}

# dom::tcl::Serialize:XMLDecl --
#
#	Produce text for XML Declaration attribute.
#	Order is determine by document serialisation procedure.
#
# Arguments:
#	attr	required attribute
#	attList	attribute list
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:XMLDecl {attr attrList} {
    array set data $attrList
    if {![info exists data($attr)]} {
	return {}
    } elseif {[string length $data($attr)]} {
	return " $attr='$data($attr)'"
    } else {
	return {}
    }
}

# dom::tcl::Serialize:node --
#
#	Produce text for an arbitrary node.
#	This simply serializes the child nodes of the node.
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:node {token args} {
    array set node [set $token]
    array set opts $args

    if {[info exists opts(-indent)]} {
	# NB. 0|1 cannot be used as booleans - mention this in docn
	if {[regexp {^false|no|off$} $opts(-indent)]} {
	    # No action required
	} elseif {[regexp {^true|yes|on$} $opts(-indent)]} {
	    set opts(-indent) 1
	} else {
	    incr opts(-indent)
	}
    }

    set result {}
    foreach childToken [set $node(node:childNodes)] {
	catch {unset child}
	array set child [set $childToken]
	append result [eval [list Serialize:$child(node:nodeType) $childToken] [array get opts]]
    }

    return $result
}

# dom::tcl::Serialize:element --
#
#	Produce text for an element.
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:element {token args} {
    array set node [set $token]
    array set opts {-newline {}}
    array set opts $args

    set result {}
    set newline {}
    if {[lsearch $opts(-newline) $node(node:nodeName)] >= 0} {
	append result \n
	set newline \n
    }
    append result [eval Serialize:Indent [array get opts]]
    switch [info exists node(node:namespaceURI)],[info exists node(node:prefix)] {

	1,1 {
	    # XML Namespace is in scope, prefix supplied
	    if {[string length $node(node:prefix)]} {
		# Make sure that there's a declaration for this XML Namespace
		set declPrefix [GetNamespacePrefix $token $node(node:namespaceURI) -prefix $node(node:prefix)]
		# ASSERTION: $declPrefix == $node(node:prefix)
		set nsPrefix $node(node:prefix):
	    } elseif {[string length $node(node:namespaceURI)]} {
		set nsPrefix [GetNamespacePrefix $token $node(node:namespaceURI)]:
	    } else {
		set nsPrefix {}
	    }
	}

	1,0 {
	    # XML Namespace is in scope, no prefix
	    set nsPrefix [GetNamespacePrefix $token $node(node:namespaceURI)]:
	    if {![string compare $nsPrefix :]} {
		set nsPrefix {}
	    }
	}

	0,1 {
	    # Internal error
	    set nsPrefix {}
	}

	0,0 -
	default {
	    # No XML Namespace is in scope
	    set nsPrefix {}
	}
    }
    append result <$nsPrefix$node(node:localName)

    append result [Serialize:attributeList [array get $node(element:attributeList)]]

    if {![llength [set $node(node:childNodes)]]} {

	append result />$newline

    } else {

	append result >$newline

	# Do the children
	if {[hasmixedcontent $token]} {
	    set opts(-indent) no
	}
	append result [eval Serialize:node [list $token] [array get opts]]

	append result [eval Serialize:Indent [array get opts]]
	append result "$newline</$nsPrefix$node(node:localName)>$newline"

    }

    return $result
}

# dom::tcl::GetNamespacePrefix --
#
#	Determine the XML Namespace prefix for a Namespace URI
#
# Arguments:
#	token	node token
#	nsuri	XML Namespace URI
#	args	configuration options
#
# Results:
#	Returns prefix.
#	May add prefix information to node

proc dom::tcl::GetNamespacePrefix {token nsuri args} {
    array set options $args
    array set node [set $token]

    GetNamespaceDecl $token $nsuri declNode prefix

    if {[llength $declNode]} {
	# A declaration was found for this Namespace URI
	return $prefix
    } else {
	# No declaration found.  Allocate a prefix
	# and add XML Namespace declaration
	set prefix {}
	catch {set prefix $options(-prefix)}
	if {![string compare $prefix {}]} {
	    upvar \#0 $node(docArray) docArray
	    set prefix ns[incr docArray(counter)]
	}
	set node(node:prefix) $prefix
	upvar \#0 $node(element:attributeList) attrs
	set attrs(${::dom::xmlnsURI}^$prefix) $nsuri

	return $prefix
    }
}

# dom::tcl::GetNamespaceDecl --
#
#	Find the XML Namespace declaration.
#
# Arguments:
#	token	node token
#	nsuri	XML Namespace URI
#	nodeVar	Variable name for declaration
#	prefVar Variable for prefix
#
# Results:
#	If the declaration is found returns node and prefix

proc dom::tcl::GetNamespaceDecl {token nsuri nodeVar prefVar} {
    upvar $nodeVar declNode
    upvar $prefVar prefix

    array set nodeinfo [set $token]
    while {[string length $nodeinfo(node:parentNode)]} {

	# Check this node's XML Namespace declarations
	catch {unset attrs}
	array set attrs [array get $nodeinfo(element:attributeList)]
	foreach {nsdecl decluri} [array get attrs ${::dom::xmlnsURI}^*] {
	    if {![string compare $decluri $nsuri]} {
		regexp [format {%s\^(.*)} $::dom::xmlnsURI] $nsdecl dummy prefix
		set declNode $token
		return
	    }
	}

	# Move up to parent
	set token $nodeinfo(node:parentNode)
	array set nodeinfo [set $token]
    }

    # Got to Document node and didn't find XML NS decl
    set prefix {}
    set declNode {}
}

# dom::tcl::Serialize:textNode --
#
#	Produce text for a text node.  This procedure may
#	return a CDATA section where appropriate.
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:textNode {token args} {
    array set node [set $token]

    if {$node(node:cdatasection)} {
	return [Serialize:CDATASection $node(node:nodeValue)]
    } elseif {[Serialize:ExceedsThreshold $node(node:nodeValue)]} {
	return [Serialize:CDATASection $node(node:nodeValue)]
    } else {
	return [Encode $node(node:nodeValue)]
    }
}

# dom::tcl::Serialize:ExceedsThreshold --
#
#	Applies heuristic(s) to determine whether a text node
#	should be formatted as a CDATA section.
#
# Arguments:
#	text	node text
#
# Results:
#	Boolean.

proc dom::tcl::Serialize:ExceedsThreshold {text} {
    return [expr {[regsub -all {[<>&]} $text {} discard] > $::dom::maxSpecials}]
}

# dom::tcl::Serialize:CDATASection --
#
#	Formats a CDATA section.
#
# Arguments:
#	text	node text
#
# Results:
#	XML text.

proc dom::tcl::Serialize:CDATASection {text} {
    set result {}
    while {[regexp {(.*)]]>(.*)} $text discard text trailing]} {
	set result \]\]&gt\;<!\[CDATA\[$trailing\]\]>$result
    }
    return <!\[CDATA\[$text\]\]>$result
}

# dom::tcl::Serialize:processingInstruction --
#
#	Produce text for a PI node.
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:processingInstruction {token args} {
    array set node [set $token]

    return "[eval Serialize:Indent $args]<?$node(node:nodeName)[expr {$node(node:nodeValue) == "" ? "" : " $node(node:nodeValue)"}]?>"
}

# dom::tcl::Serialize:comment --
#
#	Produce text for a comment node.
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:comment {token args} {
    array set node [set $token]

    return [eval Serialize:Indent $args]<!--$node(node:nodeValue)-->
}

# dom::tcl::Serialize:entityReference --
#
#	Produce text for an entity reference.
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:entityReference {token args} {
    array set node [set $token]

    return &$node(node:nodeName)\;
}

# dom::tcl::Encode --
#
#	Encode special characters
#
# Arguments:
#	value	text value
#
# Results:
#	XML format text.

proc dom::tcl::Encode value {
    array set Entity {
	$ $
	< &lt;
	> &gt;
	& &amp;
	\" &quot;
	' &apos;
    }

    regsub -all {([$<>&"'])} $value {$Entity(\1)} value

    return [subst -nocommand -nobackslash $value]
}

# dom::tcl::Serialize:attributeList --
#
#	Produce text for an attribute list.
#
# Arguments:
#	l	name/value paired list
#
# Results:
#	XML format text.

proc dom::tcl::Serialize:attributeList {l} {

    set result {}
    foreach {name value} $l {

	if {[regexp {^([^^]+)\^(.*)$} $name discard nsuri prefix]} {
	    if {[string compare $nsuri $::dom::xmlnsURI]} {
		# Need the node token to resolve the Namespace URI
		append result { } ?:$prefix =
	    } else {
		# A Namespace declaration
		append result { } xmlns:$prefix =
	    }
	} else {
	    append result { } $name =
	}

	# Handle special characters
	regsub -all & $value {\&amp;} value
	regsub -all < $value {\&lt;} value
	regsub -all > $value {\&gt;} value

	if {![string match *\"* $value]} {
	    append result \"$value\"
	} elseif {![string match *'* $value]} {
	    append result '$value'
	} else {
	    regsub -all \" $value {\&quot;} value
	    append result \"$value\"
	}

    }

    return $result
}

# dom::tcl::Serialize:Indent --
#
#	Calculate the indentation required, if any
#
# Arguments:
#	args	configuration options, which may specify -indent
#
# Results:
#	May return white space

proc dom::tcl::Serialize:Indent args {
    array set opts [list -indentspec $::dom::indentspec]
    array set opts $args

    if {![info exists opts(-indent)] || 	    [regexp {^false|no|off$} $opts(-indent)]} {
	return {}
    }

    if {[regexp {^true|yes|on$} $opts(-indent)]} {
	# Default indent level is 0
	return \n
    }

    if {!$opts(-indent)} {
	return \n
    }

    set ws [format \n%\ [expr $opts(-indent) * [lindex $opts(-indentspec) 0]]s { }]
    regsub -all [lindex [lindex $opts(-indentspec) 1] 0] $ws [lindex [lindex $opts(-indentspec) 1] 1] ws

    return $ws

}

#################################################
#
# Parsing
#
#################################################

# dom::tcl::ParseElementStart --
#
#	Push a new element onto the stack.
#
# Arguments:
#	stateVar	global state array variable
#	name		element name
#	attrList	attribute list
#	args		configuration options
#
# Results:
#	An element is created within the currently open element.

proc dom::tcl::ParseElementStart {stateVar name attrList args} {

    upvar #0 $stateVar state
    array set opts $args

    # Push namespace declarations
    # We need to be able to map namespaceURI's back to prefixes
    set nsattrlists {}
    catch {
	foreach {namespaceURI prefix} $opts(-namespacedecls) {
	    lappend state(NS:$namespaceURI) $prefix

	    # Also, synthesize namespace declaration attributes
	    # TclXML is a little too clever when it parses them away!

	    lappend nsattrlists $prefix $namespaceURI
	}
	lappend opts(-namespaceattributelists) $::dom::xmlnsURI $nsattrlists

    }

    set nsarg {}
    catch {
	lappend nsarg -namespace $opts(-namespace)
	lappend nsarg -localname $name
	lappend nsarg -prefix [lindex $state(NS:$opts(-namespace)) end]
    }

    lappend state(current) 	[eval CreateElement [list [lindex $state(current) end] $name $attrList] $nsarg [array get opts -namespaceattributelists]]

    if {[info exists opts(-empty)] && $opts(-empty)} {
	# Flag this node as being an empty element
	array set node [set [lindex $state(current) end]]
	set node(element:empty) 1
	set [lindex $state(current) end] [array get node]
    }

    # Temporary: implement -progresscommand here, because of broken parser
    if {[string length $state(-progresscommand)]} {
	if {!([incr state(progCounter)] % $state(-chunksize))} {
	    uplevel #0 $state(-progresscommand)
	}
    }
}

# dom::tcl::ParseElementEnd --
#
#	Pop an element from the stack.
#
# Arguments:
#	stateVar	global state array variable
#	name		element name
#	args		configuration options
#
# Results:
#	Currently open element is closed.

proc dom::tcl::ParseElementEnd {stateVar name args} {
    upvar #0 $stateVar state

    set state(current) [lreplace $state(current) end end]
}

# dom::tcl::ParseCharacterData --
#
#	Add a textNode to the currently open element.
#
# Arguments:
#	stateVar	global state array variable
#	data		character data
#
# Results:
#	A textNode is created.

proc dom::tcl::ParseCharacterData {stateVar data} {
    upvar #0 $stateVar state

    CreateTextNode [lindex $state(current) end] $data
}

# dom::tcl::ParseProcessingInstruction --
#
#	Add a PI to the currently open element.
#
# Arguments:
#	stateVar	global state array variable
#	name		PI name
#	target		PI target
#
# Results:
#	A processingInstruction node is created.

proc dom::tcl::ParseProcessingInstruction {stateVar name target} {
    upvar #0 $stateVar state

    CreateGeneric [lindex $state(current) end] node:nodeType processingInstruction node:nodeName $name node:nodeValue $target
}

# dom::tcl::ParseXMLDeclaration --
#
#	Add information from the XML Declaration to the document.
#
# Arguments:
#	stateVar	global state array variable
#	version		version identifier
#	encoding	character encoding
#	standalone	standalone document declaration
#
# Results:
#	Document node modified.

proc dom::tcl::ParseXMLDeclaration {stateVar version encoding standalone} {
    upvar #0 $stateVar state

    array set node [set $state(docNode)]
    array set xmldecl $node(document:xmldecl)

    array set xmldecl [list version $version		    standalone $standalone			    encoding $encoding			    ]

    set node(document:xmldecl) [array get xmldecl]
    set $state(docNode) [array get node]

    return {}
}

# dom::tcl::ParseDocType --
#
#	Add a Document Type Declaration node to the document.
#
# Arguments:
#	stateVar	global state array variable
#	root		root element type
#	publit		public identifier literal
#	systemlist	system identifier literal
#	dtd		internal DTD subset
#
# Results:
#	DocType node added

proc dom::tcl::ParseDocType {stateVar root {publit {}} {systemlit {}} {dtd {}} args} {
    upvar #0 $stateVar state

    CreateDocType $state(docNode) $root [list $publit $systemlit] $dtd {} {}
    # Last two are entities and notaions (as namedNodeMap's)

    return {}
}

# dom::tcl::ParseComment --
#
#	Parse comment
#
# Arguments:
#	stateVar	state array
#	data		comment data
#
# Results:
#	Comment node added to DOM tree

proc dom::tcl::ParseComment {stateVar data} {
    upvar #0 $stateVar state

    CreateGeneric [lindex $state(current) end] node:nodeType comment node:nodeValue $data

    return {}
}

# dom::tcl::ParseEntityReference --
#
#	Parse an entity reference
#
# Arguments:
#	stateVar	state variable
#	ref		entity
#
# Results:
#	Entity reference node added to DOM tree

proc dom::tcl::ParseEntityReference {stateVar ref} {
    upvar #0 $stateVar state

    CreateGeneric [lindex $state(current) end] node:nodeType entityReference node:nodeName $ref

    return {}
}

#################################################
#
# Trim white space
#
#################################################

# dom::tcl::Trim --
#
#	Remove textNodes that only contain white space
#
# Arguments:
#	nodeid	node to trim
#
# Results:
#	textNode nodes may be removed (from descendants)

proc dom::tcl::Trim nodeid {
    array set node [set $nodeid]

    switch $node(node:nodeType) {

	textNode {
	    if {![string length [string trim $node(node:nodeValue)]]} {
		node removeChild $node(node:parentNode) $nodeid
	    }
	}

	default {
	    # Some nodes have no child list.  Reported by Jim Hollister <jhollister@objectspace.com>
	    set children {}
	    catch {set children [set $node(node:childNodes)]}
	    foreach child $children {
		Trim $child
	    }
	}

    }

    return {}
}

#################################################
#
# Query function
#
#################################################

# dom::tcl::Query --
#
#	Search DOM.
#
# DEPRECATED: This is obsoleted by XPath.
#
# Arguments:
#	token	node to search
#	args	query options
#
# Results:
#	If query is found, return the node ID of the containing node.
#	Otherwise, return empty string

proc dom::tcl::Query {token args} {
    array set node [set $token]
    array set query $args

    set found 0
    switch $node(node:nodeType) {
	document -
	documentFragment {
	    foreach child [set $node(node:childNodes)] {
		if {[llength [set result [eval Query [list $child] $args]]]} {
		    return $result
		}
	    }
	}
	element {
	    catch {set found [expr ![string compare $node(node:nodeName) $query(-tagname)]]}
	    if {$found} {
		return $token
	    }
	    if {![catch {array set attributes [set $node(element:attributeList)]}]} {
		catch {set found [expr [lsearch [array names attributes] $query(-attrname)] >= 0]}
		catch {set found [expr $found || [lsearch [array get attributes] $query(-attrvalue)] >= 0]}
	    }

	    if {$found} {
		return $token
	    }

	    foreach child [set $node(node:childNodes)] {
		if {[llength [set result [eval Query [list $child] $args]]]} {
		    return $result
		}
	    }

	}
	textNode -
	comment {
	    catch {
		set querytext [expr {$node(node:nodeType) == "textNode" ? $query(-text) : $query(-comment)}]
		set found [expr [string match $node(node:nodeValue) $querytext] >= 0]
	    }

	    if {$found} {
		return $token
	    }
	}
	processingInstruction {
	    catch {set found [expr ![string compare $node(node:nodeName) $query(-pitarget)]]}
	    catch {set found [expr $found || ![string compare $node(node:nodeValue) $query(-pidata)]]}

	    if {$found} {
		return $token
	    }
	}
    }

    if {$found} {
	return $token
    }

    return {}
}

#################################################
#
# XPath support
#
#################################################

# dom::tcl::XPath:CreateNode --
#
#	Given an XPath expression, create the node
#	referred to by the expression.  Nodes required
#	as steps of the path are created if they do
#	not exist.
#
# Arguments:
#	node	context node
#	path	location path
#
# Results:
#	Node(s) created in the DOM tree.
#	Returns token for deepest node in the expression.

proc dom::tcl::XPath:CreateNode {node path} {

    set root [::dom::node cget $node -ownerDocument]

    set spath [::xpath::split $path]

    if {[llength $spath] <= 1} {
	# / - do nothing
	return $root
    }

    if {![llength [lindex $spath 0]]} {
	# Absolute location path
	set context $root
	set spath [lrange $spath 1 end]
	set contexttype document
    } else {
	set context $node
	set contexttype [::dom::node cget $node -nodeType]
    }

    foreach step $spath {

	# Sanity check on path
	switch $contexttype {
	    document -
	    documentFragment -
	    element {}
	    default {
		return -code error "node type \"$contexttype\" have no children"
	    }
	}

	switch [lindex $step 0] {

	    child {
		if {[llength [lindex $step 1]] > 1} {
		    foreach {nodetype discard} [lindex $step 1] break

		    switch -- $nodetype {
			text {
			    set posn [CreateNode:FindPosition [lindex $step 2]]

			    set count 0
			    set targetNode {}
			    foreach child [::dom::node children $context] {
				switch [::dom::node cget $child -nodeType] {
				    textNode {
					incr count
					if {$count == $posn} {
					    set targetNode $child
					    break
					}
				    }
				    default {}
				}
			    }

			    if {[string length $targetNode]} {
				set context $targetNode
			    } else {
				# Creating sequential textNodes doesn't make sense
				set context [::dom::document createTextNode $context {}]
			    }
			    set contexttype textNode
			}
			default {
			    return -code error "node type test \"${nodetype}()\" not supported"
			}
		    }
		} else {
		    # Find the child element
		    set posn [CreateNode:FindPosition [lindex $step 2]]

		    set count 0
		    set targetNode {}
		    foreach child [::dom::node children $context] {
			switch [node cget $child -nodeType] {
			    element {
				if {![string compare [lindex $step 1] [::dom::node cget $child -nodeName]]} {
				    incr count
				    if {$count == $posn} {
					set targetNode $child
					break
				    }
				}
			    }
			    default {}
			}
		    }

		    if {[string length $targetNode]} {
			set context $targetNode
		    } else {
			# Didn't find it so create required elements
			while {$count < $posn} {
			    set child [::dom::document createElement $context [lindex $step 1]]
			    incr count
			}
			set context $child
		    }
		    set contexttype element

		}
	    }

	    default {
		return -code error "axis \"[lindex $step 0]\" is not supported"
	    }
	}
    }

    return $context
}

# dom::tcl::CreateNode:FindPosition --

proc dom::tcl::CreateNode:FindPosition predicates {
    switch [llength $predicates] {
	0 {
	    return 1
	}
	1 {
	    # Fall-through
	}
	default {
	    return -code error "multiple predicates not supported"
	}
    }
    set predicate [lindex $predicates 0]

    switch -- [lindex [lindex $predicate 0] 0] {
	function {
	    switch -- [lindex [lindex $predicate 0] 1] {
		position {
		    if {[lindex $predicate 1] == "="} {
			if {[string compare [lindex [lindex $predicate 2] 0] "number"]} {
			    return -code error "operand must be a number"
			} else {
			    set posn [lindex [lindex $predicate 2] 1]
			}
		    } else {
			return -code error "operator must be \"=\""
		    }
		}
		default {
		    return -code error "predicate function \"[lindex [lindex $predicate 0] 1]\" not supported"
		}
	    }
	}
	default {
	    return -code error "predicate must be position() function"
	}
    }

    return $posn
}

# dom::tcl::XPath:SelectNode --
#
#	Match nodes with an XPath location path
#
# Arguments:
#	ctxt	context - Tcl list
#	path	location path
#
# Results:
#	Returns Tcl list of matching nodes

proc dom::tcl::XPath:SelectNode {ctxt path} {

    if {![llength $ctxt]} {
	return {}
    }

    set spath [xpath::split $path]

    if {[string length [node parent [lindex $ctxt 0]]]} {
	array set nodearr [set [lindex $ctxt 0]]
	set root $nodearr(docArray)(node1)
    } else {
	set root [lindex $ctxt 0]
    }

    if {[llength $spath] == 0} {
	return $root
    }
    if {[llength $spath] == 1 && [llength [lindex $spath 0]] == 0} {
	return $root
    }

    if {![llength [lindex $spath 0]]} {
	set ctxt $root
	set spath [lrange $spath 1 end]
    }

    return [XPath:SelectNode:Rel $ctxt $spath]
}

# dom::tcl::XPath:SelectNode:Rel --
#
#	Match nodes with an XPath location path
#
# Arguments:
#	ctxt	context - Tcl list
#	path	split location path
#
# Results:
#	Returns Tcl list of matching nodes

proc dom::tcl::XPath:SelectNode:Rel {ctxt spath} {
    if {![llength $spath]} {
	return $ctxt
    }

    set step [lindex $spath 0]
    set result {}
    switch [lindex $step 0] {

	child {
	    # All children are candidates
	    set children {}
	    foreach node [XPath:SN:GetElementTypeNodes $ctxt] {
		eval lappend children [node children $node]
	    }

	    # Now apply node test to each child
	    foreach node $children {
		if {[XPath:SN:ApplyNodeTest $node [lindex $step 1]]} {
		    lappend result $node
		}
	    }

	}

	descendant-or-self {
	    foreach node $ctxt {
		if {[XPath:SN:ApplyNodeTest $node [lindex $step 1]]} {
		    lappend result $node
		}
		eval lappend result [XPath:SN:DescendAndTest [node children $node] [lindex $step 1]]
	    }
	}

	descendant {
	    foreach node $ctxt {
		eval lappend result [XPath:SN:DescendAndTest [node children $node] [lindex $step 1]]
	    }
	}

	attribute {
	    if {[string compare [lindex $step 1] "*"]} {
		foreach node $ctxt {
		    set attrNode [element getAttributeNode $node [lindex $step 1]]
		    if {[llength $attrNode]} {
			lappend result $attrNode
		    }
		}
	    } else {
		# All attributes are returned
		foreach node $ctxt {
		    foreach attrName [array names [node cget $node -attributes]] {
			set attrNode [element getAttributeNode $node $attrName]
			if {[llength $attrNode]} {
			    lappend result $attrNode
			}
		    }
		}
	    }
	}

	default {
	    return -code error "axis \"[lindex $step 0]\" is not supported"
	}
    }

    # Now apply predicates
    set result [XPath:ApplyPredicates $result [lindex $step 2]]

    # Apply the next location step
    return [XPath:SelectNode:Rel $result [lrange $spath 1 end]]
}

# dom::tcl::XPath:SN:GetElementTypeNodes --
#
#	Reduce nodeset to those nodes of element type
#
# Arguments:
#	nodeset	set of nodes
#
# Results:
#	Returns nodeset in which all nodes are element type

proc dom::tcl::XPath:SN:GetElementTypeNodes nodeset {
    set result {}
    foreach node $nodeset {
	switch [node cget $node -nodeType] {
	    documentFragment -
	    element {
		lappend result $node
	    }
	    default {}
	}
    }
    return $result
}

# dom::tcl::XPath:SN:ApplyNodeTest --
#
#	Apply the node test to a node
#
# Arguments:
#	node	DOM node to test
#	test	node test
#
# Results:
#	1 if node passes, 0 otherwise

proc dom::tcl::XPath:SN:ApplyNodeTest {node test} {
    if {[llength $test] > 1} {
	foreach {name typetest} $test break
	# Node type test
	switch -glob -- $name,[node cget $node -nodeType] {
	    node,* {
		return 1
	    }
	    text,textNode -
	    comment,comment -
	    processing-instruction,processingInstruction {
		return 1
	    }
	    text,* -
	    comment,* -
	    processing-instruction,* {
		return 0
	    }
	    default {
		return -code error "illegal node type test \"[lindex $step 1]\""
	    }
	}
    } else {
	# Node name test
	switch -glob -- $test,[node cget $node -nodeType],[node cget $node -nodeName] 		\\*,element,* {
	    return 1
	} 		\\*,* {
	    return 0
	} 		*,element,$test {
	    return 1
	}
    }

    return 0
}

# dom::tcl::XPath:SN:DescendAndTest --
#
#	Descend the element hierarchy,
#	apply the node test as we go
#
# Arguments:
#	nodeset	nodes to be tested and descended
#	test	node test
#
# Results:
#	Returned nodeset of nodes which pass the test

proc dom::tcl::XPath:SN:DescendAndTest {nodeset test} {
    set result {}

    foreach node $nodeset {
	if {[XPath:SN:ApplyNodeTest $node $test]} {
	    lappend result $node
	}
	switch [node cget $node -nodeType] {
	    documentFragment -
	    element {
		eval lappend result [XPath:SN:DescendAndTest [node children $node] $test]
	    }
	}
    }

    return $result
}

# dom::tcl::XPath:ApplyPredicates --
#
#	Filter a nodeset with predicates
#
# Arguments:
#	ctxt	current context nodeset
#	preds	list of predicates
#
# Results:
#	Returns new (possibly reduced) context nodeset

proc dom::tcl::XPath:ApplyPredicates {ctxt preds} {

    set result {}
    foreach node $ctxt {
	set passed 1
	foreach predicate $preds {
	    if {![XPath:ApplyPredicate $node $predicate]} {
		set passed 0
		break
	    }
	}
	if {$passed} {
	    lappend result $node
	}
    }

    return $result
}

# dom::tcl::XPath:ApplyPredicate --
#
#	Filter a node with a single predicate
#
# Arguments:
#	node	current context node
#	pred	predicate
#
# Results:
#	Returns boolean

proc dom::tcl::XPath:ApplyPredicate {node pred} {

    switch -- [lindex $pred 0] {
	= -
	!= -
	>= -
	<= -
	> -
	> {

	    if {[llength $pred] != 3} {
		return -code error "malformed expression"
	    }

	    set operand1 [XPath:Pred:ResolveExpr $node [lindex $pred 1]]
	    set operand2 [XPath:Pred:ResolveExpr $node [lindex $pred 2]]

	    # Convert operands to the correct type, if necessary
	    switch -glob [lindex $operand1 0],[lindex $operand2 0] {
		literal,literal {
		    return [XPath:Pred:CompareLiterals [lindex $pred 0] [lindex $operand1 1] [lindex $operand2 1]]
		}

		number,number -
		literal,number -
		number,literal {
		    # Compare as numbers
		    return [XPath:Pred:CompareNumbers [lindex $pred 0] [lindex $operand1 1] [lindex $operand2 1]]
		}

		boolean,boolean {
		    # Compare as booleans
		    return -code error "boolean comparison not yet implemented"
		}

		node,node {
		    # Nodeset comparison
		    return -code error "nodeset comparison not yet implemented"
		}

		node,* {
		    set value {}
		    if {[llength [lindex $operand1 1]]} {
			set value [node stringValue [lindex [lindex $operand1 1] 0]]
		    }
		    return [XPath:Pred:CompareLiterals [lindex $pred 0] $value [lindex $operand2 1]]
		}
		*,node {
		    set value {}
		    if {[llength [lindex $operand2 1]]} {
			set value [node stringValue [lindex [lindex $operand2 1] 0]]
		    }
		    return [XPath:Pred:CompareLiterals [lindex $pred 0] $value [lindex $operand1 1]]
		}

		default {
		    return -code error "can't compare [lindex $operand1 0] to [lindex $operand2 0]"
		}
	    }
	}

	function {
	    return -code error "invalid predicate"
	}
	number -
	literal {
	    return -code error "invalid predicate"
	}

	path {
	    set nodeset [XPath:SelectNode:Rel $node [lindex $pred 1]]
	    return [expr {[llength $nodeset] > 0 ? 1 : 0}]
	}

    }

    return 1
}

# dom::tcl::XPath:Pred:Compare --

proc dom::tcl::XPath:Pred:CompareLiterals {op operand1 operand2} {
    set result [string compare $operand1 $operand2]

    # The obvious:
    #return [expr {$result $opMap($op) 0}]
    # doesn't compile
    
    switch $op {
	= {
	    return [expr {$result == 0}]
	}
	!= {
	    return [expr {$result != 0}]
	}
	<= {
	    return [expr {$result <= 0}]
	}
	>= {
	    return [expr {$result >= 0}]
	}
	< {
	    return [expr {$result < 0}]
	}
	> {
	    return [expr {$result > 0}]
	}
    }
    return -code error "internal error"
}

# dom::tcl::XPath:Pred:ResolveExpr --

proc dom::tcl::XPath:Pred:ResolveExpr {node expr} {

    switch [lindex $expr 0] {
	path {
	    return [list node [XPath:SelectNode:Rel $node [lindex $expr 1]]]
	}

	function -
	group {
	    return -code error "[lindex $expr 0] not yet implemented"
	}
	literal -
	number -
	boolean {
	    return $expr
	}

	default {
	    return -code error "internal error"
	}
    }

    return {}
}

#################################################
#
# Miscellaneous
#
#################################################

# dom::tcl::hasmixedcontent --
#
#	Determine whether an element contains mixed content
#
# Arguments:
#	token	dom node
#
# Results:
#	Returns 1 if element contains mixed content,
#	0 otherwise

proc dom::tcl::hasmixedcontent token {
    array set node [set $token]

    if {[string compare $node(node:nodeType) "element"]} {
	# Really undefined
	return 0
    }

    foreach child [set $node(node:childNodes)] {
	catch {unset childnode}
	array set childnode [set $child]
	if {![string compare $childnode(node:nodeType) "textNode"]} {
	    return 1
	}
    }

    return 0
}

# dom::tcl::prefix2namespaceURI --
#
#	Given an XML Namespace prefix, find the corresponding Namespace URI
#
# Arguments:
#	node	DOM Node
#	prefix	XML Namespace prefix
#
# Results:
#	Returns URI

proc dom::tcl::prefix2namespaceURI {node prefix} {

    # Search this node and its ancestors for the appropriate
    # XML Namespace declaration

    set parent [dom::node parent $node]
    set nsuri [dom::element getAttributeNS $node $::dom::xmlnsURI $prefix]
    if {[string length $parent] && ![string length $nsuri]} {
	set nsuri [dom::element getAttributeNS $parent $::dom::xmlnsURI $prefix]
	set parent [dom::node parent $parent]
    }

    if {[string length $nsuri]} {
	return $nsuri
    } else {
	return -code error "unable to find namespace URI for prefix \"$prefix\""
    }

}

# dom::tcl::namespaceURI2prefix --
#
#	Given an XML Namespace URI, find the corresponding prefix
#
# Arguments:
#	node	DOM Node
#	nsuri	XML Namespace URI
#
# Results:
#	Returns prefix

proc dom::tcl::namespaceURI2prefix {node nsuri} {

    # Search this node and its ancestors for the desired
    # XML Namespace declaration

    set found 0
    set prefix {}
    set parent [dom::node parent $node]
    while {[string length $parent]} {
	catch {unset nodeinfo}
	array set nodeinfo [set $node]
	catch {unset attrs}
	array set attrs [array get $nodeinfo(element:attributeList)]
	foreach {nsdecl declNSuri} [array get attrs ${::dom::xmlnsURI}^*] {
	    if {![string compare $declNSuri $nsuri]} {
		set found 1
		set prefix [lindex [split $nsdecl ^] 1]
		break
	    }
	}
	if {$found} {
	    break
	}
	set node $parent
	set parent [dom::node parent $node]
    }

    if {$found} {
	return $prefix
    } else {
	return -code error "unable to find prefix for namespace URI \"$nsuri\""
    }

}

# dom::tcl::GetField --
#
#	Return a value, or empty string if not defined
#
# Arguments:
#	var	name of variable to return
#
# Results:
#	Returns the value, or empty string if variable is not defined.

proc dom::tcl::GetField var {
    upvar $var v
    if {[info exists v]} {
	return $v
    } else {
	return {}
    }
}

# dom::tcl::Min --
#
#	Return the minimum of two numeric values
#
# Arguments:
#	a	a value
#	b	another value
#
# Results:
#	Returns the value which is lower than the other.

proc dom::tcl::Min {a b} {
    return [expr {$a < $b ? $a : $b}]
}

# dom::tcl::Max --
#
#	Return the maximum of two numeric values
#
# Arguments:
#	a	a value
#	b	another value
#
# Results:
#	Returns the value which is greater than the other.

proc dom::tcl::Max {a b} {
    return [expr {$a > $b ? $a : $b}]
}

# dom::tcl::Boolean --
#
#	Return a boolean value
#
# Arguments:
#	b	value
#
# Results:
#	Returns 0 or 1

proc dom::tcl::Boolean b {
    regsub -nocase {^(true|yes|1|on)$} $b 1 b
    regsub -nocase {^(false|no|0|off)$} $b 0 b
    return $b
}

# dom.tcl --
#
#	This file sets up the generic API for TclDOM.
#	It is used when the Tcl-only version of TclDOM
#	is loaded.
#
#	The actual pure-Tcl DOM implementation has moved
#	to domimpl.tcl
#
# Copyright (c) 2002-2003 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.
#
# $Id: dom.tcl,v 1.19 2003/03/09 11:12:49 balls Exp $

package provide dom::tclgeneric 2.6

namespace eval dom {
    namespace export DOMImplementation
    namespace export document documentFragment node
    namespace export element textNode attribute
    namespace export processingInstruction
    namespace export event

    variable maxSpecials
    if {![info exists maxSpecials]} {
	set maxSpecials 10
    }

    variable strictDOM 0

    # Default -indentspec value
    #	spaces-per-indent-level {collapse-re collapse-value}
    variable indentspec [list 2 [list {        } \t]]

    # The Namespace URI for XML Namespace declarations
    variable xmlnsURI http://www.w3.org/2000/xmlns/

}

package require dom::tcl 2.6

foreach p {DOMImplementation hasFeature createDocument create createDocumentType createNode destroy isNode parse selectNode serialize trim document documentFragment node element textNode attribute processingInstruction event} {

    proc dom::$p args "return \[eval tcl::$p \$args\]"

}

# dommap.tcl --
#
#	Apply a mapping function to a DOM structure
#
# Copyright (c) 1998-2003 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.
#
# $Id: dommap.tcl,v 1.4 2003/03/09 11:12:49 balls Exp $

package provide dommap 1.0

# We need the DOM
package require dom 2.6

namespace eval dommap {
    namespace export map
}

# dommap::apply --
#
#	Apply a function to a DOM document.
#
#	The callback command is invoked with the node ID of the
#	matching DOM node as its argument.  The command may return
#	an error, continue or break code to alter the processing
#	of further nodes.
#
#	Filter functions may be applied to match particular
#	nodes.  Valid functions include:
#
#	-nodeType regexp
#	-nodeName regexp
#	-nodeValue regexp
#	-attribute {regexp regexp}
#
#	If a filter is specified then the node must match for the
#	callback command to be invoked.  If a filter is not specified
#	then all nodes match that filter.
#
# Arguments:
#	node	DOM document node
#	cmd	callback command
#	args	configuration options
#
# Results:
#	Depends on callback command

proc dommap::apply {node cmd args} {
    array set opts $args

    # Does this node match?
    set match 1
    catch {set match [expr $match && [regexp $opts(-nodeType) [::dom::node cget $node -nodeType]]]}
    catch {set match [expr $match && [regexp $opts(-nodeName) [::dom::node cget $node -nodeName]]]}
    catch {set match [expr $match && [regexp $opts(-nodeValue) [::dom::node cget $node -nodeValue]]]}
    if {$match && ![string compare [::dom::node cget $node -nodeType] element]} {
	set match 0
	foreach {attrName attrValue} [array get [::dom::node cget $node -attributes]] {
	    set match 1
	    catch {set match [expr $match && [regexp [lindex $opts(-attribute) 0] $attrName]]}
	    catch {set match [expr $match && [regexp [lindex $opts(-attribute) 1] $attrValue]]}
	    if {$match} break
	}
    }
    if {$match && [set code [catch {eval $cmd [list $node]} msg]]} {
	switch $code {
	    0 {}
	    3 {
		return -code break
	    }
	    4 {
		return -code continue
	    }
	    default {
		return -code error $msg
	    }
	}
    }

    # Process children
    foreach child [::dom::node children $node] {
	switch [catch {eval apply [list $child] [list $cmd] $args} msg] {
	    0 {
		# No action required
	    }
	    3 {
		# break
		return -code break
	    }
	    4 {
		# continue - skip processing of siblings
		return
	    }
	    1 -
	    2 -
	    default {
		# propagate the error message
		return -code error $msg
	    }
	}
    }

    return {}
}




namespace eval preferences {

    variable rcFileName ~/.moodssrc

    proc read "{rcFileName $rcFileName}" {
        if {![file readable $rcFileName]} {
            return {}
        }
        set file [::open $rcFileName]
        set line [gets $file]
        seek $file 0
        set list {}
        if {![string match -nocase {<\?xml version=*} $line]} {
            while {[gets $file line] >= 0} {
                if {[string match #* $line]} continue
                foreach {name value} $line {
                    set name [namespace tail $name]
                    variable $name $value
                    lappend list $name $value
                }
            }
        } elseif {[catch {set root [dom::parse [::read $file]]} message]} {
            puts stderr "file $rcFileName is not a valid moodss preferences file:\n$message"
            exit 1
        } else {
            set document [dom::element cget [dom::document cget $root -documentElement] -tagName]
            switch $document {
                moodssPreferences - moompsPreferences {
                    foreach node [dom::selectNode $root /$document/*] {
                        set name [dom::node cget $node -nodeName]
                        switch $name {
                            database {
                                set name databaseOptions
                                set value {}
                                foreach {option data} [array get [dom::node cget $node -attributes]] {
                                    lappend value -$option $data
                                }
                            }
                            moodss {
                                set name moodssVersion
                                set value [dom::element getAttribute $node version]
                            }
                            viewerColors - smtpServers {
                                set value [listFromNode $node]
                            }
                            default {
                                set value [dom::node stringValue $node]
                            }
                        }
                        variable $name $value
                        lappend list $name $value
                    }
                }
                default {
                    error "cannot handle $document type"
                }
            }
        }
        close $file
        return $list
    }

if {$global::withGUI} {

    proc create {file} {
        if {[catch {
            close [open $file w]
            file attributes $file -permissions rw-------
        } message]} {
            tk_messageBox -title moodss -type ok -default ok -icon error -message $message
        }
    }

    proc save {variables} {
        variable rcFileName

        set unix [string equal $::tcl_platform(platform) unix]
        if {$unix && ![file exists $rcFileName]} {
            create $rcFileName
        }
        if {[catch {::open $rcFileName w} file]} {
            tk_messageBox -title moodss -type ok -default ok -icon error -message $file
            return
        }
        lifoLabel::push $global::messenger [mc {saving preferences...}]
        ::update idletasks
        set document [dom::create]
        set root [dom::document createElement $document moodssPreferences]
        dom::document createTextNode [dom::document createElement $root version] $global::applicationVersion
        set seconds [clock seconds]
        set date [clock format $seconds -format %D]; set time [clock format $seconds -format %T]
        dom::document createTextNode [dom::document createElement $root date] $date
        dom::document createTextNode [dom::document createElement $root time] $time
        foreach name $variables {
            switch $name {version - date - time - showToolBar - databaseOptions - viewerColors - smtpServers continue}
            dom::document createTextNode [dom::document createElement $root $name] [set ::preferences::$name]
        }
        nodeFromList $root viewerColors $::preferences::viewerColors
        nodeFromList $root smtpServers $::preferences::smtpServers
        set node [dom::document createElement $root database]
        foreach {switch value} $::preferences::databaseOptions {
            dom::element setAttribute $node [string trimleft $switch -] $value
        }
        dom::document createTextNode [dom::document createElement $root showToolBar] $global::showToolBar
        dom::document configure $document -encoding [fconfigure $file -encoding]
        set data [serialize $document]
        dom::destroy $root
        puts $file $data
        close $file
        if {            $unix && ([string length $global::moompsResourceFile] > 0) &&            ([file writable $global::moompsResourceFile] || ![file exists $global::moompsResourceFile])        } {
            if {$unix && ![file exists $global::moompsResourceFile]} {
                create $global::moompsResourceFile
            }
            set file [::open $global::moompsResourceFile w]
            set document [dom::create]
            set root [dom::document createElement $document moompsPreferences]
            set node [dom::document createElement $root moodss]
            dom::element setAttribute $node version $global::applicationVersion
            dom::document createTextNode [dom::document createElement $root date] $date
            dom::document createTextNode [dom::document createElement $root time] $time
            dom::document createTextNode [dom::document createElement $root fromAddress] $::preferences::fromAddress
            nodeFromList $root smtpServers $::preferences::smtpServers
            set node [dom::document createElement $root database]
            foreach {switch value} $::preferences::databaseOptions {
                dom::element setAttribute $node [string trimleft $switch -] $value
            }
            dom::document configure $document -encoding [fconfigure $file -encoding]
            set data [serialize $document]
            dom::destroy $root
            puts $file $data
            close $file
        }
        lifoLabel::pop $global::messenger
    }

    proc update {} {
        array set data [read]
        save [array names data]
    }

}

}



namespace eval configuration {

if {$global::withGUI} {

    variable container
    variable interface
    variable hierarchy
    variable configure
    if {[string equal $::tcl_platform(platform) unix]} {
        set hierarchy {
            application application.size application.colors application.background application.fonts application.printing
                application.pages application.database application.trace
            viewers viewers.colors viewers.graphs viewers.pies viewers.tables viewers.cells
            thresholds thresholds.email thresholds.trace
            daemon
        }
        set prefer    {1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1}
        set configure {1 1 0 1 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0}
    } else {
        set hierarchy {
            application application.size application.colors application.background application.pages application.database
                application.trace
            viewers viewers.colors viewers.graphs viewers.pies viewers.tables viewers.cells
            thresholds thresholds.email thresholds.trace
        }
        set prefer    {1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1}
        set configure {1 1 0 1 0 0 0 1 1 1 1 1 1 0 0 0}
    }

    variable closedIcon [image create photo -data {
        R0lGODlhEAANAPIAAAAAAH9/f7+/v///AP///wAAAAAAAAAAACH+JEZpbGUgd3JpdHRlbiBieSBBZG9iZSBQaG90b3Nob3CoIDUuMAAsAAAAABAADQAAAzNI
        Gsz6kAQxqAjxzcpvc1KWBUDYnRQZWmilYi37EmztlrAt43R8mzrO60P8lAiApHK5TAAAOw==
    }]
    variable openedIcon [image create photo -data {
        R0lGODlhEAANAPIAAAAAAH9/f7+/v///////AAAAAAAAAAAAACH+JEZpbGUgd3JpdHRlbiBieSBBZG9iZSBQaG90b3Nob3CoIDUuMAAsAAAAABAADQAAAzk4
        Gsz6cIQ44xqCZCGbk4MmclAAgNs4ml7rEaxVAkKc3gTAnBO+sbyQT6M7gVQpk9HlAhgHzqhUmgAAOw==
    }]
    variable leafIcon [image create photo -data {
        R0lGODlhDAANAIQAALi8uJiYmPgA+PDw8LC0sGhoaPj4+Pj8+FhYWPD08ODg4IiIiOjs6NDQ0Ojo6Njc2ODk4NjY2NDU0LCwsMjMyKisqMDAwLi4uKioqKCg
        oGhsaAAAAAAAAAAAAAAAAAAAACH5BAEAAAIALAAAAAAMAA0AAAVUIBCM5CicwaCuBFGggyEbB1G/6UzbNZLPh0Bh6IsBEwrCoihLOBmKBqHoTAwYDsUDQLUy
        IIqIZJryZsWNCfUKeUgalIovTLEALoQKJoPQIP6AgQghADs=
    }]
    variable minusIcon [image create photo -data {
        R0lGODlhCQAJAKEAAL+/v////wAAAP///ywAAAAACQAJAAACEYSPoRvG614DQVg7ZZbxoQ8UADs=
    }]
    variable plusIcon [image create photo -data {
        R0lGODlhCQAJAKEAAL+/v////wAAAP///ywAAAAACQAJAAACFISPoRu2spyCyol7G3hxz850CFIAADs=
    }]

}

    proc load {arrayList} {
        foreach {name value} $arrayList {
            set ::global::$name $value
        }
    }

if {$global::withGUI} {

    proc edit {preferencesMode} {
        variable hierarchy
        variable prefer
        variable configure
        variable container
        variable interface
        variable tree
        variable preferences
        variable dialog
        variable entryIcons
        variable leafIcon
        variable minusIcon
        variable plusIcon

        set preferences $preferencesMode
        set objects {}
        set title {moodss: }
        if {$preferences} {
            append title [mc Preferences]
        } else {
            append title [mc {Dashboard configuration}]
        }
        set dialog [new dialogBox .grabber            -buttons hoc -default o -title $title -x [winfo pointerx .] -y [winfo pointery .] -enterreturn 0            -command configuration::done -helpcommand configuration::help -deletecommand {grab release .grabber} -die 0        ]
        grab .grabber
        lappend objects [linkedHelpWidgetTip $composite::($dialog,help,path)]
        set frame [frame $widget::($dialog,path).frame]
        set tree [Tree $frame.tree            -dragenabled 0 -dropenabled 0 -linestipple gray50 -deltay [expr {[font metrics $font::(mediumBold) -linespace] + 4}]            -background $widget::option(listbox,background) -selectbackground $widget::option(listbox,selectbackground)            -closecmd {configuration::stateChange 0} -opencmd {configuration::stateChange 1} -selectcommand configuration::open            -crossopenimage $minusIcon -crosscloseimage $plusIcon        ]
        $tree bindText <Control-Button-1> {}; $tree bindImage <Control-Button-1> {}
        set container [frame $frame.container -borderwidth 1 -relief sunken]
        set message [createMessage $container.message]
        if {$preferences} {
            $message configure -text [format [mc {Preferences for the user: %s}] $::tcl_platform(user)]
        } else {
            $message configure -text [mc {Current configuration of the dashboard}]
        }
        pack $message -fill both -expand 1
        catch {unset interface(current)}
        foreach entry $hierarchy forPreferences $prefer forConfiguration $configure {
            if {($preferences && !$forPreferences) || (!$preferences && !$forConfiguration)} continue
            foreach {parent child} [split $entry .] {}
            if {[string length $child] == 0} {
                set node                    [$tree insert end root #auto -text [mc $parent] -font $font::(mediumBold) -image $configuration::closedIcon]
                set parentNode $node
            } else {
                set node                    [$tree insert end $parentNode #auto -text [mc $child] -font $font::(mediumBold) -image $configuration::leafIcon]
            }
            regsub -all {\.} $entry :: interface($node,class)
            $interface($node,class)::initialize
        }
        pack $tree -side left -fill y -padx 2
        pack $container -fill both -expand 1 -padx 2
        dialogBox::display $dialog $frame
        wm geometry $widget::($dialog,path) 600x300
        bind $frame <Destroy> "delete $objects"
    }

    proc open {tree node} {
        variable container
        variable interface

        if {[info exists interface(current)]} {
            if {$node == $interface(current)} return
            if {![$interface($interface(current),class)::check]} {
                $tree selection set $interface(current)
                bell
                return
            }
        }
        eval destroy [winfo children $container]
        set frame [frame $container.frame]
        pack $frame -fill both -expand 1
        $interface($node,class)::edit $frame
        set interface(current) $node
    }

    proc done {} {
        variable interface
        variable preferences
        variable variables
        variable dialog

        if {[info exists interface(current)] && ![$interface($interface(current),class)::check]} return
        foreach name [array names interface *,class] {
            $interface($name)::apply
        }
        if {$preferences} {
            preferences::save $variables(1)
        }
        delete $dialog
    }

    proc help {} {
        variable interface
        variable preferences

        if {[info exists interface(current)]} {
            $interface($interface(current),class)::help
        } elseif {$preferences} {
            generalHelpWindow #core.preferences
        } else {
            generalHelpWindow #core.configuration
        }
    }

    proc createMessage {path args} {
        message $path -width [winfo screenwidth .] -font $font::(mediumNormal) -justify center
        eval $path configure $args
        return $path
    }

    proc initialize {name} {
        variable preferences

        if {$preferences} {
            if {![info exists ::preferences::$name]} {
                set ::preferences::$name [set ::global::$name]
            }
            return [set ::preferences::$name]
        } else {
            return [set ::global::$name]
        }
    }

    proc apply {name value {immediately 0}} {
        variable preferences

        if {$preferences} {
            set namespaces ::preferences
            if {$immediately} {lappend namespaces ::global}
        } else {
            set namespaces ::global
        }
        foreach namespace $namespaces {
            if {![info exists ${namespace}::$name] || ![string equal $value [set ${namespace}::$name]]} {
                set ${namespace}::$name $value
            }
        }
    }

    proc variables {preferences} {
        variable variables

        return $variables($preferences)
    }

    proc stateChange {opened node} {
        variable tree
        variable closedIcon
        variable openedIcon

        if {$opened} {
            $tree itemconfigure $node -image $openedIcon
        } else {
            $tree itemconfigure $node -image $closedIcon
        }
    }


    namespace eval application {

        proc initialize {} {}

        proc edit {parentPath} {
            set message [configuration::createMessage $parentPath.message -text [mc {Application configuration}]]
            pack $message -fill both -expand 1
        }

        proc check {} {
            return 1
        }

        proc apply {} {}

        proc variables {} {return {}}

        proc help {} {
            generalHelpWindow #configuration.application
        }

        namespace eval size {

            proc variables {} {
                return {canvasHeight canvasWidth}
            }

            proc initialize {} {
                variable height [configuration::initialize canvasHeight]
                variable width [configuration::initialize canvasWidth]
                variable automatic [expr {($width == 0) && ($height == 0)}]
                variable defaultMessage [mc {Canvas size (in pixels):}]
            }

            proc edit {parentPath} {
                variable height
                variable width
                variable message
                variable automatic
                variable entries
                variable defaultMessage

                set message [configuration::createMessage $parentPath.message -text $defaultMessage]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                set button [checkbutton $parentPath.automatic                    -text [mc {automatic scaling}] -command configuration::application::size::update                    -variable configuration::application::size::automatic                ]
                grid $button -row 1 -column 0 -columnspan 100 -pady 10
                set values {640 800 1024 1280 1600}
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    set widthEntry [new spinEntry $parentPath -width 4 -list $values]
                    spinEntry::set $widthEntry $width
                    grid $widget::($widthEntry,path) -row 2 -column 2
                    set path $composite::($widthEntry,entry,path)
                    set entries $widthEntry
                } else {
                    set path [spinbox $parentPath.widthEntry -width 4 -values $values]
                    $path set $width
                    grid $path -row 2 -column 2
                    set entries $path
                }
                $path configure -textvariable configuration::application::size::width
                setupEntryValidation $path {{checkMaximumLength 4 %P} {check31BitUnsignedInteger %P}}
                grid [label $parentPath.width -text [mc width:]] -row 2 -column 1 -padx 2
                grid columnconfigure $parentPath 3 -weight 1
                set values {400 480 600 768 1024 1280}
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    set heightEntry [new spinEntry $parentPath -width 4 -list $values]
                    spinEntry::set $heightEntry $height
                    grid $widget::($heightEntry,path) -row 2 -column 5
                    set path $composite::($heightEntry,entry,path)
                    lappend entries $heightEntry
                } else {
                    set path [spinbox $parentPath.heightEntry -width 4 -values $values]
                    $path set $height
                    grid $path -row 2 -column 5
                    lappend entries $path
                }
                $path configure -textvariable configuration::application::size::height
                setupEntryValidation $path {{checkMaximumLength 4 %P} {check31BitUnsignedInteger %P}}
                grid [label $parentPath.height -text [mc height:]] -row 2 -column 4 -padx 2
                grid columnconfigure $parentPath 6 -weight 1
                if {!$configuration::preferences} {
                    grid [button $parentPath.apply -text [mc Apply] -command configuration::application::size::apply]                        -row 3 -column 0 -columnspan 100
                }
                grid rowconfigure $parentPath 3 -weight 1
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    bind $message <Destroy> "delete $widthEntry $heightEntry"
                }
                update
            }

            proc update {} {
                variable automatic
                variable entries

                if {$automatic} {set state disabled} else {set state normal}
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    foreach entry $entries {
                        composite::configure $entry -state $state
                    }
                } else {
                    foreach entry $entries {
                        $entry configure -state $state
                    }
                }
            }

            proc check {} {
                variable height
                variable width
                variable message
                variable automatic
                variable defaultMessage

                if {!$automatic} {
                    if {([string length $width] == 0) || ($width == 0)} {
                        set error [mc {please set width}]
                    } elseif {([string length $height] == 0) || ($height == 0)} {
                        set error [mc {please set height}]
                    } elseif {[info exists message]} {
                        $message configure -font $font::(mediumNormal) -text $defaultMessage
                    }
                }
                if {[info exists error]} {
                    $message configure -font $font::(mediumBold) -text $error
                    return 0
                } else {
                    return 1
                }
            }

            proc apply {} {
                variable height
                variable width
                variable automatic

                if {![check]} return
                if {$automatic} {
                    set width 0; set height 0
                }
                configuration::apply canvasHeight $height
                configuration::apply canvasWidth $width
                if {!$configuration::preferences} {
                    pages::updateScrollRegion $global::canvas
                }
            }

            proc help {} {
                generalHelpWindow #configuration.application.size
            }

        }

        namespace eval colors {

            proc variables {} {
                return canvasBackground
            }

            proc initialize {} {
                variable background [configuration::initialize canvasBackground]
            }

            proc edit {parentPath} {
                variable background
                variable colorViewer

                set message [configuration::createMessage $parentPath.message -text [mc {Dashboard background color:}]]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                set colorViewer [button $parentPath.choose                    -text [mc Choose]... -command "configuration::application::colors::choose $parentPath"                ]
                updateColorViewer
                grid $colorViewer -row 1 -column 1
                grid columnconfigure $parentPath 1 -weight 1
                grid columnconfigure $parentPath 2 -weight 1
                grid rowconfigure $parentPath 2 -weight 1
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable background

                if {![check]} return
                configuration::apply canvasBackground $background
            }

            proc updateColorViewer {} {
                variable colorViewer
                variable background

                $colorViewer configure -background $background -foreground [visibleForeground $background]
            }

            proc choose {parentPath} {
                variable background

                set choice [tk_chooseColor -initialcolor $background -title [mc {Choose color:}] -parent $parentPath]
                if {[string length $choice] > 0} {
                    set background $choice
                    updateColorViewer
                }
            }

            proc help {} {
                generalHelpWindow #configuration.application.colors
            }

        }

        namespace eval background {

            proc variables {} {
                return [list canvasBackground canvasImageFile canvasImagePosition]
            }

            proc initialize {} {
                variable backgrounds
                variable images
                variable positions

                set data [pages::data]
                if {[llength $data] == 0} {
                    set backgrounds [list [configuration::initialize canvasBackground]]
                    set images [list [configuration::initialize canvasImageFile]]
                    set positions [list [configuration::initialize canvasImagePosition]]
                } else {
                    set backgrounds {}
                    set images {}
                    set positions {}
                    foreach {page label raised} $data {
                        lappend backgrounds [composite::cget $page -background]
                        lappend images [composite::cget $page -imagefile]
                        lappend positions [composite::cget $page -imageposition]
                    }
                }
            }

            proc edit {parentPath} {
                variable choosers
                variable backgrounds
                variable images
                variable positions
                variable book

                set message [configuration::createMessage $parentPath.message -text [mc {Dashboard background colors and images:}]]
                grid $message -row 0 -column 0
                foreach {left top right bottom} [bounds $global::canvas] {}
                set size [list [expr {$right - $left}] [expr {$bottom - $top}]]
                set data [pages::data]
                if {[llength $data] == 0} {
                    set file [lindex $images 0]
                    set chooser [new backgroundChooser $parentPath                        -font $font::(mediumNormal) -color [lindex $backgrounds 0] -targetsize $size                        -imagefile $file -useimage [expr {[string length $file] > 0}] -position [lindex $positions 0]                    ]
                    grid $widget::($chooser,path) -sticky nsew -row 1 -column 0
                    set choosers [list $chooser]
                } else {
                    set book [NoteBook $parentPath.book                        -background [$parentPath cget -background] -borderwidth 1 -internalborderwidth 0                        -font $font::(mediumNormal) -side $global::pagesTabPosition                    ]
                    set choosers {}
                    set first 1
                    foreach {index label raised} $data background $backgrounds file $images position $positions {
                        $book insert end $index
                        $book itemconfigure $index -text $label
                        set chooser [new backgroundChooser [$book getframe $index]                            -font $font::(mediumNormal) -color $background -targetsize $size                            -imagefile $file -useimage [expr {[string length $file] > 0}] -position $position                        ]
                        pack $widget::($chooser,path)
                        lappend choosers $chooser
                        if {$first} {
                            $book raise $index
                            set first 0
                        }
                        if {$raised} {$book raise $index}
                    }
                    grid $book -sticky nsew -row 1 -column 0
                    bind $message <Destroy> "destroy $book"
                }
                bind $message <Destroy> "+ delete $choosers; unset configuration::application::background::choosers"
                grid [button $parentPath.apply -text [mc Apply] -command configuration::application::background::apply]                    -row 2 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1
                grid rowconfigure $parentPath 2 -weight 1
            }

            proc check {} {
                variable backgrounds
                variable choosers
                variable images
                variable positions
                variable book

                if {[info exists choosers]} {
                    set backgrounds {}
                    set images {}
                    set positions {}
                    foreach chooser $choosers {
                        backgroundChooser::applyFileEntry $chooser
                        lappend backgrounds [composite::cget $chooser -color]
                        if {[composite::cget $chooser -useimage]} {
                            lappend images [composite::cget $chooser -imagefile]
                        } else {
                            lappend images {}
                        }
                        lappend positions [composite::cget $chooser -position]
                    }
                }
                return 1
            }

            proc apply {} {
                variable backgrounds
                variable images
                variable positions

                if {![check]} return
                set data [pages::data]
                if {[llength $data] == 0} {
                    set background [lindex $backgrounds 0]
                    set file [lindex $images 0]
                    set position [lindex $positions 0]
                    $global::canvas configure -background $background
                    updateCanvasImage $file
                    if {[string length $file] > 0} {
                        updateCanvasImagePosition $global::canvasImageItem $position
                    }
                    configuration::apply canvasBackground $background
                    configuration::apply canvasImageFile $file
                    configuration::apply canvasImagePosition $position
                } else {
                    configuration::apply canvasBackground $global::canvasBackground
                    foreach {page label raised} $data background $backgrounds file $images position $positions {
                        composite::configure $page -background $background -imagefile $file -imageposition $position
                    }
                }
                updateCanvasImagesPosition
                pages::updateScrollRegion $global::canvas
            }

            proc help {} {
                generalHelpWindow #configuration.application.background
            }

        }

        namespace eval fonts {

            proc variables {} {
                return {fontFamily fontSize}
            }

            proc initialize {} {
                variable family [configuration::initialize fontFamily]
                variable size [configuration::initialize fontSize]
            }

            proc edit {parentPath} {
                variable family
                variable size
                variable label

                grid rowconfigure $parentPath 0 -weight 1
                grid rowconfigure $parentPath 3 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 5 -weight 1
                set message [configuration::createMessage $parentPath.message                    -text [mc "Global font:\n(restart application for changes to take effect)"]
                ]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid [label $parentPath.family -text [mc Family:]] -row 1 -column 1 -padx 2
                set entry [new comboEntry $parentPath -font $widget::option(entry,font) -editable 0                    -list [lsort -dictionary [font families]] -command configuration::application::fonts::family                ]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::application::fonts::family
                composite::configure $entry button -listheight 10
                grid $widget::($entry,path) -row 1 -column 2
                set entry [new comboEntry $parentPath -font $widget::option(entry,font) -width 2 -editable 0                    -command configuration::application::fonts::size                    -list {0 2 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 24 25 26 32 33 34}                ]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::application::fonts::size
                composite::configure $entry button -listheight 10
                grid $widget::($entry,path) -row 1 -column 3
                grid [label $parentPath.pixels -text [mc pixels]] -row 1 -column 4 -padx 2
                set label [label $parentPath.label -background $widget::option(entry,background) -relief sunken                    -borderwidth 1 -pady 5 -text [mc "ABCDEFGHIJKLMNOPQRSTUVWXYZ\nabcdefghijklmnopqrstuvwxyz"]
                ]
                grid $label -sticky ew -row 2 -column 0 -columnspan 100 -padx 10 -pady 10
                bind $message <Destroy> "delete $objects"
                update
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable family
                variable size

                if {![check]} return
                configuration::apply fontFamily $family
                configuration::apply fontSize $size
            }

            proc help {} {
                generalHelpWindow #preferences.application.fonts
            }

            proc family {name} {
                variable family $name
                update
            }

            proc size {value} {
                variable size $value
                update
            }

            proc update {} {
                variable family
                variable size
                variable label

                $label configure -font -*-$family-medium-r-*-*-$size-*
            }

        }

        namespace eval printing {

            proc variables {} {
                return {printToFile fileToPrintTo printCommand printOrientation printPalette printPaperSize}
            }

            proc initialize {} {
                variable toFile [configuration::initialize printToFile]
                variable printFile [configuration::initialize fileToPrintTo]
                variable command [configuration::initialize printCommand]
                variable orientations
                variable orientation
                variable palettes
                variable palette
                variable sizes
                variable size

                if {![info exists orientations]} {
                    foreach orientation $global::printOrientations {lappend orientations [mc $orientation]}
                    foreach palette $global::printPalettes {lappend palettes [mc $palette]}
                    foreach size $global::printPaperSizes {lappend sizes [mc $size]}
                }
                set index [lsearch -exact $global::printOrientations [configuration::initialize printOrientation]]
                if {$index < 0} {set index 0}
                set orientation [lindex $orientations $index]
                set index [lsearch -exact $global::printPalettes [configuration::initialize printPalette]]
                if {$index < 0} {set index 0}
                set palette [lindex $palettes $index]
                set index [lsearch -exact $global::printPaperSizes [configuration::initialize printPaperSize]]
                if {$index < 0} {set index 0}
                set size [lindex $sizes $index]
            }

            proc edit {parentPath} {
                variable toFile
                variable printFile
                variable command
                variable orientations
                variable palettes
                variable sizes

                set objects {}
                set row 0
                set message [configuration::createMessage $parentPath.message -text [mc {Printing setup:}]]
                grid $message -sticky nsew -row $row -column 0 -columnspan 3
                grid rowconfigure $parentPath $row -weight 1
                incr row
                radiobutton $parentPath.toCommand                    -variable configuration::application::printing::toFile -value 0 -text [mc Command:]
                grid $parentPath.toCommand -row $row -column 0 -sticky w -padx 2
                entry $parentPath.command -textvariable configuration::application::printing::command
                grid $parentPath.command -row $row -column 1 -columnspan 2 -sticky ew -padx 2
                incr row
                radiobutton $parentPath.toFile -variable configuration::application::printing::toFile -value 1 -text [mc {to File:}]
                grid $parentPath.toFile -row $row -column 0 -sticky w -padx 2
                entry $parentPath.file -textvariable configuration::application::printing::printFile
                grid $parentPath.file -row $row -column 1 -sticky ew -padx 2
                button $parentPath.browse                    -text [mc Browse]... -command "configuration::application::printing::inquirePrintFile $parentPath"
                grid $parentPath.browse -row $row -column 2 -sticky ew -padx 2
                if {$toFile} {
                    $parentPath.toFile invoke
                } else {
                    $parentPath.toCommand invoke
                }
                incr row
                grid [label $parentPath.orientation -text [mc Orientation:]] -row $row -column 0 -sticky w -padx 2
                set entry [new comboEntry $parentPath -font $widget::option(entry,font) -list $orientations -editable 0]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::application::printing::orientation
                composite::configure $entry button -listheight [llength $orientations]
                composite::configure $entry button scroll -selectmode single
                grid $widget::($entry,path) -row $row -column 1 -columnspan 2 -sticky ew -padx 2
                incr row
                grid [label $parentPath.palette -text [mc Palette:]] -row $row -column 0 -sticky w -padx 2
                set entry [new comboEntry $parentPath -font $widget::option(entry,font) -list $palettes -editable 0]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::application::printing::palette
                composite::configure $entry button -listheight [llength $palettes]
                composite::configure $entry button scroll -selectmode single
                grid $widget::($entry,path) -row $row -column 1 -columnspan 2 -sticky ew -padx 2
                incr row
                grid [label $parentPath.size -text [mc {Paper size:}]] -row $row -column 0 -sticky w -padx 2
                set entry [new comboEntry $parentPath -font $widget::option(entry,font) -list $sizes -editable 0]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::application::printing::size
                composite::configure $entry button -listheight [llength $sizes]
                composite::configure $entry button scroll -selectmode single
                grid $widget::($entry,path) -row $row -column 1 -columnspan 2 -sticky ew -padx 2
                grid rowconfigure $parentPath [incr row] -weight 1
                grid columnconfigure $parentPath 1 -weight 1
                bind $message <Destroy> "delete $objects"
            }

            proc inquirePrintFile {parentPath} {
                variable printFile

                set file [tk_getSaveFile                    -title [mc {moodss: Print to file}] -parent $parentPath -initialdir [file dirname $printFile]                    -defaultextension .ps -filetypes [list {Postscript .ps} [list [mc {All files}] *]]                    -initialfile [file tail $printFile]                ]
                if {[string length $file] > 0} {
                    set printFile $file
                }
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable toFile
                variable printFile
                variable command
                variable orientations
                variable orientation
                variable palettes
                variable palette
                variable size
                variable sizes

                configuration::apply printToFile $toFile 1
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    if {[string length $printFile] > 0} {set file [file join [pwd] $printFile]} else {set file {}}
                    configuration::apply fileToPrintTo $file
                } else {
                    configuration::apply fileToPrintTo [file normalize $printFile] 1
                }
                configuration::apply printCommand $command 1
                set index [lsearch -exact $orientations $orientation]; if {$index < 0} {set index 0}
                configuration::apply printOrientation [lindex $global::printOrientations $index] 1
                set index [lsearch -exact $palettes $palette]; if {$index < 0} {set index 0}
                configuration::apply printPalette [lindex $global::printPalettes $index] 1
                set index [lsearch -exact $sizes $size]; if {$index < 0} {set index 0}
                configuration::apply printPaperSize [lindex $global::printPaperSizes $index] 1
            }

            proc help {} {
                generalHelpWindow #preferences.application.printing
            }

        }

        namespace eval pages {

            proc variables {} {
                return pagesTabPosition
            }

            proc initialize {} {
                variable position [configuration::initialize pagesTabPosition]
            }

            proc edit {parentPath} {
                set message [configuration::createMessage $parentPath.message -text [mc {Pages tab position:}]]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                grid [                    radiobutton $parentPath.top -variable configuration::application::pages::position -value top -text [mc top]                ] -row 1 -column 1
                grid [                    radiobutton $parentPath.bottom -variable configuration::application::pages::position -value bottom                    -text [mc bottom]                ] -row 1 -column 2
                grid columnconfigure $parentPath 3 -weight 1
                grid rowconfigure $parentPath 2 -weight 1
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable position

                configuration::apply pagesTabPosition $position
                pages::labelsSide $position
            }

            proc help {} {
                generalHelpWindow #preferences.application.pages
            }

        }

        namespace eval database {

            proc variables {} {
                return databaseOptions
            }

            proc initialize {} {
                variable data
                variable password
                variable type

                set data(-file) {}
                set data(-database) {}
                array set data [configuration::initialize databaseOptions]
                if {[string length $data(-dsn)] > 0} {
                    set type odbc
                } elseif {[string length $data(-host)] > 0} {
                    set type mysql
                    if {[string length $data(-database)] == 0} {set data(-database) moodss}
                } else {
                    set type sqlite
                    if {[string length $data(-file)] == 0} {set data(-file) $global::sqliteDefaultFile}
                }
                catch {set password $data(-password)}
                if {![info exists data(-debuglevel)]} {
                    set data(-debuglevel) 0
                }
                if {![string equal $::tcl_platform(platform) unix]} {set data(-debuglevel) 0}
            }

            proc edit {parentPath} {
                variable data
                variable message
                variable label
                variable radioButton
                variable checkButton
                variable entry
                variable password
                variable type

                set row 0
                set text [mc {Database setup:}]
                if {$global::database != 0} {
                    append text \n
                    append text [mc {(please disconnect from database first)}]
                }
                set message [configuration::createMessage $parentPath.message -text $text]
                grid $message -sticky nsew -row $row -column 0 -columnspan 100
                grid rowconfigure $parentPath $row -weight 1
                incr row
                set radioButton(file) [radiobutton $parentPath.fileChoice                    -variable configuration::application::database::type -value sqlite -text [mc {SQLite file:}]                    -command configuration::application::database::update                ]
                grid $radioButton(file) -row $row -column 0 -sticky w -padx 2
                set entry(file) [entry $parentPath.file -textvariable configuration::application::database::data(-file)]
                grid $entry(file) -row $row -column 1 -columnspan 3 -sticky ew -padx 2
                set entry(choose) [button $parentPath.chooseFile                    -text [mc Choose]... -command "configuration::application::database::inquireSQLiteFile $parentPath"                ]
                grid $entry(choose) -row $row -column 4 -sticky e -padx 2
                incr row
                set radioButton(dsn) [radiobutton $parentPath.dsnChoice                    -variable configuration::application::database::type -value odbc -text [mc {ODBC DSN:}]                    -command configuration::application::database::update                ]
                grid $radioButton(dsn) -row $row -column 0 -sticky w -padx 2
                set entry(dsn) [entry $parentPath.dsn -textvariable configuration::application::database::data(-dsn)]
                grid $entry(dsn) -row $row -column 1 -columnspan 100 -sticky ew -padx 2
                incr row
                set radioButton(host) [radiobutton $parentPath.hostChoice                    -variable configuration::application::database::type -value mysql -text [mc {MySQL host:}]                    -command configuration::application::database::update                ]
                grid $radioButton(host) -row $row -column 0 -sticky w -padx 2
                set entry(host) [entry $parentPath.host -textvariable configuration::application::database::data(-host)]
                grid $entry(host) -row $row -column 1 -columnspan 100 -sticky ew -padx 2
                incr row
                set label(user) [label $parentPath.userLabel -text [mc user:]]
                grid $label(user) -row $row -column 0 -sticky w -padx 2
                set entry(user) [entry $parentPath.user -textvariable configuration::application::database::data(-user)]
                grid $entry(user) -row $row -column 1 -columnspan 100 -sticky ew -padx 2
                incr row
                set label(password) [label $parentPath.passwordLabel -text [mc password:]]
                grid $label(password) -row $row -column 0 -sticky w -padx 2
                set entry(password) [entry $parentPath.password                    -textvariable configuration::application::database::data(-password) -width 8 -show *                ]
                grid $entry(password) -row $row -column 1 -sticky ew -padx 2
                set label(confirm) [label $parentPath.confirmLabel -text [mc confirm:]]
                grid $label(confirm) -row $row -column 2 -padx 2
                set entry(confirm)                    [entry $parentPath.confirm -textvariable configuration::application::database::password -width 8 -show *]
                grid $entry(confirm) -row $row -column 3 -sticky ew -padx 2 -columnspan 2
                incr row
                set label(port) [label $parentPath.portLabel -text [mc port:]]
                grid $label(port) -row $row -column 0 -sticky w -padx 2
                set entry(port) [entry $parentPath.port -textvariable configuration::application::database::data(-port)]
                setupEntryValidation $entry(port) {{check31BitUnsignedInteger %P}}
                grid $parentPath.port -row $row -column 1 -columnspan 100 -sticky ew -padx 2
                incr row
                set label(database) [label $parentPath.databaseLabel -text [mc database:]]
                grid $label(database) -row $row -column 0 -sticky w -padx 2
                set entry(database) [entry $parentPath.database -textvariable configuration::application::database::data(-database)]
                grid $parentPath.database -row $row -column 1 -columnspan 100 -sticky ew -padx 2
                incr row
                set checkButton(trace) [checkbutton $parentPath.trace                    -variable configuration::application::database::data(-debuglevel) -text [mc {Trace SQL statements and queries}]                ]
                if {![string equal $::tcl_platform(platform) unix]} {$checkButton(trace) configure -state disabled}
                grid $checkButton(trace) -row $row -column 0 -columnspan 100 -sticky w -padx 2
                grid rowconfigure $parentPath [incr row] -weight 1
                grid columnconfigure $parentPath 1 -weight 1
                grid columnconfigure $parentPath 3 -weight 1
                update
            }

            proc update {} {
                variable data
                variable type
                variable label
                variable radioButton
                variable checkButton
                variable entry

                if {$global::database != 0} {
                    foreach name {file dsn host} {$radioButton($name) configure -state disabled}
                    foreach name {user password confirm port database} {$label($name) configure -state disabled}
                    foreach name {file choose dsn host user password confirm port database} {
                        $entry($name) configure -state disabled
                    }
                    $checkButton(trace) configure -state disabled
                    return
                }
                switch $type {
                    sqlite {
                        foreach name {file choose} {$entry($name) configure -state normal}
                        foreach name {user password confirm port database} {$label($name) configure -state disabled}
                        foreach name {dsn host user password confirm port database} {$entry($name) configure -state disabled}
                        if {[string length $data(-file)] == 0} {set data(-file) moodss.dat}
                        focus $entry(file)
                    }
                    odbc {
                        foreach name {user password confirm} {$label($name) configure -state normal}
                        foreach name {dsn user password confirm} {$entry($name) configure -state normal}
                        foreach name {port database} {$label($name) configure -state disabled}
                        foreach name {file host choose port database} {$entry($name) configure -state disabled}
                        focus $entry(dsn)
                    }
                    mysql {
                        foreach name {user password confirm port database} {$label($name) configure -state normal}
                        foreach name {host user password confirm port database} {$entry($name) configure -state normal}
                        foreach name {file dsn choose} {$entry($name) configure -state disabled}
                        if {[string length $data(-host)] == 0} {set data(-host) localhost}
                        if {[string length $data(-database)] == 0} {set data(-database) moodss}
                        focus $entry(host)
                    }
                }
            }

            proc inquireSQLiteFile {parentPath} {
                variable data

                set file [tk_getSaveFile                    -title [mc {moodss: SQLite file}] -parent $parentPath                    -initialdir [file dirname $data(-file)] -initialfile [file tail $data(-file)]                ]
                if {[string length $file] > 0} {
                    set data(-file) $file
                }
            }

            proc check {} {
                variable data
                variable message
                variable type
                variable entry
                variable password

                if {![string equal $type sqlite] && ![string equal $data(-password) $password]} {
                    $message configure -font $font::(mediumBold) -text [mc {passwords do not match:}]
                    focus $entry(password)
                    return 0
                }
                switch $type {
                    sqlite {
                        if {[string length $data(-file)] == 0} {
                            $message configure -font $font::(mediumBold) -text [mc {a file name is needed:}]
                            focus $entry(file)
                            return 0
                        }
                        foreach name {host dsn user password port database} {set data(-$name) {}}
                    }
                    odbc {
                        if {[string length $data(-dsn)] == 0} {
                            $message configure -font $font::(mediumBold) -text [mc {a DSN is needed:}]
                            focus $entry(dsn)
                            return 0
                        }
                        foreach name {file host database} {set data(-$name) {}}
                    }
                    mysql {
                        if {[string length $data(-host)] == 0} {
                            $message configure -font $font::(mediumBold) -text [mc {a host is needed:}]
                            focus $entry(host)
                            return 0
                        }
                        if {[string equal $data(-host) localhost] && ([string length $data(-port)] > 0)} {
                            $message configure -font $font::(mediumBold) -text [mc {port useless with local socket connection:}]
                            focus $entry(port)
                            return 0
                        }
                        if {[string length $data(-database)] == 0} {
                            $message configure -font $font::(mediumBold) -text [mc {a database name is needed:}]
                            focus $entry(database)
                            return 0
                        }
                        foreach name {file dsn} {set data(-$name) {}}
                    }
                }
                return 1
            }

            proc apply {} {
                variable data

                if {![check]} return
                if {[string length $data(-file)] > 0} {
                    if {[package vcompare $::tcl_version 8.4] < 0} {
                        if {[string length $data(-file)] > 0} {set data(-file) [file join [pwd] $data(-file)]}
                    } else {
                        set data(-file) [file normalize $data(-file)]
                    }
                }
                configuration::apply databaseOptions [array get data] 1
            }

            proc help {} {
                generalHelpWindow #preferences.application.database
            }

        }

        namespace eval trace {

            proc variables {} {
                return traceNumberOfRows
            }

            proc initialize {} {
                variable numberOfRows [configuration::initialize traceNumberOfRows]
            }

            proc edit {parentPath} {
                variable numberOfRows
                variable message

                grid rowconfigure $parentPath 0 -weight 1
                grid rowconfigure $parentPath 2 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 3 -weight 1
                set message [configuration::createMessage $parentPath.message -text [mc {Trace window configuration:}]]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid [label $parentPath.rows -text [mc {number of rows:}]] -row 1 -column 1 -padx 2 -sticky w
                set values {5 10 15 20 30 50 100}
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    set entry [new spinEntry $parentPath -width 4 -list $values]
                    bind $message <Destroy> "delete $entry"
                    spinEntry::set $entry $numberOfRows
                    grid $widget::($entry,path) -row 1 -column 2 -sticky e
                    set path $composite::($entry,entry,path)
                } else {
                    set path [spinbox $parentPath.entry -width 4 -values $values]
                    $path set $numberOfRows
                    grid $path -row 1 -column 2 -sticky e
                }
                $path configure -textvariable configuration::application::trace::numberOfRows
                setupEntryValidation $path {{checkMaximumLength 4 %P} {check31BitUnsignedInteger %P}}
            }

            proc check {} {
                variable numberOfRows
                variable message

                set valid 1
                if {[string length $numberOfRows] == 0} {
                    set text [mc {please set number of rows}]
                    set valid 0
                } elseif {$numberOfRows == 0} {
                    set text [mc {number of rows cannot be set to 0}]
                    set valid 0
                }
                if {!$valid} {
                    $message configure -font $font::(mediumBold) -text $text
                }
                return $valid
            }

            proc apply {} {
                variable numberOfRows

                if {![check]} return
                configuration::apply traceNumberOfRows $numberOfRows 1
            }

            proc help {} {
                generalHelpWindow #preferences.application.trace
            }

        }

    }


    namespace eval viewers {

        proc initialize {} {}

        proc edit {parentPath} {
            set message [configuration::createMessage $parentPath.message -text [mc {Viewers configuration}]]
            pack $message -fill both -expand 1
        }

        proc check {} {
            return 1
        }

        proc apply {} {}

        proc variables {} {return {}}

        proc help {} {
            generalHelpWindow #configuration.viewers
        }

        namespace eval colors {

            proc variables {} {
                return viewerColors
            }

            proc initialize {} {
                variable colors [configuration::initialize viewerColors]
            }

            proc edit {parentPath} {
                variable colorsFrame

                set message [configuration::createMessage $parentPath.message -text [mc {Change colors:}]]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                set colorsFrame [frame $parentPath.colors -borderwidth 1 -background black]
                refresh
                grid $colorsFrame -row 1 -column 0
                grid rowconfigure $parentPath 2 -weight 1
            }

            proc refresh {} {
                variable colors
                variable colorsFrame

                eval destroy [winfo children $colorsFrame]
                set index 0
                foreach color $colors {
                    set button [button $colorsFrame.$index -background $color -activebackground $color -borderwidth 1]
                    $button configure -command "configuration::viewers::colors::choose $index"
                    pack $button -side left
                    incr index
                }
            }

            proc choose {index} {
                variable colors
                variable colorsFrame

                set button $colorsFrame.$index
                set background [tk_chooseColor -initialcolor [$button cget -background] -title [mc {Choose color:}] -parent $button]
                if {[string length $background] > 0} {
                    $button configure -background $background
                    set colors [lreplace $colors $index $index $background]
                }
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable colors
                variable colorsFrame

                if {![check]} return
                if {![info exists colorsFrame]} return
                configuration::apply viewerColors $colors
            }

            proc help {} {
                generalHelpWindow #configuration.viewers.colors
            }

        }

        namespace eval graphs {

            proc variables {} {
                return [list                    graphNumberOfIntervals graphMinimumY graphXAxisLabelsRotation graphLabelsPosition graphPlotBackground                    graphDisplayGrid                ]
            }

            proc initialize {} {
                variable numberOfSamples [configuration::initialize graphNumberOfIntervals]
                variable zeroBasedOrdinate [string equal [configuration::initialize graphMinimumY] 0]
                variable degrees [configuration::initialize graphXAxisLabelsRotation]
                variable labelsPositions
                variable labelsPositionsWidth
                variable labelsPosition
                variable plotBackground [configuration::initialize graphPlotBackground]
                variable grid [configuration::initialize graphDisplayGrid]

                if {![info exists labelsPositions]} {
                    set labelsPositionsWidth 0
                    foreach position $global::graphLabelsPositions {
                        lappend labelsPositions [set position [mc $position]]
                        set length [string length $position]
                        if {$length > $labelsPositionsWidth} {set labelsPositionsWidth $length}
                    }
                }
                set index [lsearch -exact $global::graphLabelsPositions [configuration::initialize graphLabelsPosition]]
                if {$index < 0} {set index 0}
                set labelsPosition [lindex $labelsPositions $index]
            }

            proc edit {parentPath} {
                variable numberOfSamples
                variable degrees
                variable message
                variable labelsPositions
                variable labelsPositionsWidth
                variable labelsPosition
                variable colorViewer

                grid rowconfigure $parentPath 0 -weight 1
                grid rowconfigure $parentPath 7 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 4 -weight 1
                set message [configuration::createMessage $parentPath.message -text [mc {Data graphs settings:}]]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                if {[info exists databaseInstances::singleton]} {
                    set state disabled
                } else {
                    set state normal
                }
                grid [label $parentPath.samplesLabel -text [mc {X axis:}] -state $state] -row 1 -column 1 -padx 2 -sticky e
                grid [set frame [frame $parentPath.samples]] -row 1 -column 2 -columnspan 100 -sticky w
                set values {20 50 100 150 200 300 500 1000}
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    set entry [new spinEntry $frame -width 4 -side right -list $values -state $state]
                    lappend objects $entry
                    spinEntry::set $entry $numberOfSamples
                    pack $widget::($entry,path) -side left
                    set path $composite::($entry,entry,path)
                } else {
                    set path [spinbox $frame.entry -width 4 -values $values -state $state]
                    $path set $numberOfSamples
                    pack $path -side left
                }
                $path configure -textvariable configuration::viewers::graphs::numberOfSamples
                setupEntryValidation $path {{checkMaximumLength 4 %P} {check31BitUnsignedInteger %P}}
                pack [label $frame.samples -text [mc samples] -state $state] -side left
                grid [label $parentPath.yAxis -text [mc {Y axis:}]] -row 2 -column 1 -padx 2 -sticky e
                grid [set frame [frame $parentPath.scale]] -row 2 -column 2 -columnspan 100 -sticky w
                set button [radiobutton $frame.zero                    -variable ::configuration::viewers::graphs::zeroBasedOrdinate -value 1 -text [mc {zero based}]                ]
                pack $button -side left
                set button [radiobutton $frame.scale                    -variable ::configuration::viewers::graphs::zeroBasedOrdinate -value 0 -text [mc {auto scale}]                ]
                pack $button -side left
                grid [label $parentPath.rotationLabel -text [mc {X axis labels rotation:}]] -row 3 -column 1 -padx 2 -sticky e
                grid [set frame [frame $parentPath.rotation]] -row 3 -column 2 -columnspan 100 -sticky w
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    set entry [new spinEntry $frame -width 2 -side right -editable 0 -range {45 90 5}]
                    lappend objects $entry
                    spinEntry::set $entry $degrees
                    pack $widget::($entry,path) -side left
                    set path $composite::($entry,entry,path)
                } else {
                    set path [spinbox $frame.entry -width 2 -state readonly -from 45 -to 90 -increment 5]
                    $path set $degrees
                    pack $path -side left
                }
                $path configure -textvariable configuration::viewers::graphs::degrees
                pack [label $frame.degrees -text [mc degrees]] -side left
                grid [label $parentPath.labelsLabel -text [mc {Position of labels:}]] -row 4 -column 1 -padx 2 -sticky e
                set entry [new comboEntry $parentPath                    -font $widget::option(entry,font) -editable 0 -list $labelsPositions -width $labelsPositionsWidth                ]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::viewers::graphs::labelsPosition
                composite::configure $entry button -listheight 4
                grid $widget::($entry,path) -row 4 -column 2 -columnspan 100 -sticky w -padx 2
                grid [label $parentPath.backgroundLabel -text [mc {Plot background:}]] -row 5 -column 1 -padx 2 -sticky e
                set colorViewer [button $parentPath.choose                    -text [mc Choose]... -command "configuration::viewers::graphs::choose $parentPath"                ]
                grid $colorViewer -row 5 -column 2 -columnspan 100 -sticky w -padx 2
                updateColorViewer
                grid rowconfigure $parentPath 5 -pad 2
                grid [label $parentPath.gridLabel -text [mc Grid:]] -row 6 -column 1 -padx 2 -sticky e
                grid [set frame [frame $parentPath.grid]] -row 6 -column 2 -columnspan 100 -sticky w
                set button [radiobutton $frame.on -variable ::configuration::viewers::graphs::grid -value 1 -text [mc displayed]]
                pack $button -side left
                set button [radiobutton $frame.off -variable ::configuration::viewers::graphs::grid -value 0 -text [mc hidden]]
                pack $button -side left
                if {!$configuration::preferences} {
                    grid [button $parentPath.apply -text [mc Apply] -command configuration::viewers::graphs::apply]                        -row 7 -column 0 -columnspan 100
                }
                if {[info exists objects]} {
                    bind $message <Destroy> "delete $objects"
                }
            }

            proc updateColorViewer {} {
                variable colorViewer
                variable plotBackground

                $colorViewer configure -background $plotBackground -foreground [visibleForeground $plotBackground]
            }

            proc choose {parentPath} {
                variable plotBackground

                set choice [tk_chooseColor -initialcolor $plotBackground -title [mc {Choose color:}] -parent $parentPath]
                if {[string length $choice] > 0} {
                    set plotBackground $choice
                    updateColorViewer
                }
            }

            proc check {} {
                variable numberOfSamples
                variable message

                set valid 1
                if {[string length $numberOfSamples] == 0} {
                    set text [mc {please set number of samples}]
                    set valid 0
                } elseif {$numberOfSamples == 0} {
                    set text [mc {number of samples cannot be set to 0}]
                    set valid 0
                }
                if {!$valid} {
                    $message configure -font $font::(mediumBold) -text $text
                }
                return $valid
            }

            proc apply {} {
                variable numberOfSamples
                variable zeroBasedOrdinate
                variable degrees
                variable labelsPositions
                variable labelsPosition
                variable plotBackground
                variable grid

                if {![check]} return
                configuration::apply graphNumberOfIntervals $numberOfSamples
                if {$zeroBasedOrdinate} {set minimum 0} else {set minimum {}}
                configuration::apply graphMinimumY $minimum
                configuration::apply graphXAxisLabelsRotation $degrees
                set index [lsearch -exact $labelsPositions $labelsPosition]; if {$index < 0} {set index 0}
                configuration::apply graphLabelsPosition [set position [lindex $global::graphLabelsPositions $index]]
                configuration::apply graphPlotBackground $plotBackground
                configuration::apply graphDisplayGrid $grid
                if {$configuration::preferences} return
                foreach graph $bltGraph::(graphs) {
                    composite::configure $graph -samples $numberOfSamples -xlabelsrotation $degrees -labelsposition $position                        -plotbackground $plotBackground -grid $grid
                    catch {composite::configure $graph -yminimum $minimum}
                }
                foreach chart $dataBarChart::(list) {
                    composite::configure $chart -labelsposition $position
                    catch {composite::configure $chart -yminimum $minimum}
                }
                if {[info exists databaseInstances::singleton]} {
                    composite::configure $databaseInstances::singleton -xlabelsrotation $degrees -plotbackground $plotBackground
                }
            }

            proc help {} {
                generalHelpWindow #configuration.viewers.graphs
            }

        }

        namespace eval pies {

            proc variables {} {
                return pieLabeler
            }

            proc initialize {} {
                variable labeler [configuration::initialize pieLabeler]
            }

            proc edit {parentPath} {
                set message [configuration::createMessage $parentPath.message -text [mc {Data values position:}]]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                set button [radiobutton $parentPath.box                    -variable ::configuration::viewers::pies::labeler -value box -text [mc {next to labels}]                ]
                grid $button -row 1 -column 1
                set button [radiobutton $parentPath.peripheral                    -variable ::configuration::viewers::pies::labeler -value peripheral -text [mc peripheral]                ]
                grid $button -row 1 -column 2
                grid columnconfigure $parentPath 3 -weight 1
                grid rowconfigure $parentPath 2 -weight 1
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable labeler

                if {![check]} return
                configuration::apply pieLabeler $labeler
            }

            proc help {} {
                generalHelpWindow #configuration.viewers.pies
            }

        }

        namespace eval tables {

            proc variables {} {
                return currentValueTableRows
            }

            proc initialize {} {
                variable numberOfRows [configuration::initialize currentValueTableRows]
            }

            proc edit {parentPath} {
                variable numberOfRows
                variable message

                grid rowconfigure $parentPath 0 -weight 1
                grid rowconfigure $parentPath 2 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 3 -weight 1
                set message [configuration::createMessage $parentPath.message                    -text [mc {Values table settings (in database history mode):}]                ]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid [label $parentPath.rows -text [mc {maximum number of rows:}]] -row 1 -column 1 -padx 2 -sticky w
                set values {10 20 50 100 200 500 1000 2000 5000 10000}
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    set entry [new spinEntry $parentPath -width 6 -list $values]
                    bind $message <Destroy> "delete $entry"
                    spinEntry::set $entry $numberOfRows
                    grid $widget::($entry,path) -row 1 -column 2 -sticky e
                    set path $composite::($entry,entry,path)
                } else {
                    set path [spinbox $parentPath.entry -width 6 -values $values]
                    $path set $numberOfRows
                    grid $path -row 1 -column 2 -sticky e
                }
                $path configure -textvariable configuration::viewers::tables::numberOfRows
                setupEntryValidation $path {{checkMaximumLength 6 %P} {check31BitUnsignedInteger %P}}
            }

            proc check {} {
                variable numberOfRows
                variable message

                set valid 1
                if {[string length $numberOfRows] == 0} {
                    set text [mc {please set number of rows}]
                    set valid 0
                } elseif {$numberOfRows == 0} {
                    set text [mc {number of rows cannot be set to 0}]
                    set valid 0
                }
                if {!$valid} {
                    $message configure -font $font::(mediumBold) -text $text
                }
                return $valid
            }

            proc apply {} {
                variable numberOfRows

                if {![check]} return
                configuration::apply currentValueTableRows $numberOfRows
            }

            proc help {} {
                generalHelpWindow #configuration.viewers.tables
            }

        }

        namespace eval cells {

            proc variables {} {
                return cellsLabelModuleHeader
            }

            proc initialize {} {
                variable identify [configuration::initialize cellsLabelModuleHeader]
            }

            proc edit {parentPath} {
                set message [configuration::createMessage $parentPath.message                    -text [mc "Whether module identifier\nis included in data cells labels:"]                ]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                grid [radiobutton $parentPath.top -variable configuration::viewers::cells::identify -value 1 -text [mc yes]]                    -row 1 -column 1
                grid [radiobutton $parentPath.bottom -variable configuration::viewers::cells::identify -value 0 -text [mc no]]                    -row 1 -column 2
                grid columnconfigure $parentPath 3 -weight 1
                grid rowconfigure $parentPath 2 -weight 1
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable identify

                if {![check]} return
                configuration::apply cellsLabelModuleHeader $identify
                if {$configuration::preferences} return
                foreach viewer $viewer::(list) {
                    viewer::updateLabels $viewer
                }
            }

            proc help {} {
                generalHelpWindow #configuration.viewers.cells
            }

        }

    }


    namespace eval thresholds {

        proc initialize {} {}

        proc edit {parentPath} {
            set message [configuration::createMessage $parentPath.message -text [mc {Thresholds configuration}]]
            pack $message -fill both -expand 1
        }

        proc check {} {
            return 1
        }

        proc apply {} {}

        proc variables {} {return {}}

        proc help {} {
            generalHelpWindow #preferences.thresholds
        }

        namespace eval email {

            proc variables {} {
                return {fromAddress smtpServers mailSubject mailBody}
            }

            proc initialize {} {
                variable from [configuration::initialize fromAddress]
                variable servers [configuration::initialize smtpServers]
                variable subject [configuration::initialize mailSubject]
                variable body [configuration::initialize mailBody]
            }

            proc edit {parentPath} {
                variable servers
                variable list
                variable body
                variable text
                variable parent $parentPath
                variable message

                set row 0
                set message [configuration::createMessage $parentPath.message -text [mc {Mail settings:}]]
                grid $message -row $row -column 0 -columnspan 3 -pady 5
                incr row
                set label [label $parentPath.from -text [mc {From address:}]]
                grid $label -row $row -column 0 -columnspan 2 -sticky w -padx 2
                set entry [entry $parentPath.address -textvariable configuration::thresholds::email::from]
                grid $entry -row $row -column 2 -sticky ew -padx 2
                incr row
                set label [label $parentPath.out -justify left -text [mc "Outgoing mail\nSMTP servers:"]]
                grid $label -row $row -column 0 -columnspan 2 -sticky nw -padx 2
                set list [new listEntry $parentPath]
                listEntry::set $list $servers
                grid $widget::($list,path) -row $row -column 2 -sticky nsew -padx 2
                incr row
                set label [label $parentPath.subjectLabel -text [mc Subject:]]
                grid $label -row $row -column 0 -sticky w -padx 2
                set font $font::(fixedNormal)
                set entry [entry $parentPath.subject -font $font -textvariable configuration::thresholds::email::subject]
                grid $entry -row $row -column 1 -columnspan 2 -sticky ew -padx 2
                incr row
                set label [label $parentPath.bodyLabel -text [mc Body:]]
                grid $label -row $row -column 0 -sticky nw -padx 2
                set text [text $parentPath.body -height 1 -background white -font $font]
                $text insert end $body
                setupTextBindings $text
                grid $text -row $row -column 1 -rowspan 2 -columnspan 2 -sticky nsew -padx 2
                incr row
                set button [button $parentPath.default                    -text [mc Default] -command configuration::thresholds::email::default -padx 2                ]
                set tip [new widgetTip -path $button -text [mc {reset email message subject and body to default values}]]
                bind $button <Destroy> "delete $tip"
                grid $button -row $row -column 0 -sticky s
                grid [frame $parentPath.filler -height [font metrics $font -ascent]]
                grid rowconfigure $parentPath $row -weight 1
                grid columnconfigure $parentPath 2 -weight 1
                bind $message <Destroy> "delete $list; unset configuration::thresholds::email::list"
            }

            proc default {} {
                variable subject
                variable body
                variable text

                set subject $global::mail(subject,default)
                set body $global::mail(body,default)
                $text delete 1.0 end
                $text insert end $body
            }

            proc check {} {
                variable from
                variable parent
                variable message

                set from [string trim $from]
                if {[string length $from] == 0} {
                    $message configure -font $font::(mediumBold) -text [mc {please set From address}]
                    return 0
                }
                if {[string length [emailAddressError $from]] > 0} {
                    tk_messageBox -parent $parent -title [mc {moodss: Email error}] -type ok -icon error                        -message "$from: [emailAddressError $from]"
                    return 0
                }
                return 1
            }

            proc apply {} {
                variable from
                variable servers
                variable subject
                variable body
                variable text
                variable list

                configuration::apply fromAddress $from 1
                if {[info exists list]} {
                    set servers [listEntry::get $list]
                    set body [$text get 1.0 end]
                }
                configuration::apply smtpServers $servers 1
                configuration::apply mailSubject [string trim $subject] 1
                configuration::apply mailBody [string trim $body] 1
            }

            proc help {} {
                generalHelpWindow #preferences.thresholds.email
            }

        }

        namespace eval trace {

            proc variables {} {
                return traceThresholds
            }

            proc initialize {} {
                variable trace [configuration::initialize traceThresholds]
            }

            proc edit {parentPath} {
                set message [configuration::createMessage $parentPath.message                    -text [mc "Whether thresholds messages\nare sent to the trace module:"]]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1
                grid columnconfigure $parentPath 0 -weight 1
                set button [radiobutton $parentPath.yes -variable ::configuration::thresholds::trace::trace -value 1 -text [mc yes]]
                grid $button -row 1 -column 1
                set button [radiobutton $parentPath.no -variable ::configuration::thresholds::trace::trace -value 0 -text [mc no]]
                grid $button -row 1 -column 2
                grid columnconfigure $parentPath 3 -weight 1
                grid rowconfigure $parentPath 2 -weight 1
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable trace

                if {![check]} return
                configuration::apply traceThresholds $trace 1
            }

            proc help {} {
                generalHelpWindow #preferences.thresholds.trace
            }

        }

    }


    namespace eval daemon {

        proc variables {} {
            return moompsResourceFile
        }

        proc initialize {} {
            variable file [configuration::initialize moompsResourceFile]
            variable current $file
        }

        proc edit {parentPath} {
            variable file
            variable message

            set message [configuration::createMessage $parentPath.message]
            resetMessage $message
            grid $message -sticky nsew -row 0 -column 0 -columnspan 100
            grid rowconfigure $parentPath 0 -weight 1
            grid [label $parentPath.label -text [mc {Preferences file:}]] -row 1 -column 0 -sticky w -padx 2
            entry $parentPath.file -textvariable configuration::daemon::file -width 32
            grid $parentPath.file -row 2 -column 0 -sticky ew -padx 2
            grid columnconfigure $parentPath 0 -weight 1
            button $parentPath.browse -text [mc Browse]... -command "configuration::daemon::inquireFile $parentPath"
            grid $parentPath.browse -row 2 -column 1 -sticky e -padx 2
            grid rowconfigure $parentPath 3 -weight 1
        }

        proc resetMessage {message} {
            $message configure -font $font::(mediumNormal) -text [mc {moomps daemon configuration:}]
        }

        proc inquireFile {parentPath} {
            variable file

            set value [tk_getSaveFile                -title [mc {moodss: Daemon preferences file}] -parent $parentPath                -initialdir [file dirname $file] -initialfile [file tail $file]            ]
            if {[string length $value] > 0} {
                set file $value
            }
        }

        proc check {} {
            variable file
            variable message

            resetMessage $message
            set user $::tcl_platform(user)
            if {[file exists $file]} {
                if {[file isdirectory $file]} {
                    set error [mc {file cannot be a directory}]
                } elseif {![file writable $file]} {
                    set error [format [mc {file not writable by user: %s}] $user]
                } elseif {![catch {set channel [open $file]} error]} {
                    unset error
                    gets $channel
                    set line [string trim [gets $channel]]
                    if {![string equal $line {<!DOCTYPE moompsPreferences>}]} {
                        set error [mc {not a moomps preferences file}]
                    }
                    close $channel
                }
            } elseif {![file writable [file dirname $file]]} {
                set error [format [mc "directory: %1\$s\nnot writable by user: %2\$s"] [file dirname $file] $user]
            }
            if {[info exists error]} {
                $message configure -font $font::(mediumBold) -text $error
                return 0
            } else {
                return 1
            }
        }

        proc apply {} {
            variable file
            variable current

            if {[string equal $file $current]} return
            if {![check]} return
            set current $file
            if {[package vcompare $::tcl_version 8.4] < 0} {
                if {[string length $file] > 0} {set file [file join [pwd] $file]}
                configuration::apply moompsResourceFile $file 1
            } else {
                configuration::apply moompsResourceFile [file normalize $file] 1
            }
        }

        proc help {} {
            generalHelpWindow #preferences.moomps
        }

    }

    variable variables
    set variables(0) {}
    set variables(1) {}
    foreach entry $hierarchy forPreferences $prefer forConfiguration $configure {
        regsub -all {\.} $entry :: class
        if {$forConfiguration} {
            set variables(0) [concat $variables(0) [${class}::variables]]
        }
        if {$forPreferences} {
            set variables(1) [concat $variables(1) [${class}::variables]]
        }
    }

}

}




class store {

    variable number
    variable titles {label active current comment}
    set column 0
    foreach title $titles {
        set number($title) $column
        incr column
    }
    unset column

    proc store {this args} switched {$args} viewer {} {
        variable singleton

        if {[info exists singleton]} {
            error {only 1 store object can exist}
        }
        switched::complete $this
    }

    proc ~store {this} {
        error {not implemented}
    }

    proc options {this} {
        return [list            [list -configurations {} {}]        ]
    }

    proc set-configurations {this value} {}

    proc setData {dataName row cell active comment} {
        variable number
        upvar 1 $dataName data

        viewer::parse $cell array cellRow cellColumn type
        foreach {label incomplete} [viewer::label $array $cellRow $cellColumn 1] {}
        set data($row,-1) $cell
        set data($row,$number(label)) $label
        set data($row,$number(active)) $active
        set data($row,$number(current)) {}
        set data($row,$number(comment)) $comment
        return $incomplete
    }

    proc sortedRows {dataName} {
        upvar 1 $dataName data

        set rows {}
        foreach name [array names data *,-1] {
            lappend rows [lindex [split $name ,] 0]
        }
        return [lsort -integer $rows]
    }

    proc supportedTypes {this} {
        return $global::dataTypes
    }

    proc monitorCell {this array row column} {
        variable data
        variable number

        if {[llength $switched::($this,-configurations)] == 0} return
        set cell ${array}($row,$column)
        viewer::registerTrace $this $array
        set rowIndex [llength [array names data *,-1]]
        set index 0
        foreach configuration $switched::($this,-configurations) {
            catch {unset option}; array set option $configuration
            if {![info exists option(-cell)]} break
            if {[string equal $option(-cell) $cell]} break
            incr index
        }
        set incomplete [setData data $rowIndex $cell $option(-active) $option(-comment)]
        switched::configure $this -configurations [lrange $switched::($this,-configurations) [incr index] end]
        if {$incomplete} {
            set ($this,relabel,$rowIndex) {}
        }
        set ($this,register,$rowIndex) {}
    }

    proc update {this array} {
        variable data
        variable number

        set externalUpdate [string length $array]
        foreach {name cell} [array get data *,-1] {
            if {$externalUpdate && ([string first $array $cell] != 0)} continue
            set row [lindex [split $name ,] 0]
            viewer::parse $cell array cellRow cellColumn type
            if {[info exists ($this,relabel,$row)] && [info exists $cell]} {
                foreach [list data($row,$number(label)) incomplete] [viewer::label $array $cellRow $cellColumn 1] {}
                if {!$incomplete} {
                    unset ($this,relabel,$row)
                }
                set ($this,register,$row) {}
            }
            set database $global::database
            if {$database == 0} continue
            if {!$data($row,$number(active))} continue
            set label $data($row,$number(label))
            set comment $data($row,$number(comment))
if {$global::withGUI} {
            if {[catch {set instance $($this,databaseInstance,$array)}]} {
                set instance [database::register $database [modules::instanceData $array]]
                if {[string length $database::($database,error)] > 0} {
                    traceDialog {moodss fatal error: database module instance registration} $database::($database,error) 1
                    _exit 1
                }
                set ($this,databaseInstance,$array) $instance
            }
            if {[info exists ($this,register,$row)]} {
                database::monitor                    $database $instance $cellRow $cellColumn [lindex [viewer::label $array $cellRow $cellColumn 0] 0] $comment
                unset ($this,register,$row)
            }
            if {$externalUpdate} {
                set value ?; catch {set value [set $cell]}
                database::update $database $instance $cellRow $cellColumn $value
            }
} else {
            if {[catch {set instance $($this,databaseInstance,$array)}]} {
                set instance [$database register [modules::instanceData $array]]
                if {[string length [$database error]] > 0} {
                    exit 1
                }
                set ($this,databaseInstance,$array) $instance
            }
            if {[info exists ($this,register,$row)]} {
                $database monitor $instance $cellRow $cellColumn [lindex [viewer::label $array $cellRow $cellColumn 0] 0] $comment
                unset ($this,register,$row)
            }
            set value ?; catch {set value [set $cell]}
            $database update $instance $cellRow $cellColumn $value
}
        }
    }

    proc cells {this} {
        variable data

        set cells {}
        foreach row [sortedRows data] {
            lappend cells $data($row,-1)
        }
        return $cells
    }

    proc manageable {this} {return 0}

if {$global::withGUI} {

    proc initializationConfiguration {this} {
        variable number
        variable data

        set arguments {}
        foreach row [sortedRows data] {
            lappend arguments [list -cell $data($row,-1) -active $data($row,$number(active)) -comment $data($row,$number(comment))]
        }
        return [list -configurations $arguments]
    }

    proc reload {dataName} {
        variable data
        variable singleton
        upvar 1 $dataName new

        reset $singleton
        array set data [array get new]
        foreach row [sortedRows data] {
            viewer::parse $data($row,-1) array dummy dummy dummy
            viewer::registerTrace $singleton $array
            set ($singleton,register,$row) {}
            store::update $singleton {}
        }
    }

    proc monitored {this cell} {
        variable data

        foreach {name monitored} [array get data *,-1] {
            if {[string equal $monitored $cell]} {
                return 1
            }
        }
        return 0
    }

    proc anyActiveCells {this} {
        variable data
        variable number

        foreach name [array names data *,-1] {
            set row [lindex [split $name ,] 0]
            if {$data($row,$number(active))} {return 1}
        }
        return 0
    }

}

    proc reset {this} {
        variable data

        foreach row [sortedRows data] {
            viewer::parse $data($row,-1) array dummy dummy dummy
            viewer::unregisterTrace $this $array
        }
        catch {unset data}
    }

    proc active {options} {
        array set value $options
        if {![info exists value(-configurations)]} {
            return 0
        }
        set cells 0
        foreach options $value(-configurations) {
            array set option $options
            if {$option(-active)} {incr cells}
        }
        return $cells
    }

}

set ::store::singleton [new store]


if {$global::withGUI} {

class store {

    proc edit {writable destroyCommand} {
        if {[info exists (dialog)]} {
            raise $widget::($dialog::($(dialog),dialog),path)
        } else {
            append destroyCommand "\nunset store::(dialog)"
            set (dialog) [new dialog . $writable $destroyCommand]
        }
    }

    proc setCellColor {this cell color} {
        variable ${this}data

        if {![info exists (dialog)]} return
        dialog::setCellColor $(dialog) $cell $color
    }

    class dialog {

        proc dialog {this parentPath writable {deleteCommand {}}} viewer {} {
            variable ${this}data

            set dialog [new dialogBox .                -buttons hoc -default o -title [mc {moodss: Database archiving}]                -helpcommand {generalHelpWindow #menus.edit.database} -x [winfo pointerx .] -y [winfo pointery .]                -grab release -otherbuttons delete -command "set store::dialog::($this,valid) 1" -deletecommand "delete $this"            ]
            lappend ($this,tips) [linkedHelpWidgetTip $composite::($dialog,help,path)]
            foreach {string underline} [underlineAmpersand [mc &Delete]] {}
            composite::configure $dialog delete -text $string -underline $underline -command "store::dialog::delete $this"                -state disabled
            set frame [frame $widget::($dialog,path).frame]
            set table [createTable $this $frame]
            set ($this,drop) [new dropSite -path $selectTable::($table,tablePath) -formats DATACELLS                -command "store::dialog::dropped $this \$dragSite::data(DATACELLS)"            ]
            pack $widget::($table,path) -anchor nw -fill both -expand 1
            wm geometry $widget::($dialog,path) 400x300
            dialogBox::display $dialog $frame
            set ($this,table) $table
            set ($this,dialog) $dialog
            array set ${this}data [array get store::data]
            selectTable::rows $table [llength [array names ${this}data *,-1]]
            initialize $this [store::sortedRows ${this}data] $writable
            selectTable::refreshBorders $table
            selectTable::adjustTableColumns $table
            colorRows $this
            set ($this,valid) 0
            set ($this,deleteCommand) $deleteCommand
        }

        proc ~dialog {this} {
            variable ${this}data

            if {$($this,valid)} {
                store::reload ${this}data
            }
            eval ::delete $($this,tips) $($this,drop) $($this,table)
            catch {unset ${this}data}
            if {[string length $($this,deleteCommand)] > 0} {
                uplevel #0 $($this,deleteCommand)
            }
        }

        proc createTable {this parentPath} {
            variable ${this}data

            set help(label) [mc {data cell identification}]
            set help(active) [mc {whether data cell history should be recorded in database}]
            set help(current) [mc {current value of data cell}]
            set help(comment) [mc {user editable comment}]
            set table [new selectTable $parentPath                -selectcommand "store::dialog::select $this" -variable store::dialog::${this}data -titlerows 1 -roworigin -1                -columns [llength $store::titles]            ]
            set path $selectTable::($table,tablePath)
            set column 0
            foreach title $store::titles {
                set label [label $path.$column -font $font::(mediumBold) -text [mc $title]]
                selectTable::windowConfigure $table -1,$column -window $label -padx 1 -pady 1 -sticky nsew
                lappend ($this,tips) [new widgetTip -path $label -text $help($title)]
                incr column
            }
            return $table
        }

        proc dropped {this cells} {
            variable ${this}data

            set table $($this,table)
            foreach {name cell} [array get ${this}data *,-1] {
                set saved($cell) {}
            }
            set rows [store::sortedRows ${this}data]
            set length [llength $rows]
            if {$length == 0} {
                set last -1
            } else {
                set last [lindex $rows end]
            }
            set row $last
            set new {}
            foreach cell $cells {
                if {[info exists saved($cell)]} continue
                viewer::parse $cell array ignore ignore ignore
                set module [modules::identifier $array]
                if {[string length $module] == 0} {
                    lifoLabel::flash $global::messenger [mc {data does not belong to an original module table}]
                    bell
                    continue
                }
                if {[string equal $module trace]} {
                    lifoLabel::flash $global::messenger [mc {cannot monitor cells from trace module}]
                    bell
                    continue
                }
                store::setData ${this}data [incr row] $cell 1 {}
                selectTable::height $table $row [linesCount [set ${this}data($row,$store::number(label))]]
                lappend new $row
                incr length
            }
            if {[llength $new] > 0} {
                selectTable::rows $table $length
                initialize $this $new
                selectTable::refreshBorders $table
                selectTable::adjustTableColumns $table
                colorRows $this
                update $this {}
            }
        }

        proc select {this row} {
            set topPath $widget::($($this,dialog),path)
            set button $composite::($($this,dialog),delete,path)
            $button configure -state normal
            bind $topPath <Alt-KeyPress-d> "$button configure -relief sunken"
            bind $topPath <Alt-KeyRelease-d> "$button configure -relief raised; $button invoke"
            return 1
        }

        proc delete {this} {
            variable ${this}data

            set table $($this,table)
            set row [selectTable::selected $table]
            if {[string length $row] == 0} return
            set path $selectTable::($table,tablePath)
            foreach index [store::sortedRows ${this}data] {
                destroy $path.$index,active $path.$index,comment
            }
            viewer::parse [set ${this}data($row,-1)] array dummy dummy dummy
            viewer::unregisterTrace $this $array
            array unset ${this}data $row,*
            array set data [array get ${this}data]
            unset ${this}data
            set row 0; set rows {}
            foreach index [store::sortedRows data] {
                set ${this}data($row,-1) $data($index,-1)
                set column $store::number(label); set ${this}data($row,$column) $data($index,$column)
                set column $store::number(active); set ${this}data($row,$column) $data($index,$column)
                set column $store::number(comment); set ${this}data($row,$column) $data($index,$column)
                lappend rows $row; incr row
            }
            selectTable::rows $table $row
            initialize $this $rows
            selectTable::clear $table
            selectTable::refreshBorders $table
            selectTable::adjustTableColumns $table
            colorRows $this
            set topPath $widget::($($this,dialog),path)
            bind $topPath <Alt-KeyPress-d> {}; bind $topPath <Alt-KeyRelease-d> {}
            composite::configure $($this,dialog) delete -state disabled
        }

        proc setCellColor {this cell color} {
            variable ${this}data

            foreach {name value} [array get ${this}data *,-1] {
                if {[string equal $value $cell]} {
                    colorRow $this [lindex [split $name ,] 0] $color
                    return
                }
            }
        }

        proc colorRow {this row color} {
            set cell $row,$store::number(current)
            if {[string length $color] == 0} {
                selectTable::tag $($this,table) cell {} $cell
            } else {
                selectTable::tag $($this,table) configure color$color -background $color
                selectTable::tag $($this,table) cell color$color $cell
            }
        }

        proc colorRows {this} {
            variable ${this}data

            foreach {name cell} [array get ${this}data *,-1] {
                viewer::parse $cell array row column type
                colorRow $this [lindex [split $name ,] 0] [viewer::cellThresholdColor $array $row $column]
            }
        }

        proc initialize {this rows {writable 1}} {
            variable ${this}data

            set table $($this,table)
            set path $selectTable::($table,tablePath)
            set background [$path cget -background]
            foreach row $rows {
                set cell [set ${this}data($row,-1)]
                viewer::parse $cell array dummy dummy dummy
                viewer::registerTrace $this $array
                set cell $row,$store::number(active)
                set button [checkbutton $path.$row,active                    -activebackground $background -highlightthickness 0 -variable store::dialog::${this}data($cell) -takefocus 0                ]
                bind $button <ButtonRelease-1> "selectTable::select $table $row"
                selectTable::windowConfigure $table $cell -window $button -padx 1 -pady 1 -sticky nsew
                set cell $row,$store::number(comment)
                set entry [entry $path.$row,comment                    -font $font::(mediumNormal) -textvariable store::dialog::${this}data($cell) -borderwidth 0                    -highlightthickness 0                ]
                if {!$writable} {
                    $entry configure -state disabled
                }
                bind $entry <FocusIn> "selectTable::select $table $row"
                selectTable::windowConfigure $table $cell -window $entry -padx 1 -pady 1 -sticky nsew
                selectTable::height $table $row [linesCount [set ${this}data($row,$store::number(label))]]
            }
            update $this {}
        }

        proc update {this array} {
            variable ${this}data

            set externalUpdate [string length $array]
            foreach {name cell} [array get ${this}data *,-1] {
                if {$externalUpdate && ([string first $array $cell] != 0)} continue
                set row [lindex [split $name ,] 0]
                set value ?
                catch {set value [set $cell]}
                set ${this}data($row,$store::number(current)) $value
            }
        }

        proc saved {this} {return 0}

        proc manageable {this} {return 0}

        proc reset {this} {
            ::delete $($this,dialog)
        }

    }

}

}

        modules::loadResidentTraceModule
        if {[string length $preferencesFile] > 0} {
            configuration::load [preferences::read $preferencesFile]
        }
        proc moduleInitializationError {namespace message} {
            writeLog $message error
        }

        proc createSavedViewers {record file} {
            set store 0; set emails 0; set scripts 0
            foreach {class cells x y width height level xIcon yIcon switchedOptions} [record::viewersData $record] {
                switch $class {
                    ::store {
                        set viewer $store::singleton
                        eval switched::configure $viewer $switchedOptions
                        if {[llength $cells] > 0} {set store [store::active $switchedOptions]}
                    }
                    ::thresholds {
                        set viewer $thresholds::singleton
                        eval switched::configure $viewer $switchedOptions
                        if {[llength $cells] > 0} {foreach {emails scripts} [thresholds::active $switchedOptions] {}}
                    }
                    ::summaryTable - ::currentValueTable - ::formulas::table {
                        set viewer [eval new $class $switchedOptions]
                    }
                    default {
                        continue
                    }
                }
                set viewerCells($viewer) $cells
            }
            foreach {viewer cells} [array get viewerCells] {
                viewer::view $viewer $cells
            }
            set messages {}
            if {($global::database == 0) && ($store > 0)} {
                lappend messages {some cells activated for archiving but no database defined}
            }
            if {(($global::database == 0) || ($store == 0)) && ($emails == 0) && ($scripts == 0)} {
                lappend messages {nothing to do (database archiving, thresholds emails or scripts)}
            }
            foreach message $messages {
                writeLog "$file: $message" warning
            }
        }

        set modules::(synchronous) {}
        proc processModule {instance} {
            if {[lindex $modules::instance::($instance,times) 0] > 0} {
                lappend modules::(synchronous) $instance
            }
            set index 0
            set namespace $modules::instance::($instance,namespace)
        }

        proc refresh {} {
            static updateEvent

            catch {after cancel $updateEvent}
            if {[llength $modules::(synchronous)] == 0} return
            foreach instance $modules::(synchronous) {
                set namespace $modules::instance::($instance,namespace)
                ${namespace}::update
            }
            set updateEvent [after [expr {1000 * $global::pollTime}] refresh]
        }

        proc cellThresholdCondition {array row column color level summary} {}

        proc notInstance {file namespace} {
            if {[string equal [lindex [modules::decoded $namespace] 0] instance]} {
                writeLog "skipped loading database instance module from $file" error
                return 0
            } else {
                return 1
            }
        }

        proc processFile {name} {
            if {$global::debug} {
                writeLog "loading configuration from file: $name"
            }
            set initializer [new record -file $name]
            record::read $initializer
            configuration::load [record::configurationData $initializer]
            modules::parse [record::modulesWithArguments $initializer "notInstance $name"]
            set modules::(initialized) [record::modules $initializer]
            return $initializer
        }

    }

}

proc modificationsPoll {pollTime files} {
    static lastModified

    foreach file $files {
        if {![file readable $file]} continue
        set seconds [file mtime $file]
        if {![info exists lastModified($file)]} {
            set lastModified($file) $seconds
        } elseif {$seconds > $lastModified($file)} {
            $::interpreter($file) eval {
                foreach instance $modules::(instances) {
                    modules::unload $instance
                }
            }
            interp delete $::interpreter($file)
            set interpreter [interp create]
            initialize $interpreter
            interp eval $interpreter "set initializer \[processFile $file\]"
            $interpreter eval modules::initialize 1 moduleInitializationError
            $interpreter eval "
                modules::setPollTimes \[record::pollTime \$initializer\]
                createSavedViewers \$initializer $file
                foreach instance \$modules::(instances) {
                    processModule \$instance
                }
                refresh
            "
            set ::interpreter($file) $interpreter
            set lastModified($file) $seconds
            writeLog "reloaded $file"
        }
    }
    if {[info exists ::processFile]} {
        file mtime $::processFile [clock seconds]
    }
    after $pollTime modificationsPoll $pollTime [list $files]
}

writeLog $startMessage
if {([string length $preferencesFile] > 0) && ![file readable $preferencesFile]} {
    writeLog "could not read preferences file: $preferencesFile" warning
}
if {[archive]} {
    set database [eval new database $global::databaseOptions]
    if {[string length $database::($database,error)] > 0} {
        writeLog $database::($database,error) critical
        exit 1
    }
    if {$database::($database,created)} {
        writeLog {created table(s) in moodss database}
    }
    set global::database $database



class viewer {

    set (list) {}
if {$global::withGUI} {
    set (background) $widget::option(label,background)
    set (rightRedArrow) [image create photo -data {R0lGODlhBQAJAIAAAP8AAP8AACH5BAEKAAEALAAAAAAFAAkAAAIMRB5gp9v2YlJsJRQKADs=}]
    set (rightDarkGrayArrow) [image create photo -data {R0lGODlhBQAJAIAAAKCgoP///yH5BAEKAAEALAAAAAAFAAkAAAIMRB5gp9v2YlJsJRQKADs=}]
    set (limitAreaWidth) 40
    set (limitAreaHeight) 20
}

    proc viewer {this} {
        lappend (list) $this
    }

    proc ~viewer {this} {
        dataTrace::unregister $this
        if {[info exists ($this,drop)]} {
            delete $($this,drop)
        }
        ldelete (list) $this
if {$global::withGUI} {
        pages::monitorActiveCells
        thresholdLabel::monitorActiveCells
}
    }

    virtual proc supportedTypes {this}

    proc view {this cells} {
        set list {}
        foreach cell $cells {
            parse $cell array row column type
            if {![info exists $array]} continue
            if {[lsearch -exact [supportedTypes $this] $type] < 0} {
if {$global::withGUI} {
                wrongTypeMessage $type
}
                return 0
            }
            set update($array) {}
            lappend list $array $row $column
        }
        foreach {array row column} $list {
            monitorCell $this $array $row $column
if {$global::withGUI} {
            foreach {color level summary} [thresholds::cellData $array $row $column] {
                thresholdCondition $this $array $row $column $color $level $summary
            }
            setCellColor $this ${array}($row,$column) [cellThresholdColor $array $row $column]
}
        }
        foreach array [array names update] {
            update $this $array
        }
        return 1
    }

    virtual proc monitorCell {this array row column}

    proc parse {dataCell arrayName rowName columnName typeName} {
        upvar 1 $arrayName cellArray $rowName cellRow $columnName cellColumn $typeName cellType

        if {([scan $dataCell {%[^(](%lu,%u)} array row column] != 3) || ($column < 0)} {
            error "\"$dataCell\" is not a valid array cell"
        }
        set cellArray $array; set cellRow $row; set cellColumn $column; catch {set cellType [set ${array}($column,type)]}
    }

    proc updateInterval {value} {
        foreach viewer $(list) {
            catch {composite::configure $viewer -interval $value}
        }
    }

    proc label {array row column {identify {}}} {
        set label {}
        if {[string length $identify] == 0} {
            set identify $global::cellsLabelModuleHeader
        }
        if {$identify} {
            set identifier [modules::identifier $array]
            if {[string length $identifier] > 0} {
                regsub {<0>$} $identifier {} identifier
                set label "$identifier: "
            }
        }
        if {[catch {set ${array}(indexColumns)} columns]} {
            set columns 0
        }
        foreach index $columns {
            if {[catch {set ${array}($row,$index)} value]} {
                append label {? }
            } elseif {[string length $value] > 0} {
                append label "$value "
            }
        }
        append label [set ${array}($column,label)]
        return [list $label [string match {*\?*} $label]]
    }

    virtual proc update {this array}

    proc registerTrace {this array {last 0}} {
        dataTrace::register $this $array "viewer::update $this $array" $last
    }

    proc unregisterTrace {this array} {
        dataTrace::unregister $this $array
    }

    virtual proc cells {this}

if {$global::withGUI} {

    virtual proc initializationConfiguration {this} {
        return {}
    }

    proc setupDropSite {this path} {
        set ($this,drop) [new dropSite -path $path -formats {DATACELLS VIEWER KILL} -command "viewer::handleDrop $this"]
    }

    proc handleDrop {this} {
        if {![catch {set data $dragSite::data(DATACELLS)}]} {
            view $this $data
        } elseif {![catch {set data $dragSite::data(VIEWER)}]} {
            mutate $this $data
        } elseif {[info exists dragSite::data(KILL)]} {
            delete $this
        }
    }

    proc mutate {this class} {
        if {[string equal $class [classof $this]]} return
        set draggable [composite::cget $this -draggable]
        switch $class {
            ::currentValueTable {
                set viewer [new currentValueTable $global::canvas $global::pollTime -draggable $draggable]
            }
            ::canvas::iconic {
                if {[string length [set name [canvas::iconic::chooseFile]]] == 0} return
                set viewer [new $class $global::canvas -draggable $draggable -static $global::static -file $name]
            }
            default {
                set viewer [new $class $global::canvas -draggable $draggable]
            }
        }
        foreach list [composite::configure $viewer] {
            if {[string equal [lindex $list 0] -interval]} {
                composite::configure $viewer -interval $global::pollTime
                break
            }
        }
        set cells {}
        set count 0
        foreach cell [cells $this] {
            if {[info exists $cell]} {
                lappend cells $cell
            }
            incr count
        }
        if {[llength $cells] > 0} {
            view $viewer $cells
        }
        if {[llength $cells] < $count} {
            lifoLabel::flash $global::messenger [mc {some data cells no longer exist}]
        }
        if {[manageable $this]} {
            foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $widget::($this,path)] {}
            set level [canvasWindowManager::getStackLevel $global::windowManager $widget::($this,path)]
        } else {
            set x [composite::cget $this -x]; set y [composite::cget $this -y]
            set width {}; set height {}; set level {}
        }
        delete $this
        if {[manageable $viewer]} {
            manageViewer $viewer 1 -static $global::static -setx $x -sety $y -setwidth $width -setheight $height -level $level                -dragobject $viewer
        } else {
            composite::configure $viewer -x $x -y $y
        }
    }

    proc cellThresholdColor {array row column} {
        set manager [new thresholdsManager]
        set cell ${array}($row,$column)
        foreach {color level summary} [thresholds::cellData $array $row $column] {
            thresholdsManager::condition $manager $cell $color $level $summary
        }
        set color [lindex [lindex [thresholdsManager::colorsAndTexts $manager] 0] 0]
        delete $manager
        return $color
    }

    proc cellThresholdCondition {array row column color level summary} {
        set topColor [cellThresholdColor $array $row $column]
        foreach viewer $(list) {
            thresholdCondition $viewer $array $row $column $color $level $summary
            setCellColor $viewer ${array}($row,$column) $topColor
        }
    }


    virtual proc thresholdCondition {this array row column color level summary} {}
    virtual proc setCellColor {this cell color} {}

    virtual proc manageable {this} {return 1}

    proc monitoring {cell} {
        set viewers {}
        foreach viewer $(list) {
            if {[monitored $viewer $cell]} {
                lappend viewers $viewer
            }
        }
        return $viewers
    }

    virtual proc monitored {this cell}

    proc getDisplayColor {cell} {
        variable colorIndex
        variable usageCount

        if {![info exists colorIndex($cell)]} {
            set colors [llength $global::viewerColors]
            for {set index 0} {$index < $colors} {incr index} {
                set count($index) 0
            }
            foreach {name index} [array get colorIndex] {
                incr count($index)
            }
            set color 0
            set minimum $global::32BitIntegerMaximum
            for {set index 0} {$index < $colors} {incr index} {
                if {$count($index) < $minimum} {
                    set minimum $count($index)
                    set color $index
                }
            }
            set colorIndex($cell) $color
            set usageCount($cell) 0
        }
        incr usageCount($cell)
        return [lindex $global::viewerColors $colorIndex($cell)]
    }
    proc returnDisplayColor {cell} {
        variable colorIndex
        variable usageCount

        if {[catch {incr usageCount($cell) -1}]} return
        if {$usageCount($cell) == 0} {
            unset colorIndex($cell) usageCount($cell)
        }
    }

    proc limitEntry {this path anchor x y option name font command yCommand type} {
        set entry [entry $path.maximum -borderwidth 0 -highlightthickness 0 -width 10 -font $font]
        switch $type {
            float {setupEntryValidation $entry {{checkFloatingPoint %P}}; set type double}
            signed {setupEntryValidation $entry {{check32BitSignedInteger %P}}; set type integer}
            unsigned {setupEntryValidation $entry {{check31BitUnsignedInteger %P}}; set type integer}
            default error
        }
        lifoLabel::push $global::messenger            [format [mc {enter %s value (empty for automatic scale, Return to valid, Escape to abort)}] $name]
        foreach key {<KP_Enter> <Return>} {
            bind $entry $key "
                if {\[string is $type \[%W get\]\]} {
                    $command \[%W get\]
                    destroy %W
                    lifoLabel::pop $global::messenger
                }
            "
        }
        bind $entry <Escape> "destroy %W; lifoLabel::pop $global::messenger"
        $entry insert 0 [composite::cget $this $option]
        $entry selection range 0 end
        if {[string length $yCommand] > 0} {set y [uplevel #0 $yCommand]}
        place $entry -anchor $anchor -x $x -y $y
        focus $entry
        ::update idletasks
        grab $entry
    }

    proc wrongTypeMessage {type} {
        lifoLabel::flash $global::messenger [format [mc {cannot display data of type %s}] $type]
        bell
        if {![info exists (wrongTypeDrop)]} {
            set (wrongTypeDrop) {}
            tk_messageBox -title {moodss: drag and drop} -type ok -icon info -message [format [mc                {Some viewers only accept a limited set of data types (if this case, this viewer cannot display data of type %s)}            ] $type]
        }
    }

    proc createColorsMenu {parentPath command} {
        set menu [menu $parentPath.colorsMenu -tearoff 0]
        set spaces {   }
        if {[string equal $::tcl_platform(platform) windows]} {set spaces {      }}
        set rows 0
        set index 0
        foreach color $global::viewerColors {
            $menu add command -label $spaces -background $color -activebackground $color
            regsub -all %c $command $color string
            $menu entryconfigure $index -hidemargin 1 -command $string
            if {$rows >= 3} {
                $menu entryconfigure $index -columnbreak 1
                set rows 0
            }
            incr rows
            incr index
        }
        return $menu
    }

    virtual proc updateLabels {this} {}

}

    proc numericType {type} {
        switch $type {
            integer - real {return 1}
            default {return 0}
        }
    }

    virtual proc saved {this} {return 1}

}



class modules {

    class instance {

        proc instance {this module index} {
            set ($this,module) $module
            set ($this,loaded) [new module $module $index]
        }

        proc ~instance {this} {
            delete $($this,loaded)
        }

        proc load {this} {
            set loaded $($this,loaded)
            module::load $loaded
            set namespace $module::($loaded,namespace)
            set ($this,namespace) $namespace
            if {[info exists ::${namespace}::data(switches)]} {
                array set switch [set ::${namespace}::data(switches)]
                if {[info exists switch(--daemon)] && ($switch(--daemon) != 0)} {
                    error {--daemon option must not take any argument}
                }
                set ($this,switches) [set ::${namespace}::data(switches)]
            }
            set ($this,initialize) $module::($loaded,initialize)
            set ($this,version) $module::($loaded,version)
            initialize $this
        }

        proc initialize {this} {
            set namespace $($this,namespace)
            set ($this,identifier) [set ${namespace}::data(identifier)]
            if {![modules::validName $($this,identifier)]} {
                foreach {name index} [modules::decoded $namespace] {}
                puts stderr "\"$name\" module identifier: \"$($this,identifier)\" contains invalid characters"
                exit 1
            }
            catch {set ($this,times) [set ${namespace}::data(pollTimes)]}
            catch {set ($this,views) [set ${namespace}::data(views)]}
        }

        proc synchronize {this} {
            module::synchronize $($this,loaded)
            initialize $this
        }

        proc empty {this} {
            module::clear $($this,loaded)
        }

    }


    set (instances) {}

    proc modules {this} error

    proc source {interpreter package file} {
        switch [file extension $file] {
            .py {
                if {[catch {package require tclpython 3}]} return
                set python [python::interp new]
                set code [catch {
                    $python exec "import sys\nsys.path.insert(0, '.')"
                    $python exec {import re}
                    $python exec "import $package"
                    $python exec $module::python::utilityFunctions
                    array set data [$python eval formstring($package.form)]
                    foreach name {helpText switches updates} {
                        catch {$interpreter eval [list namespace eval $package [list set data($name) $data($name)]]}
                    }
                    $interpreter eval "package provide $package [$python eval $package.__version__]"
                } message]
                python::interp delete $python
                if {$code} {
                    error $message $::errorInfo $code
                }
            }
            .pm {
                if {[catch {package require tclperl 3}] && [catch {package require tclperl 2}]} return
                set perl [perl::interp new]
                set code [catch {
                    $perl eval "use $package"
                    $perl eval $module::perl::utilities
                    array set data [$perl eval hash_string(%${package}::data)]
                    foreach name {helpText switches updates} {
                        catch {$interpreter eval [list namespace eval $package [list set data($name) $data($name)]]}
                    }
                    $interpreter eval "package provide $package [$perl eval \$${package}::VERSION]"
                } message]
                perl::interp delete $perl
                if {$code} {
                    error $message $::errorInfo $code
                }
            }
            default {
                $interpreter eval _source [list $file]
            }
        }
    }

    proc available {{command {}} {scanCommand {}}} {
        set directory [pwd]
        set packages {}
        foreach package [package names] {
            if {[string match *::* $package]} continue
            if {![info exists ::package(directory,$package)]} continue
            switch $package {instance - formulas continue}
            if {!$global::debug && ![string match *moodss* $::package(directory,$package)]} {
                continue
            }
            if {[string length $scanCommand] > 0} {
                regsub -all %M $scanCommand $package string
                uplevel #0 $string
            }
            cd $::package(directory,$package)
            set interpreter [interp create]
            $interpreter eval "set auto_path [list $::auto_path]"
            catch {$interpreter eval {package require {}}}
            $interpreter eval {rename source _source}; $interpreter alias source ::modules::source $interpreter $package
            if {[info exists ::package(exact,$package)]} {
                set error [catch {$interpreter eval "package require -exact $package $::package(version,$package)"}]
            } else {
                set error [catch {$interpreter eval "package require $package"}]
            }
            if {!$error && [$interpreter eval info exists ::${package}::data(updates)]} {
                lappend packages $package
                set switches {}
                catch {set switches [$interpreter eval "set ::${package}::data(switches)"]}
                set switches [list $switches]
                if {[string length $command] > 0} {
                    regsub -all %M $command $package string
                    regsub -all %S $string $switches string
                    uplevel #0 $string
                }
            }
            interp delete $interpreter
        }
        cd $directory
        return [lsort $packages]
    }

    proc printAvailable {} {
        puts {searching for module packages, please wait...}
        foreach package [available] {
            puts -nonewline "$package: possibly in"
            set count 0
            foreach directory $::auto_path {
                if {[file readable [file join $directory $package pkgIndex.tcl]]} {
                    if {$count > 0} {
                        puts -nonewline ,
                    }
                    puts -nonewline " [file join $directory $package]"
                    incr count
                }
            }
            puts {}
        }
    }

    proc parse {arguments} {
        if {[llength $arguments] == 0} return
        set name [lindex $arguments 0]
        set arguments [lrange $arguments 1 end]
        foreach {name index} [decoded $name] {}
        if {![info exists ::package(directory,$name)]} {
            error "error: \"$name\" is not a valid moodss module name"
        }
        if {![validName $name]} {
            error "\"$name\" module name contains invalid characters"
        }
        switch $name formulas - thresholds {
            error "\"$name\" is a reserved module name"
        }
        if {$global::withGUI} {
            lifoLabel::push $global::messenger [format [mc {loading %s...}] $name]
        } elseif {$global::debug} {
            writeLog "loading $name..."
        }
        set instance [new instance $name $index]
        if {[catch {instance::load $instance} message]} {
            if {$global::debug} {set information $::errorInfo}
            if {$global::withGUI} {
                lifoLabel::pop $global::messenger
            }
            delete $instance
            if {$global::debug} {
                error $information
            } else {
                error "module \"$name\" load error:\n$message"
            }
        }
        if {$global::withGUI} {
            lifoLabel::pop $global::messenger
        }
        set help [expr {[lsearch -exact $arguments --help] >= 0}]
        if {[info exists instance::($instance,switches)]} {
            if {[llength $instance::($instance,switches)] == 0} {
                error "module \"$name\" switches are empty"
            }
            if {$help} {
                displayHelpMessage $name $instance::($instance,switches)
                exit
            }
            if {[catch {set next [parseCommandLineArguments $instance::($instance,switches) $arguments options]} message]} {
                delete $instance
                error "module \"$name\" options error: $message"
            }
            if {!$instance::($instance,initialize)} {
                error "module \"$name\" has no initialize procedure"
            }
            set instance::($instance,options) [array get options]
            set instance::($instance,arguments) [lrange $arguments 0 [expr {[llength $arguments] - [llength $next] - 1}]]
            set arguments $next
        } else {
            if {$help} {
                displayHelpMessage $name
                exit
            }
            set instance::($instance,arguments) {}
        }
        lappend (instances) $instance
        parse $arguments
        if {$global::withGUI} {
            update idletasks
        }
    }

    proc helpHTMLData {name} {
        set noHelpText [mc {no help available}]
        foreach instance $(instances) {
            set namespace $instance::($instance,namespace)
            foreach {module index} [decoded $namespace] {}
            if {[string compare $module $name]} continue
            if {![info exists text]} {
                set text $noHelpText
                catch {set text [set ${namespace}::data(helpText)]}
                set version $instance::($instance,version)
                break
            }
        }
        if {![info exists text]} {
            foreach {version text} [versionAndHelpText $name] {}
            if {[string length $text] == 0} {
                set text $noHelpText
            }
        }
        set header [format [mc {<b>%s</b> module version <i>%s</i>}] $name $version]
        append header <br><br>
        if {[regsub -nocase <body> $text <body>$header text] > 0} {
            regsub -nocase {<title>.*</title>} $text {} text
            return $text
        } else {
            regsub -all \n $text <br> text
            return ${header}$text
        }
    }

    proc versionAndHelpText {name} {
        set directory [pwd]
        cd $::package(directory,$name)
        set interpreter [interp create]
        $interpreter eval "set auto_path [list $::auto_path]"
        catch {$interpreter eval {package require {}}}
        $interpreter eval {rename source _source}; $interpreter alias source ::modules::source $interpreter $name
        $interpreter eval "package require $name"
        set version [$interpreter eval "package provide $name"]
        set text {}
        catch {set text [$interpreter eval "namespace eval $name {set data(helpText)}"]}
        interp delete $interpreter
        cd $directory
        return [list $version $text]
    }

    proc initialize {{daemon 0} {errorCommand {}}} {
        foreach instance $(instances) {
            set namespace $instance::($instance,namespace)
            set error 0
            if {$instance::($instance,initialize)} {
                regsub {<0>$} $namespace {} string
                if {$global::withGUI} {
                    lifoLabel::push $global::messenger [format [mc {initializing %s...}] $string]
                } elseif {$global::debug} {
                    writeLog "initializing $string module..."
                }
                catch {unset options}
                catch {array set options $instance::($instance,options)}
                if {$daemon && [info exists instance::($instance,switches)]} {
                    array set switch $instance::($instance,switches)
                    if {![info exists option(--daemon)] && [info exists switch(--daemon)]} {
                        set options(--daemon) {}
                    }
                    unset switch
                }
                if {[info exists options]} {
                    if {[catch {::${namespace}::initialize [array get options]} message]} {
                        if {$global::debug} {set information $::errorInfo}
                        set error 1
                    }
                } else {
                    if {[catch ::${namespace}::initialize message]} {
                        if {$global::debug} {set information $::errorInfo}
                        set error 1
                    }
                }
                if {$global::withGUI} {
                    lifoLabel::pop $global::messenger
                }
            }
            if {!$error} {
                instance::synchronize $instance
                set 64BitsName ::${namespace}::data(64Bits)
                if {([package vcompare $::tcl_version 8.4] < 0) && [info exists $64BitsName] && [set $64BitsName]} {
                    set message {Tcl/Tk core version 8.4 or above is required for 64 bits support}
                    set information $message
                    set error 1
                }
            }
            if {$error} {
                unload $instance
                regsub {<0>$} $namespace {} namespace
                set message "module \"$namespace\" initialize error:\n$message"
                if {$global::debug} {
                    error $information
                } elseif {[string length $errorCommand] > 0} {
                    uplevel #0 $errorCommand $namespace [list $message]
                } else {
                    error $message
                }
            }
            set instance::($instance,initialize) 0
        }
        if {$global::withGUI} {
            update idletasks
        }
    }

    proc setPollTimes {{override {}}} {
        if {[llength $(instances)] == 0} {
            set global::pollTimes {}
            set global::pollTime 0
            return
        }
        set default 0
        set minimum 0
        foreach instance $(instances) {
            set times $instance::($instance,times)
            if {[llength $times] == 0} {
                error "module $instance::($instance,namespace) poll times list is empty"
            }
            set time [lindex $times 0]
            if {$time < 0} {
                set intervals($time) {}
                continue
            }
            if {$time > $default} {
                set default $time
            }
            set times [lsort -integer $times]
            set time [lindex $times 0]
            if {$time > $minimum} {
                set minimum $time
                set minimumModule $instance::($instance,namespace)
            }
            foreach time $times {
                set data($time) {}
            }
        }
        set global::pollTimes [lsort -integer [array names data]]
        set global::pollTimes [lrange $global::pollTimes [lsearch -exact $global::pollTimes $minimum] end]
        if {$global::pollTime < $default} {
            set global::pollTime $default
        }
        if {[string length $override] > 0} {
            if {$override < $minimum} {
                puts stderr "$::argv0: minimum poll time is $minimum seconds for module $minimumModule"
                exit 1
            }
            set global::pollTime $override
        }
        if {($global::pollTime == 0) && [info exists intervals]} {
            set sum 0
            set number 0
            foreach interval [array names intervals] {
                incr sum $interval
                incr number
            }
            set global::pollTime [expr {round(double($sum) / -$number)}]
        }
    }

    proc identifier {array} {
        set namespace [namespaceFromArray $array]
        foreach instance $(instances) {
            if {[string equal $namespace $instance::($instance,namespace)]} {
                return $instance::($instance,identifier)
            }
        }
        return {}
    }

    proc asynchronous {array} {
        set namespace [namespaceFromArray $array]
        foreach instance $(instances) {
            if {[string equal $namespace $instance::($instance,namespace)]} {
                return [expr {[lindex $instance::($instance,times) 0] < 0}]
            }
        }
        error "could not find module instance for array $array"
    }

    proc instanceData {array} {
        variable instanceData

        set namespace [namespaceFromArray $array]
        foreach identifier $(instances) {
            if {[string equal $namespace $instance::($identifier,namespace)]} {
                set instance $identifier
                break
            }
        }
        if {![info exists instance]} {
            return {}
        }
        if {[info exists instanceData($instance)]} {
            return $instanceData($instance)
        }
        foreach {data(module) dummy} [modules::decoded $namespace] {}
        set data(identifier) $instance::($instance,identifier)
        set data(version) $instance::($instance,version)
        catch {set data(options) $instance::($instance,options)}
        upvar 1 ::${namespace}::data module
        set columns {}
        foreach name [array names module *,label] {
            if {[scan $name %u column] > 0} {lappend columns $column}
        }
        set list {}
        foreach column [lsort -integer $columns] {
            lappend list $module($column,label) $module($column,type) $module($column,message)
            if {[catch {lappend list $module($column,anchor)}]} {lappend list {}}
        }
        set data(data) $list
        set data(indexColumns) 0; catch {set data(indexColumns) $module(indexColumns)}
        return [set instanceData($instance) [array get data]]
    }

    proc decoded {name} {
        set index {}
        scan $name {%[^<]<%u>} name index
        return [list $name $index]
    }

    proc validName {string} {
        return [regexp {^[\w ,<>@%&*()=+:.-]+$} $string]
    }

    proc displayHelpMessage {name {switches {}}} {
        puts -nonewline "$name module usage:"
        if {[llength $switches] == 0} {
            puts -nonewline { <no arguments allowed>}
        } else {
            foreach {switch argument} $switches {
                puts -nonewline " \[$switch"
                if {$argument} {
                    puts -nonewline { argument}
                }
                puts -nonewline \]
            }
        }
        puts {}
    }

    proc loaded {} {
        if {[llength $(instances)] == 0} {
            return {}
        }
        foreach instance $(instances) {
            lappend list [list $instance $instance::($instance,namespace)]
        }
        set return {}
        foreach list [lsort -dictionary -index 1 $list] {
            foreach {instance namespace} $list {}
            lappend return $namespace $instance::($instance,identifier)
            set switches {}
            catch {set switches $instance::($instance,switches)}
            if {[llength $switches] == 0} {
                lappend return {}
            } else {
                set arguments $instance::($instance,arguments)
                set list {}
                foreach {switch required} $switches {
                    lappend list $switch $required
                    set index [lsearch -exact $arguments $switch]
                    if {$required} {
                        if {$index < 0} {
                            lappend list {}
                        } else {
                            lappend list [lindex $arguments [incr index]]
                        }
                    } else {
                        lappend list [expr {$index >= 0}]
                    }
                }
                lappend return $list
            }
        }
        return $return
    }

    proc instancesWithout {{modules {}}} {
        foreach module $modules {set skip($module) {}}
        set instances {}
        foreach instance $(instances) {
            if {[info exists skip($instance::($instance,module))]} continue
            lappend instances $instance
        }
        return $instances
    }

    proc namesWithout {modules} {
        set list {}
        foreach instance [instancesWithout $modules] {
            set module $instance::($instance,module)
            if {[lsearch -exact $list $module] < 0} {
                lappend list $module
            }
        }
        return $list
    }

    proc unload {instance} {
        ldelete (instances) $instance
        delete $instance
        if {$global::withGUI} {
            pages::monitorActiveCells
            thresholdLabel::monitorActiveCells
        }
    }

    proc loadedNamespace {string} {
        foreach instance $(instances) {
            if {[string equal $string $instance::($instance,namespace)]} {
                return 1
            }
        }
        return 0
    }

    proc namespaceFromArray {name} {
        return [string trimleft [namespace qualifiers [namespace which -variable $name]] :]
    }

    proc loadResidentTraceModule {} {
        if {[info exists (trace)]} {error {trying to load several resident trace modules}}
        set (trace) [new instance trace {}]
        instance::load $(trace)
        set namespace $instance::($(trace),namespace)
        ::${namespace}::initialize [list --rows $global::traceNumberOfRows]
    }

    proc trace {module identifier message} {
        regsub {<0>$} $identifier {} identifier
        set namespace $instance::($(trace),namespace)
        ::${namespace}::update $module $identifier $message
        foreach instance $(instances) {
            if {[string equal $instance::($instance,module) trace]} {
                set namespace $instance::($instance,namespace)
                ::${namespace}::update $module $identifier $message
            }
        }
    }

    proc loadFormulasModule {index object category} {
        set instance [new instance formulas $index]
        instance::load $instance
        set namespace $instance::($instance,namespace)
        set options {}
        if {[string length $object] > 0} {lappend options --object $object}
        if {[string length $category] > 0} {lappend options --category $category}
        set instance::($instance,options) $options
        ::${namespace}::initialize $options
        set instance::($instance,initialize) 0
        set instance::($instance,arguments) {}
        instance::synchronize $instance
        lappend (instances) $instance
        return $instance
    }

    proc flashMessage {module namespace message {seconds 1}} {
        regsub {<0>$} [set ::${namespace}::data(identifier)] {} identifier
        if {$global::withGUI} {
            ::lifoLabel::flash $::global::messenger "$identifier: $message" $seconds
            switched::configure [moduleFromNamespace $namespace] -state error
        } else {
            writeLog "$identifier: $message"
        }
        trace $module $identifier $message
    }

    proc pushMessage {module namespace message} {
        regsub {<0>$} [set ::${namespace}::data(identifier)] {} identifier
        if {$global::withGUI} {
            ::lifoLabel::push $::global::messenger "$identifier: $message"
        } else {
            writeLog "$identifier: $message"
        }
        trace $module $identifier $message
    }

    proc popMessage {} {
        if {$global::withGUI} {
            ::lifoLabel::pop $::global::messenger
        }
    }

    proc moduleFromNamespace {string} {
        foreach instance $(instances) {
            if {[string equal $instance::($instance,namespace) $string]} {
                return $instance::($instance,loaded)
            }
        }
        return 0
    }

}
    proc object {this procedure args} {
        if {[string match ::* $procedure] || ([string length [namespace qualifiers $procedure]] > 0)} {
            eval $procedure $this $args
        } else {
            eval [classof $this]::$procedure $this $args
        }
    }
}

if {[catch {
    foreach file $fileNames {
        set interpreter($file) [interp create]
        initialize $interpreter($file)
        interp eval $interpreter($file) "set initializer \[processFile $file\]"
    }
    if {$global::debug} {
        writeLog {initializing modules...}
    }
    foreach file $fileNames {
        $interpreter($file) eval modules::initialize 1 moduleInitializationError
        $interpreter($file) eval "
            modules::setPollTimes \[record::pollTime \$initializer\]
            createSavedViewers \$initializer $file
            foreach instance \$modules::(instances) {
                processModule \$instance
            }
            refresh
        "
    }
    if {![info exists arguments(-f)] && [info exists arguments(--pid-file)]} {
        set processFile $arguments(--pid-file)
        set file [open $processFile w]
        puts -nonewline $file [id process]
        close $file
    }
    if {$pollFilesTime > 0} {
        modificationsPoll $pollFilesTime $fileNames
    }
    vwait forever
} message]} {
    writeLog $::errorInfo error
}

