#!/usr/bin/wish




if {![catch {package present Tk}]} {
    catch {rename ::send {}}
    option add *BorderWidth 1
    option add *Canvas.BorderWidth 0
    option add *Frame.BorderWidth 0
    option add *Toplevel.BorderWidth 0
    option add *ScrollbarWidth 12
    option add *Listbox.Background white
    if {[string equal $tcl_platform(platform) unix]} {
        option add *Entry.Background white
        option add *Entry.disabledBackground white
        if {[package vcompare $::tcl_version 8.4] >= 0} {
            option add *Entry.readonlyBackground white
            option add *Spinbox.Background white
            option add *Spinbox.disabledBackground white
            option add *Spinbox.readonlyBackground white
        }
        option add *Entry.selectForeground black
        option add *Listbox.selectForeground black
    }
}




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            {
                -f 1 --file 1 --debug 0 -h 0 -he 0 -hel 0 -help 0 --help 0 -p 1 --poll-time 1 -r 0 --read-only 0 -S 0 --static 0
                --show-modules 0 --version 0
            } $argv arguments        ]    } message]} {
    puts stderr $message
    if {[catch {package require internationalization}]} {
        proc ::mc {string} {return $string}
    }
    printUsage 1
}
foreach {short long} {-f --file -h -he -h -hel -h -help -h --help -p --poll-time -r --read-only -S --static} {
    catch {set arguments($short) $arguments($long)}
}

if {[catch {package present Tk}]} {exit 1}
setupGlobalMouseWheelBindings

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






set dialogBoxErrorIcon [image create photo -data {
    R0lGODlhIAAgAOfJAIkAAIoAAIsAAIwAAI4AAI8AAJAAAJEAAJIAAJQAAJUAAJYAAJcAAJMCApgAAJkAAJoAAJsAAJwAAJMEBJ0AAJ4AAJ8AAKAAAKEAAKMA
    AJcGBqUAAKYAAKcAAKgAAKkAAKoAAKsAAKwAAJ8GBq0AAK4AAK8AALEAAKEHB7IAAKkEBLMAAJwKCrQAALUAALYAALcAALgAALkAALUCAroAAKELC7sAALwA
    AL0AAL4AAL8AAMAAAMEAAKoKCsIAAMMAAMQAAMUAAMYAAMgAAMkAAMoAAMsAAMwAALwHB80AAM4AANAAALcLC9UAANgAANoAANwAAN4AAN8AALcSEs0JCeIA
    AK0XF64XF68XF9AJCeYAALEXF+4AAN0JCfIAAMoSEvQAAPcAANcODuoGBvoAAPkBAf4AAP0BAf8CAvkICP8HB+4VFfkREf8QEMcpKfUWFv8SEvEZGfQYGM0p
    Kc4pKfUZGesfH9YpKfkaGv8dHfUiIvkiIu8oKP8iIvgmJvomJuouLvcpKf8oKPcvL/gwMPowMPE2NvQ2Nv8zM/80NPM6Ov81Ne0/P/M+Pu5DQ+pFRexFRf8/
    P/9FRf9KSv9RUftTU/dWVvpVVftVVf9WVvdcXP9nZ/hra/9sbPVxcfZ0dPl0dP5ycvxzc/9ycvl7e/95ef+Kiv6QkP+amvqfn/yfn/2fn/6fn/+fn/6goP+g
    oPykpP+jo/+np/ysrP+rq/+trfyvr/+xsf+4uP+8vP++vv6/v//Bwf/Fxf/Hx//Kyv/MzP3Nzf7Nzf/Ozv/U1P/b2//c3P/h4f/r6///////////////////
    ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
    /////////////////////////////////////////////////////////////////////////////////yH5BAEKAP8ALAAAAAAgACAAAAj+AP8JHEiwoMGD
    CBEKCfLDxw4dOGwknCiQyJCFQpQkOWJEB40YMFxQNFhkyBEodjSRWkmKE6AmOFqkGCnQSBEjUizZQsazJ89goMS4MEGCos0lfGAZW8q06VJhjmiIAJGwSBEn
    jXYB28q1q1dPQT50QFhkiaJcaH+hXcs2l1q0n1xwOEjEyBpXtGgBS3Ysr1+/x5IB88voQ4aCFqWIQoWKV7LHxRhLRlXscTJejE9lwXCBoEk9pky9svyYWOjQ
    xEgnexX6EogKBIVEqVSq9l7Sw2oPUw0sFKZBcoZIGLhwzKbjx3up9uVL9axAXqJ7qRLhgUAgQt5k2s5dl2rVqaT+i7fgQOAPJXskqV8vCdf3x+HFSy+xQCCP
    I3gQ6d+v/9b3+PJFR0ICAu1gBBt9JKhggrX8F6B0IiAgUA5FpNHGhRi2Ict7yaQCxocgfhjCAQLdoEMZaKSo4mgcJqNKGDDGGAYDBghkgwxcnKGjjq6otsoq
    PpIhpJBaFEDAQDE8YcaSZrCiWitLtqIaK0yaIcSRA72QgxpcLqJaLFxyGYtqi4QpwQAEtbBCF3C02YllsrQpJxwbPtaJnFQMIEBBJ8xQRx6AjpIMLYAWWigt
    yYxSaBwNBHBQCUj8IciklExq6aWCVDqpHyg4epAIIXxRSCKklmrqqYkQMkUAACT0gQdOTBwSyay01lqrITWwShEHG6hwxyTABisssHNMoCtNnPVAByTccfeI
    GywM4ClNAllAQQQQjLAFFldYoYGR0lJ70AMMKJAAAgcYKe66NAUEADs=
}]

proc printUsage {exitCode} {
    puts stderr [format [mc {Usage: %s [OPTION]... [MODULE] [OPTION]... [MODULE]...}] $::argv0]
    puts stderr [mc {  --debug          module errors verbose reporting}]
    puts stderr [mc {  -f, --file       dashboard file name}]
    puts stderr [mc {  -h, --help       display this help and exit}]
    puts stderr [mc {  -p, --poll-time  poll time in seconds}]
    puts stderr [mc {  -r, --read-only  disable viewer creation, editing, ...}]
    puts stderr [mc {  -S, --static     disable internal window manager sizing and moving}]
    puts stderr [mc {  --show-modules   try to find available moodss modules}]
    puts stderr [mc {  --version        output version information and exit}]
    exit $exitCode
}

proc printVersion {} {
    puts [format [mc {moodss (Modular Object Oriented Dynamic SpreadSheet) version %s}] $global::applicationVersion]
}

proc loadFromFile {name} {
    clearModulesAndViewers
    set global::saveFile $name
    set global::fileDirectory [file dirname $name]
    set initializer [new record -file $name]
    record::read $initializer
    configuration::load [record::configurationData $initializer]
    modules::parse [record::modulesWithArguments $initializer]
    set modules::(initialized) [record::modules $initializer]
    return $initializer
}

proc clearModulesAndViewers {} {
    foreach viewer $viewer::(list) {
        set class [classof $viewer]
        switch $class {
            ::store - ::store::dialog - ::thresholdLabel - ::thresholds {
                ${class}::reset $viewer
            }
            default {
                delete $viewer
            }
        }
    }
    if {[info exists databaseInstances::singleton]} {
        delete $databaseInstances::singleton
    }
    foreach instance [modules::instancesWithout formulas] {
        dynamicallyUnloadModule $modules::instance::($instance,namespace)
    }
    if {[llength [modules::instancesWithout]] > 0} {
        error {internal moodss error: please report to author with error trace}
    }
}

proc clear {} {
    static busy 0

    if {$busy} return
    if {[needsSaving]} {
        switch [inquireSaving] {
            yes {
                save
                if {[needsSaving]} {return 0}
            }
            cancel {return 0}
        }
    }
    set busy 1
    if {[info exists ::initializer]} {
        delete $::initializer
        unset ::initializer
    }
    clearModulesAndViewers
    databaseConnection 0
    set global::saveFile {}
    updateFileSaveHelp {}
    updateTitle
    updateMenuWidget
    updateToolBar
    updateDragAndDropZone
    configuration::load [preferences::read]
    record::snapshot
    set busy 0
    return 1
}

proc reload {} {
    if {[needsSaving]} {
        switch [inquireSaving] {
            yes {
                save
                if {[needsSaving]} return
            }
            cancel return
        }
    }
    set file [tk_getOpenFile        -title [mc {moodss: Open}] -initialdir $global::fileDirectory -defaultextension .moo        -filetypes [list [list [mc {moodss dashboard}] .moo]]    ]
    if {[string length $file] == 0} return
    databaseConnection 0
    set global::fileDirectory [file dirname $file]
    if {[info exists ::initializer]} {
        delete $::initializer
        unset ::initializer
    }
    updateCanvasImage {}; set global::canvasImageFile {}
    set ::initializer [loadFromFile $file]
    $global::canvas configure -background $global::canvasBackground
    wm geometry . {}
    foreach {width height} [record::sizes $::initializer] {}
    composite::configure $global::scroll -width $width -height $height
    updateCanvasImage $global::canvasImageFile 1
    modules::initialize 0 initializationErrorMessageBox
    modules::setPollTimes [record::pollTime $::initializer]
    foreach instance [modules::instancesWithout formulas] {
        displayModule $instance $::draggable
    }
    summaryTable::reset; currentValueTable::reset; formulas::table::reset
    createSavedImages $::initializer
    createSavedViewers $::initializer
    if {[pages::current] == 0} {
        manageScrolledCanvas 1
    } else {
        pages::manageScrolledCanvas 1
    }
    updateTitle
    updateMenuWidget
    updateToolBar
    updateDragAndDropZone
    updateFileSaveHelp $file
    updateCanvasImagesPosition
    refresh
    update
    record::snapshot
}

proc createNewCellsViewer {class cells draggable static {pollTime {}}} {
    switch $class {
        ::canvas::iconic {
            if {[string length [set name [canvas::iconic::chooseFile]]] == 0} return
            foreach {left top right bottom} [$global::canvas cget -scrollregion] {}
            set viewer [new $class $global::canvas -draggable $draggable -static $static -file $name -x $left -y $top]
            canvas::viewer::flash $viewer
        }
        ::currentValueTable {
            set viewer [new currentValueTable $global::canvas $global::pollTime -draggable $draggable -interval $pollTime]
        }
        ::dataGraph - ::dataStackedGraph - ::dataSideBarChart - ::dataStackedBarChart - ::dataOverlapBarChart {
            if {[string length $pollTime] == 0} {
                set viewer [new $class $global::canvas -labelsposition $global::graphLabelsPosition -draggable $draggable]
            } else {
                set viewer [new $class $global::canvas                    -labelsposition $global::graphLabelsPosition -draggable $draggable -interval $pollTime                ]
            }
        }
        default {
            if {[string length $pollTime] == 0} {
                set viewer [new $class $global::canvas -draggable $draggable]
            } else {
                set viewer [new $class $global::canvas -draggable $draggable -interval $pollTime]
            }
        }
    }
    if {[viewer::view $viewer $cells]} {
        if {[viewer::manageable $viewer]} {
            manageViewer $viewer 1 -static $static -dragobject $viewer
        }
        return $viewer
    } else {
        delete $viewer
        return 0
    }
}

proc createNewFormulasViewer {object category draggable static} {
    set viewer [new formulas::table $global::canvas -draggable $draggable -object $object -category $category]
    manageViewer $viewer 1 -static $static -dragobject $viewer -title [formulas::table::title $viewer]
    return $viewer
}

proc manageViewer {viewer destroyable args} {
    set path $widget::($viewer,path)
    canvasWindowManager::manage $global::windowManager $path $viewer
    eval canvasWindowManager::configure $global::windowManager $path $args
    if {$destroyable} {
        composite::configure $viewer -deletecommand "canvasWindowManager::unmanage $global::windowManager $path"
    }
}

proc save {{ask 0}} {
    if {$ask || ([string length $global::saveFile] == 0)} {
        set file [tk_getSaveFile            -title [mc {moodss: Save}] -initialdir $global::fileDirectory -defaultextension .moo            -filetypes [list [list [mc {moodss dashboard}] .moo]] -initialfile $global::saveFile        ]
        if {[string length $file] == 0} return
        set global::saveFile $file
        set global::fileDirectory [file dirname $file]
        updateFileSaveHelp $file
    }
    lifoLabel::push $global::messenger [format [mc {saving in %s...}] $global::saveFile]
    update idletasks
    set record [new record -file $global::saveFile]
    set error [catch {record::write $record} message]
    lifoLabel::pop $global::messenger
    if {$error} {
        tk_messageBox -title [mc {moodss: Save}] -type ok -icon error -message $message
    }
    delete $record
    if {!$error} record::snapshot
}

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
    }
    foreach viewer $viewer::(list) {
        if {[string equal [classof $viewer] ::formulas::table]} {
            formulas::table::update $viewer
        }
    }
    if {$global::pollTime > 0} {
        set updateEvent [after [expr {1000 * $global::pollTime}] refresh]
    }
}

proc cellThresholdCondition {array row column color level summary} {
    dataTable::cellThresholdCondition $array $row $column
    viewer::cellThresholdCondition $array $row $column $color $level $summary
}

proc inquireSaving {} {
    if {[string length $::global::saveFile] > 0} {
        set message [format [mc {There are unsaved configuration changes. Do you want them saved to file: %s?}] $::global::saveFile]
    } else {
        set message [mc {There are unsaved configuration changes. Do you want them saved to file?}]
    }
    array set answer {0 yes 1 no 2 cancel}
    return $answer([tk_dialog .saveorexit [mc {moodss: Save}] $message question 0 [mc Yes] [mc No] [mc Cancel]])
}

proc needsSaving {} {
    return [expr {[record::changed] && ([llength [modules::instancesWithout formulas]] > 0)}]
}

proc manageToolBar {{save 1}} {
    set bar [updateToolBar]
    if {$global::showToolBar} {
        grid $bar -row 0 -column 0 -sticky we
    } else {
        grid forget $bar
    }
    if {$save} {
        preferences::update
    }
}

proc createSavedImages {record} {
    foreach {file data} [record::imagesData $record] {
        images::load $file {} $data
    }
}

proc createSavedViewers {record} {
    if {[llength [set range [record::databaseRange $record]]] > 0} {
        monitorDatabaseInstances $range
    }
    set data [record::viewersData $record]
    foreach {class cells x y width height level xIcon yIcon switchedOptions} $data {
        if {![string equal $class ::formulas::table]} continue
        set viewer [eval new ::formulas::table $global::canvas $switchedOptions -draggable $::draggable]
        manageViewer $viewer 1 -static $global::static -setx $x -sety $y -setwidth $width -setheight $height -level $level            -dragobject $viewer -iconx $xIcon -icony $yIcon -title [formulas::table::title $viewer]
        set viewerCells($viewer) $cells
    }
    foreach {class cells x y width height level xIcon yIcon switchedOptions} $data {
        switch $class {
            ::formulas::table continue
            ::store - ::thresholds {
                set viewer [set ${class}::singleton]
                eval switched::configure $viewer $switchedOptions
            }
            ::thresholdLabel {
                set viewer [set ${class}::singleton]
                eval composite::configure $viewer $switchedOptions
            }
            ::currentValueTable {
                set viewer [eval new currentValueTable                    $global::canvas $global::pollTime $switchedOptions -interval $global::pollTime -draggable $::draggable                ]
                manageViewer $viewer 1 -static $global::static -setx $x -sety $y -setwidth $width -setheight $height                    -level $level -dragobject $viewer
            }
            ::canvas::iconic {
                set viewer [eval new $class $global::canvas $switchedOptions -draggable $::draggable -static $global::static]
            }
            ::page {
                set viewer [eval new $class $global::canvas $switchedOptions -draggable $::draggable]
                set background {}
                foreach {switch value} $switchedOptions {
                    if {[string equal $switch -background]} {
                        set background $value
                        break
                    }
                }
                if {[string length $background] == 0} {
                    composite::configure $viewer -background $global::canvasBackground
                }
            }
            default {
                set viewer [eval new $class $global::canvas $switchedOptions -draggable $::draggable]
                foreach list [composite::configure $viewer] {
                    if {[string equal [lindex $list 0] -interval]} {
                        composite::configure $viewer -interval $global::pollTime
                        break
                    }
                }
                if {[viewer::manageable $viewer]} {
                    manageViewer $viewer 1 -static $global::static -setx $x -sety $y -setwidth $width -setheight $height                        -level $level -dragobject $viewer
                }
            }
        }
        set viewerCells($viewer) $cells
    }
    foreach {viewer cells} [array get viewerCells] {
        viewer::view $viewer $cells
    }
}

proc dynamicallyLoadModules {arguments} {
    set instances [modules::instancesWithout formulas]
    modules::parse $arguments
    modules::initialize
    modules::setPollTimes
    set first 1
    foreach instance [modules::instancesWithout formulas] {
        if {[lsearch -exact $instances $instance] >= 0} continue
        if {$first} {
            displayModule $instance $::draggable 1
            set first 0
        } else {
            displayModule $instance $::draggable
        }
    }
    updateTitle
    updateMenuWidget
    updateToolBar
    refresh
}

proc dynamicallyUnloadModule {namespace} {
    foreach instance [modules::instancesWithout formulas] {
        if {[string equal $modules::instance::($instance,namespace) $namespace]} break
    }
    if {[lindex $modules::instance::($instance,times) 0] >= 0} {
        ldelete modules::(synchronous) $instance
    }
    foreach table $dataTable::(list) {
        if {[string equal [modules::namespaceFromArray [composite::cget $table -data]] $namespace]} {
            canvasWindowManager::unmanage $global::windowManager $widget::($table,path)
            delete $table
        }
    }
    modules::instance::empty $instance
    modules::unload $instance
    modules::setPollTimes
    updateTitle
    updateMenuWidget
    updateToolBar
}

proc residentTraceModule {display} {
    if {![winfo exists .trace]} {
        toplevel .trace
        wm withdraw .trace
        wm group .trace .
        wm title .trace [mc {moodss: Trace}]
        set namespace $modules::instance::($modules::(trace),namespace)
        set table [new dataTable .trace -data ${namespace}::data]
        dataTable::update $table
        wm protocol .trace WM_DELETE_WINDOW "wm withdraw .trace; set global::showTrace 0"
        pack $widget::($table,path) -fill both -expand 1
    }
    if {$display} {
        wm deiconify .trace
    } else {
        wm withdraw .trace
    }
    after idle {focus .}
}

proc displayModule {instance draggable {resetOrigin 0}} {
    static x
    static y

    if {![info exists x] || $resetOrigin} {
        foreach {x y dummy dummy} [$global::canvas cget -scrollregion] {}
    }
    if {[lindex $modules::instance::($instance,times) 0] >= 0} {
        lappend modules::(synchronous) $instance
    }
    if {[info exists modules::instance::($instance,views)]} {
        set viewMembers $modules::instance::($instance,views)
    } else {
        set viewMembers {{}}
    }
    set index 0
    set namespace $modules::instance::($instance,namespace)
    foreach members $viewMembers {
        set initialize [expr {[info exists ::initializer] && ([lsearch -exact $modules::(initialized) $namespace] >= 0)}]
        if {$initialize} {
            set arguments [record::tableOptions $::initializer $namespace $index]
        } else {
            set arguments {}
        }
        if {![catch {set ${namespace}::data(resizableColumns)} resizable]} {
            lappend arguments -resizablecolumns $resizable
        }
        if {[llength $members] > 0} {
            array set ::view$instance $members
            set table                [eval new dataTable $global::canvas -data ${namespace}::data -view ::view$instance -draggable $draggable $arguments]
            unset ::view$instance
        } else {
            set table [eval new dataTable $global::canvas -data ${namespace}::data -draggable $draggable $arguments]
        }
        if {[info exists modules::instance::($instance,identifier)]} {
            set title $modules::instance::($instance,identifier)
        } else {
            set title $namespace
        }
        regsub {<0>$} $title {} title
        if {$initialize} {
            set list [record::tableWindowManagerData $::initializer $namespace $index]
            if {[llength $list] > 0} {
                foreach {x y width height level xIcon yIcon} $list {}
                manageViewer $table 0 -static $global::static -setx $x -sety $y -setwidth $width -setheight $height                    -level $level -title $title -iconx $xIcon -icony $yIcon
            } else {
                manageViewer $table 0 -static $global::static -setx $x -sety $y -title $title
            }
        } else {
            manageViewer $table 0 -static $global::static -setx $x -sety $y -title $title
        }
        set x [expr {$x + $global::xWindowManagerInitialOffset}]
        set y [expr {$y + $global::yWindowManagerInitialOffset}]
        incr index
    }
}

proc initializationErrorMessageBox {namespace message} {
    set top [new toplevel .]
    set path $widget::($top,path)
    wm transient $path .
    regsub {<0>$} $namespace {} namespace
    wm title $path [format [mc {moodss: Error initializing module "%s"}] $namespace]
    wm group $path .
    wm protocol $path WM_DELETE_WINDOW "delete $top"
    set text [message $path.message -text $message -font $font::(mediumNormal) -justify left -width 640]
    grid rowconfigure $path 0 -weight 1
    grid columnconfigure $path 1 -weight 1
    grid [label $path.icon -image $::dialogBoxErrorIcon] -row 0 -column 0 -sticky nw -padx 2 -pady 2
    grid $text -row 0 -column 1 -sticky nw
    grid [frame $path.separator -relief sunken -borderwidth 1 -height 2] -row 1 -column 0  -columnspan 100 -stick we -pady 2
    grid [button $path.close -text [mc Close] -command "destroy $path"] -row 2 -column 0 -columnspan 100 -padx 2 -pady 2
}

proc databaseConnection {connect} {
    if {$connect} {
        if {$global::database != 0} return
        lifoLabel::push $global::messenger [mc {connecting to database...}]
    } else {
        if {$global::database == 0} return
        lifoLabel::push $global::messenger [mc {disconnecting from database...}]
    }
    busy 1 .
    if {$connect} {
        set database [eval new database $global::databaseOptions]
        if {[string length $database::($database,error)] > 0} {
            tk_messageBox -title [mc {moodss: Database error}] -type ok -icon error -message $database::($database,error)
            delete $database
        } else {
            if {$database::($database,created)} {
                modules::trace {} moodss(database) [mc {created tables in moodss database}]
            }
            set global::database $database
        }
    } else {
        delete $global::database
        set global::database 0
    }
    busy 0 .
    lifoLabel::pop $global::messenger
}

proc loadFromDatabase {draggable static} {
    if {![info exists databaseInstances::singleton]} {
        if {![clear]} return
        databaseConnection 1
        if {$global::database == 0} return
    }
    database::displayAndSelectInstances
    createInstancesViewer $draggable $static
    updateMenuWidget
    updateToolBar
    updateDragAndDropZone
    switched::configure $database::(dialog) -command "databaseInstances::monitor $databaseInstances::singleton"       -deletecommand {after idle {databaseInstances::deleteEmpty}}
}

proc createInstancesViewer {draggable static} {
    if {[info exists databaseInstances::singleton]} return
    set instances [new databaseInstances $global::canvas -draggable $draggable]
    set path $widget::($instances,path)
    canvasWindowManager::manage $global::windowManager $path $instances
    set title [mc {database module instances}]
    if {[info exists ::initializer] && ([llength [set list [record::databaseViewerWindowManagerData $::initializer]]] > 0)} {
        foreach {x y width height xIcon yIcon} $list {}
        canvasWindowManager::configure $global::windowManager $path            -setx $x -sety $y -setwidth $width -setheight $height -iconx $xIcon -icony $yIcon            -static $static -title $title -level $global::32BitIntegerMinimum
    } else {
        canvasWindowManager::configure $global::windowManager $path            -static $static -title $title -level $global::32BitIntegerMinimum
    }
    composite::configure $instances -selfdeletecommand {after idle clear}        -deletecommand "canvasWindowManager::unmanage $global::windowManager $path; database::removeInstances"
}

proc databaseRecording {start} {
    if {$start} {
        databaseConnection 1
        if {$global::database == 0} return
        refresh
    } else {
        databaseConnection 0
    }
    updateMenuWidget
    updateToolBar
}

proc monitorDatabaseInstances {presetRange} {
    databaseConnection 1
    if {$global::database == 0} {exit 1}
    createInstancesViewer [expr {!$global::readOnly}] $global::static
    foreach instance [modules::instancesWithout formulas] {
        foreach {name index} [modules::decoded $modules::instance::($instance,namespace)] {}
        if {![string equal $name instance]} {error "not an instance module in history mode: $name"}
        array set option $modules::instance::($instance,arguments)
        databaseInstances::monitor $databaseInstances::singleton [list $index $name $option(-identifier) $option(-arguments)] 0
    }
    eval databaseInstances::setCursors $databaseInstances::singleton $presetRange
}

proc updateCanvasImage {file {initialize 0}} {
    if {[package vcompare $::tcl_version 8.4] < 0} {
        if {[string length $file] > 0} {set file [file join [pwd] $file]}
    } else {
        set file [file normalize $file]
    }
    if {[string equal $file $global::canvasImageFile] && !$initialize} return
    if {([string length $global::canvasImageFile] > 0) && !$initialize} {
        images::release $global::canvasImageFile
    }
    if {[string length $file] == 0} {
        if {[info exists global::canvasImageItem]} {
            $global::canvas delete $global::canvasImageItem; unset global::canvasImageItem
        }
    } else {
        images::load $file $file {}
        set image [images::use $file]
        if {[info exists global::canvasImageItem]} {
            $global::canvas itemconfigure $global::canvasImageItem -image $image
        } else {
            set global::canvasImageItem [$global::canvas create image 0 0 -image $image]
        }
        $global::canvas lower $global::canvasImageItem
    }
}

proc updateCanvasImagePosition {item position {offset 0}} {
    set canvas $global::canvas
    foreach {left top right bottom} [bounds $canvas] {}
    switch $position {
        nw {
            $canvas itemconfigure $item -anchor nw
            $canvas coords $item $offset 0
        }
        default {
            $canvas itemconfigure $item -anchor center
            $canvas coords $item [expr {$offset + (($right - $left) / 2.0)}] [expr {$bottom / 2.0}]
        }
    }
}

proc updateCanvasImagesPosition {} {
    if {[info exists global::canvasImageItem]} {
        updateCanvasImagePosition $global::canvasImageItem $global::canvasImagePosition
    }
    pages::updateImagesPositions
}

proc traceDialog {title message {exit 0}} {
    set dialog [new dialogBox . -title $title -buttons x -default x -x [winfo pointerx .] -y [winfo pointery .]]
    if {$exit} {composite::configure $dialog -labels [list x [mc Exit]]}
    set frame [frame $widget::($dialog,path).frame]
    set scroll [new scroll text $frame -height 100]
    composite::configure $dialog -deletecommand "delete $scroll; set ::traceDialogDone {}"
    set text $composite::($scroll,scrolled,path)
    $text insert end $message
    $text configure -font $font::(mediumNormal) -wrap word -state disabled
    pack $widget::($scroll,path) -fill both -expand 1
    dialogBox::display $dialog $frame
    vwait ::traceDialogDone
}

proc manageScrolledCanvas {show} {
    set path $widget::($global::scroll,path)
    if {$show} {
        if {[llength [grid info $path]] == 0} {
            grid $path -row 2 -column 0 -sticky nsew
        }
    } else {
        grid forget $path
    }
}

proc createNewPage {} {
    updateCanvasImage {}; set global::canvasImageFile {}
    set pages [expr {[pages::current] != 0}]
    if {!$pages} {manageScrolledCanvas 0}
    set page [new page . -background $global::canvasBackground -draggable [expr {!$global::readOnly}]]
    if {!$pages} {pages::manageScrolledCanvas 1}
    pages::edit $page
}

proc formulasDialog {{formulasTable 0} {selectedFormula 0}} {
    if {[info exists global::formulasDialog]} {
        formulas::dialog::raise $global::formulasDialog
    } else {
        set command "formulasDialogValidated $formulasTable"
        set deletion {unset global::formulasDialog}
        if {$formulasTable == 0} {
            set list {}
            set global::formulasDialog [new formulas::dialog -command $command -deletecommand $deletion]
        } else {
            composite::configure $formulasTable -state disabled
            append deletion "; composite::configure $formulasTable -state normal"
            set list [formulas::table::formulas $formulasTable]
            set global::formulasDialog [new formulas::dialog                -command $command -deletecommand $deletion -formulas $list                -object [composite::cget $formulasTable -object] -category [composite::cget $formulasTable -category] -initial 0            ]
        }
        if {([llength $list] > 0) && ($selectedFormula > 0)} {
            formulas::dialog::select $global::formulasDialog $selectedFormula
        }
    }
}

proc formulasDialogValidated {table object category formulas} {
    if {$table == 0} {
        formulas::table::manage [createNewFormulasViewer $object $category 1 $global::static] $formulas
    } else {
        if {[formulas::table::manage $table $formulas 1]} {
            foreach viewer $viewer::(list) {
                viewer::updateLabels $viewer
            }
        }
    }
}

proc raiseExistingFormulasDialog {} {
    if {[info exists global::formulasDialog]} {
        formulas::dialog::raise $global::formulasDialog
    }
}

proc displayModuleState {namespace value} {
    switch $value {
        busy {set color #C0C0C0}
        error {set color #D0A0A0}
        idle {set color #A0D0A0}
        default error
    }
    foreach table $dataTable::(list) {
        if {[string equal [modules::namespaceFromArray [composite::cget $table -data]] $namespace]} {
            canvasWindowManager::color $global::windowManager $widget::($table,path) $color
        }
    }
}



proc setupEntryValidation {path scripts {mode key}} {
    if {[llength $scripts] == 0} return
    $path configure -validate $mode -invalidcommand bell
    foreach script $scripts {
        if {[info exists command]} {
            append command &&
        } else {
            set command "expr \{"
        }
        append command "\[$script\]"
    }
    append command \}
    $path configure -validatecommand $command
}

proc check31BitUnsignedInteger {string} {
    if {![regexp {^[0-9]*$} $string] || [regexp {^0[0-9]} $string]} {return 0}
    return [string is integer $string]
}

proc check32BitSignedInteger {string} {
    if {[string equal $string -]} {return 1}
    if {![regexp {^-?[0-9]*$} $string] || [regexp {^-?0[0-9]} $string] || [string equal $string -0]} {return 0}
    return [string is integer $string]
}

proc checkFloatingPoint {string} {
    if {[string equal $string -]} {return 1}
    if {![regexp {^-?[0-9]*\.?[0-9]*$} $string] || [regexp {^-?0[0-9]} $string]} {return 0}
    return [string is double $string]
}

proc checkMaximumLength {length string} {
    return [expr {[string length $string] <= $length}]
}
# 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]]
        }
    }

}

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

configuration::load [preferences::read]
if {[string equal $tcl_platform(platform) unix]} {
    option add *Font -*-$global::fontFamily-medium-r-*-*-$global::fontSize-*
    option add *Button*Font -*-$global::fontFamily-bold-r-*-*-$global::fontSize-*
}

package require Tktable 2.7
package require BLT 2.4
package require msgcat
namespace import msgcat::*

if {[string equal $tcl_platform(platform) unix]} {
    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 moodss is not properly installed or you need to run\nmoodss directly from its installation directory"
        exit 1
    }
}

if {[info exists arguments(-h)]} {
    printUsage 1
}
if {[info exists arguments(--version)]} {
    printVersion
    exit
}

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

}

if {[info exists arguments(--show-modules)]} {
    modules::printAvailable
    exit
}

if {1} {

proc showTopLevel {path geometry} {
    wm geometry $path $geometry
    wm deiconify $path
}


package provide scwoop 4.1

class widget {

    proc widget {this path} {
        set ($this,path) $path
    }

    proc ~widget {this} {}

    virtual proc configure {this args} {
        return [eval $($this,path) configure $args]
    }

    virtual proc cget {this args} {
        return [$($this,path) cget $args]
    }

    set option() {}
    trace variable option r ::widget::checkOption

    proc checkOption {array index operations} {
        variable option

        if {![info exists option($index)]} {
            scan $index {%[^,],%s} type name
            $type .temporary
            set option($index) [.temporary cget -$name]
            destroy .temporary
        }
    }

}


foreach class {button canvas entry frame label listbox menu menubutton message radiobutton scale scrollbar text toplevel} {
    class $class {
        proc $class {this parentPath args} widget "\[eval ::$class \$parentPath.\$this \$args\]" {}
        proc ~$class {this} {destroy $widget::($this,path)}
    }
}
if {[package vcompare $::tcl_version 8.4] >= 0} {
    class spinbox {
        proc spinbox {this parentPath args} widget {[eval ::spinbox $parentPath.$this $args]} {}
        proc ~spinbox {this} {destroy $widget::($this,path)}
    }
}

class table {
    proc table {this parentPath args} widget {[eval ::table $parentPath.$this $args]} {}
    proc ~table {this} {destroy $widget::($this,path)}
}

foreach class {barchart graph hierbox htext stripchart tabset treeview} {
    class $class {
        proc $class {this parentPath args} widget "\[eval ::blt::$class .\[string trimleft \$parentPath.\$this .\] \$args\]" {}
        proc ~$class {this} {destroy $widget::($this,path)}
    }
}

class composite {}

proc composite::composite {this base args} widget {$widget::($base,path)} {
    if {([llength $args]%2)!=0} {
        error "value for \"[lindex $args end]\" missing"
    }
    set ($this,base) $base
    set ($this,base,path) $widget::($base,path)
    set ($this,_children) {}
    set ($this,complete) 0
    set ($this,initialArguments) $args
}

proc composite::~composite {this} {
    eval delete [lsort -integer -decreasing $($this,_children)] $($this,base)
}

virtual proc composite::options {this}

proc composite::configure {this args} {
    if {[llength $args]==0} {
        return [descriptions $this]
    }
    if {![string match -* $args]} {
        return [eval widget::configure $($this,[lindex $args 0]) [lrange $args 1 end]]
    }
    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 composite::manage {this args} {
    foreach {child name} $args {
        if {[string length $name]==0} {
            error "widget $child has no name"
        }
        if {[string match -* $name]} {
            error "widget $child name \"$name\" must not start with a dash character"
        }
        if {[info exists ($this,$name)]} {
            error "\"$name\" member name already exists in composite layer"
        }
        set ($this,$name) $child
        set ($this,$name,path) $widget::($child,path)
        lappend ($this,_children) $child
    }
}

proc composite::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,initialArguments) {
        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,initialArguments)
    foreach option [array names initialize] {
        $($this,_derived)::set$option $this $($this,$option)
    }
    set ($this,complete) 1
}

proc composite::cget {this args} {
    switch [llength $args] {
        0 {
            error "wrong # args: should be \"cget $this ?child? ?child? ... option\""
        }
        1 {
            if {![string match -* $args]||![info exists ($this,$args)]} {
                error "$($this,_derived): unknown option \"$args\""
            }
            return $($this,$args)
        }
        default {
            return [eval widget::cget $($this,[lindex $args 0]) [lrange $args 1 end]]
        }
    }
}

proc composite::try {this args} {
    if {([llength $args]%2)!=0} {
        error "value for \"[lindex $args end]\" missing"
    }
    foreach {option value} $args {
        catch {widget::configure $($this,base) $option $value}
        foreach child $($this,_children) {
            catch {widget::configure $child $option $value}
        }
    }
}

proc composite::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 composite::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
}

proc composite::managingOrder {this name1 name2} {
    return [expr {$($this,$name1)-$($this,$name2)}]
}

proc composite::componentNames {this} {
    set names {}
    foreach index [array names composite:: $this,*,path] {
        if {[regexp {,(.+),path} $index dummy name]} {
            lappend names $name
        }
    }
    return [lsort -command "managingOrder $this" $names]
}


class bindings {
    proc bindings {this widget index} {
        ::set ($this,widget) $widget
        bindtags $widget [linsert [bindtags $widget] $index bindings($this)]
    }
    proc ~bindings {this} {
        if {![winfo exists $($this,widget)]} return
        ::set tags [bindtags $($this,widget)]
        ::set index [lsearch -exact $tags bindings($this)]
        bindtags $($this,widget) [lreplace $tags $index $index]
        foreach tag [bind bindings($this)] {
            bind bindings($this) $tag {}
        }
    }
    proc set {this tag sequence} {
        bind bindings($this) $tag $sequence
    }
}


class widgetTip {

    variable screenWidth [winfo screenwidth .]
    variable screenHeight [winfo screenheight .]
    variable xOffset 7
    variable yOffset 10

    class topLabel {

        proc topLabel {this parentPath args} composite {
            [new toplevel $parentPath -highlightbackground black -highlightthickness 1] $args
        } {
            composite::manage $this [new label $widget::($this,path) -justify left] label
            composite::complete $this
            pack $composite::($this,label,path)
            wm overrideredirect $widget::($this,path) 1
        }

        proc ~topLabel {this} {}

        proc options {this} {
            return [list                [list -bordercolor Black Black]                [list -borderwidth 1 1]                [list -background $widget::option(button,background) $widget::option(button,background)]                [list -font $widget::option(button,font) $widget::option(button,font)]                [list -foreground $widget::option(button,foreground) $widget::option(button,foreground)]                [list -text {} {}]                [list -wraplength 400]            ]
        }

        foreach option {-background -font -foreground -text -wraplength} {
            proc set$option {this value} "\$composite::(\$this,label,path) configure $option \$value"
        }

        proc set-bordercolor {this value} {
            $widget::($this,path) configure -highlightbackground $value
        }

        proc set-borderwidth {this value} {
            $widget::($this,path) configure -highlightthickness $value
        }

    }

    if {![info exists (label)]} {
        set (label) [new topLabel . -font $widget::option(entry,font) -background #FFFFDF]
        set (path) $widget::($(label),path)
        wm withdraw $(path)
        bind all <ButtonPress> {widgetTip::globalEvent %W}
        bind all <KeyPress> {widgetTip::globalEvent %W}
        set (xLast) -1
        set (yLast) -1
    }

    proc widgetTip {this args} switched {$args} {
        switched::complete $this
        setupBindings $this
    }

    proc ~widgetTip {this} {
        catch {after cancel $($this,event)}
        if {!$switched::($this,-ephemeral)} {
            disable $this
        }
        if {[info exists ($this,bindings)]} {
            delete $($this,bindings)
        }
        set path $switched::($this,-path)
        set tag $switched::($this,-itemortag)
        if {([string length $path] > 0) && ([string length $tag] > 0)} {
            array set match [list <Enter> "widgetTip::enable $this" <Leave> "widgetTip::disable $this"]
            foreach sequence [array names match] {
                set script {}
                foreach line [split [$path bind $tag $sequence] \n] {
                    if {![string equal [string trim $line] $match($sequence)]} {
                        if {[string length $script] > 0} {append script \n}
                        append script $line
                    }
                }
                $path bind $tag $sequence $script
            }
        }
    }

    proc options {this} {
        return [list            [list -ephemeral 0 0]            [list -font $widget::option(entry,font) $widget::option(entry,font)]            [list -itemortag {} {}]            [list -path {} {}]            [list -rectangle {} {}]            [list -state normal normal]            [list -text {} {}]        ]
    }

    proc set-ephemeral {this value} {
        if {$switched::($this,complete)} {
            error {option -ephemeral cannot be set dynamically}
        }
    }

    proc set-itemortag {this value} {
        if {$switched::($this,complete)} {
            error {option -itemortag cannot be set dynamically}
        }
        if {[string length $switched::($this,-rectangle)] > 0} {
            error {-itemortag and -rectangle options are incompatible}
        }
        if {([string length $switched::($this,-path)] > 0) && [catch {$switched::($this,-path) type $value} message]} {
            error "$switched::($this,-path) is not a canvas, $value not a valid item or tag, ...: $message"
        }
    }

    proc set-path {this value} {
        if {$switched::($this,complete)} {
            error {option -path cannot be set dynamically}
        }
        if {![winfo exists $value]} {
            error "invalid widget: \"$value\""
        }
        if {([string length $switched::($this,-itemortag)] > 0) && [catch {$value type $switched::($this,-itemortag)} message]} {
            error "$value is not a canvas, $switched::($this,-itemortag) not a valid item or tag, ...: $message"
        }
    }

    proc set-rectangle {this value} {
        if {[string length $switched::($this,-itemortag)] > 0} {
            error {-itemortag and -rectangle options are incompatible}
        }
        set error 0
        if {[llength $value] != 4} {
            set error 1
        } else {
            foreach item $value {
                if {![string is integer -strict $item]} {set error 1; break}
            }
        }
        if {$error} {
            error {-rectangle option must be a list of 4 integers}
        }
        foreach [list ($this,left) ($this,top) ($this,right) ($this,bottom)] $value {}
        setupBindings $this
        if {[string length $switched::($this,-path)] > 0} {
            set path $switched::($this,-path)
            after idle widgetTip::motion $this [expr {[winfo pointerx $path] - [winfo rootx $path]}]                [expr {[winfo pointery $path] - [winfo rooty $path]}]
        }
    }

    proc set-state {this value} {
        switch $value {
            disabled {disable $this}
            normal {}
            default {error "bad state value \"$value\": must be normal or disabled"}
        }
    }

    proc setupBindings {this} {
        if {[string length $switched::($this,-itemortag)] == 0} {
            if {![info exists ($this,bindings)]} {
                set ($this,bindings) [new bindings $switched::($this,-path) 0]
            }
            if {[string length $switched::($this,-rectangle)] > 0} {
                bindings::set $($this,bindings) <Enter> {}
                bindings::set $($this,bindings) <Leave> "widgetTip::disable $this; catch {unset widgetTip::($this,in)}"
                bindings::set $($this,bindings) <Motion> "widgetTip::motion $this %x %y"
            } else {
                bindings::set $($this,bindings) <Enter> "widgetTip::enable $this"
                bindings::set $($this,bindings) <Leave> "widgetTip::disable $this"
            }
        } else {
            $switched::($this,-path) bind $switched::($this,-itemortag) <Enter> "+ widgetTip::enable $this"
            $switched::($this,-path) bind $switched::($this,-itemortag) <Leave> "+ widgetTip::disable $this"
        }
    }

    proc set-font {this value} {}
    proc set-text {this value} {
        if {[info exists (active)] && ($(active) == $this)} {
            widget::configure $(label) -text $value
        }
    }

    proc globalEvent {widget} {
        if {![catch {string first $switched::($(active),-path) $widget} value] && ($value == 0)} {
            disable $(active)
        }
    }

    proc show {this x y} {
        variable screenWidth
        variable screenHeight
        variable xOffset
        variable yOffset

        set path $(path)
        widget::configure $(label) -font $switched::($this,-font) -text $switched::($this,-text)
        update idletasks
        set size [winfo reqwidth $path]
        set delta [expr {$screenWidth - $x - $xOffset - $size}]
        if {$delta < 0} {
            incr x -$xOffset
            incr x -$size
        } else {
            incr x $xOffset
        }
        set size [winfo reqheight $path]
        set delta [expr {$screenHeight - $y - $yOffset - $size}]
        if {$delta < 0} {
            incr y -$yOffset
            incr y -$size
        } else {
            incr y $yOffset
        }
        showTopLevel $path +$x+$y
        update idletasks
        raise $path
    }

    proc enable {this} {
        if {[catch {classof $this}]} return
        if {[string equal $switched::($this,-state) disabled] || ([string length $switched::($this,-text)] == 0)} {
            return
        }
        set x [winfo pointerx $(path)]
        set y [winfo pointery $(path)]
        if {($x == $(xLast)) && ($y == $(yLast))} {
            catch {after cancel $($this,event)}
            show $this $x $y
        } else {
            set (xLast) $x
            set (yLast) $y
            set ($this,event) [after 300 "widgetTip::enable $this"]
        }
        set (active) $this
    }

    proc disable {this} {
        catch {after cancel $($this,event)}
        catch {unset (active)}
        wm withdraw $(path)
        if {$switched::($this,-ephemeral)} {after idle "if {!\[catch {classof $this}\]} {delete $this}"}
    }

    proc motion {this x y} {
        if {[catch {classof $this}]} return
        if {($x < $($this,left)) || ($y < $($this,top)) || ($x > $($this,right)) || ($y > $($this,bottom))} {
            if {[info exists ($this,in)]} {
                unset ($this,in)
                disable $this
            }
        } else {
            if {![info exists ($this,in)]} {
                set ($this,in) {}
                enable $this
            }
        }
    }

}


class arrowButton {}

proc arrowButton::arrowButton {this parentPath args} composite {
    [new canvas $parentPath        -relief $widget::option(button,relief) -background $widget::option(button,background)        -borderwidth $widget::option(button,borderwidth) -height $widget::option(scrollbar,width)        -highlightbackground $widget::option(button,highlightbackground) -highlightcolor $widget::option(button,highlightcolor)        -highlightthickness $widget::option(button,highlightthickness) -width $widget::option(scrollbar,width)    ] $args
} {
    set ($this,triangle) [$widget::($this,path) create polygon 0 0 0 0 0 0]
    bind $widget::($this,path) <Configure> "arrowButton::redraw $this %w %h"
    set ($this,active) 0
    composite::complete $this
}

proc arrowButton::~arrowButton {this} {}

proc arrowButton::options {this} {
    return [list        [list -activebackground $widget::option(button,activebackground) $widget::option(button,activebackground)]        [list -background $widget::option(button,background) $widget::option(button,background)]        [list -borderwidth $widget::option(button,borderwidth) $widget::option(button,borderwidth)]        [list -command {} {}]        [list -direction down]        [list -disabledforeground $widget::option(button,disabledforeground) $widget::option(button,disabledforeground)]        [list -foreground $widget::option(button,foreground) $widget::option(button,foreground)]        [list -height $widget::option(scrollbar,width) $widget::option(scrollbar,width)]        [list -highlightbackground $widget::option(button,highlightbackground) $widget::option(button,highlightbackground)]        [list -highlightcolor $widget::option(button,highlightcolor) $widget::option(button,highlightcolor)]        [list -highlightthickness $widget::option(button,highlightthickness) $widget::option(button,highlightthickness)]        [list -repeatdelay 0 0]        [list -state normal]        [list -takefocus 1]        [list -width $widget::option(scrollbar,width) $widget::option(scrollbar,width)]    ]
}

proc arrowButton::set-activebackground {this value} {}

proc arrowButton::set-state {this value} {
    set path $widget::($this,path)
    switch $value {
        normal {
            $path itemconfigure $($this,triangle) -fill $composite::($this,-foreground) -outline $composite::($this,-foreground)
            bind $path <Enter> "arrowButton::activate $this"
            bind $path <Leave> "arrowButton::deactivate $this; arrowButton::raise $this"
            bind $path <ButtonPress-1>                "set arrowButton::($this,buttonPressed) 1; arrowButton::sink $this; arrowButton::startTimer $this"
            bind $path <ButtonRelease-1>                "arrowButton::raise $this; arrowButton::invoke $this 0; set arrowButton::($this,buttonPressed) 0"
            if {$composite::($this,-takefocus)} {
                bind $path <KeyPress-space> "arrowButton::sink $this"
                bind $path <KeyRelease-space> "arrowButton::raise $this; arrowButton::invoke $this 1"
            } else {
                bind $path <KeyPress-space> {}
                bind $path <KeyRelease-space> {}
            }
        }
        disabled {
            $path itemconfigure $($this,triangle)                -fill $composite::($this,-disabledforeground) -outline $composite::($this,-disabledforeground)
            bind $path <Enter> {}
            bind $path <Leave> {}
            bind $path <ButtonPress-1> {}
            bind $path <ButtonRelease-1> {}
            bind $path <KeyPress-space> {}
            bind $path <KeyRelease-space> {}
        }
        default {
            error "bad state value \"$value\": must be normal or disabled"
        }
    }
}

foreach option {-background -borderwidth -height -highlightbackground -highlightcolor -highlightthickness -width} {
    proc arrowButton::set$option {this value} "\$widget::(\$this,path) configure $option \$value"
}

foreach option {-disabledforeground -foreground} {
    proc arrowButton::set$option {this value} {set-state $this $composite::($this,-state)}
}

proc arrowButton::set-command {this value} {}

proc arrowButton::set-direction {this value} {
    if {        ([string first $value down]!=0)&&([string first $value up]!=0)&&        ([string first $value left]!=0)&&([string first $value right]!=0)    } {
        error "bad direction value \"$value\": must be down, up, left or right (or any abbreviation)"
    }
    redraw $this [winfo width $widget::($this,path)] [winfo height $widget::($this,path)]
}

proc arrowButton::set-takefocus {this value} {
    if {![regexp {^(0|1)$} $value]} {
        error "bad takefocus value \"$value\": must be 0 or 1"
    }
    $widget::($this,path) configure -takefocus $value
    set-state $this $composite::($this,-state)
}

proc arrowButton::set-repeatdelay {this value} {}

proc arrowButton::redraw {this width height} {
    set insideWidth [expr {$width-2*($composite::($this,-borderwidth)+$composite::($this,-highlightthickness))}]
    set insideHeight [expr {$height-2*($composite::($this,-borderwidth)+$composite::($this,-highlightthickness))}]
    switch -glob $composite::($this,-direction) {
        d* {
            set insideWidth [maximum [expr {$insideWidth/4}] 1]
            $widget::($this,path) coords $($this,triangle) 0 0 [expr {2*$insideWidth}] 0 $insideWidth $insideWidth
        }
        u* {
            set insideWidth [maximum [expr {$insideWidth/4}] 1]
            $widget::($this,path) coords $($this,triangle) 0 0 [expr {2*$insideWidth}] 0 $insideWidth -$insideWidth
        }
        l* {
            set insideHeight [maximum [expr {$insideHeight/4}] 1]
            $widget::($this,path) coords $($this,triangle) 0 0 0 [expr {2*$insideHeight}] -$insideHeight $insideHeight
        }
        r* {
            set insideHeight [maximum [expr {$insideHeight/4}] 1]
            $widget::($this,path) coords $($this,triangle) 0 0 0 [expr {2*$insideHeight}] $insideHeight $insideHeight
        }
    }
    centerTriangle $this $width $height
}

proc arrowButton::centerTriangle {this width height} {
    set box [$widget::($this,path) bbox $($this,triangle)]
    $widget::($this,path) move $($this,triangle)        [expr {($width-[lindex $box 2]-[lindex $box 0])/2}] [expr {($height-[lindex $box 3]-[lindex $box 1])/2}]
}

proc arrowButton::activate {this} {
    $widget::($this,path) configure -background $composite::($this,-activebackground)
    set ($this,active) 1
}

proc arrowButton::deactivate {this} {
    $widget::($this,path) configure -background $composite::($this,-background)
    set ($this,active) 0
}

proc arrowButton::sink {this} {
    set path $widget::($this,path)
    $path configure -relief sunken
    centerTriangle $this [winfo width $path] [winfo height $path]
    $path move $($this,triangle) 1 1
}

proc arrowButton::raise {this} {
    set path $widget::($this,path)
    $path configure -relief raised
    centerTriangle $this [winfo width $path] [winfo height $path]
    if {[info exists ($this,event)]} {
        after cancel $($this,event)
        unset ($this,event)
    }
}

proc arrowButton::invoke {this fromKey} {
    if {([string length $composite::($this,-command)]>0)&&($($this,active)||$fromKey)} {
        uplevel #0 $composite::($this,-command)
    }
}

proc arrowButton::startTimer {this} {
    if {$composite::($this,-repeatdelay)>0} {
        set ($this,event) [after $composite::($this,-repeatdelay) "arrowButton::processTimer $this"]
    }
}

proc arrowButton::processTimer {this} {
    if {$($this,buttonPressed)} {
        startTimer $this
        invoke $this 0
    } else {
        unset ($this,event)
    }
}

proc arrowButton::maximum {a b} {return [expr {$a>$b?$a:$b}]}
    if {[package vcompare $tcl_version 8.4] < 0} {


class spinEntry {}

proc spinEntry::spinEntry {this parentPath args} composite {
    [new frame $parentPath -highlightthickness $widget::option(button,highlightthickness)] $args
} {
    ::set path $widget::($this,path)
    composite::manage $this [new entry $path -highlightthickness 0] entry        [new arrowButton $path            -takefocus 0 -command "spinEntry::decrease $this" -height 4 -highlightthickness 0            -repeatdelay $widget::option(scrollbar,repeatdelay)        ] decrease        [new arrowButton $path            -direction up -takefocus 0 -command "spinEntry::increase $this" -height 4 -highlightthickness 0            -repeatdelay $widget::option(scrollbar,repeatdelay)        ] increase

    bind $path <Return> "spinEntry::invoke $this"
    bind $path <KP_Enter> "spinEntry::invoke $this"
    bind $composite::($this,entry,path) <Return> "spinEntry::invoke $this"
    bind $composite::($this,entry,path) <KP_Enter> "spinEntry::invoke $this"

    spinEntry::setupUpAndDownKeysBindings $this $path
    spinEntry::setupUpAndDownKeysBindings $this $composite::($this,entry,path)

    composite::complete $this
}

proc spinEntry::~spinEntry {this} {}

proc spinEntry::options {this} {
    return [list        [list -command {} {}]        [list -editable 1 1]        [list -font $widget::option(button,font)]        [list -justify $widget::option(entry,justify) $widget::option(entry,justify)]        [list -list {} {}]        [list -range {} {}]        [list -repeatdelay $widget::option(scrollbar,repeatdelay) $widget::option(scrollbar,repeatdelay)]        [list -side left]        [list -state normal]        [list -width $widget::option(entry,width) $widget::option(entry,width)]        [list -wrap 0 0]    ]
}

proc spinEntry::set-command {this value} {}

proc spinEntry::set-editable {this value} {
    setStatesAndBindings $this
}

proc spinEntry::set-list {this value} {
    if {$composite::($this,complete)} {
        error {option -orient cannot be set dynamically}
    }
    if {[string length [$composite::($this,entry,path) get]] == 0} {
        set $this [lindex $value 0]
    }
}

proc spinEntry::set-range {this value} {
    if {$composite::($this,complete)} {
        error {option -range cannot be set dynamically}
    }
    if {[llength $value] != 3} {
        error {option -range argument format must be {minimum maximum increment}}
    }
    ::set ($this,minimum) [lindex $composite::($this,-range) 0]
    ::set ($this,maximum) [lindex $composite::($this,-range) 1]
    ::set ($this,increment) [lindex $composite::($this,-range) 2]
    if {[catch {expr {$($this,maximum) - $($this,minimum) + $($this,increment)}}]} {
        error {option -range arguments must be numeric values}
    }
    if {[string length [$composite::($this,entry,path) get]] == 0} {
        set $this $($this,minimum)
    }
}

proc spinEntry::set-repeatdelay {this value} {
    widget::configure $composite::($this,decrease) -repeatdelay $value
    widget::configure $composite::($this,increase) -repeatdelay $value
}

proc spinEntry::set-state {this value} {
    if {![regexp {^(disabled|normal)$} $value]} {
        error "bad state value \"$value\": must be normal or disabled"
    }
    setStatesAndBindings $this
}

foreach option {-font -justify -width} {
    proc spinEntry::set$option {this value} "\$composite::(\$this,entry,path) configure $option \$value"
}

proc spinEntry::set-side {this value} {
    if {![regexp {^(left|right)$} $value]} {
        error "bad side value \"$value\": must be left or right"
    }
    pack forget $composite::($this,entry,path) $composite::($this,increase,path) $composite::($this,decrease,path)
    pack $composite::($this,entry,path) -side $value -fill both -expand 1
    pack $composite::($this,increase,path) $composite::($this,decrease,path) -fill y -expand 1
}

proc spinEntry::set-wrap {this value} {}

proc spinEntry::decrease {this} {
    set $this [spinEntry::next $this -1]
    invoke $this down
}
proc spinEntry::increase {this} {
    set $this [spinEntry::next $this 1]
    invoke $this up
}

proc spinEntry::next {this direction} {
    ::set value [$composite::($this,entry,path) get]
    ::set wrap $composite::($this,-wrap)
    if {[catch {::set increment $($this,increment)}]} {
        ::set index [lsearch -exact $composite::($this,-list) $value]
        incr index $direction
        if {$index < 0} {
            if {$wrap} {::set index end} else {::set index 0}
        } elseif {$index >= [llength $composite::($this,-list)]} {
            if {$wrap} {::set index 0} else {::set index end}
        }
        return [lindex $composite::($this,-list) $index]
    } else {
        ::set minimum $($this,minimum)
        ::set maximum $($this,maximum)
        if {[catch {expr {$value + 0}}]} {
            return [expr {$direction < 0? $minimum: $maximum}]
        } else {
            ::set value [expr {$value + ($direction * $increment)}]
            if {$value <= $minimum} {
                if {$wrap} {return $maximum} else {return $minimum}
            } elseif {$value >= $maximum} {
                if {$wrap} {return $minimum} else {return $maximum}
            } else {
                return $value
            }
        }
    }
}

proc spinEntry::setStatesAndBindings {this} {
    if {[string equal $composite::($this,-state) normal]} {
        widget::configure $composite::($this,decrease) -state normal
        widget::configure $composite::($this,increase) -state normal
        if {$composite::($this,-editable)} {
            $widget::($this,path) configure -takefocus 0
            $composite::($this,entry,path) configure -state normal
        } else {
            $widget::($this,path) configure -takefocus 1
            $composite::($this,entry,path) configure -state disabled
        }
        $composite::($this,entry,path) configure -foreground $widget::option(entry,foreground)
    } else {
        $widget::($this,path) configure -takefocus 0
        widget::configure $composite::($this,decrease) -state disabled
        widget::configure $composite::($this,increase) -state disabled
        widget::configure $composite::($this,entry) -state disabled
        $composite::($this,entry,path) configure -foreground $widget::option(label,disabledforeground)
    }
}

proc spinEntry::setupUpAndDownKeysBindings {this path} {
    bind $path <KeyPress-Down> "arrowButton::sink $composite::($this,decrease); spinEntry::decrease $this"
    bind $path <KeyRelease-Down> "arrowButton::raise $composite::($this,decrease)"
    bind $path <KeyPress-Up> "arrowButton::sink $composite::($this,increase); spinEntry::increase $this"
    bind $path <KeyRelease-Up> "arrowButton::raise $composite::($this,increase)"
}

proc spinEntry::invoke {this {direction none}} {
    ::set command $composite::($this,-command)
    if {[string length $command] > 0} {
        regsub -all %d $command $direction command
        uplevel #0 $command [list [$composite::($this,entry,path) get]]
    }
}

proc spinEntry::set {this text} {
    ::set path $composite::($this,entry,path)
    $path configure -state normal
    $path delete 0 end
    $path insert 0 $text
    if {!$composite::($this,-editable)} {
        $path configure -state disabled
    }
}

proc spinEntry::get {this} {
    return [$composite::($this,entry,path) get]
}
    }


class panner {
    set (default,HandleSize) 8
}

proc panner::panner {this parentPath args} composite {[new frame $parentPath] $args} {
    set ($this,handles) {}
    set ($this,lastManagerSize) 0
    set ($this,handleSize) $(default,HandleSize)
    composite::complete $this
}

proc panner::~panner {this} {}

proc panner::options {this} {
    return [list        [list -handlesize $(default,HandleSize)]        [list -handleplacement 0.9 0.9]        [list -orient vertical]        [list -panes 2 3]    ]
}

proc panner::try {this option value} {
    set path $widget::($this,path)
    catch {$path configure $option $value}
    set lastIndex [expr {(2*$composite::($this,-panes))-2}]
    for {set itemIndex 0} {$itemIndex<=$lastIndex} {incr itemIndex} {
        set frame $path.$itemIndex
        catch {$frame configure $option $value}
        if {($itemIndex%2)!=0} {
            catch {$frame.separator configure $option $value}
            catch {$frame.handle configure $option $value}
        }
    }
}
proc panner::set-handlesize {this value} {
    set ($this,handleSize) [expr {(([winfo pixels $widget::($this,path) $value]+1)/2)*2}]
    if {$composite::($this,complete)} {
        updateHandleSize $this
    }
}

proc panner::set-orient {this value} {
    if {$composite::($this,complete)} {
        error {option -orient cannot be set dynamically}
    }
    if {([string first $value vertical]!=0)&&([string first $value horizontal]!=0)} {
        error "bad orientation value \"$value\": must be horizontal or vertical (or any abbreviation)"
    }
    if {[string match v* $composite::($this,-orient)]} {
        bind $widget::($this,path) <Configure> "panner::resize $this %h"
    } else {
        bind $widget::($this,path) <Configure> "panner::resize $this %w"
    }
}

proc panner::set-panes {this value} {
    if {$composite::($this,complete)} {
        error {option -panes cannot be set dynamically}
    }
    set path $widget::($this,path)
    if {[string match v* $composite::($this,-orient)]} {
        set vertical 1
        grid columnconfigure $path 0 -weight 1
        set sticky ew
        set cursor sb_v_double_arrow
    } else {
        set vertical 0
        grid rowconfigure $path 0 -weight 1
        set sticky ns
        set cursor sb_h_double_arrow
    }
    set paneIndex 0
    set itemIndex 0
    while {1} {
        set frame [frame $path.$itemIndex]
        if {$vertical} {
            grid $frame -sticky nsew -row $itemIndex -column 0
            grid rowconfigure $path $itemIndex -weight 1000000
        } else {
            grid $frame -sticky nsew -column $itemIndex -row 0
            grid columnconfigure $path $itemIndex -weight 1000000
        }
        incr paneIndex
        set ($this,frame$paneIndex) $frame
        if {$paneIndex==$value} {
            break
        }
        incr itemIndex
        set frame [frame $path.$itemIndex]
        if {$vertical} {
            grid $frame -sticky $sticky -row $itemIndex -column 0
            grid rowconfigure $path $itemIndex -weight 1
        } else {
            grid $frame -sticky $sticky -column $itemIndex -row 0
            grid columnconfigure $path $itemIndex -weight 1
        }
        frame $frame.separator -borderwidth 1 -relief ridge
        if {$vertical} {
            $frame.separator configure -height 2
        } else {
            $frame.separator configure -width 2
        }
        place $frame.separator -anchor center -relx 0.5 -rely 0.5
        if {$vertical} {
            place $frame.separator -relwidth 1
        } else {
            place $frame.separator -relheight 1
        }
        button $frame.handle -borderwidth 1 -highlightthickness 0 -cursor $cursor -takefocus 0
        bind $frame.handle <ButtonPress-1> "panner::startMotion $this %W"
        if {$vertical} {
            bind $frame.handle <ButtonRelease-1> "panner::endMotion $this %W $itemIndex %Y"
            place $frame.handle -rely 0.5 -anchor center
        } else {
            bind $frame.handle <ButtonRelease-1> "panner::endMotion $this %W $itemIndex %X"
            place $frame.handle -relx 0.5 -anchor center
        }
        incr itemIndex
    }
    updateHandleSize $this
    set-handleplacement $this $composite::($this,-handleplacement)
}

proc panner::set-handleplacement {this value} {
    set path $widget::($this,path)
    set lastIndex [expr {(2*$composite::($this,-panes))-2}]
    if {[string first $composite::($this,-orient) vertical]==0} {
        for {set itemIndex 1} {$itemIndex<=$lastIndex} {incr itemIndex 2} {
            place $path.$itemIndex.handle -relx $value
        }
    } else {
        for {set itemIndex 1} {$itemIndex<=$lastIndex} {incr itemIndex 2} {
            place $path.$itemIndex.handle -rely $value
        }
    }
}

proc panner::startMotion {this handle} {
    set path $widget::($this,path)
    if {[string first $composite::($this,-orient) vertical]==0} {
        bind $handle <Motion> "panner::verticalMotion $this %Y"
        set (line) [frame $path.line -background black -height 1 -width [winfo width $path]]
        set (minimum) [winfo rooty $path]
        set (maximum) [expr {$(minimum)+[winfo height $path]-1}]
    } else {
        bind $handle <Motion> "panner::horizontalMotion $this %X"
        set (line) [frame $path.line -background black -width 1 -height [winfo height $path]]
        set (minimum) [winfo rootx $path]
        set (maximum) [expr {$(minimum)+[winfo width $path]-1}]
    }
}

proc panner::clip {coordinate} {
    if {$coordinate<$(minimum)} {
        return $(minimum)
    } elseif {$coordinate>$(maximum)} {
        return $(maximum)
    } else {
        return $coordinate
    }
}

proc panner::endMotion {this handle row rootCoordinate} {
    set visible [expr {[llength [place info $(line)]]>0}]
    destroy $(line)
    bind $handle <Motion> {}
    if {$visible} {
        split $this $row [expr {[clip $rootCoordinate]-$(minimum)}]
    }
    unset (line) (minimum) (maximum)
}

proc panner::verticalMotion {this yRoot} {
    place $(line) -y [expr {[clip $yRoot]-$(minimum)}]
}

proc panner::horizontalMotion {this xRoot} {
    place $(line) -x [expr {[clip $xRoot]-$(minimum)}]
}

proc panner::split {this handleIndex coordinate} {
    if {[string match v* $composite::($this,-orient)]} {
        set vertical 1
        set itemName row
        set sizeName height
    } else {
        set vertical 0
        set itemName column
        set sizeName width
    }
    set path $widget::($this,path)
    set lastIndex [expr {(2*$composite::($this,-panes))-2}]
    if {[grid propagate $path]} {
        grid propagate $path 0
        for {set itemIndex 0} {$itemIndex<=$lastIndex} {incr itemIndex} {
            grid ${itemName}configure $path $itemIndex -minsize [winfo $sizeName $path.$itemIndex]
        }
    }
    set separatorsSize 0
    set framesSize 0
    set beforeIndex [expr {$handleIndex-1}]
    set afterIndex [expr {$handleIndex+1}]
    if {$vertical} {
        set lastCoordinate [lindex [grid bbox $path 0 $handleIndex] 1]
        set masterSize [lindex [grid bbox $path] 3]
        set frameStart [lindex [grid bbox $path 0 $beforeIndex] 1]
        set box [grid bbox $path 0 $afterIndex]
        set frameEnd [expr {[lindex $box 1]+[lindex $box 3]}]
    } else {
        set lastCoordinate [lindex [grid bbox $path $handleIndex 0] 0]
        set masterSize [lindex [grid bbox $path] 2]
        set frameStart [lindex [grid bbox $path $beforeIndex 0] 0]
        set box [grid bbox $path $afterIndex 0]
        set frameEnd [expr {[lindex $box 0]+[lindex $box 2]}]
    }
    if {$coordinate>$lastCoordinate} {
        incr coordinate -[expr {$($this,handleSize)/2}]
        for {set itemIndex $handleIndex} {$itemIndex<=$lastIndex} {incr itemIndex} {
            if {($itemIndex%2)==0} {
                incr framesSize [grid ${itemName}configure $path $itemIndex -minsize]
            } else {
                incr separatorsSize $($this,handleSize)
            }
        }
        set remaining [expr {$masterSize-$coordinate-$separatorsSize}]
        if {$remaining<0} {
            set size [expr {$masterSize-$frameStart-$separatorsSize}]
            set remaining 0
        } else {
            set size [expr {$coordinate-$frameStart}]
        }
        grid ${itemName}configure $path $beforeIndex -minsize $size
        for {set itemIndex $lastIndex} {$itemIndex>=$afterIndex} {incr itemIndex -2} {
            if {$remaining>[grid ${itemName}configure $path $itemIndex -minsize]} {
                incr remaining -[grid ${itemName}configure $path $itemIndex -minsize]
            } elseif {$remaining>0} {
                grid ${itemName}configure $path $itemIndex -minsize $remaining
                set remaining 0
            } else {
                grid ${itemName}configure $path $itemIndex -minsize 0
            }
        }
    } elseif {$coordinate<$lastCoordinate} {
        incr coordinate [expr {$($this,handleSize)/2}]
        for {set itemIndex $handleIndex} {$itemIndex>=0} {incr itemIndex -1} {
            if {($itemIndex%2)==0} {
                incr framesSize [grid ${itemName}configure $path $itemIndex -minsize]
            } else {
                incr separatorsSize $($this,handleSize)
            }
        }
        set remaining [expr {$coordinate-$separatorsSize}]
        if {$remaining<0} {
            set size [expr {$frameEnd-$separatorsSize}]
            set remaining 0
        } else {
            set size [expr {$frameEnd-$coordinate}]
        }
        grid ${itemName}configure $path $afterIndex -minsize $size
        for {set itemIndex 0} {$itemIndex<=$beforeIndex} {incr itemIndex 2} {
            if {$remaining>[grid ${itemName}configure $path $itemIndex -minsize]} {
                incr remaining -[grid ${itemName}configure $path $itemIndex -minsize]
            } elseif {$remaining>0} {
                grid ${itemName}configure $path $itemIndex -minsize $remaining
                set remaining 0
            } else {
                grid ${itemName}configure $path $itemIndex -minsize 0
            }
        }
    }
}

proc panner::updateHandleSize {this} {
    set size $($this,handleSize)
    set path $widget::($this,path)
    set lastIndex [expr {(2*$composite::($this,-panes))-2}]
    if {[string match v* $composite::($this,-orient)]} {
        for {set row 1} {$row<$lastIndex} {incr row 2} {
            set frame $path.$row
            place $frame.handle -width $size -height $size
            $frame configure -height $size
            grid rowconfigure $path $row -minsize $size
        }
    } else {
        for {set column 1} {$column<$lastIndex} {incr column 2} {
            set frame $path.$column
            place $frame.handle -width $size -height $size
            $frame configure -width $size
            grid columnconfigure $path $column -minsize $size
        }
    }
}

proc panner::resize {this size} {
    if {$size==$($this,lastManagerSize)} {
        return
    }
    set ($this,lastManagerSize) $size
    set path $widget::($this,path)
    if {[grid propagate $path]} {
        return
    }
    set lastIndex [expr {(2*$composite::($this,-panes))-2}]
    set lastSize 0
    set newSize $size
    if {[string match v* $composite::($this,-orient)]} {
        set itemName row
    } else {
        set itemName column
    }
    for {set itemIndex 0} {$itemIndex<=$lastIndex} {incr itemIndex} {
        if {($itemIndex%2)==0} {
            incr lastSize [grid ${itemName}configure $path $itemIndex -minsize]
        } else {
            incr newSize -$($this,handleSize)
        }
    }
    set ratio [expr {double($newSize)/$lastSize}]
    for {set itemIndex 0} {$itemIndex<$lastIndex} {incr itemIndex 2} {
        set size [expr {round($ratio*[grid ${itemName}configure $path $itemIndex -minsize])}]
        grid ${itemName}configure $path $itemIndex -minsize $size
        incr newSize -$size
    }
    grid ${itemName}configure $path $itemIndex -minsize $newSize
}



class scroll {

    proc scroll {this scrollableClass parentPath args} composite {[new frame $parentPath] $args} {
        set path $widget::($this,path)
        composite::manage $this [new $scrollableClass $path] scrolled            [new scrollbar $path -orient horizontal -highlightthickness 0] horizontal            [new scrollbar $path -highlightthickness 0] vertical [new frame $path] filler
        widget::configure $composite::($this,scrolled)            -xscrollcommand "scroll::update $this 1 0" -yscrollcommand "scroll::update $this 0 1"
        widget::configure $composite::($this,horizontal) -command "$composite::($this,scrolled,path) xview"
        widget::configure $composite::($this,vertical) -command "$composite::($this,scrolled,path) yview"
        grid propagate $widget::($this,path) 0
        grid $composite::($this,scrolled,path) -sticky nsew -ipadx 0
        grid rowconfigure $path 0 -weight 1
        grid columnconfigure $path 0 -weight 1
        set ($this,0,1,path) $composite::($this,vertical,path)
        set ($this,1,0,path) $composite::($this,horizontal,path)
        set ($this,0,1,map) 1
        set ($this,1,0,map) 1
        composite::complete $this
    }

    proc ~scroll {this} {}

    proc options {this} {
        return [list            [list -automatic 1 1]            [list -scrollbarborderwidth $widget::option(scrollbar,borderwidth) $widget::option(scrollbar,borderwidth)]            [list                -scrollbarelementborderwidth                $widget::option(scrollbar,elementborderwidth) $widget::option(scrollbar,elementborderwidth)            ]            [list -scrollbarwidth $widget::option(scrollbar,width) $widget::option(scrollbar,width)]            [list -height $widget::option(canvas,height)]            [list -horizontal $($this,1,0,map) $($this,1,0,map)]            [list -vertical $($this,0,1,map) $($this,0,1,map)]            [list -viewthreshold 0 0]            [list -width $widget::option(canvas,width)]            [list -xscrollcommand {} {}]            [list -yscrollcommand {} {}]        ]
    }

    proc set-automatic {this value} {
        if {$composite::($this,complete)} {
            error {option -automatic cannot be set dynamically}
        }
    }

    proc set-horizontal {this value} {
        if {$composite::($this,complete)} {
            error {option -horizontal cannot be set dynamically}
        }
        set ($this,1,0,map) $value
    }

    proc set-vertical {this value} {
        if {$composite::($this,complete)} {
            error {option -vertical cannot be set dynamically}
        }
        set ($this,0,1,map) $value
    }

    proc set-viewthreshold {this value} {}

    foreach option {borderwidth elementborderwidth width} {
        proc set-scrollbar$option {this value} "
            \$composite::(\$this,vertical,path) configure -$option \$value
            \$composite::(\$this,horizontal,path) configure -$option \$value
        "
    }

    proc set-height {this value} {
        $widget::($this,path) configure -height $value
    }

    proc set-width {this value} {
        $widget::($this,path) configure -width $value
    }

    proc set-xscrollcommand {this value} {}
    proc set-yscrollcommand {this value} {}

    proc update {this row column first last} {
        if {($last - $first) < $composite::($this,-viewthreshold)} return
        set path $($this,$row,$column,path)
        foreach {previousFirst previousLast} [$path get] {}
        if {($first == $previousFirst) && ($last == $previousLast)} return
        $path set $first $last
        set visible [llength [grid info $path]]
        if {!$composite::($this,-automatic) || (($last - $first) < 1)} {
            if {!$visible && $($this,$row,$column,map)} {
                grid $path -row $row -column $column -sticky nsew
                grid $composite::($this,filler,path) -sticky nsew -column 1 -row 1
                set ($this,$row,$column,updating) {}
                ::update idletasks
                unset ($this,$row,$column,updating)
            }
        } elseif {![info exists ($this,$row,$column,updating)]} {
            grid remove $path
            set visible [llength [grid info $($this,$column,$row,path)]]
            if {!$visible} {
                grid remove $composite::($this,filler,path)
            }
        }
        if {$row} {
            if {[string length $composite::($this,-xscrollcommand)] > 0} {
                uplevel #0 $composite::($this,-xscrollcommand) $first $last
            }
        } else {
            if {[string length $composite::($this,-yscrollcommand)] > 0} {
                uplevel #0 $composite::($this,-yscrollcommand) $first $last
            }
        }
    }

}


class comboButton {}

proc comboButton::comboButton {this parentPath args} composite {
    [new arrowButton $parentPath -command "comboButton::popupListBox $this"] $args
} {
    composite::manage $this [new toplevel [winfo toplevel $parentPath] -cursor right_ptr] shell
    set shellPath $composite::($this,shell,path)
    if {$widget::option(menu,borderwidth)==0} {
        $shellPath configure -highlightbackground black -highlightthickness 1
    } else {
        $shellPath configure -relief $widget::option(menu,relief) -borderwidth $widget::option(menu,borderwidth)
    }
    bind $shellPath <Escape> "comboButton::unpopListBox $this"
    bind $shellPath <Any-ButtonRelease> "comboButton::unpopListBox $this"
    wm overrideredirect $shellPath 1
    wm withdraw $shellPath

    composite::manage $this [new scrollList $shellPath] scroll
    widget::configure $composite::($this,scroll) base -highlightthickness 0
    widget::configure $composite::($this,scroll) listbox -borderwidth 0
    pack $composite::($this,scroll,path) -fill both -expand 1

    set listboxPath $composite::($composite::($this,scroll),listbox,path)
    set sequence "comboButton::invokeCommand $this; comboButton::unpopListBox $this"
    bind $listboxPath <ButtonRelease-1> $sequence
    bind $listboxPath <KeyRelease-space> $sequence
    bind $listboxPath <Return> $sequence
    bind $listboxPath <KP_Enter> $sequence

    bindtags $composite::($composite::($this,scroll),scrollbar,path) Scrollbar

    composite::complete $this
}

proc comboButton::~comboButton {this} {}

proc comboButton::options {this} {
    return [list        [list -command {} {}]        [list -font $widget::option(button,font) $widget::option(button,font)]        [list -list {}]        [list -listheight 3]        [list -reference {} {}]        [list -state normal]        [list -takefocus {} {}]    ]
}

proc comboButton::set-command {this value} {}

proc comboButton::set-font {this value} {
    widget::configure $composite::($this,scroll) -font $value
}

proc comboButton::set-list {this value} {
    if {[llength $value]==0} {
        widget::configure $composite::($this,base) -state disabled
    } else {
        widget::configure $composite::($this,base) -state normal
    }
    widget::configure $composite::($this,scroll) -list $value
}

foreach option {-state -takefocus} {
    proc comboButton::set$option {this value} "widget::configure \$composite::(\$this,base) $option \$value"
}

proc comboButton::set-listheight {this value} {
    widget::configure $composite::($this,scroll) -height $value
}

proc comboButton::set-reference {this value} {}

proc comboButton::set-borderwidth {this value} {
    widget::configure $composite::($this,base) -borderwidth $value
}

proc comboButton::popupListBox {this} {
    set shellPath $composite::($this,shell,path)
    if {[winfo exists $composite::($this,-reference)]} {
        set path $composite::($this,-reference)
        set border 0
        catch {set border [$path cget -highlightthickness]}
        set x [expr {[winfo rootx $path]+$border}]
        wm geometry $shellPath [expr {[winfo width $path]-(2*$border)}]x[winfo reqheight $shellPath]
    } else {
        set path $widget::($this,path)
        set x [expr {[winfo rootx $path]+[winfo width $path]-[winfo reqwidth $shellPath]}]
    }
    if {$x<0} {
        set x 0
    }
    showTopLevel $shellPath +$x+[expr {[winfo rooty $path]+[winfo height $path]}]
    update idletasks
    raise $shellPath
    set (previousGrab) [grab current $shellPath]
    grab -global $shellPath
    set ($this,focus) [focus]
    focus $composite::($this,scroll,path)
}

proc comboButton::unpopListBox {this} {
    set path $composite::($this,shell,path)
    if {![winfo ismapped $path]} {
        return
    }
    wm withdraw $path
    if {[string length $(previousGrab)]>0} {
        grab $(previousGrab)
        unset (previousGrab)
    } else {
        grab release $path
    }
    catch {focus $($this,focus)}
    unset ($this,focus)
}

proc comboButton::invokeCommand {this} {
    if {[string length $composite::($this,-command)]==0} {
        return
    }
    set selection [scrollList::curselection $composite::($this,scroll)]
    if {[string length $selection]==0} {
        uplevel #0 $composite::($this,-command) [list {}]
    } else {
        uplevel #0 $composite::($this,-command) [list [scrollList::get $composite::($this,scroll) $selection]]
    }
}


class scrollList {}

proc scrollList::scrollList {this parentPath args} composite {
    [new frame $parentPath -highlightthickness $widget::option(button,highlightthickness)] $args
} {
    composite::manage $this [new listbox $widget::($this,path) -highlightthickness 0] listbox
    set listboxPath $composite::($this,listbox,path)

    bind $widget::($this,path) <FocusIn> "focus $listboxPath"
    bind $listboxPath <Button2-Motion> break
    pack $listboxPath -fill both -expand 1

    composite::manage $this        [new scrollbar $widget::($this,path) -command "$listboxPath yview" -highlightthickness 0 -takefocus 0] scrollbar
    widget::configure $composite::($this,listbox) -yscrollcommand "scrollList::updateScrollbar $this"

    composite::complete $this
}

proc scrollList::~scrollList {this} {}

proc scrollList::options {this} {
    return [list        [list -font $widget::option(listbox,font) $widget::option(listbox,font)]        [list -height $widget::option(listbox,height) $widget::option(listbox,height)]        [list -list {} {}]        [list -selectmode $widget::option(listbox,selectmode) $widget::option(listbox,selectmode)]        [list -width $widget::option(listbox,width) $widget::option(listbox,width)]    ]
}

proc scrollList::set-list {this value} {
    set listboxPath $composite::($this,listbox,path)
    $listboxPath delete 0 end
    eval $listboxPath insert 0 $value
    $listboxPath activate 0
}

foreach option {-font -height -selectmode -width} {
    proc scrollList::set$option {this value} "\$composite::(\$this,listbox,path) configure $option \$value"
}

foreach command {activate bbox curselection delete get index insert nearest scan see selection size} {
    proc scrollList::$command {this args} "eval \$composite::(\$this,listbox,path) $command \$args"
}

proc scrollList::updateScrollbar {this first last} {
    if {($last-$first)<1} {
        $composite::($this,scrollbar,path) set $first $last
        pack $composite::($this,scrollbar,path) -fill y -before $composite::($this,listbox,path) -side right
    } else {
        pack forget $composite::($this,scrollbar,path)
    }
}


class comboEntry {}

proc comboEntry::comboEntry {this parentPath args} composite {
    [new frame $parentPath -highlightthickness $widget::option(button,highlightthickness)] $args
} {
    composite::manage $this        [new entry $widget::($this,path) -highlightthickness 0] entry        [new comboButton $widget::($this,path) -command "comboEntry::selected $this" -reference $widget::($this,path)] button
    widget::configure $composite::($this,button) base -highlightthickness 0
    grid $composite::($this,entry,path) -column 0 -row 0 -sticky nsew
    grid $composite::($this,button,path) -column 1 -row 0 -sticky nsew
    grid columnconfigure $widget::($this,path) 0 -weight 1
    grid rowconfigure $widget::($this,path) 0 -weight 1
    composite::complete $this
}

proc comboEntry::~comboEntry {this} {}

proc comboEntry::options {this} {
    return [list        [list -command {} {}]        [list -editable 1 1]        [list -font $widget::option(button,font)]        [list -justify $widget::option(entry,justify) $widget::option(entry,justify)]        [list -list {} {}]        [list -state normal]        [list -width $widget::option(entry,width) $widget::option(entry,width)]    ]
}

foreach option {-justify -width} {
    proc comboEntry::set$option {this value} "widget::configure \$composite::(\$this,entry) $option \$value"
}

proc comboEntry::set-command {this value} {}

proc comboEntry::set-editable {this value} {
    comboEntry::setStates $this
    comboEntry::setBindings $this
}

proc comboEntry::set-font {this value} {
    $composite::($this,entry,path) configure -font $value
    widget::configure $composite::($this,button) -font $value
}

proc comboEntry::set-list {this value} {
    widget::configure $composite::($this,button) -list $value
}

proc comboEntry::set-state {this value} {
    if {![regexp {^(disabled|normal)$} $value]} {
        error "bad state value \"$value\": must be normal or disabled"
    }
    setStates $this
    setBindings $this
}

proc comboEntry::set-troughcolor {this value} {
    widget::configure $composite::($this,button) -troughcolor $value
}

proc comboEntry::setStates {this} {
    if {[string equal $composite::($this,-state) disabled]} {
        widget::configure $composite::($this,button) -state disabled -takefocus 0
        if {[package vcompare $::tcl_version 8.4] < 0} {
            widget::configure $composite::($this,entry) -state disabled
        } else {
            widget::configure $composite::($this,entry) -state readonly
        }
    } else {
        widget::configure $composite::($this,button) -state normal
        if {$composite::($this,-editable)} {
            widget::configure $composite::($this,button) -takefocus 0
            widget::configure $composite::($this,entry) -state normal
        } else {
            widget::configure $composite::($this,button) -takefocus 1
            if {[package vcompare $::tcl_version 8.4] < 0} {
                widget::configure $composite::($this,entry) -state disabled
            } else {
                widget::configure $composite::($this,entry) -state readonly
            }
        }
    }
}

proc comboEntry::setBindings {this} {
    if {[string equal $composite::($this,-state) normal]&&$composite::($this,-editable)} {
        bind $composite::($this,entry,path) <Down> "comboButton::popupListBox $composite::($this,button)"
        bind $composite::($this,entry,path) <Return> "comboEntry::invoke $this"
        bind $composite::($this,entry,path) <KP_Enter> "comboEntry::invoke $this"
    } else {
        bind $composite::($this,entry,path) <Down> {}
        bind $composite::($this,entry,path) <Return> {}
        bind $composite::($this,entry,path) <KP_Enter> {}
    }
}

proc comboEntry::selected {this choice} {
    widget::configure $composite::($this,entry) -state normal
    set $this $choice
    setStates $this
    if {[string length $composite::($this,-command)]>0} {
        uplevel #0 $composite::($this,-command) [list $choice]
    }
}

proc comboEntry::invoke {this} {
    if {[string length $composite::($this,-command)]>0} {
        uplevel #0 $composite::($this,-command) [list [$composite::($this,entry,path) get]]
    }
}

proc comboEntry::set {this text} {
    $composite::($this,entry,path) delete 0 end
    $composite::($this,entry,path) insert 0 $text
}

proc comboEntry::get {this text} {
    return [$composite::($this,entry,path) get]
}


class optionMenu {}

proc optionMenu::optionMenu {this parentPath args} composite {
    [new frame $parentPath -relief $widget::option(button,relief) -borderwidth $widget::option(button,borderwidth)] $args
} {
    set path $widget::($this,path)
    grid rowconfigure $path 0 -weight 1
    grid columnconfigure $path 0 -weight 1
    composite::manage $this [new label $path -padx 0 -pady 0] label
    grid $composite::($this,label,path) -column 0 -row 0 -sticky nsew
    grid columnconfigure $path 1 -minsize $widget::option(button,borderwidth)
    composite::manage $this [new frame $path        -background $widget::option(button,background) -relief $widget::option(button,relief)        -borderwidth $widget::option(button,borderwidth) -width 12 -height 8    ] stub
    set stubPath $composite::($this,stub,path)
    grid $stubPath -column 2 -row 0
    grid columnconfigure $path 3 -minsize 8

    bind $path <Enter> "if {!\$tk_strictMotif} {$stubPath configure -background $widget::option(button,activebackground)}"
    bind $path <Leave> "if {!\$tk_strictMotif} {$stubPath configure -background $widget::option(button,background)}"

    composite::manage $this [new toplevel [winfo toplevel $parentPath] -cursor right_ptr] shell
    set shellPath $composite::($this,shell,path)
    if {$widget::option(menu,borderwidth)==0} {
        $shellPath configure -highlightbackground black -highlightthickness 1
    } else {
        $shellPath configure -relief raised -borderwidth $widget::option(menu,borderwidth)
    }
    wm overrideredirect $shellPath 1
    wm withdraw $shellPath

    global embed_args
    if {[info exists embed_args]} {
        set sequence <ButtonRelease-1>
    } else {
        set sequence <ButtonPress-1>
        bind $composite::($this,label,path) $sequence "optionMenu::popChoices $this"
    }
    bind $path $sequence "optionMenu::popChoices $this"
    bind $composite::($this,stub,path) $sequence "optionMenu::popChoices $this"
    set ($this,selectedLabelIndex) 0
    composite::complete $this
}

proc optionMenu::~optionMenu {this} {}

proc optionMenu::options {this} {
    return [list        [list -choices {} {}]        [list -command {} {}]        [list -font $widget::option(menu,font) $widget::option(menu,font)]        [list -popupcommand {} {}]        [list -takefocus 1]        [list -text {} {}]    ]
}

proc optionMenu::set-command {this value} {}
proc optionMenu::set-popupcommand {this value} {}

proc optionMenu::set-font {this value} {
    $composite::($this,label,path) configure -font $value
    set-choices $this $composite::($this,-choices)
}

proc optionMenu::set-text {this value} {
    $composite::($this,label,path) configure -text $value
}

proc optionMenu::set-choices {this value} {
    set path $composite::($this,shell,path)
    eval destroy [winfo children $path]
    set index 0
    set width 0
    foreach choice $composite::($this,-choices) {
        set label [label $path.$index -text $choice -relief flat -font $composite::($this,-font)]
        if {[winfo reqwidth $label]>$width} {
            set width [winfo reqwidth $label]
        }
        bind $label <Enter> "optionMenu::select $this $index"
        pack $label -fill x
        incr index
    }
    grid columnconfigure $widget::($this,path) 0 -minsize $width
    showTopLevel $path 0x0
    update idletasks
    wm withdraw $path
    wm geometry $path {}
}

proc optionMenu::set-takefocus {this value} {
    set path $widget::($this,path)
    switch $value {
        0 {
            bind $path <space> {}
            bind $path <Return> {}
            bind $path <KP_Enter> {}
            bind $path <Up> {}
            bind $path <Down> {}
            bind $path <Escape> {}
        }
        1 {
            bind $path <space> "optionMenu::processSpaceKey $this"
            bind $path <Return> "optionMenu::unpopChoices $this; optionMenu::checkSelection $this"
            bind $path <KP_Enter> [bind $path <Return>]
            bind $path <Up> "optionMenu::selectPrevious $this"
            bind $path <Down> "optionMenu::selectNext $this"
            bind $path <Escape> "optionMenu::unpopChoices $this"
        }
        default {
            error "bad takefocus value \"$value\": must be 0 or 1"
        }
    }
    $path configure -takefocus $value
}

proc optionMenu::popChoices {this} {
    if {        ([llength $composite::($this,-choices)] == 0) ||        (([string length $composite::($this,-popupcommand)] > 0) && ![uplevel #0 $composite::($this,-popupcommand)])    } return
    update idletasks
    set shellPath $composite::($this,shell,path)

    set selected [lindex [winfo children $composite::($this,shell,path)] $($this,selectedLabelIndex)]
    $selected configure -background $widget::option(menu,activebackground) -foreground $widget::option(menu,activeforeground)        -relief $widget::option(menu,relief)

    set labelPath $composite::($this,label,path)
    set x [expr {[winfo rootx $labelPath]-$widget::option(menu,borderwidth)}]
    if {$x<0} {set x 0}
    set y [expr {[winfo rooty $labelPath]+(([winfo height $labelPath]-[winfo height $selected])/2)-[winfo y $selected]}]
    if {$y<0} {set y 0}
    showTopLevel $shellPath        [expr {[winfo width $labelPath]+(2*$widget::option(menu,borderwidth))}]x[winfo reqheight $shellPath]+$x+$y
    update idletasks
    raise $shellPath
    set (previousGrab) [grab current $shellPath]
    global embed_args
    if {[info exists embed_args]} {
        bind $shellPath <ButtonRelease-1> "optionMenu::unpopChoices $this; optionMenu::checkSelection $this"
        grab $shellPath
    } else {
        after 300 "bind $shellPath <ButtonRelease-1> {optionMenu::unpopChoices $this; optionMenu::checkSelection $this}"
        grab -global $shellPath
    }
}

proc optionMenu::unpopChoices {this} {
    set path $composite::($this,shell,path)
    if {![winfo ismapped $path]} {
        return
    }
    wm withdraw $path
    if {[string length $(previousGrab)]>0} {
        grab $(previousGrab)
        unset (previousGrab)
    } else {
        grab release $path
    }
    bind $path <ButtonRelease-1> {}
}

proc optionMenu::checkSelection {this} {
    set selected [lindex [winfo children $composite::($this,shell,path)] $($this,selectedLabelIndex)]
    if {[string length $selected]==0} return
    set selection [$selected cget -text]
    composite::configure $this -text $selection
    invokeCommand $this $selection
}

proc optionMenu::invokeCommand {this choice} {
    if {[string length $composite::($this,-command)]>0} {
        uplevel #0 $composite::($this,-command) [list $choice]
    }
}

proc optionMenu::configureChoices {this args} {
    foreach label [winfo children $composite::($this,shell,path)] {
        eval $label configure $option $args
    }
}

proc optionMenu::select {this index} {
    if {![winfo ismapped $composite::($this,shell,path)]} {
        return
    }
    set labels [winfo children $composite::($this,shell,path)]
    if {$index<0} {
        set index 0
    } elseif {$index>=[llength $labels]} {
        set index [expr {[llength $labels]-1}]
    }
    [lindex $labels $($this,selectedLabelIndex)] configure -background $widget::option(menu,background)        -foreground $widget::option(menu,foreground) -relief flat
    [lindex $labels $index] configure -background $widget::option(menu,activebackground)        -foreground $widget::option(menu,activeforeground) -relief $widget::option(menu,relief)
    set ($this,selectedLabelIndex) $index
}

proc optionMenu::selectPrevious {this} {
    select $this [expr {$($this,selectedLabelIndex)-1}]
}

proc optionMenu::selectNext {this} {
    select $this [expr {$($this,selectedLabelIndex)+1}]
}

proc optionMenu::processSpaceKey {this} {
    if {[winfo ismapped $composite::($this,shell,path)]} {
        unpopChoices $this
        checkSelection $this
    } else {
        popChoices $this
    }
}
}
if {1} {
# copyright (C) 1995-2005 Jean-Luc Fontaine (mailto:jfontain@free.fr)


::stooop::class pieLabeler {

    set (default,font) {Helvetica -12}

    proc pieLabeler {this canvas args} {
        ::set ($this,canvas) $canvas
    }

    proc ~pieLabeler {this} {}

    ::stooop::virtual proc new {this slice args}    ;# must return a canvasLabel

    ::stooop::virtual proc delete {this label}

    ::stooop::virtual proc set {this label value}

    ::stooop::virtual proc label {this args} ;# set or get label if no arguments

    # set or get label background if no arguments
    ::stooop::virtual proc labelBackground {this args}

    # set or get text label background if no arguments
    ::stooop::virtual proc labelTextBackground {this args}

    ::stooop::virtual proc selectState {this label {state {}}}

    # must be invoked only by pie, which knows when it is necessary to update
    # (new or deleted label, resizing, ...):
    ::stooop::virtual proc update {this left top right bottom}
    # for the labelers that need to know when slices are updated:
    ::stooop::virtual proc updateSlices {this left top right bottom} {}

    ::stooop::virtual proc room {this arrayName}

}
# copyright (C) 1995-2005 Jean-Luc Fontaine (mailto:jfontain@free.fr)


::stooop::class pieBoxLabeler {

    proc pieBoxLabeler {this canvas args} pieLabeler {$canvas $args} switched {
        $args
    } {
        ::set ($this,array) [::stooop::new canvasLabelsArray $canvas]
        switched::complete $this
    }

    proc ~pieBoxLabeler {this} {
        ::stooop::delete $($this,array)
    }

    proc options {this} {
        # font and justify options are used when creating a new canvas label
        # justify option is used for both the labels array and the labels
        return [list            [list -font                $pieLabeler::(default,font) $pieLabeler::(default,font)            ]            [list -justify left left]            [list -offset 5 5]            [list -xoffset 0 0]        ]
    }

    foreach option {-font -justify -offset -xoffset} {
        # no dynamic options allowed
        proc set$option {this value} "
            if {\$switched::(\$this,complete)} {
                error {option $option cannot be set dynamically}
            }
        "
    }

    proc new {this slice args} {
        # variable arguments are for the created canvas label object
        ::set label [eval ::stooop::new canvasLabel            $pieLabeler::($this,canvas) $args            [list                -justify $switched::($this,-justify)                -font $switched::($this,-font) -selectrelief sunken            ]        ]
        canvasLabelsArray::manage $($this,array) $label
        # refresh our tags
        $pieLabeler::($this,canvas) addtag pieLabeler($this)            withtag canvasLabelsArray($($this,array))
        # always append semi-column to label:
        switched::configure $label -text [switched::cget $label -text]:
        ::set ($this,selected,$label) 0
        return $label
    }

    proc delete {this label} {
        canvasLabelsArray::delete $($this,array) $label
        unset ($this,selected,$label)
    }

    proc set {this label value} {
        # update string part after last semi-column
        regsub {:[^:]*$} [switched::cget $label -text] ": $value" text
        switched::configure $label -text $text
    }

    proc label {this label args} {
        ::set text [switched::cget $label -text]
        if {[llength $args] == 0} {
            regexp {^(.*):} $text dummy text
            return $text
        } else {                   ;# update string part before last semi-column
            regsub {^.*:} $text [lindex $args 0]: text
            switched::configure $label -text $text
        }
    }

    proc labelBackground {this label args} {
        if {[llength $args] == 0} {
            return [switched::cget $label -background]
        } else {
            switched::configure $label -background [lindex $args 0]
        }
    }

    proc labelTextBackground {this label args} {
        if {[llength $args] == 0} {
            return [switched::cget $label -textbackground]
        } else {
            switched::configure $label -textbackground [lindex $args 0]
        }
    }

    proc selectState {this label {selected {}}} {
        if {[string length $selected] == 0} {
            # return current state if no argument
            return $($this,selected,$label)
        }
        switched::configure $label -select $selected
        ::set ($this,selected,$label) $selected
    }

    proc update {this left top right bottom} {
        # whole pie coordinates, includings labeler labels
        ::set canvas $pieLabeler::($this,canvas)
        # first reposition labels array below pie graphics
        ::set array $($this,array)
        ::set width [expr {$right - $left}]
        if {$width != [switched::cget $array -width]} {
            switched::configure $array -width $width            ;# fit pie width
        } else {
            canvasLabelsArray::update $array
        }
        foreach {x y} [$canvas coords canvasLabelsArray($array)] {}
        $canvas move canvasLabelsArray($array) [expr {$left - $x}]            [expr {$bottom - [canvasLabelsArray::height $array] - $y}]
    }

    proc room {this arrayName} {
        upvar 1 $arrayName data

        ::set data(left) 0                        ;# no room taken around slices
        ::set data(right) 0
        ::set data(top) 0
        ::set box            [$pieLabeler::($this,canvas) bbox canvasLabelsArray($($this,array))]
        if {[llength $box] == 0} {                              ;# no labels yet
            ::set data(bottom) 0
        } else {                    ;# room taken by all labels including offset
            ::set data(bottom) [expr {                [lindex $box 3] - [lindex $box 1] + $switched::($this,-offset)            }]
        }
    }

}
# copyright (C) 1995-2005 Jean-Luc Fontaine (mailto:jfontain@free.fr)


::stooop::class canvasReliefRectangle {

    proc canvasReliefRectangle {this canvas args} switched {$args} {
        set ($this,topLeft)            [$canvas create line 0 0 0 0 0 0 -tags canvasReliefRectangle($this)]
        set ($this,bottomRight)            [$canvas create line 0 0 0 0 0 0 -tags canvasReliefRectangle($this)]
        set ($this,canvas) $canvas
        switched::complete $this
    }

    proc ~canvasReliefRectangle {this} {
        $($this,canvas) delete canvasReliefRectangle($this)
    }

    proc options {this} {
        # force background initialization for color calculations
        return [list            [list -background white]            [list -coordinates {0 0 0 0} {0 0 0 0}]            [list -relief flat flat]        ]
    }

    proc set-background {this value} {       ;# algorithm stolen from tkUnix3d.c
        set intensity 65535                                 ;# maximum intensity
        foreach {red green blue} [winfo rgb $($this,canvas) $value] {}
        if {            (                ($red * 0.5 * $red) + ($green * 1.0 * $green) +                ($blue * 0.28 * $blue)            ) < ($intensity * 0.05 * $intensity)        } {
            set ($this,dark) [format {#%04X%04X%04X}                [expr {($intensity + (3 * $red)) / 4}]                [expr {($intensity + (3 * $green)) / 4}]                [expr {($intensity + (3 * $blue)) / 4}]            ]
        } else {
            set ($this,dark) [format {#%04X%04X%04X}                [expr {(60 * $red) / 100}] [expr {(60 * $green) / 100}]                [expr {(60 * $blue) / 100}]            ]
        }
        if {$green > ($intensity * 0.95)} {
            set ($this,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 ($this,light)                [format {#%04X%04X%04X} $lightRed $lightGreen $lightBlue]
        }
        update $this
    }

    proc set-coordinates {this value} {
        foreach {left top right bottom} $value {}
        $($this,canvas) coords $($this,topLeft)            $left $bottom $left $top $right $top
        $($this,canvas) coords $($this,bottomRight)            $right $top $right $bottom $left $bottom
    }

    proc set-relief {this value} {
        if {![info exists ($this,dark)]} return     ;# colors not yet calculated
        update $this
    }

    proc update {this} {
        switch $switched::($this,-relief) {
            flat {
                $($this,canvas) itemconfigure canvasReliefRectangle($this)                    -fill $switched::($this,-background)
            }
            raised {
                $($this,canvas) itemconfigure $($this,topLeft)                    -fill $($this,light)
                $($this,canvas) itemconfigure $($this,bottomRight)                    -fill $($this,dark)
            }
            sunken {
                $($this,canvas) itemconfigure $($this,topLeft)                    -fill $($this,dark)
                $($this,canvas) itemconfigure $($this,bottomRight)                    -fill $($this,light)
            }
            default {
                error "bad relief value \"$value\": must be flat, raised or sunken"
            }
        }
    }

}
# copyright (C) 1995-2005 Jean-Luc Fontaine (mailto:jfontain@free.fr)


::stooop::class canvasLabel {

    proc canvasLabel {this canvas args} switched {$args} {
        set ($this,canvas) $canvas
        # use an empty image as an origin marker with only 2 coordinates
        set ($this,origin) [$canvas create image 0 0 -tags canvasLabel($this)]
        set ($this,selectRectangle)            [$canvas create rectangle 0 0 0 0 -tags canvasLabel($this)]
        set ($this,rectangle)            [$canvas create rectangle 0 0 0 0 -tags canvasLabel($this)]
        set ($this,text) [$canvas create text 0 0 -tags canvasLabel($this)]
        switched::complete $this
    }

    proc ~canvasLabel {this} {
        eventuallyDeleteRelief $this
        $($this,canvas) delete canvasLabel($this)
    }

    proc options {this} {                ;# force font for proper initialization
        return [list            [list -anchor center center]            [list -background {} {}]            [list -bordercolor black black]            [list -borderwidth 1 1]            [list -bulletwidth 10 10]            [list -font {Helvetica -12}]            [list -foreground black black]            [list -justify left left]            [list -minimumwidth 0 0]            [list -padding 2 2]            [list -scale {1 1} {1 1}]            [list -select 0 0]            [list -selectrelief flat flat]            [list -stipple {} {}]            [list -text {} {}]            [list -textbackground {} {}]            [list -width 0 0]        ]
    }

    proc set-background {this value} {
        $($this,canvas) itemconfigure $($this,rectangle) -fill $value
    }

    proc set-bordercolor {this value} {
        $($this,canvas) itemconfigure $($this,rectangle) -outline $value
    }

    proc set-borderwidth {this value} {
        if {            ![string equal $switched::($this,-selectrelief) flat] &&            ($value > 1)        } {
            error "border width greater than 1 is not supported with $switched::($this,-selectrelief) select relief"
        }
        $($this,canvas) itemconfigure $($this,selectRectangle) -width $value
        $($this,canvas) itemconfigure $($this,rectangle) -width $value
        update $this
    }

    proc set-foreground {this value} {
        $($this,canvas) itemconfigure $($this,text) -fill $value
    }

    proc set-scale {this value} {
        # value is a list of ratios of the horizontal and vertical axis
        update $this       ;# refresh display which takes new scale into account
    }

    proc set-stipple {this value} {
        $($this,canvas) itemconfigure $($this,rectangle) -stipple $value
    }

    foreach option {        -anchor -bulletwidth -minimumwidth -padding -select -textbackground    } {
        proc set$option {this value} {update $this}
    }

    foreach option {-font -justify -text -width} {
        proc set$option {this value} "
            \$(\$this,canvas) itemconfigure \$(\$this,text) $option \$value
            update \$this
        "
    }

    proc set-selectrelief {this value} {
        if {![regexp {^(flat|raised|sunken)$} $value]} {
            error "bad relief value \"$value\": must be flat, raised or sunken"
        }
        if {[string equal $value flat]} {
            eventuallyDeleteRelief $this
        } else {
            if {$switched::($this,-borderwidth) > 1} {
                error "border width greater than 1 is not supported with $value select relief"
            }
        }
        update $this
    }

    proc eventuallyDeleteRelief {this} {
        if {[info exists ($this,relief)]} {
            ::stooop::delete $($this,relief)
            unset ($this,relief)
        }
    }

    proc updateRelief {this coordinates} {
        if {$switched::($this,-select)} {
            set relief $switched::($this,-selectrelief)
            if {[string equal $relief flat]} {
                eventuallyDeleteRelief $this
            } else {
                set canvas $($this,canvas)
                if {![info exists ($this,relief)]} {
                    set ($this,relief) [::stooop::new canvasReliefRectangle                        $canvas -relief $relief                    ]
                    set reliefTag canvasReliefRectangle($($this,relief))
                    foreach tag [$canvas gettags canvasLabel($this)] {
                        # adopt all label tags so moving along works
                        $canvas addtag $tag withtag $reliefTag
                    }
                }
                set background $switched::($this,-textbackground)
                if {[string length $background] == 0} {
                    # emulate transparent background
                    set background [$canvas cget -background]
                }
                switched::configure $($this,relief)                    -background $background -coordinates {0 0 0 0}
                switched::configure $($this,relief) -coordinates $coordinates
            }
        } else {
            eventuallyDeleteRelief $this
        }
    }

    proc update {this} {
        set canvas $($this,canvas)
        set rectangle $($this,rectangle)
        set selectRectangle $($this,selectRectangle)
        set text $($this,text)

        foreach {x y} [$canvas coords $($this,origin)] {}

        set border [$canvas itemcget $rectangle -width]
        set textBox [$canvas bbox $text]
        set textWidth [expr {[lindex $textBox 2] - [lindex $textBox 0]}]
        set padding [winfo fpixels $canvas $switched::($this,-padding)]
        set bulletWidth [winfo fpixels $canvas $switched::($this,-bulletwidth)]

        $canvas itemconfigure $selectRectangle -fill {} -outline {}

        # position rectangle and text as if anchor was center (the default)
        set width [expr {$bulletWidth + $border + $padding + $textWidth}]
        set halfHeight [expr {            (([lindex $textBox 3] - [lindex $textBox 1]) / 2.0) + $border        }]
        if {$width < $switched::($this,-minimumwidth)} {
            set width $switched::($this,-minimumwidth)
        }
        set halfWidth [expr {$width / 2.0}]
        set left [expr {$x - $halfWidth}]
        set top [expr {$y - $halfHeight}]
        set right [expr {$x + $halfWidth}]
        set bottom [expr {$y + $halfHeight}]
        $canvas coords $text [expr {            $left + $bulletWidth + $border + $padding + ($textWidth / 2.0)        }] $y
        $canvas coords $selectRectangle $left $top $right $bottom
        $canvas coords $rectangle $left $top            [expr {$left + $bulletWidth}] $bottom
        $canvas itemconfigure $selectRectangle            -fill $switched::($this,-textbackground)            -outline $switched::($this,-textbackground)
        updateRelief $this            [list [expr {$left + $bulletWidth + 1}] $top $right $bottom]
        # now move rectangle and text according to anchor
        set anchor $switched::($this,-anchor)
        set xDelta [expr {            ([string match *w $anchor] - [string match *e $anchor]) *            $halfWidth        }]
        set yDelta [expr {            ([string match n* $anchor] - [string match s* $anchor]) *            $halfHeight        }]
        $canvas move $rectangle $xDelta $yDelta
        $canvas move $selectRectangle $xDelta $yDelta
        $canvas move $text $xDelta $yDelta
        if {[info exists ($this,relief)]} {
            $canvas move canvasReliefRectangle($($this,relief)) $xDelta $yDelta
        }
        # finally apply scale
        eval $canvas scale canvasLabel($this) $x $y $switched::($this,-scale)
    }

}
# copyright (C) 1995-2005 Jean-Luc Fontaine (mailto:jfontain@free.fr)


::stooop::class canvasLabelsArray {

    proc canvasLabelsArray {this canvas args} switched {$args} {
        set ($this,canvas) $canvas
        # use an empty image as an origin marker with only 2 coordinates
        set ($this,origin)            [$canvas create image 0 0 -tags canvasLabelsArray($this)]
        set ($this,labels) {}
        switched::complete $this
    }

    proc ~canvasLabelsArray {this} {
        eval ::stooop::delete $($this,labels)
        # delete remaining items
        $($this,canvas) delete canvasLabelsArray($this)
    }

    proc options {this} {
        # force width initialization for internals initialization:
        return [list            [list -justify left left]            [list -width 100]        ]
    }

    proc set-justify {this value} {
        if {$switched::($this,complete)} {
            error {option -justify cannot be set dynamically}
        }
    }

    proc set-width {this value} {
        set ($this,width) [winfo fpixels $($this,canvas) $value]
        update $this
    }

    proc manage {this label} {                          ;# must be a canvasLabel
        $($this,canvas) addtag canvasLabelsArray($this)            withtag canvasLabel($label)
        lappend ($this,labels) $label
        update $this
    }

    proc delete {this label} {
        set index [lsearch -exact $($this,labels) $label]
        if {$index < 0} {
            error "invalid label $label for canvas labels array $this"
        }
        set ($this,labels) [lreplace $($this,labels) $index $index]
        ::stooop::delete $label
        update $this
    }

    proc update {this} {
        set canvas $($this,canvas)
        set halfWidth [expr {round($($this,width) / 2.0)}]
        foreach {xOrigin yOrigin} [$canvas coords $($this,origin)] {}
        set x 0; set y 0
        set height 0
        set column 0
        foreach label $($this,labels) {
            foreach {left top right bottom}                [$canvas bbox canvasLabel($label)] {}
            set wide [expr {($right - $left) > $halfWidth}]
            if {$wide} {
                # label does not fit in a half width so open a new line
                set x 0; incr y $height; set height 0
            }
            switched::configure $label -anchor nw
            # do an absolute positioning using label tag:
            foreach {xDelta yDelta} [$canvas coords canvasLabel($label)] {}
            $canvas move canvasLabel($label) [expr {$xOrigin + $x - $xDelta}]                [expr {$yOrigin + $y - $yDelta}]
            set value [expr {$bottom - $top}]
            if {$value > $height} {         ;# keep track of current line height
                set height $value
            }
            if {([incr x $halfWidth] > $halfWidth) || $wide} {
                set x 0; incr y $height; set height 0
            }
        }
    }

    proc labels {this} {
        return $($this,labels)
    }

    proc height {this} {
        set list [$($this,canvas) bbox canvasLabelsArray($this)]
        if {[llength $list] == 0} {
            return 0
        }
        foreach {left top right bottom} $list {}
        return [expr {$bottom - $top}]
    }

}
# copyright (C) 1995-2005 Jean-Luc Fontaine (mailto:jfontain@free.fr)


::stooop::class piePeripheralLabeler {

    variable PI 3.14159265358979323846

    proc piePeripheralLabeler {this canvas args} pieLabeler {$canvas $args}        switched {$args} {
        switched::complete $this
        ::set ($this,array) [::stooop::new canvasLabelsArray $canvas            -justify $switched::($this,-justify)        ]
        ::set ($this,valueWidth) [font measure            $switched::($this,-smallfont) $switched::($this,-widestvaluetext)        ]
        ::set ($this,valueHeight)            [font metrics $switched::($this,-smallfont) -ascent]
    }

    proc ~piePeripheralLabeler {this} {
        ::stooop::delete $($this,array)
        # delete remaining items (should be in pieLabeler destructor)
        $pieLabeler::($this,canvas) delete pieLabeler($this)
    }

    proc options {this} {
        # bullet width, font and justify options are used when creating a new
        # canvas label
        # justify option is used for both the labels array and the labels
        return [list            [list -bulletwidth 20 20]            [list -font                $pieLabeler::(default,font) $pieLabeler::(default,font)            ]            [list -justify left left]            [list -offset 5 5]            [list -smallfont {Helvetica -10} {Helvetica -10}]            [list -widestvaluetext 0.00 0.00]        ]
    }

    foreach option {        -bulletwidth -font -justify -offset -smallfont -widestvaluetext    } {                                            ;# no dynamic options allowed
        proc set$option {this value} "
            if {\$switched::(\$this,complete)} {
                error {option $option cannot be set dynamically}
            }
        "
    }

    proc set-smallfont {this value} {
        if {$switched::($this,complete)} {
            error {option -smallfont cannot be set dynamically}
        }
    }

    proc new {this slice args} {
        # variable arguments are for the created canvas label object
        ::set canvas $pieLabeler::($this,canvas)
        ::set text [$canvas create text 0 0            -font $switched::($this,-smallfont) -tags pieLabeler($this)        ]                                                  ;# create value label
        ::set label [eval ::stooop::new canvasLabel            $pieLabeler::($this,canvas) $args            [list                -justify $switched::($this,-justify)                -bulletwidth $switched::($this,-bulletwidth)                -font $switched::($this,-font) -selectrelief sunken            ]        ]
        canvasLabelsArray::manage $($this,array) $label
        $canvas addtag pieLabeler($this)            withtag canvasLabelsArray($($this,array))        ;# refresh our tags
        # value text item is the only one to update
        ::set ($this,textItem,$label) $text
        ::set ($this,slice,$label) $slice
        ::set ($this,selected,$label) 0
        return $label
    }

    proc anglePosition {degrees} {
        # quadrant specific index with added value for exact quarters
        return [expr {(2 * ($degrees / 90)) + (($degrees % 90) != 0)}]
    }

    ::set index 0     ;# build angle position / value label anchor mapping array
    foreach anchor {w sw s se e ne n nw} {
        ::set (anchor,[anglePosition [expr {$index * 45}]]) $anchor
        incr index
    }
    unset index anchor

    proc set {this label value} {
        ::set text $($this,textItem,$label)
        position $this $text $($this,slice,$label)
        $pieLabeler::($this,canvas) itemconfigure $text -text $value
    }

    proc label {this label args} {
        if {[llength $args] == 0} {
            return [switched::cget $label -text]
        } else {
            switched::configure $label -text [lindex $args 0]
        }
    }

    proc labelBackground {this label args} {
        if {[llength $args] == 0} {
            return [switched::cget $label -background]
        } else {
            switched::configure $label -background [lindex $args 0]
        }
    }

    proc labelTextBackground {this label args} {
        if {[llength $args] == 0} {
            return [switched::cget $label -textbackground]
        } else {
            switched::configure $label -textbackground [lindex $args 0]
        }
    }

    proc position {this text slice} {
        # place the value text item next to the outter border of the
        # corresponding slice
        variable PI

        # retrieve current slice position and dimensions
        slice::data $slice data
        # calculate text closest point coordinates in normal coordinates system
        # (y increasing in north direction)
        ::set midAngle [expr {$data(start) + ($data(extent) / 2.0)}]
        ::set radians [expr {$midAngle * $PI / 180}]
        ::set x [expr {            ($data(xRadius) + $switched::($this,-offset)) * cos($radians)        }]
        ::set y [expr {            ($data(yRadius) + $switched::($this,-offset)) * sin($radians)        }]
        ::set angle [expr {round($midAngle) % 360}]
        if {$angle > 180} {
            ::set y [expr {$y - $data(height)}]     ;# account for pie thickness
        }

        ::set canvas $pieLabeler::($this,canvas)
        # now transform coordinates according to canvas coordinates system
        ::set coordinates [$canvas coords $text]
        $canvas move $text            [expr {$data(xCenter) + $x - [lindex $coordinates 0]}]            [expr {$data(yCenter) - $y - [lindex $coordinates 1]}]
        # finally set anchor according to which point of the text is closest to
        # pie graphics
        $canvas itemconfigure $text -anchor $(anchor,[anglePosition $angle])
    }

    proc delete {this label} {
        canvasLabelsArray::delete $($this,array) $label
        $pieLabeler::($this,canvas) delete $($this,textItem,$label)
        unset            ($this,textItem,$label) ($this,slice,$label) ($this,selected,$label)
        # finally reposition the remaining value text items next to their slices
        foreach label [canvasLabelsArray::labels $($this,array)] {
            position $this $($this,textItem,$label) $($this,slice,$label)
        }
    }

    proc selectState {this label {selected {}}} {
        if {[string length $selected] == 0} {
            # return current state if no argument
            return $($this,selected,$label)
        }
        switched::configure $label -select $selected
        ::set ($this,selected,$label) $selected
    }

    proc update {this left top right bottom} {
        # arguments: whole pie coordinates, includings labeler labels
        ::set canvas $pieLabeler::($this,canvas)
        # first reposition labels array below pie graphics
        ::set array $($this,array)
        ::set width [expr {$right - $left}]
        if {$width != [switched::cget $array -width]} {
            switched::configure $array -width $width            ;# fit pie width
        } else {
            canvasLabelsArray::update $array
        }
        foreach {x y} [$canvas coords canvasLabelsArray($array)] {}
        $canvas move canvasLabelsArray($array) [expr {$left - $x}]            [expr {$bottom - [canvasLabelsArray::height $array] - $y}]
    }

    proc updateSlices {this left top right bottom} {
        foreach label [canvasLabelsArray::labels $($this,array)] {
            # position peripheral labels
            position $this $($this,textItem,$label) $($this,slice,$label)
        }
    }

    proc room {this arrayName} {
        upvar 1 $arrayName data

        ::set data(left)            [expr {$($this,valueWidth) + $switched::($this,-offset)}]
        ::set data(right) $data(left)
        ::set data(top)            [expr {$switched::($this,-offset) + $($this,valueHeight)}]
        ::set box            [$pieLabeler::($this,canvas) bbox canvasLabelsArray($($this,array))]
        if {[llength $box] == 0} {                              ;# no labels yet
            ::set data(bottom) $data(top)
        } else {                    ;# room taken by all labels including offset
            ::set data(bottom)                [expr {$data(top) + [lindex $box 3] - [lindex $box 1]}]
        }
    }

}
# copyright (C) 1995-2005 Jean-Luc Fontaine (mailto:jfontain@free.fr)


::stooop::class slice {
    variable PI 3.14159265358979323846
}

proc slice::slice {this canvas xRadius yRadius args} switched {$args} {
    # all parameter dimensions must be in pixels
    # note: all slice elements are tagged with slice($this)
    set ($this,canvas) $canvas
    set ($this,xRadius) $xRadius
    set ($this,yRadius) $yRadius
    switched::complete $this
    # wait till all options have been set for initial configuration
    complete $this
    update $this
}

proc slice::~slice {this} {
    if {[string length $switched::($this,-deletecommand)] > 0} {
        # always invoke command at global level
        uplevel #0 $switched::($this,-deletecommand)
    }
    $($this,canvas) delete slice($this)
}

proc slice::options {this} {
    return [list        [list -bottomcolor {} {}]        [list -deletecommand {} {}]        [list -height 0 0]        [list -scale {1 1} {1 1}]        [list -startandextent {0 0} {0 0}]        [list -topcolor {} {}]    ]
}

proc slice::set-height {this value} {      ;# not a dynamic option: see complete
    if {$switched::($this,complete)} {
        error {option -height cannot be set dynamically}
    }
}

proc slice::set-bottomcolor {this value} {
    if {![info exists ($this,startBottomArcFill)]} return
    set canvas $($this,canvas)
    $canvas itemconfigure $($this,startBottomArcFill)        -fill $value -outline $value
    $canvas itemconfigure $($this,startPolygon) -fill $value
    $canvas itemconfigure $($this,endBottomArcFill) -fill $value -outline $value
    $canvas itemconfigure $($this,endPolygon) -fill $value
}

proc slice::set-topcolor {this value} {
    if {![info exists ($this,topArc)]} return
    $($this,canvas) itemconfigure $($this,topArc) -fill $value
}

# data is stored at switched level
proc slice::set-deletecommand {this value} {}

proc slice::set-scale {this value} {
    if {$switched::($this,complete) && ($value > 0)} {
        # check for valid value following a non reproducible bug report
        update $this                   ;# requires initialization to be complete
    }
}

proc slice::set-startandextent {this value} {
    foreach {start extent} $value {}
    set ($this,start) [normalizedAngle $start]
    if {$extent < 0} {
        set ($this,extent) 0                 ;# a negative extent is meaningless
    } elseif {$extent >= 360} {
        # get as close as possible to 360, which would not work as it is
        # equivalent to 0
        set ($this,extent) [expr {360 - pow(10, -$::tcl_precision + 3)}]
    } else {
        set ($this,extent) $extent
    }
    if {$switched::($this,complete)} {
        update $this                   ;# requires initialization to be complete
    }
}

proc slice::normalizedAngle {value} {
    # normalize value between -180 and 180 degrees (not included)
    while {$value >= 180} {
        set value [expr {$value - 360}]
    }
    while {$value < -180} {
        set value [expr {$value + 360}]
    }
    return $value
}

proc slice::complete {this} {
    set canvas $($this,canvas)
    set xRadius $($this,xRadius)
    set yRadius $($this,yRadius)
    set bottomColor $switched::($this,-bottomcolor)
    # use an empty image as an origin marker with only 2 coordinates
    set ($this,origin)        [$canvas create image -$xRadius -$yRadius -tags slice($this)]
    if {$switched::($this,-height) > 0} {                                  ;# 3D
        set ($this,startBottomArcFill) [$canvas create arc            0 0 0 0 -style chord -extent 0 -fill $bottomColor            -outline $bottomColor -tags slice($this)        ]
        set ($this,startPolygon) [$canvas create polygon 0 0 0 0 0 0            -fill $bottomColor -tags slice($this)        ]
        set ($this,startBottomArc) [$canvas create arc 0 0 0 0            -style arc -extent 0 -fill black -tags slice($this)        ]
        set ($this,endBottomArcFill) [$canvas create arc 0 0 0 0            -style chord -extent 0 -fill $bottomColor            -outline $bottomColor -tags slice($this)        ]
        set ($this,endPolygon) [$canvas create polygon 0 0 0 0 0 0            -fill $bottomColor -tags slice($this)        ]
        set ($this,endBottomArc) [$canvas create arc 0 0 0 0            -style arc -extent 0 -fill black -tags slice($this)        ]
        set ($this,startLeftLine)            [$canvas create line 0 0 0 0 -tags slice($this)]
        set ($this,startRightLine)            [$canvas create line 0 0 0 0 -tags slice($this)]
        set ($this,endLeftLine) [$canvas create line 0 0 0 0 -tags slice($this)]
        set ($this,endRightLine)            [$canvas create line 0 0 0 0 -tags slice($this)]
    }
    set ($this,topArc) [$canvas create arc        -$xRadius -$yRadius $xRadius $yRadius        -fill $switched::($this,-topcolor) -tags slice($this)    ]
    # move slice so upper-left corner is at requested coordinates
    $canvas move slice($this) $xRadius $yRadius
}

proc slice::update {this} {
    set canvas $($this,canvas)
    # first store slice position in case it was moved as a whole
    set coordinates [$canvas coords $($this,origin)]
    set xRadius $($this,xRadius)
    set yRadius $($this,yRadius)
    $canvas coords $($this,origin) -$xRadius -$yRadius
    $canvas coords $($this,topArc) -$xRadius -$yRadius $xRadius $yRadius
    $canvas itemconfigure $($this,topArc)        -start $($this,start) -extent $($this,extent)
    if {$switched::($this,-height) > 0} {                                  ;# 3D
        updateBottom $this
    }
    # now position slice at the correct coordinates
    $canvas move slice($this) [expr {[lindex $coordinates 0] + $xRadius}]        [expr {[lindex $coordinates 1] + $yRadius}]
    # finally apply scale
    eval $canvas scale slice($this) $coordinates $switched::($this,-scale)
}

proc slice::updateBottom {this} {
    variable PI

    set start $($this,start)
    set extent $($this,extent)

    set canvas $($this,canvas)
    set xRadius $($this,xRadius)
    set yRadius $($this,yRadius)
    set height $switched::($this,-height)

    # first make all bottom parts invisible
    $canvas itemconfigure $($this,startBottomArcFill) -extent 0
    $canvas coords $($this,startBottomArcFill)        -$xRadius -$yRadius $xRadius $yRadius
    $canvas move $($this,startBottomArcFill) 0 $height
    $canvas itemconfigure $($this,startBottomArc) -extent 0
    $canvas coords $($this,startBottomArc) -$xRadius -$yRadius $xRadius $yRadius
    $canvas move $($this,startBottomArc) 0 $height
    $canvas coords $($this,startLeftLine) 0 0 0 0
    $canvas coords $($this,startRightLine) 0 0 0 0
    $canvas itemconfigure $($this,endBottomArcFill) -extent 0
    $canvas coords $($this,endBottomArcFill)        -$xRadius -$yRadius $xRadius $yRadius
    $canvas move $($this,endBottomArcFill) 0 $height
    $canvas itemconfigure $($this,endBottomArc) -extent 0
    $canvas coords $($this,endBottomArc) -$xRadius -$yRadius $xRadius $yRadius
    $canvas move $($this,endBottomArc) 0 $height
    $canvas coords $($this,endLeftLine) 0 0 0 0
    $canvas coords $($this,endRightLine) 0 0 0 0
    $canvas coords $($this,startPolygon) 0 0 0 0 0 0 0 0
    $canvas coords $($this,endPolygon) 0 0 0 0 0 0 0 0

    set startX [expr {$xRadius * cos($start * $PI / 180)}]
    set startY [expr {-$yRadius * sin($start * $PI / 180)}]
    set end [normalizedAngle [expr {$start + $extent}]]
    set endX [expr {$xRadius * cos($end * $PI / 180)}]
    set endY [expr {-$yRadius * sin($end * $PI / 180)}]

    set startBottom [expr {$startY + $height}]
    set endBottom [expr {$endY + $height}]

    if {(($start >= 0) && ($end >= 0)) || (($start < 0) && ($end < 0))} {
        # start and end angles are on the same side of the 0 abscissa
        if {$extent <= 180} {                ;# slice size is less than half pie
            if {$start < 0} {    ;# slice is facing viewer, so bottom is visible
                $canvas itemconfigure $($this,startBottomArcFill)                    -start $start -extent $extent
                $canvas itemconfigure $($this,startBottomArc)                    -start $start -extent $extent
                # only one polygon is needed
                $canvas coords $($this,startPolygon)                    $startX $startY $endX $endY                    $endX $endBottom $startX $startBottom
                $canvas coords $($this,startLeftLine)                    $startX $startY $startX $startBottom
                $canvas coords $($this,startRightLine)                    $endX $endY $endX $endBottom
            }                                        ;# else only top is visible
        } else {                             ;# slice size is more than half pie
            if {$start < 0} {
                # slice opening is facing viewer, so bottom is in 2 parts
                $canvas itemconfigure $($this,startBottomArcFill)                    -start 0 -extent $start
                $canvas itemconfigure $($this,startBottomArc)                    -start 0 -extent $start
                $canvas coords $($this,startPolygon)                    $startX $startY $xRadius 0                    $xRadius $height $startX $startBottom
                $canvas coords $($this,startLeftLine)                    $startX $startY $startX $startBottom
                $canvas coords $($this,startRightLine)                    $xRadius 0 $xRadius $height

                set bottomArcExtent [expr {$end + 180}]
                $canvas itemconfigure $($this,endBottomArcFill)                    -start -180 -extent $bottomArcExtent
                $canvas itemconfigure $($this,endBottomArc)                    -start -180 -extent $bottomArcExtent
                $canvas coords $($this,endPolygon)                    -$xRadius 0 $endX $endY $endX $endBottom -$xRadius $height
                $canvas coords $($this,endLeftLine)                    -$xRadius 0 -$xRadius $height
                $canvas coords $($this,endRightLine)                    $endX $endY $endX $endBottom
            } else {
                # slice back is facing viewer, so bottom occupies half the pie
                $canvas itemconfigure $($this,startBottomArcFill)                    -start 0 -extent -180
                $canvas itemconfigure $($this,startBottomArc)                    -start 0 -extent -180
                # only one polygon is needed
                $canvas coords $($this,startPolygon)                    -$xRadius 0 $xRadius 0 $xRadius $height -$xRadius $height
                $canvas coords $($this,startLeftLine)                    -$xRadius 0 -$xRadius $height
                $canvas coords $($this,startRightLine)                    $xRadius 0 $xRadius $height
            }
        }
    } else {     ;# start and end angles are on opposite sides of the 0 abscissa
        if {$start < 0} {                        ;# slice start is facing viewer
            $canvas itemconfigure $($this,startBottomArcFill)                -start 0 -extent $start
            $canvas itemconfigure $($this,startBottomArc)                -start 0 -extent $start
            # only one polygon is needed
            $canvas coords $($this,startPolygon) $startX $startY $xRadius 0                $xRadius $height $startX $startBottom
            $canvas coords $($this,startLeftLine)                $startX $startY $startX $startBottom
            $canvas coords $($this,startRightLine) $xRadius 0 $xRadius $height
        } else {                                   ;# slice end is facing viewer
            set bottomArcExtent [expr {$end + 180}]
            $canvas itemconfigure $($this,endBottomArcFill)                -start -180 -extent $bottomArcExtent
            $canvas itemconfigure $($this,endBottomArc)                -start -180 -extent $bottomArcExtent
            # only one polygon is needed
            $canvas coords $($this,endPolygon)                -$xRadius 0 $endX $endY $endX $endBottom -$xRadius $height
            $canvas coords $($this,startLeftLine) -$xRadius 0 -$xRadius $height
            $canvas coords $($this,startRightLine) $endX $endY $endX $endBottom
        }
    }
}

proc slice::rotate {this angle} {
    if {$angle == 0} return
    set ($this,start) [normalizedAngle [expr {$($this,start) + $angle}]]
    update $this
}

# return actual sizes and positions after scaling
proc slice::data {this arrayName} {
    upvar 1 $arrayName data

    set data(start) $($this,start)
    set data(extent) $($this,extent)
    foreach {x y} $switched::($this,-scale) {}
    set data(xRadius) [expr {$x * $($this,xRadius)}]
    set data(yRadius) [expr {$y * $($this,yRadius)}]
    set data(height) [expr {$y * $switched::($this,-height)}]
    foreach {x y} [$($this,canvas) coords $($this,origin)] {}
    set data(xCenter) [expr {$x + $data(xRadius)}]
    set data(yCenter) [expr {$y + $data(yRadius)}]
}


::stooop::class selector {

    proc selector {this args} switched {$args} {
        ::set ($this,order) 0
        switched::complete $this
    }

    proc ~selector {this} {
        variable ${this}selected
        variable ${this}order

        catch {::unset ${this}selected ${this}order}
    }

    proc options {this} {
        return [::list            [::list -selectcommand {} {}]        ]
    }

    proc set-selectcommand {this value} {}

    proc set {this indices selected} {
        variable ${this}selected
        variable ${this}order

        ::set select {}
        ::set deselect {}
        foreach index $indices {
            if {                [info exists ${this}selected($index)] &&                ($selected == [::set ${this}selected($index)])            } continue
            if {$selected} {
                lappend select $index
                ::set ${this}selected($index) 1
            } else {
                lappend deselect $index
                ::set ${this}selected($index) 0
            }
            ::set ${this}order($index) $($this,order)
            incr ($this,order)
        }
        update $this $select $deselect
    }

    proc update {this selected deselected} {
        if {[string length $switched::($this,-selectcommand)] == 0} return
        if {[llength $selected] > 0} {
            uplevel #0 $switched::($this,-selectcommand) [::list $selected] 1
        }
        if {[llength $deselected] > 0} {
            uplevel #0 $switched::($this,-selectcommand) [::list $deselected] 0
        }
    }

    proc unset {this indices} {
        variable ${this}selected
        variable ${this}order

        foreach index $indices {
            ::unset ${this}selected($index) ${this}order($index)
        }
    }

    proc ordered {this index1 index2} {
        variable ${this}order

        return [expr {            [::set ${this}order($index1)] - [::set ${this}order($index2)]        }]
    }


    proc add {this indices} {
        set $this $indices 0
    }

    proc remove {this indices} {
        unset $this $indices
    }

    proc select {this indices} {
        clear $this
        set $this $indices 1
        ::set ($this,lastSelected) [lindex $indices end]
    }

    proc deselect {this indices} {
        set $this $indices 0
    }

    proc toggle {this indices} {
        variable ${this}selected
        variable ${this}order

        ::set select {}
        ::set deselect {}
        foreach index $indices {
            if {[::set ${this}selected($index)]} {
                lappend deselect $index
                ::set ${this}selected($index) 0
                if {                    [info exists ($this,lastSelected)] &&                    ($index == $($this,lastSelected))                } {
                    ::unset ($this,lastSelected)
                }
            } else {
                lappend select $index
                ::set ${this}selected($index) 1
                ::set ($this,lastSelected) $index
            }
            ::set ${this}order($index) $($this,order)
            incr ($this,order)
        }
        update $this $select $deselect
    }

    ::stooop::virtual proc extend {this index} {}

    proc clear {this} {
        variable ${this}selected

        set $this [array names ${this}selected] 0
    }

    ::stooop::virtual proc selected {this} {
        variable ${this}selected

        ::set list {}
        foreach {index value} [array get ${this}selected] {
            if {$value} {
                lappend list $index
            }
        }
        return [lsort -command "ordered $this" $list]
    }

    ::stooop::virtual proc list {this} {
        variable ${this}selected

        return [lsort -command "ordered $this" [array names ${this}selected]]
    }

}



::stooop::class objectSelector {

    proc objectSelector {this args} selector {$args} {}

    proc ~objectSelector {this} {}


    proc extend {this id} {
        if {[info exists selector::($this,lastSelected)]} {
            set list [lsort -integer [selector::list $this]]
            set last [lsearch -exact $list $selector::($this,lastSelected)]
            set index [lsearch -exact $list $id]
            selector::clear $this
            if {$index > $last} {
                selector::set $this [lrange $list $last $index] 1
            } else {
                selector::set $this [lrange $list $index $last] 1
            }
        } else {
            selector::select $this $id
        }
    }

}


package require Tk 8.3
package provide tkpiechart 6.6


::stooop::class pie {
    set (colors) [list        #7FFFFF #FFFF7F #FF7F7F #7FFF7F #7F7FFF #FFBF00 #BFBFBF #FF7FFF #FFFFFF    ]
}

proc pie::pie {this canvas x y args} switched {$args} {
    set ($this,canvas) $canvas
    set ($this,colorIndex) 0
    set ($this,slices) {}
    set ($this,origin) [$canvas create image $x $y -tags pie($this)]
    switched::complete $this
    complete $this
}

proc pie::~pie {this} {
    if {[info exists ($this,title)]} {
        $($this,canvas) delete $($this,title)
    }
    ::stooop::delete $($this,labeler)
    eval ::stooop::delete $($this,slices) $($this,backgroundSlice)
    if {[info exists ($this,selector)]} {
        ::stooop::delete $($this,selector)
    }
    $($this,canvas) delete $($this,origin)
}

proc pie::options {this} {
    return [list        [list -autoupdate 1 1]        [list -background {} {}]        [list -colors $(colors) $(colors)]        [list -height 200]        [list -labeler 0 0]        [list -selectable 0 0]        [list -thickness 0]        [list -title {} {}]        [list -titlefont {Helvetica -12 bold} {Helvetica -12 bold}]        [list -titleoffset 2 2]        [list -width 200]    ]
}

proc pie::set-autoupdate {this value} {}

foreach option {    -background -colors -labeler -selectable -title -titlefont -titleoffset} {
    proc pie::set$option {this value} "
        if {\$switched::(\$this,complete)} {
            error {option $option cannot be set dynamically}
        }
    "
}

proc pie::set-thickness {this value} {
    if {$switched::($this,complete)} {
        error {option -thickness cannot be set dynamically}
    }
    set ($this,thickness) [winfo fpixels $($this,canvas) $value]
}

proc pie::set-height {this value} {
    set ($this,height) [expr {[winfo fpixels $($this,canvas) $value] - 1}]
    if {$switched::($this,complete)} {
        update $this
    } else {
        set ($this,initialHeight) $($this,height)
    }
}
proc pie::set-width {this value} {
    set ($this,width) [expr {[winfo fpixels $($this,canvas) $value] - 1}]
    if {$switched::($this,complete)} {
        update $this
    } else {
        set ($this,initialWidth) $($this,width)
    }
}

proc pie::complete {this} {
    set canvas $($this,canvas)

    if {$switched::($this,-labeler) == 0} {
        set ($this,labeler) [::stooop::new pieBoxLabeler $canvas]
    } else {
        set ($this,labeler) $switched::($this,-labeler)
    }
    $canvas addtag pie($this) withtag pieLabeler($($this,labeler))
    if {[string length $switched::($this,-background)] == 0} {
        set bottomColor {}
    } else {
        set bottomColor [darken $switched::($this,-background) 60]
    }
    set slice [::stooop::new slice        $canvas [expr {$($this,initialWidth) / 2}]        [expr {$($this,initialHeight) / 2}]        -startandextent {90 360} -height $($this,thickness)        -topcolor $switched::($this,-background) -bottomcolor $bottomColor    ]
    $canvas addtag pie($this) withtag slice($slice)
    $canvas addtag pieSlices($this) withtag slice($slice)
    set ($this,backgroundSlice) $slice
    if {[string length $switched::($this,-title)] == 0} {
        set ($this,titleRoom) 0
    } else {
        set ($this,title) [$canvas create text 0 0            -anchor n -text $switched::($this,-title)            -font $switched::($this,-titlefont) -tags pie($this)        ]
        set ($this,titleRoom) [expr {            [font metrics $switched::($this,-titlefont) -ascent] +            [winfo fpixels $canvas $switched::($this,-titleoffset)]        }]
    }
    update $this
}

proc pie::newSlice {this {text {}} {color {}}} {
    set canvas $($this,canvas)

    set start 90
    foreach slice $($this,slices) {
        set start [expr {$start - $slice::($slice,extent)}]
    }
    if {[string length $color] == 0} {
        set color [lindex $switched::($this,-colors) $($this,colorIndex)]
        set ($this,colorIndex) [expr {            ($($this,colorIndex) + 1) % [llength $switched::($this,-colors)]        }]
    }
    set slice [::stooop::new slice        $canvas [expr {$($this,initialWidth) / 2}]        [expr {$($this,initialHeight) / 2}] -startandextent "$start 0"        -height $($this,thickness) -topcolor $color        -bottomcolor [darken $color 60]    ]
    eval $canvas move slice($slice) [$canvas coords pieSlices($this)]
    $canvas addtag pie($this) withtag slice($slice)
    $canvas addtag pieSlices($this) withtag slice($slice)
    lappend ($this,slices) $slice
    if {[string length $text] == 0} {
        set text "slice [llength $($this,slices)]"
    }
    set labeler $($this,labeler)
    set label [pieLabeler::new $labeler $slice -text $text -background $color]
    set ($this,sliceLabel,$slice) $label
    $canvas addtag pie($this) withtag pieLabeler($labeler)
    update $this
    if {$switched::($this,-selectable)} {
        if {![info exists ($this,selector)]} {
            set ($this,selector) [::stooop::new objectSelector                -selectcommand "pie::setLabelsState $this"            ]
        }
        set selector $($this,selector)
        selector::add $selector $label
        $canvas bind canvasLabel($label) <ButtonPress-1>            "pie::buttonPress $selector $label"
        $canvas bind slice($slice) <ButtonPress-1>            "selector::select $selector $label"
        $canvas bind canvasLabel($label) <Control-ButtonPress-1>            "selector::toggle $selector $label"
        $canvas bind slice($slice) <Control-ButtonPress-1>            "selector::toggle $selector $label"
        $canvas bind canvasLabel($label) <Shift-ButtonPress-1>            "selector::extend $selector $label"
        $canvas bind slice($slice) <Shift-ButtonPress-1>            "selector::extend $selector $label"
        $canvas bind canvasLabel($label) <ButtonRelease-1>            "pie::buttonRelease $selector $label 0"
        $canvas bind slice($slice) <ButtonRelease-1>            "pie::buttonRelease $selector $label 0"
        $canvas bind canvasLabel($label) <Control-ButtonRelease-1>            "pie::buttonRelease $selector $label 1"
        $canvas bind slice($slice) <Control-ButtonRelease-1>            "pie::buttonRelease $selector $label 1"
        $canvas bind canvasLabel($label) <Shift-ButtonRelease-1>            "pie::buttonRelease $selector $label 1"
        $canvas bind slice($slice) <Shift-ButtonRelease-1>            "pie::buttonRelease $selector $label 1"
    }
    return $slice
}

proc pie::deleteSlice {this slice} {
    set index [lsearch -exact $($this,slices) $slice]
    if {$index < 0} {
        error "invalid slice $slice for pie $this"
    }
    set ($this,slices) [lreplace $($this,slices) $index $index]
    set extent $slice::($slice,extent)
    ::stooop::delete $slice
    foreach following [lrange $($this,slices) $index end] {
        slice::rotate $following $extent
    }
    pieLabeler::delete $($this,labeler) $($this,sliceLabel,$slice)
    if {$switched::($this,-selectable)} {
        selector::remove $($this,selector) $($this,sliceLabel,$slice)
    }
    unset ($this,sliceLabel,$slice)
    update $this
}

proc pie::sizeSlice {this slice unitShare {valueToDisplay {}}} {
    set index [lsearch -exact $($this,slices) $slice]
    if {$index < 0} {
        error "invalid slice $slice for pie $this"
    }
    set newExtent [expr {[maximum [minimum $unitShare 1] 0] * 360}]
    set growth [expr {$newExtent - $slice::($slice,extent)}]
    switched::configure $slice -startandextent        "[expr {$slice::($slice,start) - $growth}] $newExtent"
    if {[string length $valueToDisplay] > 0} {
        pieLabeler::set $($this,labeler) $($this,sliceLabel,$slice)            $valueToDisplay
    } else {
        pieLabeler::set $($this,labeler) $($this,sliceLabel,$slice) $unitShare
    }
    set value [expr {-1 * $growth}]
    foreach slice [lrange $($this,slices) [incr index] end] {
        slice::rotate $slice $value
    }
    if {$switched::($this,-autoupdate)} {
        update $this
    }
}

proc pie::labelSlice {this slice text} {
    pieLabeler::label $($this,labeler) $($this,sliceLabel,$slice) $text
    update $this
}

proc pie::sliceLabelTag {this slice} {
    return canvasLabel($($this,sliceLabel,$slice))
}

proc pie::setSliceBackground {this slice color} {
    switched::configure $slice -topcolor $color -bottomcolor [darken $color 60]
    pieLabeler::labelBackground $($this,labeler) $($this,sliceLabel,$slice)        $color
}

proc pie::setSliceLabelBackground {this slice color} {
    pieLabeler::labelTextBackground $($this,labeler) $($this,sliceLabel,$slice)        $color
}

proc pie::selectedSlices {this} {
    set list {}
    foreach slice $($this,slices) {
        if {[pieLabeler::selectState $($this,labeler)            $($this,sliceLabel,$slice)        ]} {
            lappend list $slice
        }
    }
    return $list
}

proc pie::setLabelsState {this labels selected} {
    set labeler $($this,labeler)
    foreach label $labels {
        pieLabeler::selectState $labeler $label $selected
    }
}

proc pie::currentSlice {this} {
    set tags [$($this,canvas) gettags current]
    if {        ([scan $tags slice(%u) slice] > 0) &&        ($slice != $($this,backgroundSlice))    } {
        return $slice
    }
    if {[scan $tags canvasLabel(%u) label] > 0} {
        foreach slice $($this,slices) {
            if {$($this,sliceLabel,$slice) == $label} {
                return $slice
            }
        }
    }
    return 0
}

proc pie::update {this} {
    set canvas $($this,canvas)
    foreach {x y} [$canvas coords $($this,origin)] {}
    set right [expr {$x + $($this,width)}]
    set bottom [expr {$y + $($this,height)}]
    pieLabeler::update $($this,labeler) $x $y $right $bottom
    pieLabeler::room $($this,labeler) room
    foreach {xSlices ySlices} [$canvas coords pieSlices($this)] {}
    $canvas move pieSlices($this) [expr {$x + $room(left) - $xSlices}]        [expr {$y + $room(top) + $($this,titleRoom) - $ySlices}]
    set scale [list        [expr {            ($($this,width) - $room(left) - $room(right)) /            $($this,initialWidth)        }]        [expr {            (                $($this,height) - $room(top) - $room(bottom) -                $($this,titleRoom)            ) / ($($this,initialHeight) + $($this,thickness))        }]    ]
    switched::configure $($this,backgroundSlice) -scale $scale
    foreach slice $($this,slices) {
        switched::configure $slice -scale $scale
    }
    pieLabeler::updateSlices $($this,labeler) $x $y $right $bottom
    if {$($this,titleRoom) > 0} {
        $canvas coords $($this,title) [expr {$x + ($($this,width) / 2)}] $y
    }
}

proc pie::buttonPress {selector label} {
    foreach selected [selector::selected $selector] {
        if {$selected == $label} return
    }
    selector::select $selector $label
}

proc pie::buttonRelease {selector label extended} {
    if {$extended} return
    set list [selector::selected $selector]
    if {[llength $list] <= 1} {
        return
    }
    foreach selected $list {
        if {$selected == $label} {
            selector::select $selector $label
            return
        }
    }
}

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

    catch ::tk::Darken
    if {[llength [info procs ::tk::Darken]] > 0} {
        proc darken {color percent} {::tk::Darken $color $percent}
    } else {
        proc darken {color percent} {::tkDarken $color $percent}
    }
}
}




class font {
    catch {widget::widget}

    set (mediumBold) [eval font create [font actual $widget::option(button,font)]]
    font configure $(mediumBold) -weight bold
    set (mediumNormal) [eval font create [font actual $(mediumBold)]]
    font configure $(mediumNormal) -weight normal
    set (mediumItalic) [eval font create [font actual $(mediumNormal)]]
    font configure $(mediumItalic) -slant italic
    set (mediumBoldItalic) [eval font create [font actual $(mediumBold)]]
    font configure $(mediumBoldItalic) -slant italic
    set (smallNormal) [eval font create [font actual $(mediumNormal)]]
    set size [maximum [expr {round(0.8 * [font actual $(mediumNormal) -size])}] 10]
    font configure $(smallNormal) -size -$size
    set (tinyNormal) [font create -family [font actual $(mediumNormal) -family] -size -10]
    set (fixedNormal) [font create -family courier -weight normal -size -[font actual $(mediumNormal) -size]]
    if {[package vcompare $::tcl_version 8.5] >= 0} {
        foreach font [list $(mediumBold) $(mediumNormal) $(mediumItalic) $(mediumBoldItalic) $(smallNormal) $(fixedNormal)] {
            font configure $font -size -[font actual $font -size]
        }
    }
}




class scrollingLabel {

    proc scrollingLabel {this parentPath args} composite {[new frame $parentPath] $args} {
        composite::manage $this [new label $widget::($this,path) -font $widget::option(button,font) -justify left] label
        composite::complete $this
        bind $widget::($this,path) <Configure> "scrollingLabel::refresh $this %w"
    }

    proc ~scrollingLabel {this} {}

    proc options {this} {
        return [list            [list -font $widget::option(button,font) $widget::option(button,font)]            [list -interval 15 15]            [list -step 1]            [list -text {}]            [list -width 0 0]        ]
    }

    proc set-interval {this value} {}

    proc set-step {this value} {
        set ($this,step) -$value
    }

    proc set-font {this value} {
        $composite::($this,label,path) configure -font $value
        refresh $this [winfo width $widget::($this,path)]
    }

    proc set-text {this value} {
        $composite::($this,label,path) configure -text $value
        refresh $this [winfo width $widget::($this,path)]
    }

    proc set-width {this value} {
        $widget::($this,path) configure -width $value
    }

    proc refresh {this width} {
        if {![info exists ($this,step)]} return
        set ($this,textWidth) [winfo reqwidth $composite::($this,label,path)]
        $widget::($this,path) configure -height [winfo reqheight $composite::($this,label,path)]
        place $composite::($this,label,path) -anchor nw -x [set ($this,x) 0] -y 0
        if {$width < $($this,textWidth)} {
            scroll $this $width
        } else {
            catch {after cancel $($this,event)}
        }
    }

    proc scroll {this width} {
        set interval $composite::($this,-interval)
        if {(($($this,step) < 0) && ($($this,x) < ($width - $($this,textWidth)))) || (($($this,step) > 0) && ($($this,x) > 0))} {
            set ($this,step) [expr {-$($this,step)}]
            set interval [expr {20 * $interval}]
        }
        place $composite::($this,label,path) -x [incr ($this,x) $($this,step)]
        catch {after cancel $($this,event)}
        set ($this,event) [after $interval "scrollingLabel::scroll $this $width"]
    }

}






::stooop::class xifo {

    proc xifo {this size} {
        set ($this,size) $size
        empty $this
    }

    proc ~xifo {this} {
        variable ${this}data
        catch {unset ${this}data}
    }

    proc in {this data} {
        variable ${this}data
        tidyUp $this
        if {[array size ${this}data] >= $($this,size)} {
            unset ${this}data($($this,first))
            incr ($this,first)
        }
        set ${this}data([incr ($this,last)]) $data
    }

    proc tidyUp {this} {
        variable ${this}data
        catch {
            unset ${this}data($($this,unset))
            unset ($this,unset)
        }
    }

    proc empty {this} {
        variable ${this}data
        catch {unset ${this}data}
        catch {unset ($this,unset)}
        set ($this,first) 0
        set ($this,last) -1
    }

    proc isEmpty {this} {
        return [expr {$($this,last) < $($this,first)}]
    }

    ::stooop::virtual proc out {this}

    ::stooop::virtual proc data {this}
}


::stooop::class lifo {

    proc lifo {this {size 2147483647}} xifo {$size} {}

    proc ~lifo {this} {}

    proc out {this} {
        xifo::tidyUp $this
        if {[array size xifo::${this}data] == 0} {
            error "lifo $this out error, empty"
        }
        set xifo::($this,unset) $xifo::($this,last)
        incr xifo::($this,last) -1
        return [set xifo::${this}data($xifo::($this,unset))]
    }

    proc data {this} {
        set list {}
        set first $xifo::($this,first)
        for {set index $xifo::($this,last)} {$index >= $first} {incr index -1} {
            lappend list [set xifo::${this}data($index)]
        }
        return $list
    }

}


::stooop::class fifo {

    proc fifo {this {size 2147483647}} xifo {$size} {}

    proc ~fifo {this} {}

    proc out {this} {
        xifo::tidyUp $this
        if {[array size xifo::${this}data] == 0} {
            error "fifo $this out error, empty"
        }
        set xifo::($this,unset) $xifo::($this,first)
        incr xifo::($this,first)
        return [set xifo::${this}data($xifo::($this,unset))]
    }

    proc data {this} {
        set list {}
        set last $xifo::($this,last)
        for {set index $xifo::($this,first)} {$index <= $last} {incr index} {
            lappend list [set xifo::${this}data($index)]
        }
        return $list
    }

}






class lifoLabel {}

proc lifoLabel::lifoLabel {this parentPath args} composite {[new scrollingLabel $parentPath] $args} {
    set ($this,lifo) [new lifo]
    composite::complete $this
}

proc lifoLabel::~lifoLabel {this} {
    delete $($this,lifo)
}

proc lifoLabel::options {this} {
    return [list        [list -borderwidth $widget::option(button,borderwidth)]        [list -font {helvetica -12}]        [list -relief sunken]    ]
}

proc lifoLabel::set-relief {this value} {
    composite::configure $composite::($this,base) base -relief $value
}

proc lifoLabel::set-borderwidth {this value} {
    composite::configure $composite::($this,base) base -borderwidth $value
}

proc lifoLabel::set-font {this value} {
    composite::configure $composite::($this,base) -font $value
}

proc lifoLabel::push {this string} {
    if {[string length [set current [composite::cget $composite::($this,base) -text]]] > 0} {
        xifo::in $($this,lifo) $current
    }
    composite::configure $composite::($this,base) -text $string
}

proc lifoLabel::pop {this} {
    set string {}
    catch {set string [lifo::out $($this,lifo)]}
    composite::configure $composite::($this,base) -text $string
    return $string
}

proc lifoLabel::flash {this string {seconds 1}} {
    after [expr {1000 * $seconds}] lifoLabel::pop $this
    push $this $string
}



class dialogBox {}

proc dialogBox::dialogBox {this parentPath args} composite {[new toplevel $parentPath] $args} {
    set path $widget::($this,path)
    wm group $path .
    wm withdraw $path
    composite::manage $this [new frame $path -relief sunken -borderwidth 1 -height 2] separator [new frame $path] buttons
    set buttons $composite::($this,buttons,path)
    composite::manage $this [new button $buttons -text [mc OK]] ok [new button $buttons -text [mc Cancel]] cancel        [new button $buttons -text [mc Help]] help [new button $buttons -text [mc Close]] close
    grid $composite::($this,separator,path) -column 0 -row 1 -sticky ew -pady 2
    grid $buttons -column 0 -row 2 -sticky nsew
    grid rowconfigure $path 0 -weight 1
    grid columnconfigure $path 0 -weight 1
    wm protocol $path WM_DELETE_WINDOW "dialogBox::close $this"
    composite::complete $this
}

proc dialogBox::~dialogBox {this} {
    if {[string length $composite::($this,-deletecommand)] > 0} {
        uplevel #0 $composite::($this,-deletecommand)
    }
}

proc dialogBox::options {this} {
    return [list        [list -buttons o]        [list -command {} {}]        [list -closecommand {} {}]        [list -default {} {}]        [list -deletecommand {} {}]        [list -die 1 1]        [list -enterreturn 1 1]        [list -grab local]        [list -helpcommand {} {}]        [list -labels {} {}]        [list -otherbuttons {} {}]        [list -title {Dialog box}]        [list -transient 1]        [list -x 0]        [list -y 0]    ]
}

proc dialogBox::set-buttons {this value} {
    set path $widget::($this,path)
    if {$composite::($this,complete)} {
        error {option -buttons cannot be set dynamically}
    }
    if {![regexp {^[chox]+$} $value]} {
        error "bad buttons value \"$value\": must be a combination of c, h, o and x"
    }
    if {[string first h $value] >= 0} {
        set button $composite::($this,help,path)
        pack $button -side left -expand 1 -pady 3 -padx 3
        widget::configure $composite::($this,help) -command "dialogBox::help $this"
        bind $path <KeyPress-F1> "$button configure -relief sunken"
        bind $path <KeyRelease-F1> "$button configure -relief raised; dialogBox::help $this"
    }
    set ok [expr {[string first o $value] >= 0}]
    if {$ok} {
        set button $composite::($this,ok,path)
        pack $button -side left -expand 1 -pady 3
        widget::configure $composite::($this,ok) -command "dialogBox::oked $this"
        updateOKBindings $this
    }
    set cancel [expr {[string first c $value] >= 0}]
    if {$cancel} {
        set button $composite::($this,cancel,path)
        pack $button -side left -expand 1 -pady 3
        widget::configure $composite::($this,cancel) -command "dialogBox::close $this"
        bind $path <KeyPress-Escape> "$button configure -relief sunken"
        bind $path <KeyRelease-Escape> "$button configure -relief raised; dialogBox::close $this"
    }
    if {[string first x $value] >= 0} {
        set button $composite::($this,close,path)
        pack $button -side left -expand 1 -pady 3
        widget::configure $composite::($this,close) -command "dialogBox::close $this"
        set keys {}
        if {!$ok} {
            foreach key {Return KP_Enter} {
                bind $path <KeyPress-$key> "$button configure -relief sunken"
                bind $path <KeyRelease-$key> "$button configure -relief raised; dialogBox::close $this 1"
            }
        }
        if {!$cancel} {
            bind $path <KeyPress-Escape> "$button configure -relief sunken"
            bind $path <KeyRelease-Escape> "$button configure -relief raised; dialogBox::close $this 1"
        }
    }
}

proc dialogBox::set-otherbuttons {this value} {
    if {$composite::($this,complete)} {
        error {option -default cannot be set dynamically}
    }
    set buttons $composite::($this,buttons,path)
    foreach name $value {
        composite::manage $this [new button $buttons -text $name] $name
        pack $composite::($this,$name,path) -side left -expand 1 -pady 3 -padx 3
    }
}

proc dialogBox::set-default {this value} {
    if {$composite::($this,complete)} {
        error {option -default cannot be set dynamically}
    }
    switch $composite::($this,-default) {
        o {$composite::($this,ok,path) configure -default active}
        c {$composite::($this,cancel,path) configure -default active}
        x {$composite::($this,close,path) configure -default active}
        default {
            error "bad default value \"$value\": must be o, c or x"
        }
    }
}

proc dialogBox::set-command {this value} {}
proc dialogBox::set-closecommand {this value} {}
proc dialogBox::set-deletecommand {this value} {}
proc dialogBox::set-die {this value} {}
proc dialogBox::set-helpcommand {this value} {}

proc dialogBox::set-enterreturn {this value} {
    updateOKBindings $this
}

proc dialogBox::set-grab {this value} {
    switch $value {
        global {grab -global $widget::($this,path)}
        local {grab $widget::($this,path)}
        release {grab release $widget::($this,path)}
        default {
            error "bad grab value \"$value\": must be global, local or release"
        }
    }
}

proc dialogBox::set-title {this value} {
    wm title $widget::($this,path) $value
}

foreach option {-x -y} {
    proc dialogBox::set$option {this value} {
        if {[winfo ismapped $widget::($this,path)]} {
            place $this
        }
    }
}

proc dialogBox::set-transient {this value} {
    if {$value} {
        wm transient $widget::($this,path) .
    } else {
        wm transient $widget::($this,path) {}
    }
}

proc dialogBox::set-labels {this value} {
    foreach {code label} $value {
        switch $code {
            c {composite::configure $this cancel -text $label}
            h {composite::configure $this help -text $label}
            o {composite::configure $this ok -text $label}
            x {composite::configure $this close -text $label}
            default {error "bad button code \"$code\": must be c, h, o or x"}
        }
    }
}

proc dialogBox::display {this path} {
    if {[string length $path] == 0} {
        if {[info exists ($this,displayed)]} {
            grid forget $($this,displayed)
            unset ($this,displayed)
        }
        return
    }
    if {[info exists ($this,displayed)]} {
        error "a widget ($($this,displayed)) is already displayed"
    }
    set ($this,displayed) $path
    grid $path -in $widget::($this,path) -column 0 -row 0 -sticky nsew
    place $this
}

proc dialogBox::oked {this {enterOrReturn 0}} {
    if {        $enterOrReturn &&        (!$composite::($this,-enterreturn) || [string equal [widget::cget $composite::($this,ok) -state] disabled])    } return
    if {[string length $composite::($this,-command)] > 0} {
        uplevel #0 $composite::($this,-command)
    }
    if {[info exists composite::($this,-die)] && $composite::($this,-die)} {
        delete $this
    }
}

proc dialogBox::close {this {enterOrReturn 0}} {
    if {        $enterOrReturn &&        (!$composite::($this,-enterreturn) || [string equal [widget::cget $composite::($this,close) -state] disabled])    } return
    if {([string length $composite::($this,-closecommand)] > 0) && ![uplevel #0 $composite::($this,-closecommand)]} return
    delete $this
}

proc dialogBox::place {this} {
    update idletasks
    set path $widget::($this,path)
    set x [minimum $composite::($this,-x) [expr {[winfo screenwidth $path] - [winfo reqwidth $path]}]]
    set y [minimum $composite::($this,-y) [expr {[winfo screenheight $path] - [winfo reqheight $path]}]]
    wm geometry $path +$x+$y
    wm deiconify $path
}

proc dialogBox::help {this} {
    if {[string length $composite::($this,-helpcommand)] > 0} {
        uplevel #0 $composite::($this,-helpcommand)
    }
}

proc dialogBox::updateOKBindings {this} {
    set path $widget::($this,path)
    if {$composite::($this,-enterreturn)} {
        set button $composite::($this,ok,path)
        foreach key {Return KP_Enter} {
            bind $path <KeyPress-$key> "$button configure -relief sunken"
            bind $path <KeyRelease-$key> "$button configure -relief raised; dialogBox::oked $this 1"
        }
    } else {
        foreach key {Return KP_Enter} {
            bind $path <KeyPress-$key> {}
            bind $path <KeyRelease-$key> {}
        }
    }
}



class listEntry {

    proc listEntry {this parentPath args} composite {
        [new selectTable $parentPath            -background $widget::option(entry,background) -focuscommand "listEntry::focus $this"            -selectcommand "listEntry::select $this"        ] $args
    } {
        ::set ($this,entry) 0
        composite::complete $this
        newRowEntry $this 0
    }

    proc ~listEntry {this} {
        variable ${this}row
        catch {unset ${this}row}
    }

    proc options {this} {
        return [list            [list -height 50]            [list -state normal normal]            [list -width 100]        ]
    }

    proc set-height {this value} {
        composite::configure $composite::($this,base) base -height $value
    }
    proc set-width {this value} {
        composite::configure $composite::($this,base) base -width $value
    }

    proc set-state {this value} {
        composite::configure $composite::($this,base) -state $value
        foreach window [selectTable::windows $composite::($this,base)] {
            $window configure -state $value
        }
    }

    proc newRowEntry {this row} {
        ::set base $composite::($this,base)
        ::set path $selectTable::($base,tablePath)
        ::set entry [entry $path.$($this,entry)            -font $font::(mediumNormal) -borderwidth 0 -highlightthickness 0 -state $composite::($this,-state)        ]
        bindings $this $entry $row
        selectTable::windowConfigure $base $row,0 -window $entry -padx 1 -pady 1 -sticky nsew
        incr ($this,entry)
        return $entry
    }

    proc bindings {this entry row} {
        bind $entry <FocusIn>            "listEntry::refresh $this $entry; selectTable::select $composite::($this,base) \[listEntry::row $this $entry\]"
        bind $entry <Return> "listEntry::enter $this $entry"
        bind $entry <KP_Enter> "listEntry::enter $this $entry"
    }

    proc row {this entry} {
        variable ${this}row

        if {[info exists ${this}row($entry)]} {
            return [::set ${this}row($entry)]
        }
        ::set base $composite::($this,base)
        ::set rows [selectTable::rows $base]
        for {::set row 0} {$row < $rows} {incr row} {
            if {[string equal [selectTable::window $base $row,0] $entry]} {
                return [::set ${this}row($entry) $row]
            }
        }
    }

    proc refresh {this {entry {}}} {
        variable ${this}row

        ::set base $composite::($this,base)
        if {[string length $entry] > 0} {::set current [row $this $entry]}
        ::set delete {}
        ::set rows [selectTable::rows $base]
        for {::set row 0} {$row < $rows} {incr row} {
            if {[info exists current] && ($row == $current)} continue
            ::set entry [selectTable::window $base $row,0]
            if {[string length [string trim [$entry get]]] == 0} {
                lappend delete $row
            }
        }
        ::set refresh 0
        if {[llength $delete] > 0} {
            selectTable::delete $base $delete
            unset ${this}row
            ::set refresh 1
        }
        if {[selectTable::rows $base] == 0} {
            selectTable::rows $base 1
            newRowEntry $this 0
            ::set refresh 1
        }
        if {$refresh} {
            selectTable::refreshBorders $base
        }
    }

    proc enter {this entry} {
        ::set row [row $this $entry]
        incr row
        ::set base $composite::($this,base)
        ::set rows [selectTable::rows $base]
        if {$row == $rows} {
            if {[string length [$entry get]] > 0} {
                selectTable::rows $base [incr rows]
                ::set entry [newRowEntry $this $row]
                selectTable::refreshBorders $base
                selectTable::see $base $row,0
            }
        } else {
            ::set entry [selectTable::window $base $row,0]
        }
        ::focus $entry
    }

    proc focus {this row in} {
        if {$in} {
            ::focus [selectTable::window $composite::($this,base) $row,0]
        }
    }

    proc select {this target} {
        ::set base $composite::($this,base)
        ::set rows [selectTable::rows $base]
        for {::set row 0} {$row < $rows} {incr row} {
            if {$row == $target} continue
            [selectTable::window $base $row,0] selection clear
        }
        return 1
    }


    proc set {this list} {
        ::set base $composite::($this,base)
        ::set rows {}
        ::set maximum [selectTable::rows $base]
        for {::set row 0} {$row < $maximum} {incr row} {lappend rows $row}
        selectTable::delete $base $rows
        selectTable::clear $base
        ::set state $composite::($this,-state)
        selectTable::rows $base [llength $list]
        ::set row 0
        foreach string $list {
            ::set entry [newRowEntry $this $row]
            $entry configure -state normal
            $entry insert end $string
            $entry configure -state $state
            incr row
        }
        refresh $this
        selectTable::refreshBorders $base
    }

    proc get {this} {
        ::set base $composite::($this,base)
        ::set rows [selectTable::rows $base]
        ::set strings {}
        for {::set row 0} {$row < $rows} {incr row} {
            ::set string [string trim [[selectTable::window $base $row,0] get]]
            if {[string length $string] > 0} {
                lappend strings $string
            }
        }
        return $strings
    }

}



class backgroundChooser {

    set (positions) [list [mc center] [mc {upper left}]]
    set (positionCodes) [list {} nw]

    proc backgroundChooser {this parentPath args} composite {[new frame $parentPath] $args} {
        set path $widget::($this,path)
        set ($this,imageButton) [checkbutton $path.imageButton            -text [mc {Image file:}] -variable backgroundChooser::($this,useImage)            -command "composite::configure $this -useimage \$backgroundChooser::($this,useImage)"        ]
        grid $($this,imageButton) -row 0 -column 0 -padx 2 -sticky e
        set ($this,imageEntry) [entry $path.imageFile -textvariable backgroundChooser::($this,imageFile)]
        grid $($this,imageEntry) -row 0 -column 1 -columnspan 2 -padx 2 -sticky ew
        set ($this,imageChoose) [button $path.imageChoose -text [mc Choose]... -command "backgroundChooser::inquireImageFile $this"]
        grid $($this,imageChoose) -row 0 -column 3 -padx 2 -sticky w
        set ($this,positionsLabel) [label $path.positionsLabel -text [mc {Image position:}]]
        grid $($this,positionsLabel) -row 1 -column 0 -padx 2 -sticky e
        set entry [new comboEntry $path -editable 0 -command "backgroundChooser::setImagePosition $this" -list $(positions)]
        composite::configure $entry entry -textvariable backgroundChooser::($this,position)
        composite::configure $entry button -listheight [llength $(positions)]
        composite::configure $entry button scroll -selectmode single
        set ($this,imagePositions) $entry
        grid $widget::($($this,imagePositions),path) -row 1 -column 1 -padx 2 -sticky w
        set ($this,window) [new window $path]
        grid $widget::($($this,window),path) -row 1 -column 2 -rowspan 2 -columnspan 2 -padx 5 -pady 5 -sticky e
        set ($this,colorButton) [button $path.colorButton -text [mc Color]... -command "backgroundChooser::inquireColor $this"]
        grid $($this,colorButton) -row 2 -column 1 -padx 2
        grid columnconfigure $path 2 -weight 1
        set ($this,image) {}
        composite::complete $this
    }

    proc ~backgroundChooser {this} {
        if {[string length $($this,image)] > 0} {image delete $($this,image)}
        delete $($this,window)
    }

    proc options {this} {
        set list [list [list [mc {image files}] .gif]]
        return [list            [list -color white]            [list -font $widget::option(label,font)]            [list -imagefile {}]            [list -imagefiletypes $list $list]            [list -position {}]            [list -targetsize {0 0} {0 0}]            [list -useimage 0]        ]
    }

    proc set-color {this value} {
        $($this,colorButton) configure -background $value -foreground [visibleForeground $value]
        composite::configure $($this,window) -background $value
    }

    proc set-font {this value} {
        foreach path [list $($this,positionsLabel) $($this,imageButton) $($this,imageEntry)] {
            $path configure -font $value
        }
        composite::configure $($this,imagePositions) -font $value
    }

    proc set-imagefile {this value} {
        set ($this,imageFile) $value
        if {[string length $($this,image)] > 0} {
            image delete $($this,image)
            set ($this,image) {}
        }
        if {[string length $value] > 0} {
            set ($this,image) [image create photo -file $value]
        }
        if {$composite::($this,-useimage)} {
            composite::configure $($this,window) -image $($this,image)
        } else {
            composite::configure $($this,window) -image {}
        }
    }

    proc set-position {this value} {
        set index [lsearch -exact $(positionCodes) $value]; if {$index < 0} {set index 0}
        set ($this,position) [lindex $(positions) $index]
        composite::configure $($this,window) -position $value
    }

    proc set-targetsize {this value} {
        composite::configure $($this,window) -size $value
    }

    proc set-useimage {this value} {
        set ($this,useImage) $value
        if {$value} {
            $($this,imageEntry) configure -state normal
            $($this,imageChoose) configure -state normal
            composite::configure $($this,imagePositions) -state normal
            composite::configure $($this,window) -image $($this,image)
        } else {
            $($this,imageEntry) configure -state disabled
            $($this,imageChoose) configure -state disabled
            composite::configure $($this,imagePositions) -state disabled
            composite::configure $($this,window) -image {}
        }
    }

    proc inquireImageFile {this} {
        set name $composite::($this,-imagefile)
        if {[string length $name] == 0} {
            set directory .
        } else {
            set directory [file dirname $name]; set name [file tail $name]
        }
        set file [tk_getOpenFile            -title [mc {moodss: Image File}] -parent $widget::($this,path) -initialdir $directory -initialfile $name            -filetypes $composite::($this,-imagefiletypes)        ]
        if {[string length $file] > 0} {
            composite::configure $this -imagefile $file
        }
    }

    proc inquireColor {this} {
        set color [tk_chooseColor            -title [mc {Choose background color:}] -parent $widget::($this,path) -initialcolor $composite::($this,-color)        ]
        if {[string length $color] > 0} {
            composite::configure $this -color $color
        }
    }

    proc setImagePosition {this position} {
        set index [lsearch -exact $(positions) $position]; if {$index < 0} {set index 0}
        composite::configure $this -position [lindex $(positionCodes) $index]
    }

    proc applyFileEntry {this} {
        composite::configure $this -imagefile $($this,imageFile)
    }

}


class backgroundChooser {

    class window {

        proc window {this parentPath args} composite {[new frame $parentPath -background black] $args} {
            set ($this,frame) [frame $widget::($this,path).frame]
            set ($this,label) [label $($this,frame).label -borderwidth 0]
            pack $($this,frame) -fill both -padx 1 -pady 1
            composite::complete $this
        }

        proc ~window {this} {
            if {[info exists ($this,image)]} {image delete $($this,image)}
        }

        proc options {this} {
            return [list                [list -background white]                [list -image {} {}]                [list -position {} {}]                [list -size [list [winfo screenwidth .] [winfo screenheight .]]]            ]
        }

        proc set-background {this value} {
            $($this,frame) configure -background $value
            $($this,label) configure -background $value
        }

        proc set-size {this value} {
            update $this
        }

        proc set-image {this value} {
            update $this
        }

        proc set-position {this value} {
            update $this
        }

        proc update {this} {
            set scale 10.0
            foreach {width height} $composite::($this,-size) {}
            $($this,frame) configure -width [expr {round($width / $scale)}] -height [expr {round($height / $scale)}]
            if {[info exists ($this,image)]} {
                image delete $($this,image)
                unset ($this,image)
            }
            set image $composite::($this,-image)
            if {[string length $image] == 0} {
                place forget $($this,label)
                return
            }
            set ($this,image) [image create photo]
            $($this,image) copy $image -subsample [expr {round($scale)}]                -to 0 0 [expr {round([image width $image] / $scale)}] [expr {round([image height $image] / $scale)}]
            $($this,label) configure -image $($this,image)
            switch $composite::($this,-position) {
                nw {
                    place $($this,label) -anchor nw -relx 0 -rely 0
                }
                default {
                    place $($this,label) -anchor center -relx 0.5 -rely 0.5
                }
            }
        }

    }

}



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

}




namespace eval ::tk::table {

    class rightColumnTipper {

        proc rightColumnTipper {this path} {
            set bindings [new bindings $path end]
            bindings::set $bindings <Enter> "::tk::table::rightColumnTipper::enter $this %x %y"
            bindings::set $bindings <Leave> "::tk::table::rightColumnTipper::leave $this"
            set ($this,bindings) $bindings
            set ($this,path) $path
        }

        proc ~rightColumnTipper {this} {
            delete $($this,bindings)
            if {![catch {classof $($this,tip)}]} {delete $($this,tip)}
        }

        proc enter {this x y} {
            bindings::set $($this,bindings) <Motion> "::tk::table::rightColumnTipper::motion $this %x %y"
            set ($this,cell) [$($this,path) index @$x,$y]
            in $this $($this,cell)
        }

        proc leave {this} {
            bindings::set $($this,bindings) <Motion> {}
            catch {unset ($this,cell)}
        }

        proc motion {this x y} {
            set cell [$($this,path) index @$x,$y]
            if {![info exists ($this,cell)]} {set ($this,cell) cell}
            if {[string equal $cell [$($this,path) index end]]} {
                foreach {left top width height} [$($this,path) bbox $cell] {}
                if {$y > ($top + $height)} {set cell -1,-1}
            }
            if {[string equal $cell $($this,cell)]} return
            in $this [set ($this,cell) $cell]
        }

        proc in {this cell} {
            scan $cell %d,%d row column
            if {($row < 0) || ($column < 0)} return
            if {$column != [$($this,path) index end col]} return
            set path $($this,path)
            set data [$path cget -variable]
            if {[string length $data] == 0} return
            set text [set ${data}($cell)]
            set label [label $path.temporary -font [$path cget -font] -text $text]
            set required [winfo reqwidth $label]
            destroy $label
            foreach {left top width height} [$path bbox $cell] {}
            if {![info exists width] || ($width >= $required)} return
            if {![catch {classof $($this,tip)}]} {delete $($this,tip)}
            set ($this,tip) [new widgetTip                -path $path -rectangle [list $left $top [expr {$left + $width}] [expr {$top + $height}]] -text $text -ephemeral 1            ]
        }

    }

}

proc adjustTableColumns {table} {
    upvar #0 [$table cget -variable] data

    if {[array size data] == 0} return
    update idletasks
    set label [label .temporary]
    set firstRow [$table cget -roworigin]
    set lastRow [expr {$firstRow + [$table cget -rows]}]
    set column [$table cget -colorigin]
    set lastColumn [expr {$column + [$table cget -cols]}]
    set defaultFont [$table cget -font]
    for {} {$column < $lastColumn} {incr column} {
        set maximum 0
        for {set row $firstRow} {$row < $lastRow} {incr row} {
            if {[string length [$table hidden $row,$column]] > 0} continue
            if {[catch {set window [$table window cget $row,$column -window]}]} {
                set font $defaultFont
                if {[$table tag includes title $row,$column] && ([string length [$table tag cget title -font]] > 0)} {
                    set font [$table tag cget title -font]
                }
                set text {}; catch {set text $data($row,$column)}
                $label configure -font $font -text $text
                set width [expr {[winfo reqwidth $label] + (2 * [$table cget -padx])}]
            } else {
                set width [expr {[winfo reqwidth $window] + (2 * [$table window cget $row,$column -padx])}]
            }
            if {$width > $maximum} {
                set maximum $width
            }
        }
        $table width $column -$maximum
    }
    destroy $label
}


proc drawTableLimits {path lastColumn {embeddedWindowsCommand {}}} {
    set previous [$path tag row lastrow]
    if {[llength $previous] > 0} {
        $path tag row {} $previous
        if {[string length $embeddedWindowsCommand] > 0} {
            uplevel #0 $embeddedWindowsCommand $previous {{1 0 1 0}}
        }
    }
    catch {$path tag cell {} [$path tag cell lastcell]}
    set row [$path index end row]
    if {$row < 0} {
        $path configure -borderwidth {1 0 1 1}
        $path window configure -1,$lastColumn -borderwidth 1
    } else {
        $path configure -borderwidth {1 0 1 0}
        $path window configure -1,$lastColumn -borderwidth {1 1 1 0}
        $path tag row lastrow $row
        $path tag cell lastcell [$path index end]
        if {[string length $embeddedWindowsCommand] > 0} {
            uplevel #0 $embeddedWindowsCommand $row {{1 0 1 1}}
        }
    }
}



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}

}


namespace eval help {

    variable description "<center><h4>moodss
<br>Modular Object Oriented Dynamic SpreadSheet
<br>version $global::applicationVersion</h4></center>

<p><i>Copyright &copy; 1997-2005 Jean-Luc FONTAINE (jfontain@free.fr). All rights reserved.</i>
<br><i>Japanese translation thanks to SENRI Hiroshi and KITAHARA Kosei.</i>

<p>This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License (GPL) version 2 as published by the Free Software Foundation (at http://www.gnu.org).
<br>This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

<p>This software uses the following extensions:<ul>
  <li>the BLT library by George Howlett
  <li>the tkTable widget by Jeffrey Hobbs
  <li>the MIME/SMTP library (part of tcllib) by Marshall Rose
  <li>the BWidget widget set
  <li>the tclXML and tclDOM libraries from Zveno
  <li>the Tcl HTML library from Sun Microsystems
  <li>the stooop OO (part of tcllib) extension by me
  <li>the scwoop widget library by me
  <li>the tkpiechart widget by me
  <li>the SQLite library (included in the moodss standalone binary package and Windows package)
</ul>

<p><p>The KDE Crystal theme icons are licensed under the GNU Lesser General Public License (LGPL) version 2.1 as published by the Free Software Foundation (at http://www.gnu.org), with the following addition:

<p><i>Copyright (C) 2002 and following years KDE Artists.</i>
<br>The GNU Lesser General Public License or LGPL is written for software libraries in the first place. We expressly want the LGPL to be valid for this artwork library too. KDE Crystal theme icons is a special kind of software library, it is an artwork library, its elements can be used in a Graphical User Interface, or GUI.
<br>Source code, for this library means:<ul>
  <li>for vectors svg
  <li>for pixels, if applicable, the multi-layered formats xcf or psd, or otherwise png
</ul>
<br>The LGPL in some sections obliges you to make the files carry notices. With images this is in some cases impossible or hardly useful. With this library a notice is placed at a prominent place in the directory containing the elements. You may follow this practice. The exception in section 6 of the GNU Lesser General Public License covers the use of elements of this art library in a GUI.

<p><p>The tclXML and tclDOM libraries by Zveno are made available under the following license terms:

<p><i>Copyright &copy; 1998-2002 Zveno Pty Ltd (http://www.zveno.com/).</i>
<br>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.
<br>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.

<p><p>The Tcl HTML library developed by Sun Microsystems is made available under the following license terms:

<p>Sun Microsystems, Inc.  The following terms apply to all files associated with the software unless explicitly disclaimed in individual files.
<br>The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. Modifications to this software may be copyrighted by their authors and need not follow the licensing terms described here, provided that the new terms are clearly indicated on the first page of each file where they apply.
<br>IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
<br>THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN \"AS IS\" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
<br>RESTRICTED RIGHTS: Use, duplication or disclosure by the government is subject to the restrictions as set forth in subparagraph (c) (1) (ii) of the Rights in Technical Data and Computer Software Clause as DFARS 252.227-7013 and FAR 52.227-19."

}

proc aboutDialogBox {} {
    set dialog [new dialogBox . -buttons x -default x -title [mc {moodss: About}] -x [winfo pointerx .] -y [winfo pointery .]]
    set viewer [new htmlViewer $widget::($dialog,path) -data $help::description]
    composite::configure $viewer base -height 300 -width 500
    dialogBox::display $dialog $widget::($viewer,path)
    composite::configure $dialog -deletecommand "delete $viewer"
}

proc linkedHelpWidgetTip {path} {
    return [new widgetTip        -path $path        -text [mc {display the relevant section in the global help window (may take some time if the window is not yet opened)}]    ]
}




class selectTable {

    proc selectTable {this parentPath args} composite {
        [new scroll table $parentPath            -height 200 -yscrollcommand "selectTable::refreshBorders $this; selectTable::refreshSelection $this"        ] $args
    } {
        set path $composite::($composite::($this,base),scrolled,path)
        $path configure -font $font::(mediumNormal) -colstretchmode last -cursor {} -bordercursor {} -highlightthickness 1            -highlightcolor [$path cget -background] -sparsearray 0 -exportselection 0 -rows 0            -drawmode single
        set ($this,rows) 0
        bindtags $path [list $path all]
        set ($this,left) [frame $path.left -background {} -highlightthickness 1]
        set ($this,right) [frame $path.right -background {} -highlightthickness 1]
        set ($this,bottom) [frame $path.bottom -background {} -highlightthickness 1]
        set ($this,limit) [frame $path.limit -background {} -highlightthickness 1]
        set ($this,tablePath) $path
        bind $path <Configure> "selectTable::refreshBorders $this"
        set ($this,selector) [new objectSelector -selectcommand "selectTable::setRowsState $this"]
        bind $path <ButtonPress-1> "selectTable::select $this \[%W index @0,%y row\]"
        composite::complete $this
    }

    proc ~selectTable {this} {
        variable ${this}frame

        foreach {row frame} [array get ${this}frame] {
            ::delete $frame
        }
        ::delete $($this,selector)
    }

    proc options {this} {
        return [list            [list -background $widget::option(label,background)]            [list -columns 1]            [list -focuscommand {} {}]            [list -followfocus 1]            [list -roworigin 0 0]            [list -selectcommand {} {}]            [list -state normal normal]            [list -titlerows 0 0]            [list -variable {} {}]        ]
    }

    proc set-background {this value} {
        $($this,tablePath) configure -background $value
        foreach {dark light} [3DBorders $($this,tablePath) $value] {}
        $($this,left) configure -highlightbackground $dark
        $($this,right) configure -highlightbackground $light
        $($this,bottom) configure -highlightbackground $light
        $($this,limit) configure -highlightbackground $light
    }

    proc set-columns {this value} {
        $($this,tablePath) configure -cols $value
        refreshBorders $this
        ::adjustTableColumns $($this,tablePath)
    }

    proc set-focuscommand {this value} {}

    proc set-followfocus {this value} {
        if {$composite::($this,complete)} {
            error {option -followfocus cannot be set dynamically}
        }
        if {$value} {
            bind $widget::($this,path) <FocusIn> "selectTable::focus $this 1"
            bind $($this,tablePath) <FocusIn> "selectTable::focus $this 1"
            bind $($this,tablePath) <FocusOut> "selectTable::focus $this 0"
        } else {
            bind $widget::($this,path) <FocusIn> {}
            bind $($this,tablePath) <FocusIn> {}
            bind $($this,tablePath) <FocusOut> {}
        }
    }

    proc set-selectcommand {this value} {}

    proc set-state {this value} {
        switch $value {
            normal {}
            disabled {
                clear $this
            }
            default {
                error "bad state value \"$value\": must be normal or disabled"
            }
        }
    }

    proc set-roworigin {this value} {
        if {$composite::($this,complete)} {
            error {option -roworigin cannot be set dynamically}
        }
        $($this,tablePath) configure -roworigin $value
    }

    proc set-titlerows {this value} {
        if {$composite::($this,complete)} {
            error {option -titlerows cannot be set dynamically}
        }
        $($this,tablePath) configure -titlerows $value
    }

    proc set-variable {this value} {
        if {$composite::($this,complete)} {
            error {option -variable cannot be set dynamically}
        }
        $($this,tablePath) configure -variable $value
    }

    proc setRowsState {this rows select} {
        variable ${this}frame

        set path $($this,tablePath)
        if {$select} {
            foreach row $rows {
                set ${this}frame($row) [new selectFrame $path $row]
            }
        } else {
            foreach row $rows {
                ::delete [set ${this}frame($row)]
                unset ${this}frame($row)
            }
        }
    }


    proc rows {this {number {}}} {
        if {[string length $number] == 0} {
            return $($this,rows)
        } else {
            $($this,tablePath) configure -rows [expr {$number + $composite::($this,-titlerows)}]
            set ($this,rows) $number
        }
    }

    proc select {this row} {
        if {$row < 0} {return 0}
        if {[string equal $composite::($this,-state) disabled]} {return 0}
        if {[info exists ($this,selected)] && ($row == $($this,selected))} {return 1}
        if {([string length $composite::($this,-selectcommand)] == 0) || [uplevel #0 $composite::($this,-selectcommand) $row]} {
            set ($this,selected) $row
            selector::select $($this,selector) $row
            $($this,tablePath) see $row,[$($this,tablePath) index topleft col]
            return 1
        } else {
            return 0
        }
    }

    proc refreshSelection {this first last} {
        variable ${this}frame

        set path $($this,tablePath)
        foreach {row frame} [array get ${this}frame] {
            ::delete $frame
            set ${this}frame($row) [new selectFrame $path $row]
        }
    }

    proc refreshBorders {this} {
        foreach {x y width height} [$($this,tablePath) bbox bottomright] {}
        if {![info exists x]} return
        incr y -1
        incr height $y
        place $($this,limit) -y $height -relwidth 1 -height 1
        place $($this,left) -width 1 -relheight 1 -height 1
        place $($this,right) -relx 1 -x -1 -y 1 -width 1 -relheight 1
        place $($this,bottom) -rely 1 -relwidth 1 -height 1
    }

    proc selected {this} {
        set list {}
        catch {lappend list $($this,selected)}
        return $list
    }

    proc clear {this} {
        selector::clear $($this,selector)
        catch {unset ($this,selected)}
    }

    proc focus {this in} {
        variable ${this}frame

        if {![info exists ($this,selected)]} return
        if {$in} {
            selectFrame::refresh [set ${this}frame($($this,selected))] 0
        } else {
            selectFrame::refresh [set ${this}frame($($this,selected))] 1
        }
        if {[string length $composite::($this,-focuscommand)] > 0} {
            uplevel #0 $composite::($this,-focuscommand) $($this,selected) $in
        }
    }

    proc delete {this rows} {
        set path $($this,tablePath)
        foreach row $rows {$path delete rows $row}
        incr ($this,rows) -[llength $rows]
    }

    proc windows {this} {
        set path $($this,tablePath)
        set list {}
        foreach cell [$path window names] {
            lappend list [$path window cget $cell -window]
        }
        return $list
    }

    proc windowConfigure {this cell args} {
        return [eval $($this,tablePath) window configure $cell $args]
    }

    proc window {this cell} {
        return [$($this,tablePath) window cget $cell -window]
    }

    proc see {this cell} {
        $($this,tablePath) see $cell
    }

    proc spans {this args} {
        return [eval $($this,tablePath) spans $args]
    }

    proc tag {this option args} {
        return [eval $($this,tablePath) tag $option $args]
    }

    proc height {this args} {
        return [eval $($this,tablePath) height $args]
    }

    proc adjustTableColumns {this} {
        ::adjustTableColumns $($this,tablePath)
    }

}


class selectTable {

    class selectFrame {

        proc selectFrame {this table row} {
            foreach side {left top right bottom} {
                lappend ($this,frames) [new frame $table -background {} -highlightthickness 1 -highlightbackground black]
            }
            set ($this,table) $table
            set ($this,row) $row
            refresh $this 0
        }

        proc ~selectFrame {this} {
            eval delete $($this,frames)
        }

        proc refresh {this hide} {
            set table $($this,table)
            foreach {x y width height}                [$table bbox $($this,row),[$table index topleft col] $($this,row),[$table index bottomright col]] {}
            if {![info exists x]} return
            if {$hide} {
                foreach frame $($this,frames) {
                    place forget $widget::($frame,path)
                }
            } else {
                foreach {left top right bottom} $($this,frames) {}
                incr y -1
                place $widget::($left,path) -x -1 -y $y -width 1 -height $height
                place $widget::($top,path) -x -1 -y $y -relwidth 1 -width 1 -height 1
                place $widget::($right,path) -relx 1 -x 0 -y $y -width 1 -height [expr {$height + 1}]
                place $widget::($bottom,path) -x -1 -y [expr {$y + $height}] -relwidth 1 -width 1 -height 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 imageButton {

    proc imageButton {this parentPath args} composite {[new frame $parentPath -borderwidth 1] $args} {
        composite::manage $this [new label $widget::($this,path) -text ?] label
        bind $widget::($this,path) <Leave> {%W configure -relief flat}
        set path $composite::($this,label,path)
        bind $path <Configure> "imageButton::update $this %w %h"
        place $path -x 0 -y 0
        composite::complete $this
    }

    proc ~imageButton {this} {
        catch {image delete $($this,grayed)}
    }

    proc options {this} {
        return [list            [list -command {} {}]            [list -disabledgray 0 0]            [list -image {} {}]            [list -state normal]        ]
    }

    proc set-command {this value} {}

    proc set-disabledgray {this value} {}

    proc set-image {this value} {
        $composite::($this,label,path) configure -image $value
        catch {image delete $($this,grayed); unset ($this,grayed)}
    }

    proc set-state {this value} {
        set path $widget::($this,path)
        set label $composite::($this,label,path)
        switch $value {
            normal {
                bind $path <Enter> {%W configure -relief raised}
                bind $label <ButtonPress-1> "imageButton::action $this 1"
                bind $label <ButtonRelease-1> "imageButton::action $this 0"
                $label configure -image $composite::($this,-image)
            }
            disabled {
                bind $path <Enter> {}
                bind $label <ButtonPress-1> {}
                bind $label <ButtonRelease-1> {}
                if {$composite::($this,-disabledgray)} {
                    if {![info exists ($this,-grayed)]} {
                        set image $composite::($this,-image)
                        set ($this,-grayed)                            [image create photo -width [image width $image] -height [image height $image] -palette 256 -gamma 2]
                        $($this,-grayed) copy $image
                    }
                    $label configure -image $($this,-grayed)
                }
            }
            default {
                error "bad state value \"$value\": must be normal or disabled"
            }
        }
        if {!$composite::($this,-disabledgray)} {
            $label configure -state $value
        }
    }

    proc update {this width height} {
        $widget::($this,path) configure -width [incr width 3] -height [incr height 3]
    }

    proc action {this pressed} {
        if {$pressed} {
            relief $this 1
            set ($this,inside) 1
            bind $composite::($this,label,path) <Motion> "imageButton::motion $this %X %Y"
        } else {
            relief $this 0
            bind $composite::($this,label,path) <Motion> {}
            if {$($this,inside) && ([string length $composite::($this,-command)] > 0)} {
                uplevel #0 $composite::($this,-command)
                after 1000 "$widget::($this,path) configure -relief flat"
            }
        }
    }

    proc motion {this X Y} {
        set inside [string equal [winfo containing $X $Y] $composite::($this,label,path)]
        if {$inside == $($this,inside)} return
        if {$inside} {
            relief $this 1
        } else {
            relief $this 0
            $widget::($this,path) configure -relief flat
        }
        set ($this,inside) $inside
    }

    proc relief {this sunken} {
        set label $composite::($this,label,path)
        if {$sunken} {
            $widget::($this,path) configure -relief sunken
            place $label -x 1 -y 1
            $label configure -background $widget::option(button,activebackground)
        } else {
            $widget::($this,path) configure -relief raised
            place $label -x 0 -y 0
            $label configure -background $widget::option(button,background)
        }
    }

}



if {[package vcompare $::tk_version 8.4] >= 0} {
    set ::tk::Priv(updirImage) [image create photo -data {
        R0lGODlhFgAWAOcAANXW2MfN2LfC1rG91rG91bbB1sbM17O/13ua1FuF0kh40UF01Ud3z1qDznmY0LC91NfX18LJ13iY1D1z1z934FaL722e95Sy6p2353ql
        81qP8Ud62ztv01+GzrK90sTL2GGJ1DJv4GKR6azG9tnj9e/z+vL1+/H1++Do977Q8nWe6jhx2Ux6zai2zz9334as79Le9eTr+OXs+avC69rk9qC77Eh72Up4
        zLO90djY2HWW0zJv3oOp79Hd9Nfi9vv8/v////39/tfi9dXg9Zu37Dxz2G6PzdPT07O/1j1y1WGQ57vO8MjX8snX8vj5/cPT8XSd6D5y0qe1ztXV1XuZ0UB3
        3JOz7bjM7rnM7/f5/brM77bK7pu25Ud62XCRy8zO0cfN11uEz02F7KO76arB6/b4/F6U91CL+Dl68VN9zLnAzUh3z2GS7Zq15/r7/f7+/vf5/j2B/zl+/ENz
        zaezyWuX6Iqq5Yyr5fH0++3x+qnA66fB8czc+l+X/zp//T1x06Ctxl2P7XOb53ad57XJ8fP2/Xmk82CU84Ww/0uK/8TY/7vT/0eI/zt//Z+sxUaE9lKM9VKL
        9VGL9kSF/EOE/EuK/jyB/z2C/zx//EJyzKOvxTd69EOF/UKF/0CE/0KE/zZ59VB7y7K5xzhz4UiI/EmI/EKE/kqJ/0GE/UaG/GyMyMPFyT9z002F616S8V+S
        8V2R8WeX8pm69j1w0Zuqxc7OznSV0EB11m2Y53Sc6Huh6e7z/Pb5/Z2672aIycXFxb3G1F2Fzk9+1nyg4oKl5pm26sDR8q3E7oKm5lZ+yqiyw8/Pz77F012E
        zUp60nOZ4Yys542t6FZ+yauzw8vLy7rD0m+QzUZ2z1iE13qc246t5ZGv6ER1z0R0y0t4zURzy///////////////////////////////////////////////
        /////////////////////////////////////////////////////////////////////////////////yH5BAEKAP8ALAAAAAAWABYAAAj+AP8JHPgPQAAB
        AwgUMACAoEOCBxAkULBgAYMGDh5AeDgwgoQJFCpYuIAhg4YNHDp42OjwA4gQIkaQKGHCxAkUKVSsYNGCpcAIIFy8gBFDhowZSI3SqGHjBo4cA3Xs4NHDh9UZ
        P4AEmeFDyBAiRYwcgYokiZIlTJowmeEEiFsgM5gweQIlipQpAKhUsXIFC5YZWd66/TFDyxYuXbx8ARNGzBgyZGaUESx4hpkzaNKoEbCGTZs2M0y4dfP2xxsg
        cGbEkTOHDoEFdezcweM2j563e/i87ePnD6DXgQQNIgSkkKFDbxElUgRkEaNGfxwVYPAIUqRIkiZRqpTckndLlzDFZdJkoMEmTug5deqUqLt3T59AhRIFwMEo
        UqXylzJ1KjmqVKmQQsooqqzyzwOstOLKKwzCEstbsiz4iiutzEJLLf9AYMstuOQCRS656LILELz0AsWHuNziyy9HCARMMMIMQ8yMxBRjzDHIIEPMMMIko8wy
        UP2TAzPNOPMMNNEkqSQ0zzgjzTTU+JRhNdZcg0022myzjTbZYMONL8pQM8VDORwhhRdpdOONN9+EogotvywjJUE5TPGFGnQA4ogmoqxSy1gEBQQAOw==
    }]
    set ::tk::Priv(folderImage) [image create photo -data {
        R0lGODlhEAAQAMYAADJ02zJz2zNz2zJ03DFw1vX7/fX5/TBt0uj1/ej2/en1/V99sTFt0TBu0TFu0jBt0TBqzNvw/dru/dvu/drw/S9mxsvo/cvp/SVf0S5j
        wLni/bzi/bnh/bzh/Z7G7vz8/azR/S1hvana/anb/Ya57Iy9/Ym+/Ym9/SxeuJnT/SJZy2uq/Wup/SJZzCtasYjL/R9SxVCY/U+Y/U+X/R5SxSpYrnrE/RxJ
        vTmH/TmI/RtJvSlVqG2+/RhAtSh8/Sh7/Sd7/Rg/tShSo2K3/RM3qv39/a6uxhM3rChQnxAtoidNm0+u/QslmQwlmSdLlwkdkQkekQkekP//////////////
        ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
        /////////////////////////////////////////////////yH5BAEKAH8ALAAAAAAQABAAAAe5gH9/AAECAwAAgoqLBAUGjgYGBIuKBwiXCQgKCAsMDQ4N
        Dwx/EBGmphIRExOpExEUEBUWs7QWFxi4uRgZGhobvhwdGB4fxR8gGCEiI7oYJB8lJiYnJxgoKSorxsUsKyzfLC0uLzAxMjIz5ucy5jM0NTY3ODk58zjz9PM6
        Ozw9Pj4/AP74AYTgwCBChhApwrChwyJGjiAZkuShRSNJlCxhYqSjx48dm/xx8qQklCgnn0RBCeUJpZcvAwEAOw==
    }]
    set ::tk::Priv(fileImage) [image create photo -data {
        R0lGODlhEAAQAIQAAI+Pj/////7+/vz8/Pv7+/n5+ff39/b29vr6+vj4+PT09PPz8/Ly8v39/fX19fHx8e/v7/Dw8Onp6evr6+jo6Ozs7Orq6u3t7e7u7qio
        qP///////////////////////yH5BAEKAB8ALAAAAAAQABAAAAWDICCOZCkGaBoIA1EYR3CqAoEkhrIwMqAGDcTLoWA8erRBIXFw7CBIFIuAIzIikijQBtM9
        JpRo7WZwPiqWCbLRKjQZkEvlckFGGLtHBIOB+KEnEYKDEQ9nFlknC4uMCwoTGZEZJw6Vlg4HFRkoAB8+BqChBgkXm52ePyoEkx+tJiatrSEAOw==
    }]
}

set toolBarImage(new) [image create photo -data {
    R0lGODlhFgAWAKUAAM3R3c/T3snO2sTI1cHF07K3yP////3+/vX3+vHz+O3v9t/i6/j5+/P1+fDx+Obo8Ofp8fv8/ff4+/Dy+Nzf6fb4+vn6/IyRo/r7/O7w
    9+vt9M/S3snN2sjM2XR4hczQ3MrP2/z8/dve6NXZ49TX49PW4uXn8ODj7Nnc5tba5PHy+Ort8+Pm7uHk7ejq8vX2+vL0+ers89LW4P//////////////////
    /////////////////////////////////yH5BAEKAD8ALAAAAAAWABYAAAbpwB8gQCwKBoRC4cdsOgOGaPSASCgCi6XzKZ0yGo7AA6Ld/qBdQ0TSCEwilDI3
    HfkGGIYK2YzuRiwIF4KDF1t9UgcYEhkZGhscHR6GaQYHawkaCwAfIJJzXSEYCBALIiMkJZ5Nh5UMVSYnIigoKapMrAcqGisQJiwnCxS2Z11UGQoaEBAPLS0L
    w1AH0ggNExPILr0sLdB5FRUILw0JKsi8JibdEusICDDkyDHLLOrrFeIJVti99RL34/o0ZEs3aZ0/fAEH9gMHUAEyZQS5tAsHsNyued0iaLRggWGCCY14DZPh
    oaTJkyhtBQEAOw==
}]
set toolBarImage(open) [image create photo -data {
    R0lGODlhFgAWAOcAAAImtjJu2m6i7qamyqLG+tLS1hY+unJ6xs7y/jp+9tbi+rrq/g5S0tby/oq+/kJWvmp+xhpa0rLm/u7y+sbK1k6a/nqy8iIyyoqSzq6y
    0naK0gI6xmJ2yjZawkaG5vLy+h5Czp6m2vb2/pau5h5e1rKy0jZOyprO/m6S4lKO6laS+kZy0urq+qbe/gYqvrK20gY+3tLW6kaO/n6y/iJi7h5KwhI6tnai
    7lJmwgIqwrq61rLK9mKa6vL+/oaWzo6W0jJ29hYuwsLK7iZKwjJi0ipWyoa69laK4mqCyi5i0sLu/qK66maO7t7i9l6W6hpS5m6e7h5a7gIy1qLK/ub2/s7O
    6vr6/mqCztba9jZy3kJi1nKq/r7C1uL+/pK6+gomvhI60v7+/oq2+r7W+pa++hJC3ipGvkp+4oKq9jJy8gI63u7u+sbG5ipm6r6+3lqe/l6a+qquziY6ykaW
    /qrO+kZy5g4qypaezjZm1tra7mKG3gYyth5q8hJS0qLS/ub+/rrm/iJi1maS6uLy/n6Kyj5a0rLa/q7C8uLi9sby/iJW0gIiyqKq3m6q/hpGvnKCxkJexiZS
    yi5q2kJq4k565n6i7ubm9oau9goy0m6m/kqG9lKK+jpy3q7S9naa5mae7tre+r7u/sLC3nqy+kJ+9p7S/ho2ujp29srO7sru/pq68g4yvu7+/s72/jZq1pKe
    1r7C6mae+iI2ysrK4t7e7iZm2jp23m6W5gJC5s7S7o669maK3maW5gImzn6m7oay9nq2/oK6/hpCvtr2/srO1k6e/q620h5i1pbS/iJOxi5azipm2pbC9iJa
    0nae6nqi6rKy2ra22gIqyrq63i5GxoKK0rLS+n6m9r7q/o6SyiZi1j523ubm+rbm/tbW7iZi8sbu/o62+hZS0r7m/mqS5rLS8t7e9pae2nKW5gZC5tLS6u7u
    /vLy/qqu0srK5t7e8nqi7jJu3hpa1gI6yr6+4uLi+sLC4nqy/o6SztjY2NjY2NjY2NjY2NjY2NjY2NjY2CH5BAEKAP8ALAAAAAAWABYAAAj+AP8JHEiwoMGD
    CBMq/EcMH6ECCw1mwIfFHIaIAylggCWCxZpzLwoeEwDlEw8n4v61C8GN3ToW3NYdgDhwWytwoRZIYKbBXRgrLmFyY/OIy0BbrRJhkzCCkYifIoJyq7euWpyB
    WZLSedUkjNef7NixwLJrl54OV5AgyZpoSa6vUF2CUiTo0iU08OCtinfTzwpfvp458+QJBblmAoDNkVGMDwhIkhAkSnHr0BhrdKaQ0fVLjJE5oBNgAuBDUlIG
    VEBR6YKg24lgjd7IANIGDCZZLrjUahXszJ9h5cCVmhFrExAaT8r0WnRBlpl/2lp5UEVFSSkHDrbA0ZQmCgwpUpiPB4EAfUEEVqFaIBu1JZMKUjRwwfje68KX
    kCQs6EGQapyhKV6EU8kulNQxiRaFmGCGKQKRYMsOX1khwhrcmJOHOkKwQU800HCAg0B9iAOXhC/VY443VbABixvQ1HCHQPPcAlcYInxgCS3qzMKFDhnEMcAi
    A82jTQCuuIIHHsooU0QkkdTgiDA2GLDHAxhFFBAAOw==
}]
set toolBarImage(save) [image create photo -data {
    R0lGODlhFgAWAOcAABIWRlZmiuLm6oqWssLK2iYuWpqmvmJylqayxk5Wfuru8nZ+ojo+arbC0o6Ops7W4rKywu7y9n6OrpaWrkpSerK6zh4qUqamukJOcpqa
    rvb29oKCmqKuxrq6ymZqjpaivhoiTlZehkJCbtbW3srK0sLC0i4uYq66zsrS3m5ylq6uvn6Kpp6iujIyYr6+yh4eTlZulpKeump2lkZejnqGojZCavr6/oKG
    ptbe5q6yxoaOrpqqwra2xkZOdnJ6murq7qqqvpKSqp6esjY2Zio2WiYmWmJuklJihra+0s7O0j5Cbtra4ubq7qq2ys7S3r6+1l5mihIaQo6atnp+otre5kpK
    cpKWslJSel5ehkZGbsbG1qKivpqets7O2hYaTrKyyiIiVoqKpjo6amp6mv7+/oaSrk5Odrq6zpqatnKCon6Srp6uxrrG1sbO2tLa4rK+0mZukjpGboaKqq62
    yiYqXl5qjr6+zqquwra2yubm6qamvp6evo6Sro6OqpaWsqqqxsrK1rq61oKOqp6qwnaCok5aflZihjI6Yj5Gbp6ett7e5q6uxpKSru7u8qKittLS3naGqr6+
    0hYWRp6mvj4+arrC0vLy9ra2zqamwnJyklpulm52loaGonZ6nhoaTm56mmpukioqXqqqws7O3o6OrpaWtt7e6pKSsqKiwp6eurKyzuLm7rKyxoKCnkJCcn6K
    qh4eUurq8ubq8sbG2rq60srK2qKiutLS4oqWtpqmwpqasnqGpio2XkpKdkZGcpqaunKCpsbO3tLa5oKOrhYWSrrC1tjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY
    2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY
    2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2CH5BAEKAP8ALAAAAAAWABYAAAj+AP8JHEiwoMGD
    CBP+I2Gng50cQPREtJVIF6M+YUC1SkLQzqpVZCQAk0CmpMmSSHRkIshDGA4yM2BAOnmSwzAlBHMIG0EGhoQdNE0OWjCEoKgHD8isqeQkaMkYB4oOBNImWIRG
    CrJmjSVLlgAnhKC0IMhlVoNiSN6cQMBhzaAPUlYQMhLCBFk2c5ogGJTLQIwBEtLIOFDHUIJQBK00mPOmwhwOfgcIkvtJxhEMdAj2OfGmpIZGeRQtGdFFS4kz
    ARCBISinyQkbEfKsUjTiUS1AJezgMVRj9cBWCBCYKlEi0CVVf/5sSYXGVqFDsAhOmfTB1KhasyLR+rLoD6o9Wyh28Io+0EcMKbee0LrEHdMWNGhO+cFQwAvB
    FAPKjIrE/o+oLXuU4gcpjMRhgX0DebDCLlrQgscXKrhXESOkhFEDCJIQFEInm7jAA0QXOKLLBEE4IMcGLQCQ4UAZiEDJFVeYYUYVVfgigghKUMLAC5JModCP
    QAYZEAA7
}]
set toolBarImage(saveAs) [image create photo -data {
    R0lGODlhFgAWAOcAABIWRlZahv6mOsamTv7uVvqmSsaCSsrS3oZqatqiciIqUv7ucp6uxr5+Uv66Tt6iev7ugv6+Bn6Cpi46Yu7Gqv7qltaulqq2yv7Gao6e
    tv7eAv7qwpqitmp2ljpWhpaGira2xu7y9vLajtKOUsamlqp2YoKSsrbC0trOsv7iFv7KVj5Kcubi2v6+PvbSpraGdr6ylta6Xk5mkvraSoKCoOaKMurOsnZ2
    kv7uzjY+av725v7ODrKqkrKSgs6+uoKKov6qGv6eJpaSshIaQtbe5v7WbrrC1lZmiv7eKv7mYKqirvripqquwsrK0rq6yjpGbkpWeoaSrjI2ZhoiTva2aurq
    6v6yJv7ONtLS1Ipyfv7GKvrmzv7iimJmjsLK2tra6v768qamvaKaprKamoaKqsaObpKSqpqqwnJ+nsLCxsbG2O6aRkZOdsrK2rK6ztKmis7W4vLSJvrePjIy
    Yq6uwnaKqjpCbsKusuqmaua+Wp6OnIaOqiIiU/LaXrq+zkZGcSYuWHZ+nNri6v7Siv7aUmJuktbKxpaeuvraalpulqqqvv66Ev7mNsbGyr6Sgv7WJtbW1vra
    klJSev7GBv7+/v7KHo6Oojo6ara+0h4mTsK6xo6Opj5Cbq66zsLC0oaGouru8o6Wsvb29v7itu66ev7ORr6+0kpKdJqatiImVt7e5l5miuLm7tLS3uKmbioq
    WqKiunJ2mp6Kku6KKhoaTtLOztaqkn6OrmpulrKyxE5Odq62zfrWWv7edsKqovr6/s6qls7Ozj4+alJehrq60jI+Zv7iBnZ6kpaWsKayxs7O3tLa4ioyXvrW
    gp6etIqOroqKpvaqUm56moaWtsbO2raennKCpv7ebvrOHl5qjv7aXtrW0p6qwr6+zUJCb46OriYqWpqGkra2zoKKqv7eRnp+ov66GqKuxvLy9tbS0ra6yu7u
    8iYmVlZegoqKqpKSrjI6Yp6iujY2ZtLW4nqKpmZukpKWsnp6lv7Wgr6+1j4+boaGps7O0rq6zurq7tjY2CH5BAEKAP8ALAAAAAAWABYAAAj+AP8JHEjw37Y8
    pB5YMFSwYUEUcZJsoPAmHcEmfpx0o6MoTEdYqAZomGSuQJlaBP2wYEWpjrVplGKCqaQhApAaWY4RVEeECCUPiUzEpBTJ2I5FQRr8+EMw1zyfMkwwiKljhoZK
    VmZ9CKSPIJMDXyid8TMv5pIUj7QIwLOvUNeBYahRCwGKLih/vBhdabGGBJpVlwg684LJCKZOu5LBkEOulAMDxwoFkELwkJFOF86dO8MhBgFeKqIhSDQMijyB
    kCDZw3Th8IVkPPok0YZhxI0Ow9jMwdKkSbBnnYxQAoOuiogF14pQIdHNzzA7r9JIT0PmwglK6PyxKFLh2iBXd0Cy5GIzAdz0NBLOJfuiJp+mZhV6DXqBbJOZ
    FVLYTW9Ujhu3L8q04YMLOIySgB7vvBOKHeCkIl0TWMSSQQbK5NOPLzZsYUE47pBBwyfFKMBHMKn9g0sUobRBjDjV9OBION+4s8+HxWTCB0Gr0LOHGsSAMEYJ
    srzzzT5EPjPBFDcOFIA0gXQDAh1KiOEMKmZYAs0nNAAyRJICmeGNMJKEecopf5TpzZeX0AKAJQ616eabcA4UEAA7
}]
set toolBarImage(print) [image create photo -data {
    R0lGODlhFgAWAMYAALa2try8vMTExMPDw8LCwr+/v8DAwKCgoM3Nzbm5uezs7P////z8/Pj4+PPz8/T09KysrMfHx/v7+/X19fDw8Onp6erq6qqqqrq6uu3t
    7fb29uTk5N7e3qmpqb29ve/v79jY2MjIyNHR0bOzs+Li4ubm5uDg4Nra2tXV1c/Pz6KiorW1tdLS0ri4uK+vr62traurq6ioqJ6enpmZmZaWlouLi7KystfX
    1/r6+ujo6Nvb25ycnNTU1MbGxsXFxdXU1f7+/vn5+evr68zMzMHBwdbW1srKyrfht6rgqvf89/f3967grpvam/T59Le3t+7u7vb19uPj4+Hh4eXl5efn593d
    3Z2dndnZ2ZqamqWlpcvLy8nJyWpqajIyMjExMTAwMC8vLzQ0NHx8fJubm7CwsFBQUA4ODkdHR5eXl5OTk5CQkIyMjIiIiENDQxEREWFhYaOjo6GhoZSUlNzc
    3LGxsZiYmPLy8tPT05+fn9DQ0NjY2NjY2NjY2NjY2NjY2NjY2CH5BAEKAH8ALAAAAAAWABYAAAf+gH+CggABAocCAwQFBgcIg5CDCQoLlQsMDQ4PEBGRkZOW
    EhMUFRYXnZ6DGBmVEhoUFhsbp6mDAayisBscHB2otR4ZDBofsRwgIB0htX8iIyQUCiUmJygpCCorLLUtCRAuLzAxKjIzNDUrNpE3KAgFOA/xDx85JDrWKTsI
    PIIoPT4/HlhaAISBBBxBGmiYIGSIByJFfBg5giTJwIsXlQTo4WHDEiZNJIgcSZIkgxtOXDyBAmWCy5cwY06IEgOCCSlTqOQoZaGnTwsVclDZIKWKlQvsUKAo
    cgPZladXkN0oonQpliwItPggQICI169guUbQsoVGDAMGuHTx8gWM27dxbr94CSOGQIsxGMg4KWPmDA00gNHQSKNmDZs2bt4kyPJiC5w4O+T0CEKZsoMnVEjM
    oZOmzo40Pm4YIbNDhh1LQHBcpiJFhxY1cmL0KDLoToIPT3IrqFflBoshRnag8MSiA5zjcFTEwSPDyhgs0PMMCgQAOw==
}]
set toolBarImage(configuration) [image create photo -data {
    R0lGODlhFgAWAOf/ABAvXVZaXFhfZilj0ztkzzJp02NoakVs0mZudT1x1TV132pyeWZ1h0101EV41mh3iUh62Ep82nJ5gW17jVl8yGN/oGd/qFd/2G2Al159
    0VGD216AzWR/x1qB2m2EoXCDp2+Go3mFkl2G2XyDl36FjV6H2nGIpWSIz2CI21iM3VuL5EuS71mP2maMzGuLxnKLtGGP1GqL2WSO21eS6nOPsYGNmliT62yN
    23OOw3iQrYuNil+U322O3H2QqGGT5nORwIqPkoKRpF2X8GSW6XCT24yQn5CSj3KV3X2Wv3KX2GyZ34+TomKe72mc6G+b4nCc43Sd13mc0JGZoZSZm3mb5G2g
    7Xue0n+b3nud5nWh6G+j75ScsIGd4IefyY+evYufw3+i14eixp2fnH2i5ISg5HKo7p+hnoKl2pahu4ek1J2ipHum7ouh33+n4oan0JiksXqp6ZCkyYunyoKm
    6ZaluHar8X2o8KKkoYem4oOo6pSnzImo5ZCo04qr1Iqp5o+o4ISt6Iuq54qs4pqpyaeppoyr6JGt0JGr4qmrqKOstIOx8pms0pOt5I+u64mx7KmusI+y6JGw
    7qCvz5Ox75az5Ja34JC49Ju07Kq1w5a476e3ypu46LC4wKW43qG55Jm78p677LW6vK+7yKC97ra7vpy+9be8v6DA6p7A97q+zqnB7bvAwqXC9KzD4r7BvavD
    76jE9qzE8K3F8arH+KjJ88DFyMDE06/H86vI+cfEybfK5LLK9rPL97fL8cbMzrPP9MrMycHM57TQ9cLO3LnQ78TQ3tDN0b3Q98XQ7MPT58zS1LnV+r7W9cvS
    6L/X9srW5NPV0sjX68TY8dHW2cfW98HZ+MLa+dXW4NbY1dPX59Xa3M7Z9c/a9tbb3s3d8drb5dTc8tne4dnd7dXh797f6d/h3tzi5Nzg8ODi3+Hk4N7j89/n
    8OLn6uLm9ubo5efo8ubr7uzq7uft7+nu8Ovs9u3v6+vw8+/x7u3z9fHz8PP18vD2+PT38/f59vn7+P///yH5BAEKAP8ALAAAAAAWABYAAAj+AP8JHEiwoMGB
    KPAwWsiwoUM/MQSKyBZvG7eL3MCti/fuHEZu2759O/FvTLBizqyp9BZP3rx99capVBkt259/bHgdo+bMWbVw9zj628dOms9jwnod+nclFq1ex6KaO9dvmr93
    8ZohPbYrFp5/R0CxwjVr1i9o+/r5G1pO16xds1h94vKvQaBPqDIp0vLGWL+08VadQjUY1KQj/wooSGFIkx4fRKbkwmZMDJI6rYoN25QHxT8CDjB1C1YO0wwZ
    H3rkaKHCTTdx5pTxUfEZRyog6eLZimJDiA0VK4aYOlcPUbZUFxIjmRaPHb5rXWwMYTJkSJJcWPWtIwXh3wEXudL35nMFRUt1JkyaPIrXT183L8kToPBCylgo
    L1q0lHHiJP+ZR8bk8kYMDdQ1RBV/8NFGHQwyYAYCZdhRRx5uuIHFEN1dQAUcL3gAhSKK2DECIQLAASIeH3iQRxYd/HPBHI3UgMgHlliSyQRqBCBIJpa4cYcE
    hZDhmQiNZDKCER+MggooRRizACSlfJIGEAhAwggP/6AwySd0mAICLqfAcooUDJwyCyyduELCJp8Q8Y8Mi9DRyQhy4EKLLLcsoscptNAyCxojDLIIYhl4sUQs
    raiyyy2M3iLLonh2ogodRVAg0AZskBHJIWxE8kchhxTS6aeB+IEHBwAEBAA7
}]
set toolBarImage(refresh) [image create photo -data {
    R0lGODlhFgAWAOcAADJu3naWztbi9pqmurK6xnKSyrbK6l6GzuLq9lqGzsLK1nqe2jp+/uru8sLS8k56zoKm5qayysrS5u7y+mKS5j5y0q7G8kKG/oam5m6S
    zvL2+srW7sLCwqa2zlqG1vb2+pq25q7C7kJyztLe9tLa6m6e9qrC6k6G6jZ69mKa/m6OyrbC1oqq5l6O7qK21qaywvr6+kp6zsbK1mqW6nae6uLm7lqS+tLS
    0srW8pay5p624lqCzq6+0lKO9tri9kJ21m6a5qK+7n6i4pqqwr7S8pKy6vr+/s7W5tbW1srKyj523tLa7rq+zkaG9r7G0jpu0kZ62r7O7lJ6ypKu5p6uxmaK
    yjqC/sLO5l6S8nqm8kZ2yjpy2lKK+oau7srO0p667nqa0maa9rrO7laK7trm9mKW7lJ+ztre6mKK0lqO8oKq7o6u5sbO1qK64s7a9rK+0sLW9vb6+nai8kqK
    +sLGylqW/j5y2nqi6ubq8t7m8k5+1s7a7pq27kJ23nKa4qKuxj6C/mKS6ubu+nqW0v7+/lZ+yjpy4rLG7tbe7o6u6kp2zrrC0qK66j5+/vLy9s7Ozm6e/maa
    +rrO8mKW9ubq+t7m+kZyyjp68qqywqa+6kp62sbGxkp60rK+1j5y1tbi+laO8t7i8mqa8n6i6uLq+vL2/pKu6vr6/kZ2zsrKzvb6/kqK/qK67k6G7m6OzlqS
    /pay6n6i5pqqxpKy7r7O8nqa1t7m9nKa5jJu4naW0rbK7lqG0q7G9p625j524r7G1trm+qK65mKS7qa+7tjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY
    2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY
    2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2CH5BAEKAP8ALAAAAAAWABYAAAj+AP8JHPgPCZsV
    nTqtkIGEoEOCnWrtUOTJE6oEuXg0fChQQa0tfUCVgNXrThpNTw682UhQwQEAgXgJ0KChVClStGhsidGB5T8FaHypGUGJFJk8CBAIEuSDkSZFKwcWwDVUwAYJ
    RxAd2TNCgABEIJSouNFwhadAUdxsQKQBBqE4GnC4cQPHAY0KPZEM6jPLwCFEhAILFqNLlxgDIDSpSMUmwYkgma4YIfTBwaEoYr6YCAFrEpdLZpisQBUoR5sa
    hBwFAcEahA4HcQjVscJARIROnoCwWON2RI4pU1yMwCO4DiArFagQ+NHiVqzYDtKA0iFYcAraFYZ0QtWkxwxShD7PvbowqzqhCTYAMbD0h82OS4DmWJhMBlKY
    UNXJvAKEQg8Bvb400UQkwAQWRwPmuWFDE1uowME/BHjSChZYyPGJKoKpQgqGYpTRyhMDPFJQLj/MQMMtdwzjABy6fHFHEJKYAsQPVdBxg0CL7GDGAhjEAgEE
    GPzYIwZ36FFIBI9shMQvB2jix25rJALlGn5wUggmSfiExCIZKOJBLSyYUgQLC+xgSRUvJHGjQ0jcEEEGhWihyAMiPODKAByk4hNBSCCRCgEDDCHLHwRwkESS
    BAUEADs=
}]
set toolBarImage(help) [image create photo -data {
    R0lGODlhFgAWAOcAAMPH1JKfzXew4tLT16Gt1cDJ5kGa6H2w4LS70quz0ejs+ff5/6av0KW404G04Xu48IiXzI2bzM3P1v///7jB4srM1aew0Dx4zSBrzqS3
    0sLP2lSr85Wo15+p0eTo9qmz2ujr+Iqbz3yt6FaEyWyr453D7ZCdz/7+//39/6ax2vn5/6y23Jez4hlgx8rP1qzF3Gqx8I2cz6Gs19je8vz8//b2/s3U7NXZ
    7tTY7l+a4nmYykWW45+44rC63/j4//T0/PPz/Ku125ej0pC26SNev4ix23y17e/z/fr6//b2/fDw+u3t+OPl9L3E442f1Dx60pSmy8zS2D2Q45On16iy2vf3
    /u7u+Onp9tvf8rvD4uDh8n6t6UNou2Ka2I226NDW7dLX7vX1/e/v+evr9+bm9KWv2erq9pKx4hVSvLzC0rTE11ad5oycz/Ly+ujo9eTk8+bo9qOu2Onp9cvP
    6V6V4WuBv0OG1ZSz4sTM5uHj9OXl9K643tfa7pWj0oqx6BtHsY2s03St6qiz2/n6/7i/3+zs99jc8LrB4bnA4Yyf1Dtzz5Sfx8vQ1y930YqYzMvR67rC4OTl
    9OXl86my2cbM5qax2YCx7DZRsKS40z+D2JSo2JKezsPL5MvP5rnB4Nrc7+Xm9cPK5pil1Iqe1Iq78wI7r3udzVqV4Jel0qKs1K6319/i8sDG4rjA4JOh0I+s
    32ub4C5oyUNcs1J+xXOj4Z2o0KSu0ay11qaw1Zmlz5Oj0Yim3E+D1BFGsmt9vbzB0crO1jFnwYar4Ke74Ky31qe22YCl3jJnxjZSsIaUxLzE0xxYvSNfxE2H
    2SJYvF52u9jY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY
    2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2CH5BAEKAP8ALAAAAAAWABYAAAj+AP8JHEiwoMGD
    BAEEQChQAMIBBAoAYGjgAIKJBBMoWMBgYIOCDh5AiCBhIIACEyZQqGDhAoYMBDVs4AChg0CIKSd4+AAihIgRBUmUMEEhwT+NKU+gSKFiBYsWLgi+gBFDxowE
    FHLSqGHjBg4IOXQU3MEDgoIeCpL6+AEkCBAhQ4gULGKE6JGsE5AkUbKEApMmTp5AIRhFyhQTE6ggQVEFiJUrWLJogbCFS8EuXkx8mQFGRRgxY8gsKWOGyhk0
    aQiqWcNGRuIqbZa4eQMnjpw5EOjUKWjnjlk8ecSY0SNnDx8yb/r4+VMQUCATggYRKjTb0CE3et4gSqRoEUFGjc5qOHoEKZKkJZPMkJFDqZIJS5cKYsqkaROn
    TnI8fQIVShQECKOQUopBppyCSiqqrMJKK6789wosscjinUGz0FKLLbfgkosuu/DSiy+/MARMMMIMQ0wxxhyDTDIMEaTMMsw048wzIbZo40EBAQA7
}]
set toolBarImage(exit) [image create photo -data {
    R0lGODlhFgAWAOcAAJJGPvbm3r6qpqJeVsqKYqZ2burOwr42IroqFsJ6TurGsvbq4tKefro+IrpeNtaifvry6sJuQua+ptKadrZKJsaGXsZWNrpWLs6WcsZu
    SspiQtaCYt6qjpJOQv728tqKbtJ+ZvLazs6KZsaCVs6Sbr5qPqp2csZySv769taGYrpmPsJyRs5ySspmQtKKapZSRsZiQsZ+Vu7SvsI+Kt6ylrZSMtqSdsJ2
    TsqGXvLe1tqegsJ6Wvru5v7++s52Ts5+XtamisZ2TrpiNrpaMu7SxtaWdtaSdtKObsp6VubKvs5uStKaftKCXspqRurKus6OataeesqGYsZ6TpZOQsp2VpZK
    QsqCWvLWypJKPqJiWsqOaurCrtqultaKZsp+Vr5iPs6GYpJKQurWxr5mQtaKbtKSbvLi2sqKZtKWcuKyltqmhrpiPpZSSs6Sdr5mOsZ6WtaafrZWKt6ukpZO
    Rvrq5u7Gstqigv7y7sJuSr5qRv7+/taeguKynu7WysZ2UtaKasZ+WsJySr5mPtKaes5yTrpaNspqSu7Ovu7Kur6qqs6Scs52UsZ6UsJ2Uvru6t6ultKegsaC
    WsaGYtaefsqKaqZ2csJ6UrpeOtaigvry7sJuRrpWMpJORv729r5qQsZyTv76+rpiOsqCXs6GZtKWdtqmiua+qs6WdtaGZtaWeurCssp+WtKScuKymtaagtjY
    2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY
    2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY
    2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2CH5BAEKAP8ALAAAAAAWABYAAAj+AP8JHEiwoEGC
    AgZ0YMPmhcOHc+a8CDNAAMFKM0DY+EDmzx9UIFOkYELS0IFKAgXM0PLmUqgvY8asWaMiUKAbjCxV2HHA4gAQbyhsclCoRgYXRUQE+nIzSAIcMAb842Tj0qZL
    cU5sCaBHD6gAEvycePMm0qIO/9h8WFNoyKoFelDkMMBVTwACMbyYnfJvDpkvhajQ0RPiSBCye3joMWMlEgFCaF+QGRPHiZ4rGRy00jNJxRPFEmIQyMD3xZ81
    VBzpieJGUx09HKTc4GD3jCRCVf6ZDsVKTx9BQVYogO0nxmcUdqJkyD3njwNXegy4uYHnNY0YkUQsAPVAi5LIf1TowNEjRhOjQIj0PIpRgQQEUGq0NMHSN4Un
    MJ1APTFvmQaOEbQFQAoaLeTGSQqBlNAHYTFosoUeciQwiGoykDBIC/TNwQQjmoxyB2Gk4IAGAaUotsAgDDDQQhh9MdFIEIHY8aFcRJjRgx48qEEKJJBoQF8H
    IDDSSAw3sCKDal05IsMeE2BSCiQWsDiAITjcgB0gMaDBBQ00TILBIHsAwYUiDWTxjwAH7IBDJKJUcEYUOBBwxpcM8PhEDQhY9E8BB8DgwyInsJCBEko00UQL
    LcBgQQMIoDRQQlhMMUUYk4ZRBRZYAJBpRQIFBAA7
}]
set toolBarImage(record) [image create photo -data {
    R0lGODlhFgAWAMYAANbW1tPT09LS0gAAALS0tMfHx9XV1Q0EBG4gILMzM949PepAQNk5Oa0sLGcZGQwCArGxscjIyGEdHeJCQtgqKsYSEr0EBL0AAMIEBMwP
    D9YhIdAvL1YTE5+fn8XFxdTU1H0mJuU5OcEODrgAALoAAMAAAMMAAMYAAMkAAM4KCtYlJW4WFp2dnbkFBcsAAM4AANEDA9QhIVIPD9EAANQAANUICMIiIgsB
    AXBwcNcAANoAANIVFVsODpWVlcbGxt0AANkJCZUVFd8AAN8CArgZGV5eXqqqquIAAOUAAMIYGFtbW6ioqOUBAbMUFOgAAN4GBo4ODusAAM8LC1UHB+MEBK8P
    DwoAAD09PeoBAcQNDUgFBVNTU14HB0BAQD4+PmZmZlxcXKmpqf//////////////////////////////////////////////////////////////////////
    /////////////////////////////////////////////////yH5BAEKAH8ALAAAAAAWABYAAAf+gH+Cg4SFhod/A4qLAwQFiIMDBwgJCgsMDQ4PAxARiAMS
    ExQVFhcYGRobHAMdHoYDICEiIyQXJSYnKCkqKwMsrpESIS20trgoLi8wMTKsnoIHE7O1t7nJMzQ1Njc4EAKJCBTF1cgv2Dk6OzwDPT6JCRXUx9c06D9AQQM4
    BIkKpeT07AkZQmRAESOJFhizZq6ejh9CjiBJMkDJkkQMMMxrKFAikyYVLw5okIHhuYcRkTh5AiVkIgcayp2EKNFJFClTDCIk8GBDCo4oa0ahUsXKlX1/Cgzg
    oAKGQ5oqo2DJomXAlnaCIAxYEaNG0KhUsnAZ0KXboAgdBsiwsQPIECRFTJ5IqVLVy5cOzwR5YDHgBo8gRJI0gTLFCtkvvwx56ICD0aIrW3C0QhQBQg8cRcAo
    UVIER49OkP4IKEDASJglS4w4MhQIADs=
}]
set toolBarImage(recording) [image create photo -data {
    R0lGODlhFgAWAOcAANTV18fM17bB1rC91bbB1cXL1rK/1nqZ1FuE0kh40UB01Ud3z1qDzniX0K+809bW1sHI13iY1D1z1z934FaL722e95Sy6p2353ql81qP
    8Ud62ztv01+GzbG80cPK12GI0zJv4GKR6azG9tnj9e/z+vL1+/H1++Do977Q8nWe6jhx2Ux6zae1zj9334as79Le9eTr+OXs+drk9qC77Eh72Up4zLK80NfX
    13WV0zJv3oOp79Hd9Nfi9tfh9dfi9dXg9Zu37Dxz2G6PzdLS0rK/1T1y1WGQ57vO8MjX8oKm6cPT8XSd6D5y0qa0ztTU1HqZ0UB33JOz7bjM7rnM7/8iIv9G
    Rv9XV/86Ov8WFv8CAv8AAL7Q8LbK7pu25Ud62HCQy8vN0MfM1luEz02F7KO76arB6/+YmP+5uf9+fv8uLv8JCV6U91CL+Dl68VN9zLi/zEh3z2GS7Zq155m1
    5/+Xl/83N/8LC1+S8TuA/zl+/EJzzaayyGuX6Iqq5Yyr5ZKv5v9mZv8lJf8HBzp//T1x05+txl2P7XOb53ad54Om6P8NDTyB/zt//Z6sxUaE9lKM9VKL9VGL
    9j2C/zx//EJyzKOuxTd69EOF/UCE/0KE/zZ59VB7yrG5xzhz4UiI/EmI/GyMyMLEyD5z002F616S8WKU8T1w0Zupxc3NzXSUz0B11m2Y53Sc6HOc6GaIyMTE
    xNPT073F1F2Ezk9+1nyg4oKl5oKm5lZ+yqexw87Ozr3E0l2EzUp60nOZ4Yys542t6FZ+yaqywsrKyrrC0W+QzUZ2z1iE13qc246t5ZGv6ER1z0R0y0t4zURz
    y9jY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY
    2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2CH5BAEKAP8ALAAAAAAWABYAAAj+AP8JHPgPQAAB
    AwYQKACAoEOCBg4gSKBAwQIGDRw8eDgQQgQJEyhUsHABQwYNGzh02OjQwwcQIUSMIFGihIkTKFKoWMGCpUAIH1q4eAEjhtGjMWTMoFHDxo2BOHLo2MGjqtUe
    PXj4+AEkiJAhT4kUMXIESZKzaNMiUbKESRMnAJ5AiSJlShIqVaxcwZJFi5YkW7h08fIFTBgxY8iUKZOkipkzaNKo8ZtkzRo2bdy8IQAnjhw5c5JYOXOGTh07
    lO/gwZNHz54BCvj08fMnyRU0dAAFEuT3jmo8gwgVgm3oEKJESbCkqRNIkV8tqhctYkSoEYEFjh5BghQpixo7vJ+7R5c0iVKlAgwsXVp/6bl76HgwZdK0iROA
    Bp08fdr/XjweT550Akoo/zggyiik+Kbggr6VQsooppyCyj8PpKLKKqwswUqGGrLSyhIarqKKK6/AIlAsssxCSy0s1mILi7a8SMsst+CSy1P/3KDLLrz04ssv
    QAbpSy+8ABOMMD5ROAwxxRhzDDLJJIPMMcYo4wouwjjx0A1DNPGFG8sww0wzm4Byyiu5JEnQDU6A8cYehTRSCSehoAILjgIFBAA7
}]
set toolBarImage(stop) [image create photo -data {
    R0lGODlhFgAWAOcAANTV18fM17bB1rC91bbB1cXL1rK/1nqZ1FuE0kh40UB01Ud3z1qDzniX0K+809bW1sHI13iY1D1z1z934FaL722e95Sy6p2353ql81qP
    8Ud62ztv01+GzbG80cPK12GI0zJv4GKR6azG9tnj9e/z+vL1+/H1++Do977Q8nWe6jhx2Ux6zae1zj9334as79Le9eTr+OXs+drk9qC77Eh72Up4zLK80NfX
    13WV0zJv3oOp79Hd9Nfi9tfh9dfi9dXg9Zu37Dxz2G6PzdLS0rK/1T1y1WGQ57vO8MjX8oKm6cPT8XSd6D5y0qa0ztTU1HqZ0UB33JOz7bjM7rnM7////77Q
    8LbK7pu25Ud62HCQy8vN0MfM1luEz02F7KO76arB616U91CL+Dl68VN9zLi/zEh3z2GS7Zq155m151+S8TuA/zl+/EJzzaayyGuX6Iqq5Yyr5ZKv5jp//T1x
    05+txl2P7XOb53ad54Om6DyB/zt//Z6sxUaE9lKM9VKL9VGL9j2C/zx//EJyzKOuxTd69EOF/UCE/0KE/zZ59VB7yrG5xzhz4UiI/EmI/GyMyMLEyD5z002F
    616S8WKU8T1w0Zupxc3NzXSUz0B11m2Y53Sc6HOc6GaIyMTExNPT073F1F2Ezk9+1nyg4oKl5oKm5lZ+yqexw87Ozr3E0l2EzUp60nOZ4Yys542t6FZ+yaqy
    wsrKyrrC0W+QzUZ2z1iE13qc246t5ZGv6ER1z0R0y0t4zURzy9jY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY
    2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY
    2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2CH5BAEKAP8ALAAAAAAWABYAAAj+AP8JHPgPQAAB
    AwYQKACAoEOCBg4gSKBAwQIGDRw8eDgQQgQJEyhUsHABQwYNGzh02OjQwwcQIUSMIFGihIkTKFKoWMGCpUAIH1q4eAEjhtGjMWTMoFHDxo2BOHLo2MGjqtUe
    PXj4+AEkiJAhT4kUMXIESZKzaNMiUbKESRMnAJ5AiSJlShIqePPiTVLFyhUsWbRs4dLFy5cvd/XmTQIGTBgxY8gQKGPmzBk0iRVTSZJGjZo1bNoMUODmDZw4
    mRWn6axGzhw6o+vYuYMntd7OefLombOHwAI+ffz4+aMZL25AgQQNKsCAUKHnhYpT6WzoEKJEigA0WMSokXfpnRmVMVrk6NE/B5AiSVrNvv3qSZIiUapk6d+D
    S5gyaVqiaT9/TZsswV8mmHDSiScCfQJKKKKM4uAopDhISoSihFKKKac89c8NqKSiyiqstCLiiKysooorr8Dik32xyDILLbXYcsstttRCCy6cmAKLEw/dMEQT
    WYyRiy667JKII5V0csqKBN3ghBZktEHHHoMo8oglnmgoUEAAOw==
}]
set toolBarImage(play) [image create photo -data {
    R0lGODlhFgAWAOcAANTV18fM17bB1rC91bbB1cXL1rK/1nqZ1FuE0kh40UB01Ud3z1qDzniX0K+809bW1sHI13iY1D1z1z934FaL722e95Sy6p2353ql81qP
    8Ud62ztv01+GzbG80cPK12GI0zJv4GKR6azG9tnj9e/z+vL1+/H1++Do977Q8nWe6jhx2Ux6zae1zj9334as79Le9eTr+OXs+Yap6drk9qC77Eh72Up4zLK8
    0NfX13WV0zJv3oOp79Hd9Nfi9v///9fh9dfi9dXg9Zu37Dxz2G6PzdLS0rK/1T1y1WGQ57vO8MjX8snX8liS+cPT8XSd6D5y0qa0ztTU1HqZ0UB33JOz7bjM
    7rnM77bK7pu25Ud62HCQy8vN0MfM1luEz02F7KO76arB66e+6ous516U91CL+Dl68VN9zLi/zEh3z2GS7Zq155m151eO8juA/zl+/EJzzaayyGuX6Iqq5Yyr
    5ZKv5kKE/Dp//T1x05+txl2P7XOb53ad54Om6IKm6XWf7V2R8TyB/zt//Z6sxUaE9lKM9VKL9VGL9kSF/EOE/EWG/z2C/zx//EJyzKOuxTd69EOF/UKF/0GE
    /0CE/0KE/zZ59VB7yrG5xzhz4UiI/EmI/EKE/kGE/UaG/GyMyMLEyD5z002F616S8V+S8WSW8l2R8j1w0Zupxc3NzXSUz0B11m2Y53Sc6HOc6GaIyMTExNPT
    073F1F2Ezk9+1nyg4oKl5oKm5lZ+yqexw87Ozr3E0l2EzUp60nOZ4Yys542t6FZ+yaqywsrKyrrC0W+QzUZ2z1iE13qc246t5ZGv6ER1z0R0y0t4zURzy9jY
    2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY
    2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2CH5BAEKAP8ALAAAAAAWABYAAAj+AP8JHPgPQAAB
    AwYQKACAoEOCBg4gSKBAwQIGDRw8eDgQQgQJEyhUsHABQwYNGzh02OjQwwcQIUSMIFGihIkTKFKoWMGCpUAIH1q4eAEjhowYSJHOoFHDxg0cA3Po2MGjh1Uf
    Mnr8+NEDSBAhQ4gUgWrkCJIkSpYoUeLDB5O1apU0cfIEShQAUqZQqWKlr5W2bv1auYIli5YtXLp4+QKmcWPAbsGEETOGTBkzZwigSaNGzRrPaiC7lcGmTRs3
    b+AMUBBHzhw6sOmIdlvHtJ07eFbn0bOHTx8/f2b7AEQ80B1BBBYMIlSokKFDiGYnIq5oEaNGBRg4esT9ESRIoiOyEZc0iVIlSwAaXMKUqX0mTZAjbeLECROm
    S508/XPwCVQoUQAG19YopPwnSiiglGLKKf88gEoqqqzixCqrtEUhK05MqEoqrbjyikCwxCLLLLSU6EMtJdaC4iyy2HILLlD9g0MuuuzCSy++5KhjL7zs8gsw
    wfjUoDDDEFOMMccgg8wxxhSTTCu3BBPFQzgUAYUWZiizzDLMVNKJKa7gIiRBOESxxRlw4CFII5Z4csorMQoUEAA7
}]
set toolBarImage(playing) [image create photo -data {
    R0lGODlhFgAWAOcAANTV18fM17bB1rC91bbB1cXL1rK/1nqZ1FuE0kh40UB01Ud3z1qDzniX0K+809bW1sHI13iY1D1z1z934FaL722e95Sy6p2353ql81qP
    8Ud62ztv01+GzbG80cPK12GI0zJv4GKR6azG9tnj9e/z+vL1+/H1++Do977Q8nWe6jhx2Ux6zae1zj9334as79Le9eTr+OXs+Yap6drk9qC77Eh72Up4zLK8
    0NfX13WV0zJv3oOp79Hd9Nfi9iD/INfh9dfi9dXg9Zu37Dxz2G6PzdLS0rK/1T1y1WGQ57vO8MjX8snX8lj/WGL/YliS+cPT8XSd6D5y0qa0ztTU1HqZ0UB3
    3JOz7bjM7rnM76P/o7f/t47/jrbK7pu25Ud62HCQy8vN0MfM1luEz02F7KO76arB69H/0ev/66e+6ous516U91CL+Dl68VN9zLi/zEh3z2GS7Zq155m157n/
    uVeO8juA/zl+/EJzzaayyGuX6Iqq5Yyr5ZKv5nP/c4H/gWX/ZTf/NxT/FAb/BkKE/Dp//T1x05+txl2P7XOb53ad54Om6IKm6XWf7V2R8TH/MTj/OCz/LBf/
    Fwn/CQH/AQD/ADyB/zt//Z6sxUaE9lKM9VKL9VGL9kSF/EOE/A//DxL/Eg3/DQj/CEWG/z2C/zx//EJyzKOuxTd69EOF/UKF/wL/AkGE/0CE/0KE/zZ59VB7
    yrG5xzhz4UiI/EmI/EKE/kGE/UaG/GyMyMLEyD5z002F616S8V+S8WSW8l2R8j1w0Zupxc3NzXSUz0B11m2Y53Sc6HOc6GaIyMTExNPT073F1F2Ezk9+1nyg
    4oKl5oKm5lZ+yqexw87Ozr3E0l2EzUp60nOZ4Yys542t6FZ+yaqywsrKyrrC0W+QzUZ2z1iE13qc246t5ZGv6ER1z0R0y0t4zURzy9jY2NjY2NjY2NjY2NjY
    2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2NjY2CH5BAEKAP8ALAAAAAAWABYAAAj+AP8JHPgPQAAB
    AwYQKACAoEOCBg4gSKBAwQIGDRw8eDgQQgQJEyhUsHABQwYNGzh02OjQwwcQIUSMIFGihIkTKFKoWMGCpUAIH1q4eAEjhowYSJHOoFHDxg0cA3Po2MGjh1Uf
    Mnr8+NEDSBAhQ4gUgWrkCJIkSpYoUcKkiZO1apU8gRJFyhQAVKpYuYKlL5YsWrY48YuFSxcvX8CEETOGTJnHj82c0eK2DJo0atawaeOGwBs4ceLIER1njpks
    THw4kUGnTh07d/AMUJBHzx4+uPn08fMHUCBBTga5JlTI0OxDiBIpWsSokaNHkCJJmkSpknVLhS4RWIApkyZNmzjTdfL0CVQo6qKsjyJVylQBBqdQyUeVKpWq
    +9RXWWfVytUrWAA0EIsssxQ4Cy2UJEjJKrXYYossssRyCy7/OJCLLrvwomEjCvbiS4a87KLLL8AE888DwgxDTDFQFFNMgi4aA0WLxAxzDDLJCKTMMsw048yP
    lDzz4zNCNsMMNNFIA9U/OExDTTXWXIPNlFReY0012WizjU8nctONN9+AE4444oQDzjfjHBPNNlM8hEMRUnzRBjnllGPOK7cAg4w0XBKEwxRguIGHIZeYAgsu
    wSSzpEABAQA7
}]

proc initializeMenuHelp {} {
    if {[info exists ::menuHelp]} return
    set ::menuHelp(file,new) [mc {unload all modules and remove all viewers}]
    set ::menuHelp(file,open) [mc {load dashboard from a file}]
    set ::menuHelp(file,saveAs) [mc {choose file for saving dashboard configuration}]
    set ::menuHelp(file,print) [mc {print dashboard window}]
    set ::menuHelp(file,exit) [mc {close main window and exit program}]
    set ::menuHelp(edit,configuration) [mc {edit current dashboard configuration}]
    set ::menuHelp(view,refresh) [mc {refresh display of all synchronous modules}]
    set ::menuHelp(view,refreshDatabase) [mc {update display from database according to cursors positions}]
    set ::menuHelp(help,global) [mc {global help for user}]
    set ::menuHelp(file,database,load) [mc {display cells data history from database}]
    set ::menuHelp(file,database,record) [mc {start recording cells data history in database}]
    set ::menuHelp(file,database,stop) [mc {stop recording cells data history in database}]
    set ::menuHelp(file,database,record,disabled) [mc {no cells to archive: edit database}]
}

proc updateTitle {} {
    foreach {loadedUserModules anySynchronousModules databaseConnected databaseMode anyRecordableCells} [userInputStates] {}
    if {$databaseMode} {
        set title [mc {moodss: Database history}]
        wm title . $title
        wm iconname . $title
    } elseif {$loadedUserModules} {
        set names [modules::namesWithout formulas]
        if {$anySynchronousModules} {
            wm title . [format [mc {moodss: %s data (every %u seconds)}] [commaSeparatedString $names] $global::pollTime]
        } else {
            wm title . [format [mc {moodss: %s data (asynchronous)}] [commaSeparatedString $names]]
        }
        wm iconname . "moodss $names"
    } else {
        wm title . moodss
        wm iconname . moodss
    }
}

proc updateMenuWidget {{parentPath .}} {
    static help
    static cache

    initializeMenuHelp
    foreach {loadedUserModules anySynchronousModules databaseConnected databaseMode anyRecordableCells} [userInputStates] {}
    set moduleNames [modules::namesWithout formulas]
    if {[info exists cache]} {
        set change 0
        foreach {name value} [array get cache] {
            if {![string equal [set $name] $value]} {set change 1; break}
        }
        if {!$change} return
    }
    foreach name {
        loadedUserModules anySynchronousModules databaseMode databaseConnected anyRecordableCells global::readOnly moduleNames
    } {
        set cache($name) [set $name]
    }

    set compound [expr {[package vcompare $::tcl_version 8.4] >= 0}]
    set menu .[string trimleft $parentPath.menu .]
    if {[winfo exist $menu]} {
        for {set entry 0} {[string length [$menu type $entry]]} {incr entry} {
            destroy [$menu entrycget $entry -menu]
            $menu delete $entry
        }
    } else {
        menu $menu -tearoff 0
        frame $menu.bound
    }
    if {![info exists help(bar)]} {
        set help(bar) [new menuContextHelp $menu]
    }
    set index(bar) -1

    menu $menu.file -tearoff 0
    if {![info exists global::fileMenuContextHelper]} {
        set global::fileMenuContextHelper [new menuContextHelp $menu.file]
    }
    set index(file) -1

    foreach {string underline} [underlineAmpersand [mc &File]] {}
    $menu add cascade -label $string -menu $menu.file -underline $underline
    menuContextHelp::set $help(bar) [incr index(bar)] [mc {file related operations}]

    catch {unset global::fileMenuContextHelperSaveIndex}
    bind $parentPath <Control-n> {}
    bind $parentPath <Control-o> {}
    bind $parentPath <Control-s> {}
    bind $parentPath <Control-a> {}
    if {!$global::readOnly} {
        foreach {string underline} [underlineAmpersand [mc &New]] {}
        $menu.file add command -label $string... -command clear -underline $underline -accelerator Ctrl+N
        bind $parentPath <Control-n> clear
        menuContextHelp::set $global::fileMenuContextHelper [incr index(file)] $::menuHelp(file,new)
        if {$compound} {$menu.file entryconfigure $index(file) -compound left -image $::toolBarImage(new)}

        foreach {string underline} [underlineAmpersand [mc &Open]] {}
        $menu.file add command -label $string... -command reload -underline $underline -accelerator Ctrl+O
        bind $parentPath <Control-o> reload
        menuContextHelp::set $global::fileMenuContextHelper [incr index(file)] $::menuHelp(file,open)
        if {$compound} {$menu.file entryconfigure $index(file) -compound left -image $::toolBarImage(open)}

        foreach {string underline} [underlineAmpersand [mc &Save]] {}
        $menu.file add command -label $string -command {save 0} -underline $underline -accelerator Ctrl+S
        bind $parentPath <Control-s> {save 0}
        set global::fileMenuContextHelperSaveIndex [incr index(file)]
        if {$compound} {$menu.file entryconfigure $index(file) -compound left -image $::toolBarImage(save)}
        if {($loadedUserModules == 0) && !$databaseMode} {
            $menu.file entryconfigure $index(file) -state disabled
        }
        foreach {string underline} [underlineAmpersand [mc {Save &as}]] {}
        $menu.file add command -label $string... -command {save 1} -underline $underline -accelerator Ctrl+A
        bind $parentPath <Control-a> {save 1}
        menuContextHelp::set $global::fileMenuContextHelper [incr index(file)] $::menuHelp(file,saveAs)
        if {$compound} {$menu.file entryconfigure $index(file) -compound left -image $::toolBarImage(saveAs)}
        if {($loadedUserModules == 0) && !$databaseMode} {
            $menu.file entryconfigure $index(file) -state disabled
        }
    }

    foreach {string underline} [underlineAmpersand [mc &Modules]] {}
    $menu.file add cascade -label $string -menu [menu $menu.file.modules -tearoff 0] -underline $underline
    menuContextHelp::set $global::fileMenuContextHelper [incr index(file)] [mc {operations on modules}]

    if {![info exists help(modules)]} {
        set help(modules) [new menuContextHelp $menu.file.modules]
    }
    set index(modules) -1
    set disable 1
    if {!$databaseMode} {
        if {$global::readOnly} {
            if {[llength $moduleNames] > 0} {
                set disable 0
                foreach {string underline} [underlineAmpersand [mc Loa&ded]] {}
                $menu.file.modules add command -label $string... -command {new moduleOperations display} -underline $underline
                menuContextHelp::set $help(modules) [incr index(modules)] [mc {view loaded modules and their options}]
            }
        } else {
            set disable 0
            foreach {string underline} [underlineAmpersand [mc &Load]] {}
            $menu.file.modules add command -label $string... -command {new moduleOperations load} -underline $underline
            menuContextHelp::set $help(modules) [incr index(modules)] [mc {load new module instances}]
            if {[llength $moduleNames] > 0} {
                foreach {string underline} [underlineAmpersand [mc &Manage]] {}
                $menu.file.modules add command -label $string... -command {new moduleOperations manage} -underline $underline
                menuContextHelp::set $help(modules) [incr index(modules)] [mc {unload, reconfigure modules or create new instances}]
            }
        }
    }
    if {$disable} {
        $menu.file entryconfigure $index(file) -state disabled
    }

    if {!$global::readOnly} {
        foreach {string underline} [underlineAmpersand [mc &Database]] {}
        $menu.file add cascade -label $string -menu [menu $menu.file.database -tearoff 0] -underline $underline
        set global::fileDatabaseMenu $menu.file.database
        menuContextHelp::set $global::fileMenuContextHelper [incr index(file)] [mc {operations on database}]
        if {![info exists help(database)]} {
            set help(database) [new menuContextHelp $menu.file.database]
        }
        set index(database) -1
        foreach {string underline} [underlineAmpersand [mc &Load]] {}
        $menu.file.database add command -label $string... -command "loadFromDatabase [expr {!$global::readOnly}] $global::static"            -underline $underline
        menuContextHelp::set $help(database) [incr index(database)] $::menuHelp(file,database,load)
        if {$compound} {
            if {($loadedUserModules == 0) && $databaseMode} {
                $menu.file.database entryconfigure $index(database) -compound left -image $::toolBarImage(playing)
            } else {
                $menu.file.database entryconfigure $index(database) -compound left -image $::toolBarImage(play)
            }
        }
        if {!$databaseMode && ($loadedUserModules > 0)} {
            foreach {string underline} [underlineAmpersand [mc &Record]] {}
            $menu.file.database add command -label $string -command {databaseRecording 1} -underline $underline
            menuContextHelp::set $help(database) [incr index(database)] $::menuHelp(file,database,record)
            if {$compound} {$menu.file.database entryconfigure $index(database) -compound left -image $::toolBarImage(record)}
            set global::fileDatabaseMenuStartIndex $index(database)
            if {($global::database != 0) || !$anyRecordableCells} {
                $menu.file.database entryconfigure $index(database) -state disabled
            }
            foreach {string underline} [underlineAmpersand [mc &Stop]] {}
            $menu.file.database add command -label $string -command {databaseRecording 0} -underline $underline
            menuContextHelp::set $help(database) [incr index(database)] $::menuHelp(file,database,stop)
            if {$compound} {
                if {$global::database == 0} {
                    $menu.file.database entryconfigure $index(database) -compound left -image $::toolBarImage(stop)
                } else {
                    $menu.file.database entryconfigure $index(database) -compound left -image $::toolBarImage(recording)
                }
            }
            if {$global::database == 0} {
                $menu.file.database entryconfigure $index(database) -state disabled
            }
        }
    }

    foreach {string underline} [underlineAmpersand [mc &Print]] {}
    $menu.file add command -label $string... -command $global::printDialogCommand -underline $underline -accelerator Ctrl+P
    menuContextHelp::set $global::fileMenuContextHelper [incr index(file)] $::menuHelp(file,print)
    if {$compound} {$menu.file entryconfigure $index(file) -compound left -image $::toolBarImage(print)}
    bind $parentPath <Control-p> {}
    if {[string equal $::tcl_platform(platform) unix] || ![catch {package require Tkprint 1.1}]} {
        bind $parentPath <Control-p> $global::printDialogCommand
    } else {
        $menu.file entryconfigure $index(file) -state disabled
    }
    $menu.file add separator
    incr index(file)
    foreach {string underline} [underlineAmpersand [mc &Quit]] {}
    $menu.file add command -label $string -command exit -underline $underline -accelerator Ctrl+Q
    menuContextHelp::set $global::fileMenuContextHelper [incr index(file)] $::menuHelp(file,exit)
    if {$compound} {$menu.file entryconfigure $index(file) -compound left -image $::toolBarImage(exit)}
    bind $parentPath <Control-q> exit

    if {!$global::readOnly} {
        foreach {string underline} [underlineAmpersand [mc &Edit]] {}
        $menu add cascade -label $string -menu [menu $menu.edit -tearoff 0] -underline $underline
        set index(edit) -1
        if {![info exists help(edit)]} {
            set help(edit) [new menuContextHelp $menu.edit]
        }
        menuContextHelp::set $help(bar) [incr index(bar)] [mc {content editing, configuration and preferences}]

        foreach {string underline} [underlineAmpersand [mc &Thresholds]] {}
        $menu.edit add command -label $string... -command {thresholds::edit} -underline $underline
        menuContextHelp::set $help(edit) [incr index(edit)] [mc {edit data thresholds}]
        if {$databaseMode || ($loadedUserModules == 0)} {
            $menu.edit entryconfigure $index(edit) -state disabled
        } else {
            $menu.edit entryconfigure $index(edit) -state normal
        }

        foreach {string underline} [underlineAmpersand [mc &Configuration]] {}
        $menu.edit add command -label $string... -command {configuration::edit 0} -underline $underline
        menuContextHelp::set $help(edit) [incr index(edit)] $::menuHelp(edit,configuration)
        if {$compound} {$menu.edit entryconfigure $index(edit) -compound left -image $::toolBarImage(configuration)}

        foreach {string underline} [underlineAmpersand [mc {New &page}]] {}
        $menu.edit add command -label $string... -underline $underline -command createNewPage
        menuContextHelp::set $help(edit) [incr index(edit)] [mc {create a new page}]

        foreach {string underline} [underlineAmpersand [mc {New &viewer}]] {}
        $menu.edit add cascade -label $string -menu [menu $menu.edit.new -tearoff 0] -underline $underline
        if {![info exists help(new)]} {
            set help(new) [new menuContextHelp $menu.edit.new]
        }
        menuContextHelp::set $help(edit) [incr index(edit)] [mc {create empty data viewers}]
        if {($loadedUserModules == 0) && !$databaseMode} {
            $menu.edit entryconfigure $index(edit) -state disabled
        }

        foreach {string underline} [underlineAmpersand [mc {&Graph chart}]] {}
        $menu.edit.new add command -label $string... -underline $underline            -command "createNewCellsViewer ::dataGraph {} 1 $global::static \$global::pollTime"
        menuContextHelp::set $help(new) 0 [mc {create an empty graph chart data viewer}]

        foreach {string underline} [underlineAmpersand [mc {Stacked graph &chart}]] {}
        $menu.edit.new add command -label $string... -underline $underline            -command "createNewCellsViewer ::dataStackedGraph {} 1 $global::static \$global::pollTime"
        menuContextHelp::set $help(new) 1 [mc {create an empty stacked graph chart data viewer}]

        foreach {string underline} [underlineAmpersand [mc {&Overlap bar chart}]] {}
        $menu.edit.new add command -label $string... -underline $underline            -command "createNewCellsViewer ::dataOverlapBarChart {} 1 $global::static"
        menuContextHelp::set $help(new) 2 [mc {create an empty overlap bar chart data viewer}]

        foreach {string underline} [underlineAmpersand [mc {Side &bar chart}]] {}
        $menu.edit.new add command -label $string... -underline $underline            -command "createNewCellsViewer ::dataSideBarChart {} 1 $global::static"
        menuContextHelp::set $help(new) 3 [mc {create an empty side bar chart data viewer}]

        foreach {string underline} [underlineAmpersand [mc {&Stacked bar chart}]] {}
        $menu.edit.new add command -label $string... -underline $underline            -command "createNewCellsViewer ::dataStackedBarChart {} 1 $global::static"
        menuContextHelp::set $help(new) 4 [mc {create an empty stacked bar chart data viewer}]

        foreach {string underline} [underlineAmpersand [mc {&2D pie chart}]] {}
        $menu.edit.new add command -label $string... -underline $underline            -command "createNewCellsViewer ::data2DPieChart {} 1 $global::static"
        menuContextHelp::set $help(new) 5 [mc {create an empty 2D pie chart data viewer}]

        foreach {string underline} [underlineAmpersand [mc {&3D pie chart}]] {}
        $menu.edit.new add command -label $string... -underline $underline            -command "createNewCellsViewer ::data3DPieChart {} 1 $global::static"
        menuContextHelp::set $help(new) 6 [mc {create an empty 3D pie chart data viewer}]

        foreach {string underline} [underlineAmpersand [mc {&Values table}]] {}
        $menu.edit.new add command -label $string... -underline $underline            -command "createNewCellsViewer ::currentValueTable {} 1 $global::static \$global::pollTime"
        menuContextHelp::set $help(new) 7 [mc {create an empty values table data viewer}]

        foreach {string underline} [underlineAmpersand [mc {Statistics &table}]] {}
        $menu.edit.new add command -label $string... -underline $underline            -command "createNewCellsViewer ::summaryTable {} 1 $global::static \$global::pollTime"
        menuContextHelp::set $help(new) 8 [mc {create an empty statistics table data viewer}]

        foreach {string underline} [underlineAmpersand [mc {&Free text}]] {}
        $menu.edit.new add command -label $string... -underline $underline            -command "createNewCellsViewer ::freeText {} 1 $global::static"
        menuContextHelp::set $help(new) 9 [mc {create an empty free text data viewer}]

        foreach {string underline} [underlineAmpersand [mc &Iconic]] {}
        $menu.edit.new add command -label $string... -underline $underline            -command "createNewCellsViewer ::canvas::iconic {} 1 $global::static"
        menuContextHelp::set $help(new) 10 [mc {create an iconic data viewer with no associated data cell}]

        foreach {string underline} [underlineAmpersand [mc {For&mulas table}]] {}
        $menu.edit.new add command -label $string... -underline $underline -command formulasDialog
        menuContextHelp::set $help(new) 11 [mc {create an empty formulas table data viewer}]

        foreach {string underline} [underlineAmpersand [mc &Database]] {}
        $menu.edit add command -label $string... -underline $underline
        menuContextHelp::set $help(edit) [incr index(edit)] [mc {select cells to archive in database}]
        if {$databaseMode || ($loadedUserModules == 0)} {
            $menu.edit entryconfigure $index(edit) -state disabled
        } else {
            $menu.edit entryconfigure $index(edit) -state normal
            if {$global::database == 0} {
                $menu.edit entryconfigure $index(edit) -command {updateDatabaseStart disabled; store::edit 1 updateDatabaseStart}
            } elseif {$loadedUserModules > 0} {
                $menu.edit entryconfigure $index(edit) -command {store::edit 0 {}}
            }
        }

        $menu.edit add separator
        incr index(edit)
        foreach {string underline} [underlineAmpersand [mc &Preferences]] {}
        $menu.edit add command -label $string... -command {configuration::edit 1} -underline $underline
        menuContextHelp::set $help(edit) [incr index(edit)] [mc {edit application-wide preferences}]
    }

    foreach {string underline} [underlineAmpersand [mc &View]] {}
    $menu add cascade -label $string -menu [menu $menu.view -tearoff 0] -underline $underline
    if {![info exists help(options)]} {
        set help(options) [new menuContextHelp $menu.view]
    }
    menuContextHelp::set $help(bar) [incr index(bar)] [mc {data visualization settings}]
    set index(view) -1
    bind $parentPath <Control-r> {}
    if {!$global::readOnly && ((($loadedUserModules > 0) && $anySynchronousModules) || $databaseMode)} {
        foreach {string underline} [underlineAmpersand [mc &Refresh]] {}
        $menu.view add command -label $string -command {after idle ::refresh} -underline $underline -accelerator Ctrl+R
        bind $parentPath <Control-r> {after idle ::refresh}
        if {$databaseMode} {
            menuContextHelp::set $help(options) [incr index(view)] $::menuHelp(view,refreshDatabase)
        } else {
            menuContextHelp::set $help(options) [incr index(view)] $::menuHelp(view,refresh)
        }
        if {$compound} {$menu.view entryconfigure $index(view) -compound left -image $::toolBarImage(refresh)}
    }
    if {$databaseMode} {
        foreach {string underline} [underlineAmpersand [mc {&Database range}]] {}
        $menu.view add command -label $string... -command database::displayAndSelectRange -underline $underline
        menuContextHelp::set $help(options) [incr index(view)] [mc {select time range for database history views}]
    }
    if {$loadedUserModules > 0} {
        if {!$global::readOnly && $anySynchronousModules} {
            foreach {string underline} [underlineAmpersand [mc {&Poll time}]] {}
            $menu.view add command -label $string... -command inquirePollTime -underline $underline
            menuContextHelp::set $help(options) [incr index(view)] [mc {change poll time for all synchronous modules}]
        }
        foreach {string underline} [underlineAmpersand [mc &Trace]] {}
        $menu.view add checkbutton -label $string -command {residentTraceModule $global::showTrace} -underline $underline            -variable global::showTrace -offvalue 0 -onvalue 1
        menuContextHelp::set $help(options) [incr index(view)] [mc {show or hide loaded modules informational, error, ... messages}]
    }
    foreach {string underline} [underlineAmpersand [mc {Tool &bar}]] {}
    $menu.view add checkbutton -label $string        -command manageToolBar -underline $underline -variable global::showToolBar -offvalue 0 -onvalue 1
    menuContextHelp::set $help(options) [incr index(view)] [mc {show or hide the tool bar}]

    if {[string equal $::tcl_platform(platform) windows]} {
        set string ?
        set underline 0
    } else {
        foreach {string underline} [underlineAmpersand [mc &Help]] {}
    }
    $menu add cascade -label $string -menu [menu $menu._help -tearoff 0] -underline $underline
    if {![info exists help(help)]} {
        set help(help) [new menuContextHelp $menu._help]
    }
    set index(help) -1
    menuContextHelp::set $help(bar) [incr index(bar)] [mc {help on moodss and modules}]

    foreach {string underline} [underlineAmpersand [mc &Global]] {}
    $menu._help add command -label $string... -underline 0 -accelerator F1 -command generalHelpWindow
    bind $parentPath <F1> generalHelpWindow
    menuContextHelp::set $help(help) [incr index(help)] $::menuHelp(help,global)
    if {$compound} {$menu._help entryconfigure $index(help) -compound left -image $::toolBarImage(help)}

    if {([llength $moduleNames] > 0) && !$databaseMode} {
        foreach {string underline} [underlineAmpersand [mc &Modules]] {}
        $menu._help add cascade -label $string -menu [menu $menu._help.modules -tearoff 0] -underline $underline
        menuContextHelp::set $help(help) [incr index(help)] [mc {help on loaded modules}]
        if {![info exists help(modulesHelp)]} {
            set help(modulesHelp) [new menuContextHelp $menu._help.modules]
        }
        set index(modulesHelp) -1
        foreach module $moduleNames {
            $menu._help.modules add command -label $module... -command "moduleHelpWindow $module \[modules::helpHTMLData $module\]"
            menuContextHelp::set $help(modulesHelp) [incr index(modulesHelp)]                [format [mc {display %s module documentation}] $module]
        }
    }

    foreach {string underline} [underlineAmpersand [mc &About]] {}
    $menu._help add command -label $string... -underline $underline -command aboutDialogBox
    menuContextHelp::set $help(help) [incr index(help)] [mc {display authors and general information}]
    if {$compound} {
        $menu._help entryconfigure $index(help) -compound left -image [image create photo -data {
            R0lGODlhFgAWAOfyAAADlAcPSgAAsAAAsQsDhwgJcQAAuQAOcQAHmAAEqgIAugAGoQMCswANgQAJmgALkgQGqwgDtAwAvBYAoRUHjBIRYhgFlBEBvQAJxRkM
            hg4OnhULrxMYfRwbWRUWjB4IwgkXtA0UxBsbgSMdaRwinQwjxBEkxSElmRcmwCQgviwniCcrkSgnqx8srSsiySAoyzM1UjAovicuwCoyrjc6YjIzxzM5rjk3
            y0JBgz9Bt0E+y0JAxkxNbERBx0pHpEdEw0xHq0dGvkhFxUJH00NI1EhM0k9MxVxaXVVVk0tO1ExP1VxXkE9R11dQ0ldSzFthkVZZ2V9Z1Fpd1mZlt2hi13Jw
            dG9vhGxwimVo3GVq1mZp3XJyk3V2f3Z2i3p4fGpv3G1x3n15im91x3Vy23uAg3Zz3Hd03YF9mn2BkHJ434OBhXV64YCEk3t63IWHhIaIhX183oSJjIeJhoWK
            jX9+4H+A24mLiIeMj4qMiYGC3ouNio2Ol46QjYmJxIaH45KQlJORlZGTkI6SoY+PsZSSlpKUkY6J4IiM4ZGWmJaUmJCQv4qO45aYlYuP5JaXoZeZloyQ5ZGQ
            4JqbmJyanpaWxZ2bn5aX05aU5J6gnZiW5p+hnp+fqZuY3Jia46GjoJmb5KShpqKkoZqc5Zud5qSmo5ye56CkwKWnpKOixZ2f6KKmtaOf5Keppqiqp6mrqKmq
            tKqsqautqqap0qKn6a2qu6eq062vrKSp67Cyrquq6LGzr7Gxu6yr6bK0sbS2s7W3tLGx77e5trm7uLK17Lq8ubO37bu9uri+wLS47r7BvcDCvr3B0L297sDA
            17++78C/8MLB88XE3MXB7cDE7sfC7sLF78bF6sXJ2cPG8MXI8srK4c3N5c3M8c/O887S79XQ79LR9tTU69fS8djT89nX29fX79nZ5Nva8tfb+N3e6N3d9OXi
            5uLi+ufk6erm+Ovp7fLz/fb0+P///////////////////////////////////////////////////////yH5BAEKAP8ALAAAAAAWABYAAAj+AP8JtCXwX6+C
            BYMVJIZQIKiCD/8Jg1hwV8N/oQryUXbsj0BG6+K9I/foosV/ZNrBc6dOkJp07rx1O2cOIZ5CoeL8iQYN2Spg3sI9K3XoUK5vr/DogTjpG7BLZuDkOgdtlJkc
            PeA8W3Zx2TRIUogYAletlBkgHXLcgqaoICtEu6xdwhLjh7dsmcwYQWIFlbhVU96wEjjJW64xO0b0kTZrjBIbiPagA9YGCMJoxeD8aFFFFtQhKP5JusbskBOE
            quRKkfGPliUwTkxQ+AfKmigsMwoSQpUpSw0VmAZlUeJiAA5NqGaB0XHCkStX/yytIQJC4JkfJjAAEEipThEXHBCXimniIoPAOScGLCgYKUqMDUcKSloyQ0UY
            gb7IPGEDnceXGxh4oAtCXnSxxxx4EHIKHnL8ogYeNBDxgQIZXMGFHHgUlJFDF5lwgQICAFBAQxH9E8tFGkQAwQQLWHDAP7awYkuMrMCiyyms5NjKKVs8kMAC
            DjzAARoUcdiQJv9U0EAGBQSA0Ib/QNcQlDBcVGKJRf5zSkEBAQA7
        }]
    }
    $parentPath configure -menu $menu
}

proc updateFileSaveHelp {file} {
    if {![info exists global::fileMenuContextHelperSaveIndex]} return
    if {[string length $file] == 0} {
        set string $::menuHelp(file,saveAs)
    } else {
        set string [format [mc {into %s file, save dashboard configuration}] $file]
    }
    menuContextHelp::set $global::fileMenuContextHelper $global::fileMenuContextHelperSaveIndex $string
    switched::configure $global::fileSaveHelpTip -text $string
}

proc createMessageWidget {parentPath} {
    set frame [frame $parentPath.messenger -borderwidth $widget::option(button,borderwidth) -relief sunken]
    set label [new thresholdLabel $frame -text [mc Message:]]
    grid $widget::($label,path) -row 0 -column 0 -sticky nw -ipadx 1
    set global::messenger [new lifoLabel $frame -font $font::(mediumNormal) -borderwidth 0]
    composite::configure $global::messenger base -width 300
    grid $widget::($global::messenger,path) -row 0 -column 1 -sticky nsew
    grid columnconfigure $frame 1 -weight 1
    return $frame
}

proc updateDragAndDropZone {{parentPath .}} {
    static drop
    static cache

    set databaseMode [lindex [userInputStates] 3]
    if {[info exists cache] && [string equal $cache(databaseMode) $databaseMode]} return
    set cache(databaseMode) $databaseMode

    set frame .[string trimleft $parentPath.drops .]
    if {![info exists drop]} {
        frame $frame

        set label [label $frame.graph -image applicationIcon -relief sunken]
        pack $label -pady 1 -side left
        new dropSite -path $label -formats DATACELLS            -command "createNewCellsViewer ::dataGraph \$dragSite::data(DATACELLS) 1 $global::static \$global::pollTime"
        new widgetTip -path $label -text [mc {graph chart drag'n'drop site}]
        set drag [new dragSite -path $label]
        dragSite::provide $drag VIEWER {dragEcho ::dataGraph}

        set label [label $frame.stackedGraph -image [image create photo -data [dataStackedGraph::iconData]] -relief sunken]
        pack $label -pady 1 -side left
        new dropSite -path $label -formats DATACELLS            -command "createNewCellsViewer ::dataStackedGraph \$dragSite::data(DATACELLS) 1 $global::static \$global::pollTime"
        new widgetTip -path $label -text [mc {stacked graph chart drag'n'drop site}]
        set drag [new dragSite -path $label]
        dragSite::provide $drag VIEWER {dragEcho ::dataStackedGraph}

        set label [label $frame.overlapBarChart -image [image create photo -data [dataOverlapBarChart::iconData]] -relief sunken]
        pack $label -pady 1 -side left
        new dropSite -path $label -formats DATACELLS            -command "createNewCellsViewer ::dataOverlapBarChart \$dragSite::data(DATACELLS) 1 $global::static"
        new widgetTip -path $label -text [mc {overlap bar chart drag'n'drop site}]
        set drag [new dragSite -path $label]
        dragSite::provide $drag VIEWER {dragEcho ::dataOverlapBarChart}

        set label [label $frame.sideBarChart -image [image create photo -data [dataSideBarChart::iconData]] -relief sunken]
        pack $label -pady 1 -side left
        new dropSite -path $label -formats DATACELLS            -command "createNewCellsViewer ::dataSideBarChart \$dragSite::data(DATACELLS) 1 $global::static"
        new widgetTip -path $label -text [mc {side bar chart drag'n'drop site}]
        set drag [new dragSite -path $label]
        dragSite::provide $drag VIEWER {dragEcho ::dataSideBarChart}

        set label [label $frame.stackedBarChart -image [image create photo -data [dataStackedBarChart::iconData]] -relief sunken]
        pack $label -pady 1 -side left
        new dropSite -path $label -formats DATACELLS            -command "createNewCellsViewer ::dataStackedBarChart \$dragSite::data(DATACELLS) 1 $global::static"
        new widgetTip -path $label -text [mc {stacked bar chart drag'n'drop site}]
        set drag [new dragSite -path $label]
        dragSite::provide $drag VIEWER {dragEcho ::dataStackedBarChart}

        set label [label $frame.2DPieChart -image [image create photo -data [data2DPieChart::iconData]] -relief sunken]
        pack $label -pady 1 -side left
        new dropSite -path $label -formats DATACELLS            -command "createNewCellsViewer ::data2DPieChart \$dragSite::data(DATACELLS) 1 $global::static"
        new widgetTip -path $label -text [mc {2D pie chart drag'n'drop site}]
        set drag [new dragSite -path $label]
        dragSite::provide $drag VIEWER {dragEcho ::data2DPieChart}

        set label [label $frame.3DPieChart -image [image create photo -data [data3DPieChart::iconData]] -relief sunken]
        pack $label -pady 1 -side left
        new dropSite -path $label -formats DATACELLS            -command "createNewCellsViewer ::data3DPieChart \$dragSite::data(DATACELLS) 1 $global::static"
        new widgetTip -path $label -text [mc {3D pie chart drag'n'drop site}]
        set drag [new dragSite -path $label]
        dragSite::provide $drag VIEWER {dragEcho ::data3DPieChart}

        set label [label $frame.currentValueTable -image [image create photo -data [currentValueTable::iconData]] -relief sunken]
        pack $label -pady 1 -side left
        new dropSite -path $label -formats DATACELLS            -command "createNewCellsViewer ::currentValueTable \$dragSite::data(DATACELLS) 1 $global::static \$global::pollTime"
        new widgetTip -path $label -text [mc {values table drag'n'drop site}]
        set drag [new dragSite -path $label]
        dragSite::provide $drag VIEWER {dragEcho ::currentValueTable}

        set label [label $frame.summaryTable -image [image create photo -data [summaryTable::iconData]] -relief sunken]
        pack $label -pady 1 -side left
        new dropSite -path $label -formats DATACELLS            -command "createNewCellsViewer ::summaryTable \$dragSite::data(DATACELLS) 1 $global::static \$global::pollTime"
        new widgetTip -path $label -text [mc {statistics table drag'n'drop site}]
        set drag [new dragSite -path $label]
        dragSite::provide $drag VIEWER {dragEcho ::summaryTable}

        set label [label $frame.freeText -image [image create photo -data [freeText::iconData]] -relief sunken]
        pack $label -pady 1 -side left
        new dropSite -path $label -formats DATACELLS            -command "createNewCellsViewer ::freeText \$dragSite::data(DATACELLS) 1 $global::static"
        new widgetTip -path $label -text [mc {free text drag'n'drop site}]
        set drag [new dragSite -path $label]
        dragSite::provide $drag VIEWER {dragEcho ::freeText}

        set label [label $frame.icon -image [image create photo -data [canvas::iconic::iconData]] -relief sunken]
        pack $label -pady 1 -side left
        new dropSite -path $label -formats DATACELLS            -command "createNewCellsViewer ::canvas::iconic \$dragSite::data(DATACELLS) 1 $global::static"
        new widgetTip -path $label -text [mc {iconic data viewer drag'n'drop site}]
        set drag [new dragSite -path $label]
        dragSite::provide $drag VIEWER {dragEcho ::canvas::iconic}

        set label [label $frame.threshold -image [image create photo -data [thresholds::iconData]] -relief sunken]
        pack $label -pady 1 -side left
        set drop(thresholds,label) $label
        set drop(thresholds,site) [new dropSite            -path $label -formats DATACELLS            -command {thresholds::edit; viewer::view $thresholds::singleton $dragSite::data(DATACELLS)}        ]
        new widgetTip -path $label -text [mc {threshold drop site}]

        set eraserData {
            R0lGODdhJAAkAKUAAPj4+Hh4eLi4uMiAKLhQAPDouPDksOjYoOjQmOjMkODAgOC8eNiwaPj8+Ojw6ODg4NjY2MDIwNioYNikWLCwsNCYSFCQqJigmJCQkNCQ
            QODo6NDg6Mjg4IiIiAAAAHB4cMiIMGhoaMDY2MjY4GBgYMh8IEhQSLDQ2EBAQKjI0LjQ2Dg4OCAoIKDAyJC4yIi4wICAgHiwuKDI0IiQiJjAyJCYkJiYmKCg
            oKioqICwwMDAwMjQyNDY0HiouOjo6AAAACwAAAAAJAAkAAAG/kCAcCgMEI/G4zBZVBKZSijy6VxWAVKqFRvoer9dwZULBlfF1cGAwJ5ux0p1wWA4HNrNN3xI
            KMzrBwgICQR5eV5oVX10doIJCQoKhWRfewAEX46QCgsLDAQNWnsBDg8PEBBdm50Mn25wpKaoERECAawMEhITk4cBiU+yELQCAhQUAbm7ExWFZVcW0dG1xhQX
            FxgBE8wVGb1YYxYaG+Qc0cfXGBgdHhXd3qJK4uQb5hoaFtjrHR8eGRkgQHxL8kWMhXIc7I3bYKEDvw8hQngAocaDh2dEDibkIOIgvREjLEAMQYKEhwElCFzU
            I8RCQhEwPZIDCdICSRImPKS8+MtQ/kuYIk6ckEmzpgWcJlB4UInIl4WgQlMcLApSRTRzKFCssMjVohkLUVNIpaqi7NWQK1aw4BlmC1ixKVpYoFlWhdCzVtWy
            7blFbIu/c0fUFTo0sF0Lawu6+evChYXBhAsLLju0q+XLjV88jhw1GuW7e8uAeaGZM9xohMVa2AujtevXrWOADZtChgzUcOXuncG7t+/es+HaphEtt+4vNZIr
            X75c+HDiFuL+Jb7Xxo3r2LNnty2DhnfHFqZ7X/3FBo7z6NOr906jMXj2jcl7sVGsvv37xdzHt9C+cQ75Xdigw4AEFmjggO79Z0GC/1W3w4MQRighhC7koGCF
            FspWHQ8cJ3bo4Yce5iCbBRnGoGF5pqSo4oosjmhiDD30AGAANvhg44045qhjEAA7
        }
        set label [label $frame.eraser -image [image create photo -data $eraserData] -relief sunken]
        pack $label -pady 1 -side left
        new dropSite -path $label -formats OBJECTS -command "eval delete \$dragSite::data(OBJECTS)"
        new widgetTip -path $label -text [mc {objects deletion drag'n'drop site}]
        set drag [new dragSite -path $label]
        dragSite::provide $drag KILL list
    }
    if {$databaseMode} {
        $drop(thresholds,label) configure -state disabled
        switched::configure $drop(thresholds,site) -state disabled
    } else {
        $drop(thresholds,label) configure -state normal
        switched::configure $drop(thresholds,site) -state normal
    }
    return $frame
}

proc inquirePollTime {} {
    set dialog [new dialogBox .grabber        -buttons hoc -default o -title [mc {moodss: Poll time}] -die 0 -x [winfo pointerx .] -y [winfo pointery .]        -helpcommand {generalHelpWindow #menus.view.polltime} -deletecommand {grab release .grabber}    ]
    grab .grabber
    lappend objects [linkedHelpWidgetTip $composite::($dialog,help,path)]
    set frame [frame $widget::($dialog,path).frame]
    set minimum [lindex $global::pollTimes 0]
    set message [message $frame.message        -width [winfo screenwidth .] -font $font::(mediumNormal) -justify center        -text [format [mc {Enter new poll time (greater than %u):}] $minimum]    ]
    pack $message

    if {[package vcompare $::tcl_version 8.4] < 0} {
        set entry [new spinEntry $frame -width 5 -list $global::pollTimes -side right]
        spinEntry::set $entry $global::pollTime
        setupEntryValidation $composite::($entry,entry,path) {{check31BitUnsignedInteger %P}}
        pack $widget::($entry,path) -anchor e -side left -expand 1 -padx 2
        lappend objects $entry
    } else {
        set entry [spinbox $frame.spinbox -font $font::(mediumBold) -width 5 -values $global::pollTimes]
        $entry set $global::pollTime
        setupEntryValidation $entry {{check31BitUnsignedInteger %P}}
        pack $entry -anchor e -side left -expand 1 -padx 2
    }

    pack [label $frame.label -text [mc seconds]] -anchor w -side right -expand 1 -padx 2
    dialogBox::display $dialog $frame
    widget::configure $dialog -command "
        if {[package vcompare $::tcl_version 8.4] < 0} {
            set time \[spinEntry::get $entry\]
        } else {
            set time \[$entry get\]
        }
        if {\$time < $minimum} {
            bell
            $message configure -text \[format \[mc {Enter new poll time\n(must be greater than %u):}\] $minimum\]
        } else {
            if {\$time != \$global::pollTime} {
                set global::pollTime \$time
                viewer::updateInterval \$time
                updateTitle
                refresh
            }
            delete $dialog
        }
    "
    bind $frame <Destroy> "delete $objects"
}

proc updateToolBar {{parentPath .}} {
    static button
    static icon
    static tip
    static cache

    initializeMenuHelp
    set frame .[string trimleft $parentPath.tools .]
    if {![info exists button]} {
        set dark [lindex [3DBorders . $widget::option(menu,background)] 0]
        frame $frame
        set widget [new imageButton $frame -image $::toolBarImage(new) -command clear]
        new widgetTip -path $widget::($widget,path) -text $::menuHelp(file,new)
        set button(new) $widget
        set widget [new imageButton $frame -image $::toolBarImage(open) -command reload]
        new widgetTip -path $widget::($widget,path) -text $::menuHelp(file,open)
        set button(open) $widget
        set widget [new imageButton $frame -image $::toolBarImage(save) -command {save 0}]
        set global::fileSaveHelpTip [new widgetTip -path $widget::($widget,path)]
        set button(save) $widget
        set widget [new imageButton $frame -image $::toolBarImage(saveAs) -command {save 1}]
        new widgetTip -path $widget::($widget,path) -text $::menuHelp(file,saveAs)
        set button(saveAs) $widget
        set widget [new imageButton $frame -image $::toolBarImage(print) -command $global::printDialogCommand]
        new widgetTip -path $widget::($widget,path) -text $::menuHelp(file,print)
        set button(print) $widget
        set widget [new imageButton $frame -image $::toolBarImage(configuration) -command {configuration::edit 0}]
        new widgetTip -path $widget::($widget,path) -text $::menuHelp(edit,configuration)
        set button(configuration) $widget
        set widget [new imageButton $frame -image $::toolBarImage(refresh) -command {after idle ::refresh}]
        set tip(refresh) [new widgetTip -path $widget::($widget,path)]
        set button(refresh) $widget
        set widget [new imageButton $frame -image $::toolBarImage(help) -command generalHelpWindow]
        new widgetTip -path $widget::($widget,path) -text $::menuHelp(help,global)
        set button(help) $widget
        set widget [new imageButton $frame -image $::toolBarImage(exit) -command exit]
        new widgetTip -path $widget::($widget,path) -text $::menuHelp(file,exit)
        set button(exit) $widget
        set widget [new imageButton $frame -image $::toolBarImage(record) -command {databaseRecording 1}]
        set global::fileDatabaseStartButtonTip            [new widgetTip -path $widget::($widget,path) -text $::menuHelp(file,database,record,disabled)]
        set button(record) $widget
        set global::fileDatabaseStartButton $button(record)
        frame $frame.recordSeparator -bg $dark -width 1
        set widget [new imageButton $frame -image $::toolBarImage(recording) -command {databaseRecording 0}]
        new widgetTip -path $widget::($widget,path) -text $::menuHelp(file,database,stop)
        set button(recording) $widget
        set widget [new imageButton $frame -image $::toolBarImage(stop) -command {databaseRecording 0}]
        new widgetTip -path $widget::($widget,path) -text $::menuHelp(file,database,stop)
        set button(stop) $widget
        set widget [new imageButton $frame            -image $::toolBarImage(play) -command "loadFromDatabase [expr {!$global::readOnly}] $global::static"        ]
        new widgetTip -path $widget::($widget,path) -text $::menuHelp(file,database,load)
        set button(play) $widget
        frame $frame.playSeparator -bg $dark -width 1
        set widget [new imageButton $frame -image $::toolBarImage(playing) -command [composite::cget $button(play) -command]]
        new widgetTip -path $widget::($widget,path) -text $::menuHelp(file,database,load)
        set button(playing) $widget
        grid columnconfigure $frame 100 -weight 1
    }
    foreach {loadedUserModules anySynchronousModules databaseConnected databaseMode anyRecordableCells} [userInputStates] {}
    if {[info exists cache]} {
        set change 0
        foreach {name value} [array get cache] {
            if {![string equal [set $name] $value]} {set change 1; break}
        }
        if {!$change} {return $frame}
    }
    foreach name {loadedUserModules anySynchronousModules databaseMode databaseConnected anyRecordableCells global::readOnly} {
        set cache($name) [set $name]
    }
    switched::configure $tip(refresh) -text $::menuHelp(view,refresh)
    if {$global::readOnly} {
        if {$databaseMode} {
            set list {print refresh help exit}
            switched::configure $tip(refresh) -text $::menuHelp(view,refreshDatabase)
        } else {
            set list {print help exit}
        }
    } elseif {$loadedUserModules == 0} {
        if {$databaseMode} {
            set list {new open save saveAs print playing configuration refresh help exit}
            switched::configure $tip(refresh) -text $::menuHelp(view,refreshDatabase)
        } else {
            set list {new open save saveAs print play configuration help exit}
            array set disable {save {} saveAs {}}
        }
    } else {
        set list {new open save saveAs print record}
        if {$global::database == 0} {
            if {!$anyRecordableCells} {set disable(record) {}}
            lappend list stop
            set disable(stop) {}
        } else {
            lappend list recording
            set disable(record) {}
        }
        lappend list play configuration
        if {$anySynchronousModules} {
            lappend list refresh
        }
        lappend list help exit
    }
    if {[string equal $::tcl_platform(platform) windows] && [catch {package require Tkprint 1.1}]} {
        ldelete list print
    }
    eval grid forget [winfo children $frame]
    set column 0
    foreach name $list {
        if {[string equal $name record]} {
            grid $frame.recordSeparator -row 0 -sticky ns -column $column
            incr column
        }
        if {[info exists disable($name)]} {set state disabled} else {set state normal}
        composite::configure $button($name) -state $state
        grid $widget::($button($name),path) -row 0 -sticky ns -column $column
        incr column
        if {[string equal $name play] && ([llength [grid info $frame.recordSeparator]] > 0)} {
            grid $frame.playSeparator -row 0 -sticky ns -column $column
            incr column
        }
    }
    return $frame
}

proc updateDatabaseStart {{state {}}} {
    if {[string length $state] == 0} {
        if {[store::anyActiveCells $store::singleton]} {
            set state normal
            switched::configure $global::fileDatabaseStartButtonTip -text $::menuHelp(file,database,record)
        } else {
            set state disabled
            switched::configure $global::fileDatabaseStartButtonTip -text $::menuHelp(file,database,record,disabled)
        }
    }
    $global::fileDatabaseMenu entryconfigure $global::fileDatabaseMenuStartIndex -state $state
    composite::configure $global::fileDatabaseStartButton -state $state
}

proc userInputStates {} {
    set modules [modules::namesWithout formulas]
    set history [llength $modules]
    foreach module $modules {
        if {![string equal $module instance]} {
            set history 0
            break
        }
    }
    if {$history || [info exists databaseInstances::singleton]} {
        return {0 0 1 1 0}
    } else {
        return [list            [expr {[llength $modules] > 0}] [expr {[llength $global::pollTimes] > 0}]            [expr {$global::database != 0}] 0 [store::anyActiveCells $store::singleton]        ]
    }
}

proc createBackgroundMenu {} {
    set menu [new menu $global::canvas -tearoff 0]
    $widget::($menu,path) add command -label [mc Background]... -command changeBackground
    if {[package vcompare $::tcl_version 8.4] < 0} {
        bind $global::canvas <ButtonPress-3> "if {\[string length \$::tkPriv(popup)\] == 0} {tk_popup $widget::($menu,path) %X %Y}"
    } else {
        bind $global::canvas <ButtonPress-3>            "if {\[string length \$::tk::Priv(popup)\] == 0} {tk_popup $widget::($menu,path) %X %Y}"
    }
    return $menu
}

proc changeBackground {} {
    set page [pages::current]
    if {$page == 0} {
        set title [mc {moodss: Background}]
        set background $global::canvasBackground
        set file $global::canvasImageFile
        set position $global::canvasImagePosition
    } else {
        set title [mc {moodss: Page background}]
        set background [composite::cget $page -background]
        set file [composite::cget $page -imagefile]
        set position [composite::cget $page -imageposition]
   }
    foreach {left top right bottom} [bounds $global::canvas] {}
    set size [list [expr {$right - $left}] [expr {$bottom - $top}]]
    set dialog [new dialogBox .grabber        -buttons hoc -default o -title $title -x [winfo pointerx .] -y [winfo pointery .]        -helpcommand {generalHelpWindow #configuration.application.backgrounds}    ]
    grab .grabber
    set ::background$dialog 0
    composite::configure $dialog        -command "incr ::background$dialog" -deletecommand "grab release .grabber; incr ::background$dialog 0"
    set chooser [new backgroundChooser $widget::($dialog,path)        -font $font::(mediumNormal) -color $background -targetsize $size        -imagefile $file -useimage [expr {[string length $file] > 0}] -position $position    ]
    dialogBox::display $dialog $widget::($chooser,path)
    vwait ::background$dialog
    if {[set ::background$dialog]} {
        if {[composite::cget $chooser -useimage]} {
            set file [composite::cget $chooser -imagefile]
        } else {
            set file {}
        }
        set background [composite::cget $chooser -color]
        set position [composite::cget $chooser -position]
        if {$page == 0} {
            $global::canvas configure -background $background
            updateCanvasImage $file
            if {[string length $file] > 0} {
                updateCanvasImagePosition $global::canvasImageItem $position
            }
            set global::canvasBackground $background
            set global::canvasImageFile $file
            set global::canvasImagePosition $position
        } else {
            composite::configure $page -background $background -imagefile $file -imageposition $position
        }
    }
    delete $chooser
}



class canvasWindowManager {

    class handles {

        set (defaultTitleBackground) gray

        proc handles {this parentPath manager args} composite {[new frame $parentPath] $args} {
            if {![string equal [winfo class $parentPath] Canvas]} {
                error {parent must be the manager canvas}
            }
            set ($this,item) [$parentPath create window 0 0 -window $widget::($this,path) -anchor nw]
            set ($this,manager) $manager
            set ($this,canvas) $parentPath
            set ($this,filled) 0
            set ($this,drag) [new dragSite -path $widget::($this,path) -grab 0]
            composite::complete $this
            updateDragProviding $this
        }

        proc ~handles {this} {
            delete $($this,drag)
            catch {delete $($this,labelDrag)}
            $($this,canvas) delete $($this,item) outline
            catch {delete $($this,minimize)}
        }

        proc options {this} {
            return [list                [list -background $widget::option(frame,background) $widget::option(frame,background)]                [list -borderwidth 3]                [list -dragobject {} {}]                [list -handlesize 7 7]                [list -path {} {}]                [list -relief ridge]                [list -setheight {} {}]                [list -setwidth {} {}]                [list -setx {}]                [list -sety {}]                [list -static 0]                [list -title {} {}]                [list -titlebackground $(defaultTitleBackground) $(defaultTitleBackground)]            ]
        }

        proc set-handlesize {this value} {
            resize $this [winfo width $widget::($this,path)] [winfo height $widget::($this,path)]
        }

        proc set-path {this value} {
            if {$($this,filled)} {
                error {cannot manage more than 1 widget}
            }
            if {![winfo exists $value]} {
                error "invalid widget: \"$value\""
            }
            pack $value -in $widget::($this,path) -side bottom -fill both -expand 1
            stack $this raise
            set ($this,filled) 1
        }

        proc set-background {this value} {
            $widget::($this,path) configure -background $value
        }

        proc set-borderwidth {this value} {
            if {$value < 3} {
                set value 3
            }
            $widget::($this,path) configure -borderwidth $value
        }

        proc set-relief {this value} {
            $widget::($this,path) configure -relief $value
        }

        proc set-setheight {this value} {
            $($this,canvas) itemconfigure $($this,item) -height $value
        }
        proc set-setwidth {this value} {
            $($this,canvas) itemconfigure $($this,item) -width $value
        }

        proc set-setx {this value} {
            if {[string length $value] == 0} {
                set value [lindex [$global::canvas cget -scrollregion] 0]
            }
            $($this,canvas) coords $($this,item) $value [lindex [$($this,canvas) coords $($this,item)] end]
        }

        proc set-sety {this value} {
            if {[string length $value] == 0} {
                set value [lindex [$global::canvas cget -scrollregion] 1]
            }
            $($this,canvas) coords $($this,item) [lindex [$($this,canvas) coords $($this,item)] 0] $value
        }

        proc set-static {this value} {
            updateBindings $this $value
            updateMinimize $this
        }

        proc set-title {this value} {
            if {![info exists ($this,title)]} {
                set title [frame $widget::($this,path).title]
                pack $title -side top -fill x -before $composite::($this,-path)
                set label [label $title.label                    -pady 0 -font $font::(smallNormal) -background $composite::($this,-titlebackground) -anchor w                ]
                pack $label -side left -fill both -expand 1
                set minimize [new arrowButton $title                    -highlightthickness 0 -command "canvasWindowManager::minimize $($this,manager) $this [list $value]"                ]
                set size [expr {[winfo reqheight $label] - (2 * [composite::cget $minimize -borderwidth])}]
                composite::configure $minimize -width $size -height $size
                composite::configure $minimize base -cursor left_ptr
                if {[string length $composite::($this,-path)] > 0} {
                    pack $title -before $composite::($this,-path)
                }
                set ($this,labelDrag) [new dragSite -path $label -grab 0]
                set ($this,title) $title
                set ($this,label) $label
                set ($this,minimize) $minimize
                updateDragProviding $this
            }
            $($this,label) configure -text $value
            updateBindings $this $composite::($this,-static)
            updateMinimize $this
        }

        proc set-titlebackground {this value} {
            if {![info exists ($this,label)]} return
            if {[string length $value] == 0} {set value $(defaultTitleBackground)}
            $($this,label) configure -background $value
        }

        proc set-dragobject {this value} {
            updateDragProviding $this
        }

        proc updateDragProviding {this} {
            dragSite::provide $($this,drag) HANDLES "dragEcho $this"
            set title [info exists ($this,title)]
            if {$title} {
                dragSite::provide $($this,labelDrag) HANDLES "dragEcho $this"
            }
            set object $composite::($this,-dragobject)
            if {[string length $object] == 0} {
                dragSite::provide $($this,drag) OBJECTS {}
                if {$title} {dragSite::provide $($this,labelDrag) OBJECTS {}}
            } else {
                dragSite::provide $($this,drag) OBJECTS "dragEcho $object"
                if {$title} {dragSite::provide $($this,labelDrag) OBJECTS "dragEcho $object"}
            }
        }

        proc updateBindings {this static} {
            set path $widget::($this,path)
            if {$static} {
                bind $path <Configure> {}
                bind $path <Motion> {}
                bind $path <Enter> {}
                bind $path <Button1-Motion> {}
                bind $path <ButtonPress-1> {}
                bind $path <ButtonRelease-1> "canvasWindowManager::handles::toggleVisibility $this"
                $path configure -cursor left_ptr
            } else {
                bind $path <Configure> "canvasWindowManager::handles::resize $this %w %h"
                bind $path <Motion> "canvasWindowManager::handles::setCursor $this %x %y"
                bind $path <Enter> "canvasWindowManager::handles::setCursor $this %x %y"
                bind $path <Button1-Motion> "canvasWindowManager::handles::buttonMotion $this %x %y"
                bind $path <Control-ButtonPress-1> "canvasWindowManager::handles::buttonPress $this %x %y 1"
                bind $path <ButtonPress-1> "canvasWindowManager::handles::buttonPress $this %x %y"
                bind $path <ButtonPress-1> "+ dragSite::button1Pressed $($this,drag)"
                bind $path <ButtonRelease-1> "canvasWindowManager::handles::buttonRelease $this"
            }
            bind $path <ButtonRelease-2> "canvasWindowManager::handles::toggleVisibility $this"
            if {[info exists ($this,label)]} {
                set path $($this,label)
                if {$static} {
                    $path configure -cursor left_ptr
                    bind $path <Button1-Motion> {}
                    bind $path <ButtonPress-1> {}
                    bind $path <ButtonRelease-1> "canvasWindowManager::handles::toggleVisibility $this"
                } else {
                    $path configure -cursor fleur
                    bind $path <Button1-Motion> "canvasWindowManager::handles::buttonMotion $this %x %y"
                    bind $path <Control-ButtonPress-1> "
                        set canvasWindowManager::handles::($this,direction) {}
                        canvasWindowManager::handles::buttonPress $this %x %y 1
                    "
                    bind $path <ButtonPress-1> "
                        set canvasWindowManager::handles::($this,direction) {}
                        canvasWindowManager::handles::buttonPress $this %x %y
                    "
                    bind $path <ButtonPress-1> "+ dragSite::button1Pressed $($this,labelDrag)"
                    bind $path <ButtonRelease-1> "canvasWindowManager::handles::buttonRelease $this"
                }
                bind $path <ButtonRelease-2> "canvasWindowManager::handles::toggleVisibility $this"
            }
        }

        proc buttonMotion {this x y} {
            set (motion) {}
            updateOutline $this $x $y
        }

        proc buttonPress {this x y {control 0}} {
            set canvas $($this,canvas)
            set (xLast) $x; set (yLast) $y
            set (control) $control
            lifoLabel::push $global::messenger {}
            createOutline $this
            foreach {x y} [canvasWindowManager::coordinates $canvas $($this,item)] {}
            set (xOutline) $x; set (yOutline) $y
            foreach {(left) top right bottom} [$canvas cget -scrollregion] {}
            set (rectangles) [list                [list $(left) $top [winfo width $canvas] [winfo height $canvas]]                [list $(left) $top [expr {$right - $(left)}] [expr {$bottom - $top}]]            ]
            eval lappend (rectangles) [canvasWindowManager::rectangles $($this,manager) $this]
            set width [winfo width $widget::($this,path)]; set height [winfo height $widget::($this,path)]
            set offset [xOffset $canvas $x $y $width $height]
            if {[string length $offset] > 0} {
                set (xOffset) $offset
                set (xMagnet) [expr {$x + $offset}]
            }
            set offset [yOffset $canvas $x $y $width $height]
            if {[string length $offset] > 0} {
                set (yOffset) $offset
                set (yMagnet) [expr {$y + $offset}]
            }
        }

        proc toggleVisibility {this} {
            if {[canvasWindowManager::raisedOnTop $($this,manager) $composite::($this,-path)]} {
                stack $this lower
            } else {
                stack $this raise
            }
        }

        proc buttonRelease {this} {
            lifoLabel::pop $global::messenger
            if {[info exists (motion)]} {
                updateGeometry $this
                stack $this raise
                unset (motion)
            } else {
                toggleVisibility $this
            }
            destroyOutline $this
            catch {unset (xLast) (yLast)}
            catch {unset (control)}
            catch {unset (hidden)}
            catch {unset (xMagnet)}; catch {unset (yMagnet)}
            catch {unset (xOutline) (yOutline)}
            catch {unset (left) (rectangles)}
            catch {unset (xOffset)}; catch {unset (yOffset)}
        }

        proc resize {this width height} {
            set size [maximum $composite::($this,-handlesize) $composite::($this,-borderwidth)]

            set halfHeight [expr {$height / 2}]
            set ($this,topHandleBottom) [minimum $size $halfHeight]
            set ($this,bottomHandleTop) [expr {$height - $($this,topHandleBottom)}]
            set ($this,midHandleTop) [maximum [expr {$height / 3}] [expr {$($this,topHandleBottom) + $size}]]
            set ($this,midHandleBottom) [minimum [expr {(2 * $height) / 3}] [expr {$($this,bottomHandleTop) - $size}]]

            set halfWidth [expr {$width / 2}]
            set ($this,leftHandleRight) [minimum $size $halfWidth]
            set ($this,rightHandleLeft) [expr {$width - $($this,leftHandleRight)}]
            set ($this,midHandleLeft) [maximum [expr {$width / 3}] [expr {$($this,leftHandleRight) + $size}]]
            set ($this,midHandleRight) [minimum [expr {(2 * $width) / 3}] [expr {$($this,rightHandleLeft) - $size}]]
        }

        proc setCursor {this x y} {
            if {[info exists (motion)]} {
                return
            }
            set border $composite::($this,-borderwidth)
            set path $widget::($this,path)
            set cursor fleur
            set direction {}
            if {$x < $border} {
                set side left
                set direction w
            } elseif {$x >= ([winfo width $path] - $border)} {
                set side right
                set direction e
            }
            if {[info exists side]} {
                if {$y < $($this,topHandleBottom)} {
                    set cursor top_${side}_corner
                    append direction n
                } elseif {$y > $($this,bottomHandleTop)} {
                    set cursor bottom_${side}_corner
                    append direction s
                } elseif {($y > $($this,midHandleTop)) && ($y < $($this,midHandleBottom))} {
                    set cursor ${side}_side
                } else {
                    set cursor fleur
                    set direction {}
                }
            } else {
                if {$y < $border} {
                    set side top
                    set direction n
                } elseif {$y >= ([winfo height $path] - $border)} {
                    set side bottom
                    set direction s
                }
                if {[info exists side]} {
                    if {$x < $($this,leftHandleRight)} {
                        set cursor ${side}_left_corner
                        append direction w
                    } elseif {$x > $($this,rightHandleLeft)} {
                        set cursor ${side}_right_corner
                        append direction e
                    } elseif {($x > $($this,midHandleLeft)) && ($x < $($this,midHandleRight))} {
                        set cursor ${side}_side
                    } else {
                        set cursor fleur
                        set direction {}
                    }
                }
            }
            if {![string equal $cursor [$widget::($this,path) cget -cursor]]} {
                $widget::($this,path) configure -cursor $cursor
                update idletasks
            }
            set ($this,direction) $direction
        }

        proc updateOutline {this x y} {
            lifoLabel::pop $global::messenger
            set canvas $($this,canvas)
            if {[llength [$canvas gettags outline]] == 0} return
            if {![info exists (hidden)] || ![info exists ($this,direction)]} return
            if {$(hidden)} {
                stackOutline $this raise
            }
            foreach {xFrame yFrame} [canvasWindowManager::coordinates $canvas $($this,item)] {}
            foreach {left top right bottom} [bounds $canvas] {}
            if {($xFrame - $left + $x) < 0} {
                set x [expr {$left - $xFrame}]
            }
            if {($yFrame - $top + $y) < 0} {
                set y [expr {$top - $yFrame}]
            }
            set width [expr {$right - $left}]
            if {($xFrame - $left + $x) >= $width} {
                set x [expr {$width + $left - $xFrame - 1}]
            }
            set height [expr {$bottom - $top}]
            if {($yFrame - $top + $y) >= $height} {
                set y [expr {$height + $top - $yFrame - 1}]
            }
            set width [winfo width $widget::($this,path)]
            set height [winfo height $widget::($this,path)]
            if {[string length $($this,direction)] == 0} {
                moveOutline $canvas $x $y $width $height
                return
            }
            set xCursor [expr {$xFrame + $x}]; set yCursor [expr {$yFrame + $y}]
            switch $($this,direction) {
                n - s {
                    set offset [ySnapOffset $canvas $xCursor $yCursor $width]
                    if {[string length $offset] > 0} {incr y $offset}
                }
                e - w {
                    set offset [xSnapOffset $canvas $xCursor $yCursor $height]
                    if {[string length $offset] > 0} {incr x $offset}
                }
                default {
                    set offset [xSnapOffset $canvas $xCursor $yCursor $height]
                    if {[string length $offset] > 0} {incr x $offset}
                    set offset [ySnapOffset $canvas $xCursor $yCursor $width]
                    if {[string length $offset] > 0} {incr y $offset}
                }
            }
            switch $($this,direction) {
                nw - wn {
                    displayOutline $this [expr {$xFrame + $x}] [expr {$yFrame + $y}] [expr {$width - $x}] [expr {$height - $y}]
                }
                n {
                    displayOutline $this $xFrame [expr {$yFrame + $y}] $width [expr {$height - $y}]
                }
                ne - en {
                    displayOutline $this $xFrame [expr {$yFrame + $y}] $x [expr {$height - $y}]
                }
                e {
                    displayOutline $this $xFrame $yFrame $x $height
                }
                se - es {
                    displayOutline $this $xFrame $yFrame $x $y
                }
                s {
                    displayOutline $this $xFrame $yFrame $width $y
                }
                sw - ws {
                    displayOutline $this [expr {$xFrame + $x}] $yFrame [expr {$width - $x}] $y
                }
                w {
                    displayOutline $this [expr {$xFrame + $x}] $yFrame [expr {$width - $x}] $height
                }
            }
        }

        proc createOutline {this} {
            set canvas $($this,canvas)
            if {[llength [$canvas gettags outline]] > 0} return
            foreach side {top bottom left right} {
                if {[info exists ($side,item)]} continue
                set frame [frame $canvas.${side}outline -background black]
                set ($side,item) [$canvas create window 0 0 -window $frame -width 0 -height 0 -anchor nw -tags outline]
            }
            stackOutline $this lower
            eval displayOutline $this [$canvas coords $($this,item)]                [winfo width $widget::($this,path)] [winfo height $widget::($this,path)]
        }

        proc stackOutline {this order} {
            set canvas $($this,canvas)
            foreach side {top bottom left right} {
                $order [$canvas itemcget $($side,item) -window]
            }
            set (hidden) [string compare $order raise]
        }

        proc displayOutline {this x y width height} {
            lifoLabel::push $global::messenger "$width x $height"
            set minimum [expr {(2 * $composite::($this,-borderwidth)) + 1}]
            set width [maximum $minimum $width]
            set height [maximum $minimum $height]
            set canvas $($this,canvas)
            $canvas coords $(top,item) $x $y
            $canvas coords $(bottom,item) $x [expr {$y + $height - 1}]
            $canvas coords $(left,item) $x $y
            $canvas coords $(right,item) [expr {$x + $width - 1}] $y
            $canvas itemconfigure $(top,item) -width $width
            $canvas itemconfigure $(bottom,item) -width $width
            $canvas itemconfigure $(left,item) -height $height
            $canvas itemconfigure $(right,item) -height $height
        }

        proc destroyOutline {this} {
            set canvas $($this,canvas)
            foreach side {top bottom left right} {
                if {![info exists ($side,item)]} continue
                destroy [$canvas itemcget $($side,item) -window]
                unset ($side,item)
            }
            catch {$canvas delete outline}
        }

        proc updateGeometry {this} {
            set canvas $($this,canvas)
            eval $canvas coords $($this,item) [$canvas coords outline]
            if {![info exists (top,item)] || ![info exists (left,item)]} return
            $canvas itemconfigure $($this,item) -width [$canvas itemcget $(top,item) -width]                -height [$canvas itemcget $(left,item) -height]
        }

        proc getGeometry {this} {
            return [concat                [$($this,canvas) coords $($this,item)]                [$($this,canvas) itemcget $($this,item) -width] [$($this,canvas) itemcget $($this,item) -height]            ]
        }

        proc stack {this order} {
            $order $widget::($this,path)
            if {[string length $composite::($this,-path)] > 0} {
                raise $composite::($this,-path) $widget::($this,path)
            }
            canvasWindowManager::stacked $($this,manager) $composite::($this,-path) [string compare $order lower]
        }

        proc stackLower {this handles} {
            lower $widget::($this,path) $widget::($handles,path)
            if {[string length $composite::($this,-path)] > 0} {
                raise $composite::($this,-path) $widget::($this,path)
            }
        }

        proc moveTo {this x y} {
            $($this,canvas) coords $($this,item) $x $y
        }

        proc updateMinimize {this} {
            if {![info exists ($this,minimize)]} return
            if {$composite::($this,-static)} {
                pack forget $widget::($($this,minimize),path)
            } else {
                pack $widget::($($this,minimize),path) -side right -before $($this,label)
            }
        }

        proc xSnapOffset {canvas x y height} {
            if {$(control)} {return {}}
            set delta {}
            set snap $global::snapDistance(window)
            foreach rectangle $(rectangles) {
                foreach {left top ignore size} [eval vectors $rectangle] {
                    if {$size == 0} continue
                    if {(($y + $height) < $top) && ($y > ($top + $size))} continue
                    set value [expr {$left - $x}]
                    if {abs($value) < $snap} {
                        set delta $value
                        set snap [expr {abs($value)}]
                    }
                }
            }
            return $delta
        }
        proc ySnapOffset {canvas x y width} {
            if {$(control)} {return {}}
            set delta {}
            set snap $global::snapDistance(window)
            foreach rectangle $(rectangles) {
                foreach {left top size ignore} [eval vectors $rectangle] {
                    if {$size == 0} continue
                    if {(($x + $width) < $left) && ($x > ($left + $size))} continue
                    set value [expr {$top - $y}]
                    if {abs($value) < $snap} {
                        set delta $value
                        set snap [expr {abs($value)}]
                    }
                }
            }
            return $delta
        }

        proc moveOutline {canvas x y width height} {
            set xDelta [expr {$x - $(xLast)}]
            if {[info exists (xMagnet)]} {
                incr (xMagnet) $xDelta
                set offset [xOffset $canvas $(xMagnet) $(yOutline) $width $height]
                if {[string length $offset] == 0} {
                    set xDelta [expr {$(xMagnet) - $(xOutline)}]
                    unset (xMagnet)
                } elseif {abs($offset) < abs($(xOffset))} {
                    set xDelta [expr {$(xMagnet) - $(xOutline)}]
                    incr xDelta $offset
                    set (xMagnet) [expr {$(xOutline) + $xDelta}]
                } else {
                    set xDelta 0
                }
            } else {
                set offset [xOffset $canvas [expr {$(xOutline) + $xDelta}] $(yOutline) $width $height]
                if {[string length $offset] > 0} {
                    incr xDelta $offset
                    set (xMagnet) [expr {$(xOutline) + $xDelta}]
                }
            }
            set (xOffset) $offset
            set yDelta [expr {$y - $(yLast)}]
            if {[info exists (yMagnet)]} {
                incr (yMagnet) $yDelta
                set offset [yOffset $canvas $(xOutline) $(yMagnet) $width $height]
                if {[string length $offset] == 0} {
                    set yDelta [expr {$(yMagnet) - $(yOutline)}]
                    unset (yMagnet)
                } elseif {abs($offset) < abs($(yOffset))} {
                    set yDelta [expr {$(yMagnet) - $(yOutline)}]
                    incr yDelta $offset
                    set (yMagnet) [expr {$(yOutline) + $yDelta}]
                } else {
                    set yDelta 0
                }
            } else {
                set offset [yOffset $canvas $(xOutline) [expr {$(yOutline) + $yDelta}] $width $height]
                if {[string length $offset] > 0} {
                    incr yDelta $offset
                    set (yMagnet) [expr {$(yOutline) + $yDelta}]
                }
            }
            set (yOffset) $offset
            $canvas move outline $xDelta $yDelta
            fence $canvas outline
            incr (xOutline) $xDelta; incr (yOutline) $yDelta
            set (xLast) $x; set (yLast) $y
            foreach {x y} [$canvas coords outline] break
            lifoLabel::push $global::messenger "[expr {round($x) - [lindex [$canvas cget -scrollregion] 0]}] [expr {round($y)}]"
        }

        proc xOffset {canvas x y width height} {
            set left [xSnapOffset $canvas $x $y $height]
            set right [xSnapOffset $canvas [incr x $width] $y $height]
            if {[string length $left] == 0} {
                if {[string length $right] == 0} {return {}} else {return $right}
            } else {
                if {([string length $right] == 0) || (abs($left) < abs($right))} {return $left} else {return $right}
            }
        }
        proc yOffset {canvas x y width height} {
            set top [ySnapOffset $canvas $x $y $width]
            set bottom [ySnapOffset $canvas $x [incr y $height] $width]
            if {[string length $top] == 0} {
                if {[string length $bottom] == 0} {return {}} else {return $bottom}
            } else {
                if {([string length $bottom] == 0) || (abs($top) < abs($bottom))} {return $top} else {return $bottom}
            }
        }

    }

}



class canvasWindowManager {

    class icon {

        set (image,gray) [image create photo -data {
            R0lGODlhGAAYAMIEAAAAAHh8eL+/v9jc2P///////////////yH5BAEAAAQALAAAAAAYABgAAANrSLrcviDKSWskQOjNuwdB5o0jKJKoZgZs676wOQzBbNc2
            nc+ynuO33WAFKxZNmkBHyWFykAJncvkJTZvUDlQazT5DxrCrB5yVfTny7nwegsXirff6FXHvVfu8q7XyN3h9FoODAQRwiA+KiwkAOw==
        }]
        set (image,gray,green) [image create photo -data {
            R0lGODlhGAAYAMIFAAAAAHh8eIDAgL//v9j/2P///////////yH5BAEAAAcALAAAAAAYABgAAANweLrcviDKSWs8YOjNuwdB5o0jKJKoZgps676wSRDCbNc2
            nc+ynuO3HWEFKxZNGkFHyWFykANncvkJTZvUDlQazT5DxrCrB5yVfTny7nwegsXirff6FXHvVfu8q7XyN3h9FoODAQcBiImKi4yID4+QCQA7
        }]
        set (image,gray,red) [image create photo -data {
            R0lGODlhGAAYAMIFAAAAAHh8eMCAgP+/v//f3////////////yH5BAEAAAcALAAAAAAYABgAAANweLrcviDKSWs8YOjNuwdB5o0jKJKoZgps676wSRDCbNc2
            nc+ynuO3HWEFKxZNGkFHyWFykANncvkJTZvUDlQazT5DxrCrB5yVfTny7nwegsXirff6FXHvVfu8q7XyN3h9FoODAQcBiImKi4yID4+QCQA7
        }]

        proc icon {this canvas title args} switched {$args} {
            set image [$canvas create image 0 0 -image $(image,gray) -tags icon($this)]
            set text [$canvas create text 0 [expr {([image height $(image,gray)] / 2.0) + 1}]                -anchor n -text $title -font $font::(smallNormal) -tags icon($this)            ]
            foreach {left top right bottom} [$canvas bbox icon($this)] {}
            set x [expr {round(($right - $left) / 2.0)}]
            $canvas move $image $x 0
            $canvas move $text $x 0
            set ($this,image) $image
            set ($this,moved) 0
            set ($this,canvas) $canvas
            switched::complete $this
        }

        proc ~icon {this} {
            $($this,canvas) delete icon($this)
        }

        proc options {this} {
            return [list                [list -command {} {}]                [list -color {} {}]                [list -state normal]            ]
        }

        proc set-command {this value} {
            if {[string length $value] == 0} {
                $($this,canvas) bind icon($this) <Double-Button-1> {}
            } elseif {[string equal $switched::($this,-state) normal]} {
                $($this,canvas) bind icon($this) <Double-Button-1> "uplevel #0 $value"
            }
        }

        proc set-color {this value} {
            foreach {red green blue} [winfo rgb $($this,canvas) $value] {}
            if {($green > ($red * 1.1)) && ($green > ($blue * 1.1))} {
                $($this,canvas) itemconfigure $($this,image) -image $(image,gray,green)
            } elseif {($red > ($green * 1.1)) && ($red > ($blue * 1.1))} {
                $($this,canvas) itemconfigure $($this,image) -image $(image,gray,red)
            } else {
                $($this,canvas) itemconfigure $($this,image) -image $(image,gray)
            }
        }

        proc set-state {this value} {
            set canvas $($this,canvas)
            switch $value {
                disabled {
                    $canvas bind icon($this) <Double-Button-1> {}
                    $canvas bind icon($this) <ButtonPress-1> {}
                    $canvas bind icon($this) <Button1-Motion> {}
                    $canvas bind icon($this) <ButtonRelease-1> {}
                }
                normal {
                    if {[string length $switched::($this,-command)] == 0} {
                        $canvas bind icon($this) <Double-Button-1> {}
                    } else {
                        $canvas bind icon($this) <Double-Button-1> "uplevel #0 $switched::($this,-command)"
                    }
                    $canvas bind icon($this) <ButtonPress-1> "canvasWindowManager::icon::select $this %x %y"
                    $canvas bind icon($this) <Button1-Motion> "canvasWindowManager::icon::moving $this %x %y"
                    $canvas bind icon($this) <ButtonRelease-1> "lifoLabel::pop $global::messenger"
                }
                default error
            }
        }

        proc select {this x y} {
            set (xLast) $x; set (yLast) $y
            lifoLabel::push $global::messenger {}
        }

        proc moving {this x y} {
            set canvas $($this,canvas)
            $canvas move icon($this) [expr {$x - $(xLast)}] [expr {$y - $(yLast)}]
            set (xLast) $x; set (yLast) $y
            set ($this,moved) 1
            fence $canvas icon($this)
            foreach {x y} [$canvas coords icon($this)] break
            lifoLabel::pop $global::messenger
            lifoLabel::push $global::messenger "[expr {round($x) - [lindex [$canvas cget -scrollregion] 0]}] [expr {round($y)}]"
        }

        proc fromTag {tag} {
            set identifier 0
            scan $tag icon(%u) identifier
            return $identifier
        }

        proc coordinates {this {x {}} {y {}}} {
            set canvas $($this,canvas)
            foreach {xCurrent yCurrent} [$canvas coords icon($this)] {}
            if {[string length $x] == 0} {return [list $xCurrent $yCurrent]}
            $canvas move icon($this) [expr {$x - $xCurrent}] [expr {$y - $yCurrent}]
            fence $canvas icon($this)
        }

    }

}



class canvasWindowManager {

    proc canvasWindowManager {this canvas} {
        set ($this,drag) [new dragSite -path $canvas -validcommand "canvasWindowManager::validateDrag $this" -grab 0]
        set ($this,canvas) $canvas
    }

    proc ~canvasWindowManager {this} {
        variable ${this}data
        variable ${this}handleIcon
        variable ${this}handleCoordinates
        variable ${this}handleIconCoordinates

        foreach {handle icon} [array get ${this}handleIcon] {
            delete $icon
        }
        foreach {name handle} [array get ${this}data handle,*] {
            delete $handle
        }
        catch {unset ${this}data}
        catch {unset ${this}handleIcon}; catch {unset ${this}handleCoordinates}; catch {unset ${this}handleIconCoordinates}
        delete $($this,drag)
    }

    proc manage {this path viewer} {
        variable ${this}data

        set handle [new handles $($this,canvas) $this -path $path]
        set ${this}data(handle,$path) $handle
        set ${this}data(viewerHandle,$viewer) $handle
    }

    proc unmanage {this path} {
        variable ${this}data
        variable ${this}handleIcon
        variable ${this}handleCoordinates
        variable ${this}handleIconCoordinates

        set handle [set ${this}data(handle,$path)]
        if {[info exists ${this}handleIcon($handle)]} {
            delete [set ${this}handleIcon($handle)]
            unset ${this}handleIcon($handle)
            catch {unset ${this}handleIconCoordinates($handle)}
        }
        catch {unset ${this}handleCoordinates($handle)}
        foreach {name value} [array get ${this}data viewerHandle,*] {
            if {$value == $handle} {array unset ${this}data $name; break}
        }
        delete $handle
        unset ${this}data(handle,$path) ${this}data(relativeStackingLevel,$path)
    }

    proc configure {this path args} {
        variable ${this}data

        set handle [set ${this}data(handle,$path)]
        array set value $args
        if {![catch {string length $value(-level)} length] && ($length > 0)} {
            set names [array names ${this}data relativeStackingLevel,*]
            if {[llength $names] > 0} {
                foreach name $names {
                    set pathFrom([set ${this}data($name)]) [lindex [split $name ,] end]
                }
                foreach level [lsort -integer [array names pathFrom]] {
                    if {$level > $value(-level)} {
                        handles::stackLower $handle [set ${this}data(handle,$pathFrom($level))]
                        break
                    }
                }
            }
            set ${this}data(relativeStackingLevel,$path) $value(-level)
        }
        catch {set xIcon $value(-iconx); set yIcon $value(-icony)}
        catch {unset value(-level)}
        catch {unset value(-iconx) value(-icony)}
        if {![catch {set object $value(-dragobject)}]} {
            composite::configure $handle -dragobject $object
            unset value(-dragobject)
        }
        eval composite::configure $handle [array get value]
        ::update idletasks
        if {[info exists xIcon] && ([string length $xIcon] > 0)} {
            minimize $this $handle [composite::cget $handle -title] $xIcon $yIcon $value(-static)
        }
    }

    proc getGeometry {this path} {
        variable ${this}data
        variable ${this}handleIcon
        variable ${this}handleCoordinates

        set handle [set ${this}data(handle,$path)]
        set geometry [handles::getGeometry $handle]
        if {[info exists ${this}handleIcon($handle)]} {
            return [eval lreplace [list $geometry] 0 1 [set ${this}handleCoordinates($handle)]]
        } else {
            return $geometry
        }
    }

    proc getStackLevel {this path} {
        variable ${this}data

        return [set ${this}data(relativeStackingLevel,$path)]
    }

    proc iconCoordinates {this path} {
        variable ${this}data
        variable ${this}handleIcon

        set handle [set ${this}data(handle,$path)]
        if {[catch {set icon [set ${this}handleIcon($handle)]}]} {
            return [list {} {}]
        } else {
            return [icon::coordinates $icon]
        }
    }

    proc relativeStackingLevels {this} {
        variable ${this}data

        set list {}
        foreach {name value} [array get ${this}data relativeStackingLevel,*] {
            lappend list $value
        }
        return [lsort -integer $list]
    }

    proc stacked {this path raised} {
        variable ${this}data

        set levels [relativeStackingLevels $this]
        if {[llength $levels] == 0} {
            set ${this}data(relativeStackingLevel,$path) 0
        } elseif {$raised} {
            set ${this}data(relativeStackingLevel,$path) [expr {[lindex $levels end] + 1}]
        } else {
            set ${this}data(relativeStackingLevel,$path) [expr {[lindex $levels 0] - 1}]
        }
    }

    proc raisedOnTop {this path} {
        variable ${this}data

        return [expr {[set ${this}data(relativeStackingLevel,$path)] >= [lindex [relativeStackingLevels $this] end]}]
    }

    proc raise {this next} {
        variable ${this}data
        variable ${this}handleIcon

        set canvas $($this,canvas)
        set bounds [bounds $canvas]
        set handles {}
        foreach {name handle} [array get ${this}data handle,*] {
            if {[info exists ${this}handleIcon($handle)]} continue
            if {![intersect [$canvas bbox $handles::($handle,item)] $bounds]} continue
            set path($handle) [scan $name handle,%s]
            lappend handles $handle
        }
        set length [llength $handles]
        if {$length < 2} {
            raiseOther $this $next
            return
        }
        set handles [lsort -integer $handles]
        set maximum $global::32BitIntegerMinimum
        set index 0
        foreach handle $handles {
            set level [set ${this}data(relativeStackingLevel,$path($handle))]
            if {$level > $maximum} {
                set maximum $level
                set top $index
            }
            incr index
        }
        if {$next} {
            if {[incr top] >= $length} {
                if {[raiseOther $this 1]} return
                set top 0
            }
        } else {
            if {[incr top -1] < 0} {
                if {[raiseOther $this 0]} return
                set top end
            }
        }
        handles::stack [lindex $handles $top] raise
    }

    proc raiseOther {this next} {
        variable ${this}data
        variable ${this}handleIcon

        set canvas $($this,canvas)
        set bounds [bounds $canvas]
        set handles {}
        foreach {name handle} [array get ${this}data handle,*] {
            if {[catch {set tag icon([set ${this}handleIcon($handle)])}]} continue
            if {![intersect [$canvas bbox $tag] $bounds]} continue
            lappend handles $handle
        }
        set tags {}
        foreach handle [lsort -integer $handles] {
            lappend tags icon([set ${this}handleIcon($handle)])
        }
        foreach viewer $canvas::viewer::(list) {
            set tag $canvas::viewer::($viewer,tag)
            if {![intersect [$canvas bbox $tag] $bounds]} continue
            lappend tags $tag
        }
        if {[llength $tags] == 0} {return 0}
        if {[info exists ($this,raiseOtherEvent)]} {
            set command [lindex [after info $($this,raiseOtherEvent)] 0]
            after cancel $($this,raiseOtherEvent)
            uplevel #0 $command
            set index [lsearch -exact $tags $($this,raiseOtherTag)]
            if {$index < 0} {
                if {$next} {set index 0} else {set index end}
            } elseif {$next} {
                if {[incr index] >= [llength $tags]} {unset index}
            } else {
                if {[incr index -1] < 0} {unset index}
            }
        } else {
            if {$next} {set index 0} else {set index end}
        }
        if {![info exists index]} {
            unset ($this,raiseOtherTag)
            return 0
        }
        set ($this,raiseOtherTag) [lindex $tags $index]
        foreach {left top right bottom} [$canvas bbox $($this,raiseOtherTag)] {}
        set highlighter [new highlighter]
        highlighter::show $highlighter            [expr {[winfo rootx $canvas] + $left}] [expr {[winfo rooty $canvas] + $top}]            [expr {$right - $left}] [expr {$bottom - $top}]
        set ($this,raiseOtherEvent) [after 1000 "delete $highlighter; unset canvasWindowManager::($this,raiseOtherEvent)"]
        return 1
    }

    proc minimize {this handle title {xIcon {}} {yIcon {}} {static 0}} {
        variable ${this}handleIcon
        variable ${this}handleCoordinates
        variable ${this}handleIconCoordinates

        foreach {x y} [handles::getGeometry $handle] break
        set ${this}handleCoordinates($handle) [list $x $y]
        handles::moveTo $handle $global::32BitIntegerMinimum $global::32BitIntegerMinimum
        set icon [new icon $($this,canvas) $title -command "canvasWindowManager::deIconify $this $handle"]
        if {$static} {switched::configure $icon -state disabled} else {switched::configure $icon -state normal}
        if {[string length $xIcon] > 0} {
            icon::coordinates $icon $xIcon $yIcon
            set ${this}handleIconCoordinates($handle) [list $xIcon $yIcon]
        } elseif {[info exists ${this}handleIconCoordinates($handle)]} {
            eval icon::coordinates $icon [set ${this}handleIconCoordinates($handle)]
        } else {
            stowIcon $this $icon
        }
        switched::configure $icon -color [composite::cget $handle -titlebackground]
        set ${this}handleIcon($handle) $icon
    }

    proc deIconify {this handle} {
        variable ${this}handleIcon
        variable ${this}handleCoordinates
        variable ${this}handleIconCoordinates

        set icon [set ${this}handleIcon($handle)]
        if {$icon::($icon,moved)} {
            set ${this}handleIconCoordinates($handle) [icon::coordinates $icon]
        }
        delete $icon
        eval handles::moveTo $handle [set ${this}handleCoordinates($handle)]
        handles::stack $handle raise
        unset ${this}handleIcon($handle) ${this}handleCoordinates($handle)
    }

    proc stowIcon {this identifier} {
        set canvas $($this,canvas)
        set padding $global::iconPadding
        ::update idletasks
        set bounds [bounds $canvas]
        foreach {region(left) region(top) region(right) region(bottom)} $bounds {}
        foreach item [$canvas find all] {
            set index 0
            foreach tag [$canvas gettags $item] {
                if {[scan $tag icon(%u) index] > 0} break
            }
            if {($index == 0) || ($index == $identifier)} continue
            if {![intersect [$canvas bbox icon($index)] $bounds]} continue
            set found($index) {}
        }
        set coordinates {}
        foreach index [array names found] {
            lappend coordinates [$canvas bbox icon($index)]
        }
        set coordinates [lsort -integer -index 0 $coordinates]
        foreach {left top right bottom} [$canvas bbox icon($identifier)] {}
        set height [expr {$bottom - $top + (2 * $padding)}]
        set width [expr {$right - $left + (2 * $padding)}]
        set maximum $region(bottom)
        while {[set minimum [expr {$maximum - $height}]] >= 0} {
            set spaces {}
            set x $region(left)
            foreach list $coordinates {
                foreach {left top right bottom} $list {}
                if {($top > $maximum) || ($bottom < $minimum)} continue
                if {$left > $x} {
                    lappend spaces $x $left
                }
                set x $right
            }
            if {$x < $region(right)} {
                lappend spaces $x $region(right)
            }
            foreach {left right} $spaces {
                if {($right - $left) > $width} {
                    set position(x) $left
                    set position(y) $minimum
                    break
                }
            }
            if {[info exists position]} break
            set maximum $minimum
        }
        if {![info exists position]} {
            set position(x) [expr {$region(left)}]
            set position(y) [expr {$region(bottom) - $height}]
        }
        foreach {x y} [icon::coordinates $identifier] {}
        foreach {left top right bottom} [$canvas bbox icon($identifier)] {}
        icon::coordinates $identifier [expr {$position(x) + ($x - $left)}] [expr {$position(y) + ($y - $top)}]
    }

    proc viewerPage {this object} {
        variable ${this}data
        variable ${this}handleIcon

        if {[catch {set handle [set ${this}data(viewerHandle,$object)]}]} {
            return {}
        }
        set tag $handles::($handle,item)
        catch {set tag icon([set ${this}handleIcon($handle)])}
        return [pages::tagOrItemPage $tag]
    }

    proc handles {this} {
        variable ${this}data

        set list {}
        foreach {name handle} [array get ${this}data handle,*] {
            lappend list $handle
        }
        return $list
    }

    proc rectangles {this exclude} {
        variable ${this}handleIcon

        set canvas $($this,canvas)
        set page [pages::tagOrItemPage $handles::($exclude,item)]
        set list {}
        foreach handle [handles $this] {
            if {($handle == $exclude) || [info exists ${this}handleIcon($handle)]} continue
            set item $handles::($handle,item)
            if {![string equal [pages::tagOrItemPage $item] $page]} continue
            foreach {x y} [coordinates $canvas $item] {}
            lappend list [list $x $y [winfo width $widget::($handle,path)] [winfo height $widget::($handle,path)]]
        }
        return $list
    }

    proc coordinates {canvas itemOrTag} {
        set values {}
        foreach value [$canvas coords $itemOrTag] {
            lappend values [expr {round($value)}]
        }
        return $values
    }

    proc validateDrag {this x y} {
        variable ${this}handleIcon

        set drag $($this,drag)
        set canvas $($this,canvas)
        foreach format [dragSite::provide $drag] {dragSite::provide $drag $format {}}
        foreach tag [$canvas gettags current] {
            if {[set icon [icon::fromTag $tag]] > 0} {
                set handle 0
                foreach {name value} [array get ${this}handleIcon] {
                    if {$value == $icon} {set handle $name; break}
                }
                if {$handle == 0} {error {could not find a handle for selected icon}}
                dragSite::provide $drag MINIMIZED "dragEcho [list [list $this $handle $icon]]"
                return 1
            }
        }
        return [canvas::viewer::validateDrag $canvas $x $y]
    }

    proc dragData {this format} {
        return [canvas::viewer::dragData $($this,canvas) $format]
    }

    proc moveIconToPage {list x y} {
        foreach {manager handle icon} $list {}
        variable ${manager}handleCoordinates
        set ${manager}handleCoordinates($handle) [list $x $y]
        icon::coordinates $icon $x $y
    }

    proc moveHandlesToPage {handles x y} {
        set manager $global::windowManager
        variable ${manager}handleCoordinates
        variable ${manager}handleIconCoordinates
        set ${manager}handleCoordinates($handles) [list $x $y]
        catch {unset ${manager}handleIconCoordinates($handles)}
        handles::moveTo $handles $x $y
    }

    proc moveAll {this xMaximum} {
        variable ${this}handleIcon

        foreach handle [handles $this] {
            if {![catch {set icon [set ${this}handleIcon($handle)]}]} {
                foreach {x y} [icon::coordinates $icon] {}
                if {$x >= $xMaximum} {
                    moveIconToPage [list $this $handle $icon] [expr {round($x) % $xMaximum}] $y
                }
            } else {
                foreach {x y} [canvasWindowManager::handles::getGeometry $handle] break
                if {$x >= $xMaximum} {
                    moveHandlesToPage $handle [expr {round($x) % $xMaximum}] $y
                }
            }
        }
    }

    proc color {this path value} {
        variable ${this}data
        variable ${this}handleIcon

        set handle [set ${this}data(handle,$path)]
        composite::configure $handle -titlebackground $value
        if {![catch {set icon [set ${this}handleIcon($handle)]}]} {
            switched::configure $icon -color $value
        }
    }

}



class imageLabel {

    proc imageLabel {this parentPath args} composite {[new frame $parentPath] $args} {
        set path $widget::($this,path)
        composite::manage $this [new label $path] label [new label $path] image
        place $composite::($this,image,path) -relx 1 -rely 0.5 -anchor e
        bind $composite::($this,label,path) <Configure> "imageLabel::update $this"
        bind $composite::($this,image,path) <Configure> "imageLabel::update $this"
        composite::complete $this
    }

    proc ~imageLabel {this} {}

    proc options {this} {
        return [list            [list -bindtags {} {}]            [list -font $widget::option(label,font) $widget::option(label,font)]            [list -image {} {}]            [list -text {} {}]            [list -width 0 0]        ]
    }

    proc set-bindtags {this value} {
        if {$composite::($this,complete)} {
            error {option -bindtags cannot be set dynamically}
        }
        set path $composite::($this,label,path); bindtags $path [concat [bindtags $path] $value]
        set path $composite::($this,image,path); bindtags $path [concat [bindtags $path] $value]
    }

    proc set-font {this value} {
        $composite::($this,label,path) configure -font $value
    }

    proc set-image {this value} {
        $composite::($this,image,path) configure -image $value
    }

    proc set-text {this value} {
        $composite::($this,label,path) configure -text $value
    }

    proc set-width {this value} {
        if {$value == 0} {
            update $this
        } else {
            $widget::($this,path) configure -width $value
        }
    }

    proc update {this} {
        set height 0
        set label $composite::($this,label,path); set image $composite::($this,image,path)
        if {[set value [winfo reqheight $label]] > $height} {set height $value}
        if {[set value [winfo reqheight $image]] > $height} {set height $value}
        $widget::($this,path) configure -height $height
        set labelWidth [winfo reqwidth $label]; set imageWidth [winfo reqwidth $image]
        set width [winfo width $widget::($this,path)]
        if {($labelWidth + $imageWidth) < $width} {
            place $label -anchor e -relx 1 -x -$imageWidth -rely 0.5
        } else {
            place $label -anchor w -relx 0 -x 0 -rely 0.5
        }
        if {$composite::($this,-width) == 0} {
            $widget::($this,path) configure -width [expr {$labelWidth + $imageWidth}]
        }
    }

}



class colorLabels {

    proc colorLabels {this parentPath args} composite {[::new frame $parentPath] $args} {
        set ($this,labels) {}
        composite::complete $this
    }

    proc ~colorLabels {this} {
        eval ::delete $($this,labels)
     }

    proc options {this} {
        return [list            [list -colorheight 0 0]        ]
    }

    proc set-colorheight {this value} {
        if {$composite::($this,complete)} {
            error {option -colorheight cannot be set dynamically}
        }
    }

    proc new {this popupMenu args} {
        set label [eval ::new label $widget::($this,path) -colorheight $composite::($this,-colorheight) $args]
        if {[string length $popupMenu] > 0} {
            set command "set colorLabels::label::(clicked) $label; tk_popup $popupMenu %X %Y"
            foreach path [concat $widget::($label,path) [winfo children $widget::($label,path)]] {
                bind $path <ButtonPress-3> $command
            }
        }
        lappend ($this,labels) $label
        refresh $this
        return $label
    }

    proc delete {this label} {
        ldelete ($this,labels) $label
        ::delete $label
        refresh $this
    }

    proc refresh {this} {
        set path $widget::($this,path)
        catch {eval grid forget [grid slaves $path]}
        set row 0
        foreach label $($this,labels) {
            grid $widget::($label,path) -row $row -sticky new
            incr row
            grid rowconfigure $path $row -minsize 1
            incr row
        }
    }

}


class colorLabels {

    class label {

        proc label {this parentPath args} composite {[new frame $parentPath] $args} {
            set path $widget::($this,path)
            composite::manage $this [new frame $path -highlightbackground black -highlightthickness 1 -width 11] frame                [new label $path -font $font::(mediumNormal) -anchor nw -justify left -padx 2] label
            pack $composite::($this,frame,path) -side left
            pack $composite::($this,label,path) -fill both -expand 1
            composite::complete $this
        }

        proc ~label {this} {}

        proc options {this} {
            return [list                [list -background {} {}]                [list -color {} {}]                [list -colorheight 0 0]                [list -relief flat flat]                [list -text {} {}]            ]
        }

        proc set-background {this value} {
            if {[string length $value] == 0} {
                set value $widget::option(label,background)
            }
            $composite::($this,label,path) configure -background $value
        }

        proc set-color {this value} {
            $composite::($this,frame,path) configure -background $value
        }

        proc set-colorheight {this value} {
            update $this
        }

        proc set-relief {this value} {
             $composite::($this,label,path) configure -relief $value
        }

        proc set-text {this value} {
            $composite::($this,label,path) configure -text $value
            update $this
        }

        proc update {this} {
            set height $composite::($this,-colorheight)
            if {$height <= 0} {
                set height [winfo reqheight $composite::($this,label,path)]
            }
            $composite::($this,frame,path) configure -height $height
        }

        proc height {this} {
            return [winfo reqheight $composite::($this,label,path)]
        }

    }

}



class blt2DViewer {

    set (axisTickFont) $font::(smallNormal)

    proc blt2DViewer {this parentPath path {labelsColorHeight 0} {noMinimum 0}} viewer {} {
        if {$noMinimum} {set ($this,noMinimum) {}}
        set ($this,path) $path
        $path configure -background $viewer::(background) -cursor {} -highlightthickness 0            -plotpadx 1 -plotpady 2
        $path yaxis configure -tickshadow {} -title {} -tickfont $(axisTickFont)
        $path legend configure -hide 1
        set labels [new colorLabels $parentPath -colorheight $labelsColorHeight]
        viewer::setupDropSite $this $parentPath
        set menu [menu $path.menu -tearoff 0]
        set ($this,help) [new menuContextHelp $menu]
        set index 0
        foreach type [list maximum minimum] {
            if {$noMinimum && [string equal $type minimum]} continue
            $menu add command -label [mc [string totitle $type]]... -state disabled -command "
                viewer::limitEntry $this $path w $index {} -y$type $type $(axisTickFont)                    {blt2DViewer::limitEntered $this $type} {blt2DViewer::plotLimit $this $type} float
            "
            menuContextHelp::set $($this,help) $index [mc "set ordinate $type value or automatic scaling"]
            incr index
        }
        $menu add cascade -label [mc Labels] -menu [menu $menu.labels -tearoff 0] -state disabled
        menuContextHelp::set $($this,help) $index [mc {position of data cells labels relative to the graphics}]
        set ($this,labelsHelp) [new menuContextHelp $menu.labels]
        $menu.labels add radiobutton -label [mc Right] -variable ::blt2DViewer::($this,labelsPosition) -value right            -command "composite::configure $this -labelsposition right"
        menuContextHelp::set $($this,labelsHelp) 0 [mc {place data cells labels on the right}]
        $menu.labels add radiobutton -label [mc Bottom] -variable ::blt2DViewer::($this,labelsPosition) -value bottom            -command "composite::configure $this -labelsposition bottom"
        menuContextHelp::set $($this,labelsHelp) 1 [mc {place data cells labels on the bottom}]
        $menu.labels add radiobutton -label [mc Left] -variable ::blt2DViewer::($this,labelsPosition) -value left            -command "composite::configure $this -labelsposition left"
        menuContextHelp::set $($this,labelsHelp) 2 [mc {place data cells labels on the left}]
        $menu.labels add radiobutton -label [mc Top] -variable ::blt2DViewer::($this,labelsPosition) -value top            -command "composite::configure $this -labelsposition top"
        menuContextHelp::set $($this,labelsHelp) 3 [mc {place data cells labels on top}]
        bindtags $parentPath [concat [bindtags $parentPath] PopupMenu$this]
        bindtags $path [concat [bindtags $path] PopupMenu$this]
        set ($this,colorsMenu) [viewer::createColorsMenu $path "blt2DViewer::setColor $this \$colorLabels::label::(clicked) %c"]
        if {!$global::readOnly} {
            bind PopupMenu$this <ButtonPress-3> "tk_popup $menu %X %Y"
        }
        foreach type [list maximum minimum] {
            set label [new imageLabel $path -font $(axisTickFont) -bindtags PopupMenu$this]
            set ($this,drop,$type) [new dropSite -path $path -formats DATACELLS -state disabled                -regioncommand "blt2DViewer::dropRegion $this $type" -command "blt2DViewer::limitCellDrop $this $type"            ]
            set ($this,tips,$type) {}
            if {!$global::readOnly} {
                set tip [new widgetTip -path $path -state disabled]
                switch $type {
                    maximum {switched::configure $tip -rectangle [list 0 0 $viewer::(limitAreaWidth) $viewer::(limitAreaHeight)]}
                    minimum {
                        set ($this,tip,minimum) $tip
                    }
                }
                lappend ($this,tips,$type) $tip
                lappend ($this,tips,$type) [new widgetTip -path $widget::($label,path)]
            }
            set ($this,$type) $label
            set ($this,limit,$type) {}
            updateTip $this $type
        }
        set ($this,elements) {}
        set ($this,labels) $labels
        set ($this,menu) $menu
        positionLimitLabel $this maximum 0; positionLimitLabel $this minimum 0
        bind $path <Configure> "+ blt2DViewer::refresh $this"
    }

    proc ~blt2DViewer {this} {
        set ($this,destruction) {}
        bind $($this,path) <Configure> {}
        if {[info exists ($this,drag)]} {
            delete $($this,drag)
        }
        eval delete $($this,elements)
        if {[info exists ($this,selector)]} {
            delete $($this,selector)
        }
        eval delete $($this,labels) $($this,help) $($this,labelsHelp) $($this,drop,maximum) $($this,drop,minimum)            $($this,tips,maximum) $($this,tips,minimum) $($this,maximum) $($this,minimum)
    }

    proc supportedTypes {this} {
        return $global::numericDataTypes
    }

    proc setCellColors {this list} {
        set ($this,nextCellIndex) 0
    }

    proc dragData {this format} {
        set legends [selector::selected $($this,selector)]
        set selectedElements {}
        foreach element $($this,elements) {
            if {[lsearch -exact $legends $($this,legend,$element)] < 0} continue
            lappend selectedElements $element
        }
        switch $format {
            OBJECTS {
                if {[llength $selectedElements] > 0} {
                    return $selectedElements
                } elseif {[llength $($this,elements)] == 0} {
                    return $this
                } else {
                    return {}
                }
            }
            DATACELLS {
                return [cellsFromElements $this $selectedElements]
            }
        }
    }

    proc validateDrag {this legend x y} {
        if {($legend == 0) && ([llength $($this,elements)] == 0)} {
            return 1
        } elseif {[lsearch -exact [selector::selected $($this,selector)] $legend] >= 0} {
            return 1
        } else {
            return 0
        }
    }

    proc monitorCell {this array row column} {
        set cell ${array}($row,$column)
        if {![canMonitor $this $array]} return
        if {[lsearch -exact [cellsFromElements $this $($this,elements)] $cell] >= 0} return
        viewer::registerTrace $this $array
        if {[info exists ($this,nextCellIndex)]} {
            set color [lindex $composite::($this,-cellcolors) $($this,nextCellIndex)]
            if {[string length $color] == 0} {
                unset color ($this,nextCellIndex)
            } else {
                incr ($this,nextCellIndex)
            }
        }
        if {![info exists color]} {set color [viewer::getDisplayColor $cell]}
        set element [newElement $this $($this,path) -color $color]
        if {$global::readOnly} {
            set legend [colorLabels::new $($this,labels) {} -color $color]
        } else {
            set legend [colorLabels::new $($this,labels) $($this,colorsMenu) -color $color]
        }
        switched::configure $element -deletecommand "blt2DViewer::deletedElement $this $array $element"
        lappend ($this,elements) $element
        updateLayout $this
        foreach [list ($this,label,$element) incomplete] [viewer::label $array $row $column] {}
        set ($this,legend,$element) $legend
        set ($this,cell,$element) $cell
        if {$composite::($this,-draggable)} {
            set labelPath $composite::($legend,label,path)
            set drag [new dragSite -path $labelPath -validcommand "blt2DViewer::validateDrag $this $legend"]
            dragSite::provide $drag OBJECTS "blt2DViewer::dragData $this"
            dragSite::provide $drag DATACELLS "blt2DViewer::dragData $this"
            set ($this,drag,$element) $drag
            set selector $($this,selector)
            selector::add $selector $legend
            bind $labelPath <ButtonPress-1> "blt2DViewer::buttonPress $selector $legend"
            bind $labelPath <Control-ButtonPress-1> "selector::toggle $selector $legend"
            bind $labelPath <Shift-ButtonPress-1> "selector::extend $selector $legend"
            bind $labelPath <ButtonRelease-1> "blt2DViewer::buttonRelease $selector $legend 0"
            bind $labelPath <Control-ButtonRelease-1> "blt2DViewer::buttonRelease $selector $legend 1"
            bind $labelPath <Shift-ButtonRelease-1> "blt2DViewer::buttonRelease $selector $legend 1"
        }
        if {$incomplete} {
            set ($this,relabel,$element) {}
        } else {
            composite::configure $($this,legend,$element) -text $($this,label,$element)
        }
        switched::configure $($this,drop,maximum) -state normal
        foreach tip $($this,tips,maximum) {switched::configure $tip -state normal}
        if {![info exists ($this,noMinimum)]} {
            switched::configure $($this,drop,minimum) -state normal
            foreach tip $($this,tips,minimum) {switched::configure $tip -state normal}
        }
        for {set index 0} {$index <= [$($this,menu) index end]} {incr index} {
            $($this,menu) entryconfigure $index -state normal
        }
        modified $this [llength $($this,elements)]
    }

    virtual proc canMonitor {this array} {
        return 1
    }

    proc cells {this} {
        return [cellsFromElements $this $($this,elements)]
    }

    proc deletedElement {this array element} {
        viewer::unregisterTrace $this $array
        ldelete ($this,elements) $element
        if {$composite::($this,-draggable)} {
            delete $($this,drag,$element)
            selector::remove $($this,selector) $($this,legend,$element)
        }
        colorLabels::delete $($this,labels) $($this,legend,$element)
        set length [llength $($this,elements)]
        if {$length == 0} {
            updateLayout $this
            composite::configure $this -ymaximum {} -ymaximumcell {}
            if {![info exists ($this,noMinimum)]} {
                composite::configure $this -yminimum {} -yminimumcell {}
            }
            positionLimitLabel $this maximum 0; positionLimitLabel $this minimum 0
            switched::configure $($this,drop,maximum) -state disabled; switched::configure $($this,drop,minimum) -state disabled
            foreach tip [concat $($this,tips,maximum) $($this,tips,minimum)] {switched::configure $tip -state disabled}
            for {set index 0} {$index <= [$($this,menu) index end]} {incr index} {
                $($this,menu) entryconfigure $index -state disabled
            }
        }
        viewer::returnDisplayColor $($this,cell,$element)
        unset ($this,cell,$element) ($this,label,$element) ($this,legend,$element)
        if {![info exists ($this,destruction)]} {modified $this $length}
    }

    virtual proc update {this array} {
        updateTimeDisplay $this [set seconds [clock seconds]]
        foreach element $($this,elements) {
            set cell $($this,cell,$element)
            if {[string first $array $cell] != 0} continue
            if {[catch {set value [set $cell]}]} {
                updateElement $this $element $seconds ?
                composite::configure $($this,legend,$element) -text "$($this,label,$element): ?"
            } else {
                if {[info exists ($this,relabel,$element)]} {
                    viewer::parse $cell ignore row column ignore
                    foreach [list ($this,label,$element) incomplete] [viewer::label $array $row $column] {}
                    if {!$incomplete} {
                        unset ($this,relabel,$element)
                    }
                }
                if {[string is double -strict $value]} {
                    updateElement $this $element $seconds $value
                } else {
                    updateElement $this $element $seconds ?
                }
                composite::configure $($this,legend,$element) -text "$($this,label,$element): $value"
            }
        }
        if {[info exists cell]} {
            updateLimit $this maximum $array
            if {[info exists ($this,relabelTip,maximum)]} {updateTip $this maximum}
            if {![info exists ($this,noMinimum)]} {
                updateLimit $this minimum $array
                if {[info exists ($this,relabelTip,minimum)]} {updateTip $this minimum}
            }
            refresh $this
        }
    }

    virtual proc newElement {this path args}

    virtual proc updateElement {this element seconds value}

    virtual proc updateTimeDisplay {this seconds} {}

    virtual proc initializationConfiguration {this} {
        set colors {}
        foreach element $($this,elements) {
            lappend colors [switched::cget $element -color]
        }
        return [list -cellcolors $colors]
    }

    proc cellsFromElements {this elements} {
        set cells {}
        foreach element $elements {
            lappend cells $($this,cell,$element)
        }
        return $cells
    }

    proc monitored {this cell} {
        foreach element $($this,elements) {
            if {[string equal $($this,cell,$element) $cell]} {
                return 1
            }
        }
        return 0
    }

    proc setLegendsState {this legends select} {
        if {$select} {
            set relief sunken
        } else {
            set relief flat
        }
        foreach legend $legends {
            composite::configure $legend -relief $relief
        }
    }

    proc allowDrag {this} {
        set ($this,drag) [new dragSite -path $($this,path) -validcommand "blt2DViewer::validateDrag $this 0"]
        dragSite::provide $($this,drag) OBJECTS "blt2DViewer::dragData $this"
        set ($this,selector) [new objectSelector -selectcommand "blt2DViewer::setLegendsState $this"]
    }

    proc setCellColor {this cell color} {
        foreach element $($this,elements) {
            if {[string equal $($this,cell,$element) $cell]} {
                composite::configure $($this,legend,$element) -background $color
                return
            }
        }
    }

    virtual proc modified {this monitored} {}

    proc buttonPress {selector legend} {
        foreach selected [selector::selected $selector] {
            if {$selected == $legend} return
        }
        selector::select $selector $legend
    }

    proc buttonRelease {selector legend extended} {
        if {$extended} return
        set list [selector::selected $selector]
        if {[llength $list] <= 1} return
        foreach selected $list {
            if {$selected == $legend} {
                selector::select $selector $legend
                return
            }
        }
    }

    proc reset {this type} {
        composite::configure $($this,$type) -text {} -image {}
        switch $type {
            maximum {$($this,path) yaxis configure -max {}}
            minimum {$($this,path) yaxis configure -min {}}
        }
        positionLimitLabel $this $type 0
        set ($this,limit,$type) {}
        updateTip $this $type
        refresh $this
    }

    proc updateLimit {this type {array {}}} {
        if {[string length $composite::($this,-y$type)] > 0} {
            set value $composite::($this,-y$type)
            if {[string equal $value $($this,limit,$type)]} return
        } elseif {([string length $array] > 0) && ![catch {set cell $($this,cell,$type)}]} {
            if {[string first $array $cell] != 0} return
            set value ?; catch {set value [set $cell]}
            if {[string equal $value $($this,limit,$type)]} return
        } else return
        set ($this,limit,$type) $value
        if {[string equal $value ?]} {
            set value {}
            composite::configure $($this,$type) -text ? -image $viewer::(rightDarkGrayArrow)
        } else {
            composite::configure $($this,$type) -text $value -image $viewer::(rightRedArrow)
        }
        set color black
        switch $type {
            maximum {
                set minimum [$($this,path) yaxis cget -min]
                if {([string length $minimum] == 0) || ($value > $minimum)} {
                    $($this,path) yaxis configure -max $value
                } else {
                    set color red
                }
            }
            minimum {
                set maximum [$($this,path) yaxis cget -max]
                if {([string length $maximum] == 0) || ($value < $maximum)} {
                    $($this,path) yaxis configure -min $value
                } else {
                    set color red
                }
            }
        }
        composite::configure $($this,maximum) label -foreground $color
        composite::configure $($this,minimum) label -foreground $color
        refresh $this
    }

    proc dropRegion {this type} {
        set X [winfo rootx $($this,path)]
        switch $type {
            maximum {set Y [winfo rooty $($this,path)]}
            minimum {set Y [expr {[winfo rooty $($this,path)] + [plotLimit $this minimum] - ($viewer::(limitAreaHeight) / 2)}]}
        }
        return [list $X $Y [expr {$X + $viewer::(limitAreaWidth)}] [expr {$Y + $viewer::(limitAreaHeight)}]]
    }

    proc plotLimit {this type} {
        switch $type {
            maximum {return [$($this,path) yaxis transform [lindex [$($this,path) yaxis limits] 1]]}
            minimum {return [$($this,path) yaxis transform [lindex [$($this,path) yaxis limits] 0]]}
        }
    }

    proc limitCellDrop {this type} {
        if {[llength $dragSite::data(DATACELLS)] != 1} {
            lifoLabel::flash $global::messenger [mc "only one data cell can be used for $type ordinate"]
            bell
            return
        }
        set cell [lindex $dragSite::data(DATACELLS) 0]
        viewer::parse $cell ignore ignore ignore cellType
        if {[lsearch -exact [supportedTypes $this] $cellType] < 0} {
            viewer::wrongTypeMessage $cellType
        } else {
            composite::configure $this -y${type}cell $cell
        }
    }

    proc setLimit {this type value} {
        if {[string length $value] == 0} {
            reset $this $type
        } else {
            composite::configure $this -y${type}cell {}
            updateLimit $this $type
            updateTip $this $type
        }
    }

    proc setLimitCell {this type cell} {
        if {[info exists ($this,cell,$type)]} {
            viewer::parse $($this,cell,$type) array ignore ignore ignore
            viewer::unregisterTrace $this $array
            unset ($this,cell,$type)
        }
        if {[string length $cell] == 0} {
            reset $this $type
        } else {
            composite::configure $this -y$type {}
            viewer::parse $cell array ignore ignore ignore
            viewer::registerTrace $this $array
            set ($this,cell,$type) $cell
            updateLimit $this $type $array
            updateTip $this $type
        }
    }

    proc positionLimitLabel {this type visible} {
        set label $($this,$type)
        if {$visible} {
            ::update idletasks
            set path $($this,path)
            set width [expr {[$path extents leftmargin] - round([$path yaxis cget -ticklength] / 2.0)}]
            if {$width < 0} {
                after 500 "blt2DViewer::positionLimitLabel $this $type 1"
            }
            composite::configure $label -width $width
            place $widget::($label,path) -anchor e -x $width -y [expr {[plotLimit $this $type] - 1}]
        } else {
            place forget $widget::($label,path)
        }
    }

    proc limitEntered {this type value} {
        if {[string length $value] == 0} {
            composite::configure $this -y${type}cell {}
        }
        composite::configure $this -y$type $value
    }

    proc updateTip {this type} {
        if {[info exists ($this,cell,$type)]} {
            viewer::parse $($this,cell,$type) array row column ignore
            foreach {label incomplete} [viewer::label $array $row $column] {}
            if {$incomplete} {
                set ($this,relabelTip,$type) {}
            } else {
                catch {unset ($this,relabelTip,$type)}
            }
            set text [format [mc "$type cell: %s"] $label]
        } elseif {![catch {set value $composite::($this,-y$type)}] && ([string length $value] > 0)} {
            set text [format [mc "fixed $type value set to %s"] $value]
        } else {
            set text [mc "set fixed $type value or drop cell as dynamic $type value here"]
        }
        foreach tip $($this,tips,$type) {switched::configure $tip -text $text}
    }

    proc setColor {this legend color} {
        foreach element $($this,elements) {
            if {$($this,legend,$element) == $legend} break
        }
        switched::configure $element -color $color
        composite::configure $legend -color $color
    }

    virtual proc updateLabels {this {values 1}} {
        if {$values} {
            foreach element $($this,elements) {
                viewer::parse $($this,cell,$element) array ignore ignore ignore
                set ($this,relabel,$element) {}
                set update($array) {}
            }
            foreach array [array names update] {
                update $this $array
            }
        } else {
            foreach element $($this,elements) {
                viewer::parse $($this,cell,$element) array row column ignore
                composite::configure $($this,legend,$element)                    -text [set ($this,label,$element) [lindex [viewer::label $array $row $column] 0]]
            }
        }
        if {[info exists ($this,cell,maximum)]} {updateTip $this maximum}
        if {[info exists ($this,cell,minimum)]} {updateTip $this minimum}
    }

    proc updateLayout {this} {
        set parentPath $widget::($this,path)
        set label [llength $($this,elements)]
        set labelsPath $widget::($($this,labels),path)
        grid propagate $parentPath 0
        set ($this,labelsPosition) $composite::($this,-labelsposition)
        switch $($this,labelsPosition) {
            top - bottom {
                grid columnconfigure $parentPath 0 -minsize 0 -weight 1
                grid columnconfigure $parentPath 1 -minsize 0 -weight 0
            }
            left - default {
                grid rowconfigure $parentPath 0 -minsize 0 -weight 1
                grid rowconfigure $parentPath 1 -minsize 0 -weight 0
            }
        }
        switch $($this,labelsPosition) {
            left {
                grid $($this,path) -row 0 -column 1 -sticky nsew
                if {$label} {grid $labelsPath -row 0 -column 0 -sticky nw}
                grid columnconfigure $parentPath 0 -minsize 0 -weight 1
                grid columnconfigure $parentPath 1 -minsize 70 -weight 1000
            }
            top {
               grid $($this,path) -row 1 -column 0 -sticky nsew
                if {$label} {grid $labelsPath -row 0 -column 0 -sticky nw}
                grid rowconfigure $parentPath 0 -minsize 0 -weight 1
                grid rowconfigure $parentPath 1 -minsize 100 -weight 1000
            }
            bottom {
                grid $($this,path) -row 0 -column 0 -sticky nsew
                if {$label} {grid $labelsPath -row 1 -column 0 -sticky nw}
                grid rowconfigure $parentPath 0 -minsize 100 -weight 1000
                grid rowconfigure $parentPath 1 -minsize 0 -weight 1
            }
            default {
                grid $($this,path) -row 0 -column 0 -sticky nsew
                if {$label} {grid $labelsPath -row 0 -column 1 -sticky nw}
                grid columnconfigure $parentPath 0 -minsize 70 -weight 1000
                grid columnconfigure $parentPath 1 -minsize 0 -weight 1
            }
        }
        if {$label} {
            grid $labelsPath -ipadx 2 -ipady 2
        } else {
            grid forget $labelsPath
        }
    }

    proc refresh {this} {
        if {![info exists ($this,noMinimum)]} {
            ::update idletasks
            if {[info exists ($this,tip,minimum)]} {
                set y [expr {[plotLimit $this minimum] - ($viewer::(limitAreaHeight) / 2)}]
                switched::configure $($this,tip,minimum)                    -rectangle [list 0 $y $viewer::(limitAreaWidth) [expr {$y + $viewer::(limitAreaHeight)}]]
            }
            if {[info exists ($this,cell,minimum)] || ([string length $composite::($this,-yminimum)] > 0)} {
                positionLimitLabel $this minimum 1
            }
        }
        if {[info exists ($this,cell,maximum)] || ([string length $composite::($this,-ymaximum)] > 0)} {
            positionLimitLabel $this maximum 1
        }
    }

}



class dataBarChart {

    set (plotBackground) $widget::option(button,background)
    set (list) {}

    proc dataBarChart {this parentPath noMinimum args} composite {[new frame $parentPath] $args} blt2DViewer {
        $widget::($this,path) [blt::barchart $widget::($this,path).bar -title {} -bottommargin 6 -plotbackground $(plotBackground)]
        0 $noMinimum
    } {
        if {$noMinimum} {set ($this,noMinimum) {}}
        set path $widget::($this,path).bar
        $path grid off
        $path xaxis configure -hide 1; $path yaxis configure -hide 1
        set ($this,path) $path
        composite::complete $this
        lappend (list) $this
        after idle "dataBarChart::updateMessage $this"
    }

    proc ~dataBarChart {this} {
        ldelete (list) $this
        if {[string length $composite::($this,-deletecommand)]>0} {
            uplevel #0 $composite::($this,-deletecommand)
        }
    }

    proc options {this} {
        return [list            [list -cellcolors {} {}]            [list -deletecommand {} {}]            [list -draggable 0 0]            [list -height $global::viewerHeight]            [list -labelsposition right]            [list -mode normal normal]            [list -width $global::viewerWidth]            [list -ymaximum {} {}]            [list -ymaximumcell {} {}]            [list -yminimum $global::graphMinimumY]            [list -yminimumcell {} {}]        ]
    }

    proc set-cellcolors {this value} {
        if {$composite::($this,complete)} {
            error {option -cellcolors cannot be set dynamically}
        }
        blt2DViewer::setCellColors $this $value
    }

    proc set-deletecommand {this value} {}

    foreach option {-height -width} {
        proc set$option {this value} "\$widget::(\$this,path) configure $option \$value"
    }

    proc set-draggable {this value} {
        if {$composite::($this,complete)} {
            error {option -draggable cannot be set dynamically}
        }
        if {$value} {
            blt2DViewer::allowDrag $this
        }
    }

    proc set-mode {this value} {
        $($this,path) configure -barmode $value
    }

    proc set-labelsposition {this value} {
        blt2DViewer::updateLayout $this
    }

    proc set-ymaximum {this value} {
        blt2DViewer::setLimit $this maximum $value
    }
    proc set-ymaximumcell {this value} {
        blt2DViewer::setLimitCell $this maximum $value
    }
    proc set-yminimum {this value} {
        if {[info exists ($this,noMinimum)]} return
        blt2DViewer::setLimit $this minimum $value
    }
    proc set-yminimumcell {this value} {
        if {[info exists ($this,noMinimum)]} return
        blt2DViewer::setLimitCell $this minimum $value
    }

    proc newElement {this path args} {
        return [eval new element $path $args]
    }

    virtual proc updateElement {this element seconds value} {
        if {[string equal $value ?]} {
            element::update $element 0
        } else {
            element::update $element $value
        }
    }

    proc modified {this monitored} {
        $($this,path) yaxis configure -hide [expr {$monitored == 0}]
        updateMessage $this
    }

    proc updateMessage {this} {
        if {[catch {classof $this}]} return
        if {[llength [blt2DViewer::cells $this]] == 0} {
            centerMessage $widget::($this,path) [message $this] $(plotBackground) $global::viewerMessageColor
        } else {
            centerMessage $widget::($this,path) {}
        }
    }

    virtual proc message {this}

    proc initializationConfiguration {this} {
        if {[info exists ($this,noMinimum)]} {
            set list {}
        } else {
            set list [list -yminimum $composite::($this,-yminimum) -yminimumcell $composite::($this,-yminimumcell)]
        }
        return [concat            [list                -ymaximum $composite::($this,-ymaximum) -ymaximumcell $composite::($this,-ymaximumcell)                -labelsposition $composite::($this,-labelsposition)            ] $list [blt2DViewer::_initializationConfiguration $this]        ]
    }

}

class dataBarChart {

    class element {

        proc element {this path args} switched {$args} {
            $path element create $this -label {} -borderwidth 1 -xdata 0
            set ($this,path) $path
            switched::complete $this
        }

        proc ~element {this} {
            $($this,path) element delete $this
            if {[string length $switched::($this,-deletecommand)]>0} {
                uplevel #0 $switched::($this,-deletecommand)
            }
        }

        proc options {this} {
            return [list                [list -color black black]                [list -deletecommand {} {}]            ]
        }

        proc set-color {this value} {
            $($this,path) element configure $this -foreground $value
        }

        proc set-deletecommand {this value} {}

        proc update {this y} {
            $($this,path) element configure $this -ydata $y
        }

    }

}

class dataSideBarChart {

    proc dataSideBarChart {this parentPath args} dataBarChart {$parentPath 0 $args} {
        composite::configure $this -mode aligned
    }

    proc ~dataSideBarChart {this} {}

    proc iconData {} {
        return {
            R0lGODdhJAAkAMYAAPj4+Hh4ePj8+DBgGHh8eKDweAAAAJjscJjkcJDgaJDcaIjYaIjUYIDMYIDEWHjAWHi8WHBIAHC4UOjUSHC0UODMQGisSNjEQNjASGCk
            SNC4SGCgQMiwSFiYQMioSFiYOMCgSFiQOLiYSFCMOLiQSICEgFCIMLCMSBBgeIiQiEiEMKiESMDQ2JCYkEiAKKh8SKjA0KCkoEB4KKB0SJC0wKisqJhsSLi8
            uEBwIJhkSHiouMDEwDhsIJBcSGCYsMjQyNDY0ODk4Ojs6AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
            AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
            AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAJAAkAAAH/oAAgoOCAYSHhoeDiYWKhIyKkIiPhAIDl5iZk44AkIkBAQQDBaSlpAMG
            oKqrrK2ggpYHsrOyAwSUnJ6VAwi9vr22uI66g5YJx8jHwYucnbigogrS09KorteusAML3N3cy425wgCWDObn5uDO4szFAw3w8fDqkuOfoe/y8dbY/a/kAxwI
            HCiQXjNi2h4oXKhQHQEB7MJpg0CxIsUBETJq3LgpHLQBEkKKDIlxgsmTJiOk8qeNgsuXLjFWmElzZoRb7SQCtMCzJ0+MF4IKDXoTok5Ilnz6xIihqdOmRXOu
            +5ihqtWqGDVo3apVJQGWADeIHSsWI4ezaM/etLerg9u3/m4xephLd+5aqUgHfNjLdy9GEIADA456VJCBwwNCKF6sGKOIx5AfqzxMuTJlApgHjNjMeTNGEqBD
            g76JubTp0iVSDzDBujVrjCdiy44dAYXt27hTl0jBe4CK38B/Y1xBvDjx2iySK0+OggDvFtAHuJhOfTrGF9izY68No7v37s2hxxg/QIb58+YxzljPfn1tGvDj
            w28+vob98ujPY7TBvz//9/LF15x9NxQ4AA4IJoggRjk06GCDtekg4YQSNlfgDhgOwMOGHG6IUQ8ghghibT6UaGKJzWH4w4qZtIjRRjDiJmNzKwJhIxCn5ajj
            jqbZGMSPQAYp5JBEFinEkUgmB6nkkkw2GQgAOw==
        }
    }

    proc message {this} {
        return [mc "side bar chart:\ndrop data cell(s)"]
    }

}

class dataStackedBarChart {

    proc dataStackedBarChart {this parentPath args} dataBarChart {$parentPath 1 $args} {
        composite::configure $this -mode stacked
    }

    proc ~dataStackedBarChart {this} {}

    proc iconData {} {
        return {
            R0lGODdhJAAkAKUAAPj4+Hh4eHh8eDBgGPj8+KjweAAAAJjkcJDYaIjMYIDAWDg4OHi0UGioSGCgQFiUOHBIAPDYSOjMQODESNi4SNCwSMioSMCcSLiUSLCI
            SBBgeLDY6KDQ4ICEgJDE2IiQiIi80JCYkHi0yKCkoHCswKisqGCguLi8uFiYsMDEwEiQqMjQyNDY0ODk4Ojs6AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
            AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAJAAkAAAG/kCAcCgMEI/G4zBZVBKZSiiSKFAOrtisdrsFEKqAgFgwKJjP6LQaPTAIBOIhYXCo2+/4/H0g
            +B7nCIGCg4SFg3x+RHMJjI2Oj5COAwFfBGFjAwqam5ydnpwDC29wcgMMp6ipqqupk5WKAw2ys7S1trSufbAOvL2+v8C+uZZiAWQPyMnKy8zKoaNMBBDT1NXW
            19eUunIQEd7f4OHi4BDaltwS6err7O3r5a/FAhAT9fb3+Pn3EKJv0RAUAgocSLDgQHjbhEirwLChw4cQHSI8pxCChYsYM2rcmHHipTcQLogcSbKkSZL8oHHD
            wLKly5cwXXrklqGmzZs4c96cqVCDv8+fQIMKFWoOgIGjBjRsWMq0qdOnTTUgPTpKgAYOWLNq3cpVq4aqAjqI7aDBg9mzaNOqRft1bIcPcD9oAEG3rt27eO1+
            jfshhN8QGkQIHky4sGHCX/+GGMF4hAYSkCNLnkxZ8tfGI0poLqHBhOfPoEOLBv11c4kTqE9oQMG6tevXsF1/TX0ihe0UGlTo3s27t2/eX2+nWEF8xdDjyH8K
            KL6ChXPnYKNLny7gOYsW2LNr3869u3cX4MOLH0++vPkgADs=
        }
    }

    proc updateElement {this element seconds value} {
        if {[string equal $value ?]} {
            dataBarChart::element::update $element 0
        } else {
            dataBarChart::element::update $element [expr {abs($value)}]
        }
    }

    proc message {this} {
        return [mc "stacked bar chart:\ndrop data cell(s)"]
    }

}

class dataOverlapBarChart {

    proc dataOverlapBarChart {this parentPath args} dataBarChart {$parentPath 0 $args} {
        composite::configure $this -mode overlap
    }

    proc ~dataOverlapBarChart {this} {}

    proc iconData {} {
        return {
            R0lGODdhJAAkAMYAAPj4+Hh4ePj8+DBgIHh8eKDweAAAAJjscJjocJDgcJDgaIjYaIjUaIDQYIDMYIDIYHjEWHjAWHBIAHC8WOjQQHC0UODIQGiwUNjEQNi8
            QGCoSNC0QGCkSMisQFigQMikQFicQMCgQFiYQLiYQFCQOLiQQICEgLCIQBBgeIiQiEiMOKiAQLjI0JCYkEiEMKh8QKCkoECAMKB0QKC4yKisqEB8MJhsQIio
            uLi8uEB4KJhkQMDEwDh0KJBcQHCgsMjQyODk4NDY0Ojs6AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
            AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
            AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAJAAkAAAH/oAAgoOCAYSHhoeDiYWKhIyKkIiPhAIDl5iZmQCSlIuFAQQDBaSlpqQD
            BgGrrK2urIKWB7O0tbMDBJ2fu7EDCL/Awb+4uo28AJYJysvMygOrjsbGq6IK1tfY1qm5r92wyAML4uPk4s/FnJ69DOzt7uzn0enHlg329/j28dGQidQDDgIK
            HBhwm7eDvR4oXMhQ4T5H/SoNgECxokWKDyOpAxeho0cJIEOKFLnRX6gBE1KqlEChpcuXLSWoOpjIUoWbOCVY2Mmz504JBI5BsnShqFEJGJIqXZoUqFCJRo9m
            mEq16lQJAQRIm/dPg9evEjaIHUtWrExu3npxWMtWQoe3/nDjvsWqdd5WSx7y6pXwoa/fv33pbh06AIThwxJCKF7MWLFgu/MMSB4gorJlCSMya96cWabkz6Al
            Exg9gITp0xJKqF7NWjXQ0bBjjzZBu/Rp0xJO6N6tG4Xv38CB0zaRovgAFciTS1jBvDlzFCyiS58eHQWB4i2yD3DBvbuEF+DDg4dOvbz17DDSD4jBvr0EGfDj
            w0cxo779+/Wtp6fBf0CN/wBKYMOABA6Iwg0IJqgggtbxh8ODA+Qg4YQS6GDhhRYeuOCG1j24w4cD8CDiiBL0YOKJJqLgw4ostriidR/+IKMml4wkUnA4/kaA
            jED0CIRsQAYpZGxBBOHjkUgmEKnkkj4K4eSTUEYp5ZRUBgIAOw==
        }
    }

    proc updateElement {this element seconds value} {
        dataBarChart::_updateElement $this $element $seconds $value
        set path $dataBarChart::($this,path)
        set list {}
        foreach name [$path element show] {
            set value [$path element cget $name -ydata]
            if {![string is double -strict $value]} {set value 0}
            lappend list [list $name $value]
        }
        set names {}
        foreach list [lsort -real -index end -decreasing $list] {
            foreach {name value} $list {}
            lappend names $name
        }
        $path element show $names
    }

    proc message {this} {
        return [mc "overlap bar chart:\ndrop data cell(s)"]
    }

}



class bltGraph {

    variable plotBackground black
    set (graphs) {}

    proc bltGraph {this path {graph 0}} {
        if {![info exists (menu,grid,label)]} {
            set (menu,grid,label) [mc Grid]
            set (menu,grid,help) [mc {whether a grid is displayed in the plot area}]
        }
        $path configure -plotborderwidth 1 -topmargin 3            -bufferelements 1
        $path xaxis configure -tickfont $blt2DViewer::(axisTickFont) -title {} -command bltGraph::axisTime            -tickshadow {} -showticks 0
        bind $path <Configure> "+ bltGraph::resized $this"
        if {$graph != 0} {
            set ($this,marker) [$path marker create polygon -fill {} -coords {-Inf Inf Inf Inf Inf -Inf -Inf -Inf}]
            $path crosshairs configure -color blue
            lappend (graphs) [set ($this,graph) $graph]
        }
        set ($this,path) $path
        set ($this,plotWidth) 0
        set ($this,range) 0
        set ($this,crossHairs) 0
    }

    proc ~bltGraph {this} {
        bind $($this,path) <Configure> {}
        if {[info exists ($this,graph)]} {ldelete (graphs) $($this,graph)}
    }

    proc setRange {this value} {
        set ($this,range) $value
    }

    proc xAxisUpdateRange {this {maximumTime {}}} {
        if {$($this,range) == 0} return
        if {[string length $maximumTime] == 0} {
            set maximumTime [$($this,path) xaxis cget -max]
            if {[string length $maximumTime] > 0} {$($this,path) xaxis configure -min [expr {$maximumTime - $($this,range)}]}
        } else {
            $($this,path) xaxis configure -min [expr {$maximumTime - $($this,range)}] -max $maximumTime
        }
    }

    proc axisTime {path value} {
        set now [clock seconds]
        if {[string length [set minimum [$path xaxis cget -min]]] == 0} {return ?}
        set minimum [expr {round($minimum)}]
        if {[clock format $minimum -format %Y] < [clock format $now -format %Y]} {
            set format {%Y-%m-%d }
        } elseif {[clock format $minimum -format %j] < [clock format $now -format %j]} {
            set format {%m-%d }
        }
        set value [expr {round($value)}]
        if {($value % 60) == 0} {
            append format %R
        } else {
            append format %T
        }
        return [clock format $value -format $format]
    }

    proc xUpdateGraduations {this} {
        if {($($this,plotWidth) == 0) || ($($this,range) == 0)} return
        set minimum [expr {(2.0 * 6 * $($this,range)) / $($this,plotWidth)}]
        foreach step {10 60 300 600 1800 3600 18000 36000 86400 604800 2419200 31536000} division {5 6 5 5 5 6 5 5 4 7 4 12} {
            if {$step > $minimum} break
        }
        $($this,path) xaxis configure -stepsize $step -subdivisions $division -showticks 1
    }

    proc resized {this} {
        update idletasks
        set path $($this,path)
        set width [$path extents plotwidth]
        if {$width != $($this,plotWidth)} {
            set ($this,plotWidth) $width
            xUpdateGraduations $this
        }
    }

    proc enterPlotArea {this x y} {
        set path $($this,path)
        $path configure -cursor tcross
        $path crosshairs on
        set ($this,crossHairs) 1
        bind $path <Any-Motion> "bltGraph::processMotion $this %x %y"
        lifoLabel::push $global::messenger "[axisTime $path $x] $y"
    }

    proc leavePlotArea {this} {
        set path $($this,path)
        $path configure -cursor {}
        $path crosshairs off
        set ($this,crossHairs) 0
        bind $path <Any-Motion> {}
        lifoLabel::pop $global::messenger
    }

    proc processMotion {this x y} {
        set path $($this,path)
        $path crosshairs configure -position @$x,$y
        foreach {x y} [$path invtransform $x $y] {}
        lifoLabel::pop $global::messenger
        lifoLabel::push $global::messenger "[axisTime $path $x] $y"
    }

    proc hideAxisAndCrossHair {this yesOrNo} {
        set path $($this,path)
        $path xaxis configure -hide $yesOrNo
        $path yaxis configure -hide $yesOrNo
        if {[info exists ($this,marker)]} {
            if {$yesOrNo} {
                $path marker bind $($this,marker) <Enter> {}
                $path marker bind $($this,marker) <Leave> {}
            } else {
                $path marker bind $($this,marker) <Enter> "bltGraph::enterPlotArea $this %x %y"
                $path marker bind $($this,marker) <Leave> "bltGraph::leavePlotArea $this"
            }
        }
    }

    proc allowDrag {this drag} {
        dragSite::provide $drag DATETIME "bltGraph::dragData $this"
        set ($this,validCommand) [switched::cget $drag -validcommand]
        switched::configure $drag -validcommand "bltGraph::validateDrag $this"
    }

    proc validateDrag {this x y} {
        if {$($this,crossHairs)} {
            return 1
        } else {
            return [eval $($this,validCommand) $x $y]
        }
    }

    proc dragData {this format} {
        return [expr {round(            [lindex [eval $($this,path) invtransform [split [string trimleft [$($this,path) crosshairs cget -position] @] ,]] 0]        )}]
    }

    proc xRotateLabels {this value} {
        $($this,path) xaxis configure -rotate $value
    }

}



class dataGraph {

    proc dataGraph {this parentPath args} composite {[new frame $parentPath] $args} blt2DViewer {
        $widget::($this,path) [blt::stripchart $widget::($this,path).graph -title {}] 5
    } {
        set ($this,graphPath) $widget::($this,path).graph
        $($this,graphPath) pen create void -linewidth 0 -symbol none
        $($this,graphPath) grid configure -minor 0
        set graph [new bltGraph $($this,graphPath) $this]
        bltGraph::hideAxisAndCrossHair $graph 1
        $blt2DViewer::($this,menu) add checkbutton            -label $bltGraph::(menu,grid,label) -command "composite::configure $this -grid \$dataGraph::($this,-grid)"            -variable dataGraph::($this,-grid) -offvalue 0 -onvalue 1
        menuContextHelp::set $blt2DViewer::($this,help) [$blt2DViewer::($this,menu) index end] $bltGraph::(menu,grid,help)
        after idle "dataGraph::updateMessage $this"
        set ($this,graph) $graph
        composite::complete $this
    }

    proc ~dataGraph {this} {
        delete $($this,graph)
        if {[string length $composite::($this,-deletecommand)] > 0} {
            uplevel #0 $composite::($this,-deletecommand)
        }
    }

    proc iconData {} {
        return {
            R0lGODdhJAAkAKUAAPj8+Hh4eDBgIDBgGKDscJDcaIjQYHjAWDg4OHC0UGikSFiYQHh8eHBIAPDcSODQQNjEONC8MMiwMMCoKLicIAAAABBgeICEgKjU4JCY
            kLi8uIiQiJjI2IjA0NDY0KCkoIC4yKisqHCwwGikuMDEwFicsMjQyODk4Ojs6AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
            AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAJAAkAAAG/kCAcCgMEI/G4zBZVBKZSijy6VxWAVKqFRsICL7dsNgrGAjGAbMZLRQQ3gKs0v0mxId0eBNf
            6BfORF9+fl+Cg4BQAgaLi3cAioyRkoxnRklhAgeamoWbnJmem18IpGKBCaipqmAIX6tnCExZjwq1trWVAbFkYF0IWnMCC8PDlXtje8dovL1jDMvQVbthwFHV
            Sg3Z2VNVULMA2Q7i4g3X1ZdiDQ/r7OsNaNrv0F1EDRD3+PnbAdn65d5HGkQYOFAbwYICDxLctkVIAwkQIcrjF7GixYrllDWYwHFCA1Igs3XsGG+kx2lJGlBY
            +e7XE5UrKUzkF1OmpYDZfEWJF4DBzxKeN5HQcxkllk8iz3btqcC0qdOnUKNKZUDVglWqWLMysHpVK1cLWhlcuGABg1kLGdKqTVvWLAYLGuJqaHtW7NgLGzZY
            4MCXA1y5c/f25ft1sF8GefOy7cCYsQUPkC00nkx5MlgGaz9otgCic2eunkF8De25q+bTIVKHsCCitevXXa3CvsxAtWrAc0fo3q2btoaqXLHilkuiuHGrJZIn
            v2y8uNbm0EmYmE7dxNavVKtr374dsnfvYb+LH0/+hPnz6NOrX88ehfv38OPLn08/CAA7
        }
    }

    proc options {this} {
        set samples [expr {$global::graphNumberOfIntervals + 1}]
        return [list            [list -cellcolors {} {}]            [list -deletecommand {} {}]            [list -draggable 0 0]            [list -grid $global::graphDisplayGrid]            [list -height $global::viewerHeight]            [list -interval 0 0]            [list -labelsposition right]            [list -plotbackground $global::graphPlotBackground]            [list -samples $samples $samples]            [list -width $global::viewerWidth]            [list -xlabelsrotation $global::graphXAxisLabelsRotation]            [list -ymaximum {} {}]            [list -ymaximumcell {} {}]            [list -yminimum $global::graphMinimumY]            [list -yminimumcell {} {}]        ]
    }

    proc set-cellcolors {this value} {
        if {$composite::($this,complete)} {
            error {option -cellcolors cannot be set dynamically}
        }
        blt2DViewer::setCellColors $this $value
    }

    proc set-deletecommand {this value} {}

    foreach option {-height -width} {
        proc set$option {this value} "\$widget::(\$this,path) configure $option \$value"
    }

    proc set-draggable {this value} {
        if {$composite::($this,complete)} {
            error {option -draggable cannot be set dynamically}
        }
        if {$value} {
            blt2DViewer::allowDrag $this
            bltGraph::allowDrag $($this,graph) $blt2DViewer::($this,drag)
        }
    }

    proc set-grid {this value} {
        if {$value} {
            $($this,graphPath) grid configure -hide no
        } else {
            $($this,graphPath) grid configure -hide yes
        }
        set ($this,-grid) $value
    }

    proc set-interval {this value} {
        set graph $($this,graph)
        bltGraph::setRange $graph [expr {($composite::($this,-samples) - 1) * $value}]
        bltGraph::xAxisUpdateRange $graph
        bltGraph::xUpdateGraduations $graph
    }

    proc set-samples {this value} {
        if {$composite::($this,-interval) == 0} return
        set graph $($this,graph)
        bltGraph::setRange $graph [expr {($value - 1) * $composite::($this,-interval)}]
        bltGraph::xAxisUpdateRange $graph
        bltGraph::xUpdateGraduations $graph
    }

    proc set-labelsposition {this value} {
        blt2DViewer::updateLayout $this
    }

    proc set-plotbackground {this value} {
        $($this,graphPath) configure -plotbackground $value
        $($this,graphPath) pen configure void -color $value
        $($this,graphPath) grid configure -color [visibleForeground $value]
    }

    proc set-xlabelsrotation {this value} {
        bltGraph::xRotateLabels $($this,graph) $value
    }

    proc set-ymaximum {this value} {
        blt2DViewer::setLimit $this maximum $value
    }
    proc set-ymaximumcell {this value} {
        blt2DViewer::setLimitCell $this maximum $value
    }
    proc set-yminimum {this value} {
        blt2DViewer::setLimit $this minimum $value
    }
    proc set-yminimumcell {this value} {
        blt2DViewer::setLimitCell $this minimum $value
    }

    proc newElement {this path args} {
        return [eval new element $path $composite::($this,-interval) $args]
    }

    proc updateTimeDisplay {this seconds} {
        bltGraph::xAxisUpdateRange $($this,graph) $seconds
    }

    proc updateElement {this element seconds value} {
        element::update $element $seconds $value
    }

    proc canMonitor {this array} {
        if {$composite::($this,-interval) > 0} {
            return 1
        } else {
            return [string equal [lindex [modules::decoded $array] 0] instance]
        }
    }

    proc update {this array} {
        if {$composite::($this,-interval) > 0} {
            return [blt2DViewer::_update $this $array]
        }
        foreach element $blt2DViewer::($this,elements) {
            set cell $blt2DViewer::($this,cell,$element)
            foreach {start end} [databaseInstances::range $cell] {}
            if {[string length $start] == 0} {
                element::range $element {}
                continue
            }
            set start [clock scan $start]
            set end [clock scan $end]
            if {($element::($element,start) == $start) && ($element::($element,end) == $end)} {
                continue
            }
            element::range $element [databaseInstances::history $cell]
        }
        foreach {minimum maximum} [databaseInstances::cursorsRange] {}
        set graph $($this,graph)
        bltGraph::setRange $graph [expr {$maximum - $minimum}]
        bltGraph::xUpdateGraduations $graph
        bltGraph::xAxisUpdateRange $graph $maximum
        if {[info exists cell]} {
            blt2DViewer::updateLimit $this maximum $array
        }
    }

    proc modified {this monitored} {
        bltGraph::hideAxisAndCrossHair $($this,graph) [expr {$monitored == 0}]
        updateMessage $this
    }

    proc updateMessage {this} {
        if {[llength [blt2DViewer::cells $this]] == 0} {
            centerMessage $widget::($this,path)                [mc "graph chart:\ndrop data cell(s)"] $composite::($this,-plotbackground) $global::viewerMessageColor
        } else {
            centerMessage $widget::($this,path) {}
        }
    }

    proc initializationConfiguration {this} {
        return [concat            [list                -ymaximum $composite::($this,-ymaximum) -ymaximumcell $composite::($this,-ymaximumcell)                -yminimum $composite::($this,-yminimum) -yminimumcell $composite::($this,-yminimumcell)                -labelsposition $composite::($this,-labelsposition) -grid $composite::($this,-grid)            ] [blt2DViewer::_initializationConfiguration $this]        ]
    }

    virtual proc updateLabels {this} {
        blt2DViewer::_updateLabels $this [expr {$composite::($this,-interval) > 0}]
    }

}


class dataGraph {

    class element {

        proc element {this path interval args} switched {$args} {
            variable x$this
            variable y$this
            variable weight$this

            if {$interval == 0} {
                blt::vector create x${this}
                blt::vector create y${this}
                blt::vector create weight${this}
                set ($this,start) 0
                set ($this,end) 0
            } else {
                set dots [expr {$global::graphNumberOfIntervals + 1}]
                blt::vector create x${this}($dots)
                blt::vector create y${this}($dots)
                blt::vector create weight${this}($dots)
            }
            $path element create $this -label {} -xdata x$this -ydata y$this -weight weight$this -styles {{void 0 0}}
            if {$interval == 0} {
                $path element configure $this -pixels 1
            } else {
                $path element configure $this -symbol none
            }
            set ($this,path) $path
            set ($this,interval) $interval
            switched::complete $this
        }

        proc ~element {this} {
            variable x$this
            variable y$this
            variable weight$this

            blt::vector destroy x$this y$this weight$this
            $($this,path) element delete $this
            if {[string length $switched::($this,-deletecommand)] > 0} {
                uplevel #0 $switched::($this,-deletecommand)
            }
        }

        proc options {this} {
            return [list                [list -color black black]                [list -deletecommand {} {}]            ]
        }

        proc set-color {this value} {
            $($this,path) element configure $this -color $value
        }

        proc set-deletecommand {this value} {}

        proc update {this x y} {
            variable x$this
            variable y$this
            variable weight$this

            if {[x${this} index end] == 0} {
                if {[string equal $y ?]} return
                x${this} index : [expr {$x - $($this,interval)}]
                y${this} index : $y
                weight${this} index end 1
                unset ($this,interval)
            }
            set length [llength [x$this search 0 [$($this,path) xaxis cget -min]]]
            incr length -2
            catch {x$this delete :$length; y$this delete :$length; weight$this delete :$length}
            x$this append $x
            if {[string equal $y ?]} {
                y$this append [y${this} index end]
                weight$this append 0
            } else {
                y$this append $y
                weight$this append 1
            }
        }

        proc range {this list} {
            variable x$this
            variable y$this
            variable weight$this

            blt::vector destroy x$this y$this weight$this
            blt::vector create x${this}; blt::vector create y${this}; blt::vector create weight${this}
            foreach {stamp value} $list {
                set stamp [clock scan $stamp]
                if {[string length $value] == 0} {
                    if {[info exists xValid]} {
                        x$this append $xValid; y$this append $yValid
                        weight$this append 0
                        unset xValid yValid
                    }
                    set void {}
                } else {
                    if {[info exists void]} {
                        x$this append $stamp; y$this append $value
                        weight$this append 0
                        unset void
                    }
                    x$this append [set xValid $stamp]; y$this append [set yValid $value]
                    weight$this append 1
                }
            }
            $($this,path) element configure $this -xdata x$this -ydata y$this -weight weight$this
            if {[llength $list] == 0} {
                set ($this,start) 0
                set ($this,end) 0
            } else {
                set ($this,start) [clock scan [lindex $list 0]]
                set ($this,end) [clock scan [lindex $list end-1]]
            }
        }

    }

}



class dataStackedGraph {

    proc dataStackedGraph {this parentPath args} composite {[new frame $parentPath] $args} blt2DViewer {
        $widget::($this,path) [blt::barchart $widget::($this,path).graph -title {} -barmode stack -barwidth 0] 0 1
    } {
        set ($this,graphPath) $widget::($this,path).graph
        set graph [new bltGraph $($this,graphPath) $this]
        bltGraph::hideAxisAndCrossHair $graph 1
        $blt2DViewer::($this,menu) add checkbutton            -label $bltGraph::(menu,grid,label) -command "composite::configure $this -grid \$dataStackedGraph::($this,-grid)"            -variable dataStackedGraph::($this,-grid) -offvalue 0 -onvalue 1
        menuContextHelp::set $blt2DViewer::($this,help) [$blt2DViewer::($this,menu) index end] $bltGraph::(menu,grid,help)
        after idle "dataStackedGraph::updateMessage $this"
        set ($this,graph) $graph
        composite::complete $this
    }

    proc ~dataStackedGraph {this} {
        delete $($this,graph)
        if {[string length $composite::($this,-deletecommand)] > 0} {
            uplevel #0 $composite::($this,-deletecommand)
        }
    }

    proc iconData {} {
        return {
            R0lGODdhJAAkAKUAAPj8+Hh4eDBgIDBgGHh8eKDocKjweJjgaJDYaIjQYAAAAIDIWHjAWHi4UHCwUHBIAGioSPDYSGCgQOjQSFiYQODISFCQOODESNi8SNC4
            SNCwSMisSMCkSMCcSLiYSBBgeLCQSLDY6ICEgKDQ4LCMSIiQiJjI2KiESJCYkIjA0KCkoIC4yKisqHiwwLi8uGiouMDEwGCgsMjQyNDY0ODk4Ojs6AAAAAAA
            AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAJAAkAAAG/kCAcCgMEI/G4zBZVBKZSijy6RQ0lQLBwHrcbpdFglhQEBAC4jRBYGgbzGm22xyoQ8nlO77A
            L2f3fGYAUgACB4dchYeLjI2LgoQCCJMIf5SXmJmQRWhrCZ+goaKjoQIKYnVEAgusra6vsK4CRpEMtre4ubq4s4NYDcDBwsPEwpuDnQIOy8zNzs/NpqhQCg8Q
            EA/Z2dfc3d7cvYQPEdkR5uYPEurr7O0S4UoPE/P09A8U+Pna9/kUx3ViHlQYSLBgNgsWshl8gNCCtDNQHlyYSLHixGwWKWqDd+QBho8gQ4ocGfIBrXgZUqpc
            ybLlygcEfCELqKGmzZs4c958cAoi8JEHG4IKHUq06FCTMn9yWMq0qdOnTZGK60C1qtWrWK3ClKmgazUPYMOK9fCh7IexZM3y9NozYFkQcOPC/RCibogPcuna
            /aCGgIi/Ij6MGPGBhGHDZQcrJmx2MWG/gEtILvHBhOUPJzJXtsy5s+fLBCaXQEEaxYcUqFOYTc26tWu+pVGomK3iw4rbuHPr3p2bL20VLIKz+NCiuPHjyJMf
            5yuchYvnLj68mE69uvXr1flCdwGjO4wPMcKLH0++/Hi+3mHIWC/DrPv38OOXJcBexoz79/vq38+fAP4ZNAQo4IAEFmjggTUkqOCCDDbo4INBAAA7
        }
    }

    proc options {this} {
        set samples [expr {$global::graphNumberOfIntervals + 1}]
        return [list            [list -cellcolors {} {}]            [list -deletecommand {} {}]            [list -draggable 0 0]            [list -grid $global::graphDisplayGrid]            [list -height $global::viewerHeight]            [list -interval 0 0]            [list -labelsposition right]            [list -plotbackground $global::graphPlotBackground]            [list -samples $samples $samples]            [list -width $global::viewerWidth]            [list -xlabelsrotation $global::graphXAxisLabelsRotation]            [list -ymaximum {} {}]            [list -ymaximumcell {} {}]        ]
    }

    proc set-cellcolors {this value} {
        if {$composite::($this,complete)} {
            error {option -cellcolors cannot be set dynamically}
        }
        blt2DViewer::setCellColors $this $value
    }

    proc set-deletecommand {this value} {}

    proc set-grid {this value} {
        if {$value} {
            $($this,graphPath) grid configure -hide no
        } else {
            $($this,graphPath) grid configure -hide yes
        }
        set ($this,-grid) $value
    }

    foreach option {-height -width} {
        proc set$option {this value} "\$widget::(\$this,path) configure $option \$value"
    }

    proc set-draggable {this value} {
        if {$composite::($this,complete)} {
            error {option -draggable cannot be set dynamically}
        }
        if {$value} {
            blt2DViewer::allowDrag $this
            bltGraph::allowDrag $($this,graph) $blt2DViewer::($this,drag)
        }
    }

    proc set-interval {this value} {
        set graph $($this,graph)
        bltGraph::setRange $graph [expr {($composite::($this,-samples) - 1) * $value}]
        bltGraph::xAxisUpdateRange $graph
        bltGraph::xUpdateGraduations $graph
    }

    proc set-samples {this value} {
        if {$composite::($this,-interval) == 0} return
        set graph $($this,graph)
        bltGraph::setRange $graph [expr {($value - 1) * $composite::($this,-interval)}]
        bltGraph::xAxisUpdateRange $graph
        bltGraph::xUpdateGraduations $graph
    }

    proc set-labelsposition {this value} {
        blt2DViewer::updateLayout $this
    }

    proc set-plotbackground {this value} {
        $($this,graphPath) configure -plotbackground $value
        $($this,graphPath) grid configure -color [visibleForeground $value]
    }

    proc set-xlabelsrotation {this value} {
        bltGraph::xRotateLabels $($this,graph) $value
    }

    proc set-ymaximum {this value} {
        blt2DViewer::setLimit $this maximum $value
    }
    proc set-ymaximumcell {this value} {
        blt2DViewer::setLimitCell $this maximum $value
    }

    proc updateTimeDisplay {this seconds} {
        bltGraph::xAxisUpdateRange $($this,graph) $seconds
    }

    proc newElement {this path args} {
        return [eval new element $path $args]
    }

    proc updateElement {this element seconds value} {
        element::update $element $seconds $value
    }

    proc canMonitor {this array} {
        if {$composite::($this,-interval) > 0} {
            return 1
        } else {
            return [string equal [lindex [modules::decoded $array] 0] instance]
        }
    }

    proc update {this array} {
        if {$composite::($this,-interval) > 0} {
            return [blt2DViewer::_update $this $array]
        }
        foreach element $blt2DViewer::($this,elements) {
            set cell $blt2DViewer::($this,cell,$element)
            foreach {start end} [databaseInstances::range $cell] {}
            if {[string length $start] == 0} {
                element::range $element {}
                continue
            }
            set start [clock scan $start]
            set end [clock scan $end]
            if {($element::($element,start) == $start) && ($element::($element,end) == $end)} {
                continue
            }
            element::range $element [databaseInstances::history $cell]
        }
        foreach {minimum maximum} [databaseInstances::cursorsRange] {}
        set graph $($this,graph)
        bltGraph::setRange $graph [expr {$maximum - $minimum}]
        bltGraph::xUpdateGraduations $graph
        bltGraph::xAxisUpdateRange $graph $maximum
        if {[info exists cell]} {
            blt2DViewer::updateLimit $this maximum $array
        }
    }

    proc modified {this monitored} {
        bltGraph::hideAxisAndCrossHair $($this,graph) [expr {$monitored == 0}]
        updateMessage $this
    }

    proc updateMessage {this} {
        if {[llength [blt2DViewer::cells $this]] == 0} {
            centerMessage $widget::($this,path)                [mc "stacked graph chart:\ndrop data cell(s)"] $composite::($this,-plotbackground) $global::viewerMessageColor
        } else {
            centerMessage $widget::($this,path) {}
        }
    }

    proc initializationConfiguration {this} {
        return [concat            [list                -ymaximum $composite::($this,-ymaximum) -ymaximumcell $composite::($this,-ymaximumcell)                -labelsposition $composite::($this,-labelsposition) -grid $composite::($this,-grid)            ] [blt2DViewer::_initializationConfiguration $this]        ]
    }

    virtual proc updateLabels {this} {
        blt2DViewer::_updateLabels $this [expr {$composite::($this,-interval) > 0}]
    }

}


class dataStackedGraph {

    class element {

        proc element {this path args} switched {$args} {
            variable x$this
            variable y$this

            blt::vector create x${this}
            blt::vector create y${this}
            $path element create $this -label {} -xdata x$this -ydata y$this -borderwidth 0 -barwidth 0.001
            set ($this,start) 0; set ($this,end) 0
            set ($this,path) $path
            switched::complete $this
        }

        proc ~element {this} {
            variable x$this
            variable y$this

            blt::vector destroy x$this y$this
            $($this,path) element delete $this
            if {[string length $switched::($this,-deletecommand)] > 0} {
                uplevel #0 $switched::($this,-deletecommand)
            }
        }

        proc options {this} {
            return [list                [list -color black black]                [list -deletecommand {} {}]            ]
        }

        proc set-color {this value} {
            $($this,path) element configure $this -foreground $value
        }

        proc set-deletecommand {this value} {}

        proc update {this x y} {
            variable x$this
            variable y$this

            set length [llength [x$this search 0 [$($this,path) xaxis cget -min]]]
            incr length -2
            catch {x$this delete :$length; y$this delete :$length}
            set length [x$this length]
            x$this append $x
            if {[string equal $y ?]} {
                y$this append 0
            } else {
                y$this append [expr {abs($y)}]
            }
            if {$length > 0} {
                fill $this [expr {$length - 1}] $length
            }
        }

        proc range {this list} {
            variable x$this
            variable y$this

            blt::vector destroy x$this y$this
            blt::vector create x${this}
            blt::vector create y${this}
            foreach {stamp value} $list {
                if {[string length $value] == 0} continue
                x$this append [clock scan $stamp]
                y$this append [expr {abs($value)}]
            }
            $($this,path) element configure $this -xdata x$this -ydata y$this
            if {[llength $list] == 0} {
                set ($this,start) 0
                set ($this,end) 0
            } else {
                set ($this,start) [clock scan [lindex $list 0]]
                set ($this,end) [clock scan [lindex $list end-1]]
            }
        }

        proc fill {this from to} {
            variable x$this
            variable y$this

            set path $($this,path)
            blt::vector create add
            set step [expr {double([$path xaxis cget -max] - [$path xaxis cget -min]) / [$path extents plotwidth]}]
            add seq [x${this} index $from] [x${this} index $to] $step
            add delete 0
            if {[add length] == 0} {
                blt::vector destroy add
                return 0
            }
            if {[add index end] == [x${this} index $to]} {add delete end}
            if {[add length] == 0} {
                blt::vector destroy add
                return 0
            }
            set after [x${this} index $to:end]
            x${this} set [x${this} index 0:$from]; x${this} append add; x${this} append $after
            blt::vector create limits
            limits append [y${this} index $from] [y${this} index $to]
            limits populate add [add length]
            add delete 0 end
            set after [y${this} index $to:end]
            y${this} set [y${this} index 0:$from]; y${this} append add; y${this} append $after
            blt::vector destroy add limits
            return 1
        }

    }

}



class dataPieChart {

    set (smallFont) $font::(smallNormal)

    proc dataPieChart {this parentPath thickness args} composite {
        [new canvas $parentPath -background $viewer::(background) -highlightthickness 0 -borderwidth 2] $args
    } viewer {} {
        set path $widget::($this,path)
        set ($this,slices) {}
        viewer::setupDropSite $this $path
        set menu [menu $path.menu -tearoff 0]
        set ($this,help) [new menuContextHelp $menu]
        set width [$path cget -borderwidth]
        $menu add command -label [mc Total]... -state disabled -command "
            viewer::limitEntry $this $path nw $width [expr {$width - 1}] -total total $(smallFont)                {dataPieChart::totalEntered $this} {} unsigned
        "
        menuContextHelp::set $($this,help) 0 [mc {set total value or automatic scaling}]
        if {!$global::readOnly} {
            if {[package vcompare $::tcl_version 8.4] < 0} {
                bind PopupMenu$this <ButtonPress-3> "if {\[string length \$::tkPriv(popup)\] == 0} {tk_popup $menu %X %Y}"
            } else {
                bind PopupMenu$this <ButtonPress-3> "if {\[string length \$::tk::Priv(popup)\] == 0} {tk_popup $menu %X %Y}"
            }
        }
        bindtags $path [concat [bindtags $path] PopupMenu$this]
        set ($this,colorsMenu) [viewer::createColorsMenu $path {switched::configure $dataPieChart::slice::(clicked) -background %c}]
        set label [new imageLabel $path -font $(smallFont) -bindtags PopupMenu$this]
        place $widget::($label,path) -x 0 -y 0
        set ($this,drop) [new dropSite -path $path -formats DATACELLS -state disabled            -regioncommand "dataPieChart::dropRegion $this" -command "dataPieChart::totalCellDrop $this"        ]
        set ($this,tips) {}
        if {!$global::readOnly} {
            lappend ($this,tips)                [new widgetTip -path $path -rectangle [list 0 0 $viewer::(limitAreaWidth) $viewer::(limitAreaHeight)]]
            lappend ($this,tips) [new widgetTip -path $widget::($label,path)]
        }
        set ($this,total) $label
        set ($this,menu) $menu
        composite::complete $this
        set padding [$path cget -borderwidth]
        if {[string equal $::global::pieLabeler peripheral]} {
            set labeler                [new piePeripheralLabeler $path -font $font::(mediumNormal) -smallfont $(smallFont) -widestvaluetext {00.0 %}]
        } else {
            set labeler [new pieBoxLabeler $path -font $font::(mediumNormal)]
        }
        set ($this,pie) [new pie $path $padding $padding            -title {} -thickness $thickness -selectable $composite::($this,-draggable) -labeler $labeler            -colors $global::viewerColors -autoupdate 0        ]
        set padding [expr {2 * $padding}]
        bind $path <Configure> "switched::configure $($this,pie) -width \[expr {%w - $padding}\] -height \[expr {%h - $padding}\]"
        after idle "dataPieChart::updateMessage $this"
        updateTip $this
    }

    proc ~dataPieChart {this} {
        if {[info exists ($this,drag)]} {delete $($this,drag)}
        eval delete $($this,slices) $($this,pie) $($this,help) $($this,total) $($this,drop) $($this,tips)
        if {[string length $composite::($this,-deletecommand)] > 0} {
            uplevel #0 $composite::($this,-deletecommand)
        }
    }

    proc options {this} {
        return [list            [list -cellcolors {} {}]            [list -deletecommand {} {}]            [list -draggable 0 0]            [list -height 200]            [list -total {} {}]            [list -totalcell {} {}]            [list -width 300]        ]
    }

    proc set-cellcolors {this value} {
        if {$composite::($this,complete)} {
            error {option -cellcolors cannot be set dynamically}
        }
        set ($this,nextCellIndex) 0
    }

    proc set-deletecommand {this value} {}

    proc set-draggable {this value} {
        if {$composite::($this,complete)} {
            error {option -draggable cannot be set dynamically}
        }
        if {!$value} return
        set ($this,drag) [new dragSite -path $widget::($this,path) -validcommand "dataPieChart::validateDrag $this"]
        dragSite::provide $($this,drag) OBJECTS "dataPieChart::dragData $this"
        dragSite::provide $($this,drag) DATACELLS "dataPieChart::dragData $this"
    }

    foreach option {-height -width} {
        proc set$option {this value} "\$widget::(\$this,path) configure $option \$value"
    }

    proc set-total {this value} {
        setTotal $this $value
    }

    proc set-totalcell {this value} {
        setTotalCell $this $value
    }

    proc dragData {this format} {
        set slices [slice::selected $($this,pie)]
        switch $format {
            OBJECTS {
                if {[llength $slices] > 0} {
                    return $slices
                } elseif {[llength $($this,slices)] == 0} {
                    return $this
                } else {
                    return {}
                }
            }
            DATACELLS {
                return [cellsFromSlices $this $slices]
            }
        }
    }

    proc validateDrag {this x y} {
        if {[llength $($this,slices)] == 0} {
            return 1
        }
        return [expr {[lsearch -exact [slice::selected $($this,pie)] [slice::current $($this,pie)]] >= 0}]
    }

    proc supportedTypes {this} {
        return $global::numericDataTypes
    }

    proc monitorCell {this array row column} {
        set cell ${array}($row,$column)
        if {[lsearch -exact [cellsFromSlices $this $($this,slices)] $cell] >= 0} return
        viewer::registerTrace $this $array
        if {[info exists ($this,nextCellIndex)]} {
            set color [lindex $composite::($this,-cellcolors) $($this,nextCellIndex)]
            if {[string length $color] == 0} {
                unset color ($this,nextCellIndex)
            } else {
                incr ($this,nextCellIndex)
            }
        }
        foreach {label incomplete} [viewer::label $array $row $column] {}
        if {![info exists color]} {set color [viewer::getDisplayColor $cell]}
        if {$global::readOnly} {
            set slice [new slice $($this,pie) {} -background $color -label $label]
        } else {
            set slice [new slice $($this,pie) $($this,colorsMenu) -background $color -label $label]
        }
        lappend ($this,slices) $slice
        switched::configure $slice -deletecommand "dataPieChart::deletedSlice $this $array $slice"
        set ($this,cell,$slice) $cell
        if {$incomplete} {
            set ($this,relabel,$slice) {}
        }
        switched::configure $($this,drop) -state normal
        $($this,menu) entryconfigure 0 -state normal
        updateMessage $this
    }

    proc update {this {array {}}} {
        set cells [cellsFromSlices $this $($this,slices)]
        set sum $composite::($this,-total)
        if {[string length $sum] == 0} {set sum 0}
        if {![catch {set cell $($this,totalCell)}]} {
            if {[catch {set sum [set $cell]}]} {
                composite::configure $($this,total) -image $viewer::(rightDarkGrayArrow) -text ?
            } else {
                composite::configure $($this,total) -image $viewer::(rightRedArrow) -text $sum
                if {[info exists ($this,relabelTip)]} {updateTip $this}
                if {[string equal $sum ?]} {set sum 0}
            }
        }
        set sum [expr {double($sum)}]
        if {$sum == 0} {
            foreach cell $cells {
                if {[catch {set value [set $cell]}] || [string equal $value ?] || ![string is double -strict $value]} {
                    continue
                }
                set sum [expr {$sum + abs($value)}]
            }
        }
        foreach slice $($this,slices) cell $cells {
            if {[catch {set value [set $cell]}] || [string equal $value ?] || ($sum == 0)} {
                slice::update $slice 0 ?
            } else {
                if {[string is double -strict $value]} {
                    set value [expr {abs($value) / $sum}]
                    slice::update $slice $value "[format %.1f [expr {$value * 100}]] %"
                } else {
                    slice::update $slice 0 $value
                }
            }
            if {[info exists ($this,relabel,$slice)] && [info exists $cell]} {
                viewer::parse $cell array row column type
                foreach {label incomplete} [viewer::label $array $row $column] {}
                switched::configure $slice -label $label
                if {!$incomplete} {
                    unset ($this,relabel,$slice)
                }
            }
        }
        pie::update $($this,pie)
    }

    proc deletedSlice {this array slice} {
        viewer::unregisterTrace $this $array
        ldelete ($this,slices) $slice
        viewer::returnDisplayColor $($this,cell,$slice)
        unset ($this,cell,$slice)
        if {[llength $($this,slices)] == 0} {
            composite::configure $this -total {} -totalcell {}
            switched::configure $($this,drop) -state disabled
            $($this,menu) entryconfigure 0 -state disabled
        }
        updateMessage $this
    }

    proc cellsFromSlices {this slices} {
        set cells {}
        foreach slice $slices {
            lappend cells $($this,cell,$slice)
        }
        return $cells
    }

    proc cells {this} {
        return [cellsFromSlices $this $($this,slices)]
    }

    proc setCellColor {this cell color} {
        foreach slice $($this,slices) {
            if {[string equal $($this,cell,$slice) $cell]} {
                switched::configure $slice -labelbackground $color
                return
            }
        }
    }

    proc monitored {this cell} {
        foreach slice $($this,slices) {
            if {[string equal $($this,cell,$slice) $cell]} {
                return 1
            }
        }
        return 0
    }

    proc updateMessage {this} {
        if {[catch {classof $this}]} return
        if {[llength $($this,slices)] == 0} {
            centerMessage $widget::($this,path) [message $this] $widget::option(canvas,background) $global::viewerMessageColor
        } else {
            centerMessage $widget::($this,path) {}
        }
    }

    virtual proc message {this}

    proc setTotal {this value} {
        if {([string length $value] == 0) || ($value == 0)} {
            composite::configure $($this,total) -text {} -image {}
        } else {
            composite::configure $this -totalcell {}
            composite::configure $($this,total) -text $value -image $viewer::(rightRedArrow)
        }
        if {[info exists ($this,pie)]} {
            update $this
            updateTip $this
        }
    }

    proc totalCellDrop {this} {
        if {[llength $dragSite::data(DATACELLS)] != 1} {
            lifoLabel::flash $global::messenger [mc {only one data cell can be used for total value}]
            bell
            return
        }
        set cell [lindex $dragSite::data(DATACELLS) 0]
        viewer::parse $cell ignore ignore ignore type
        if {[lsearch -exact [supportedTypes $this] $type] < 0} {
            viewer::wrongTypeMessage $type
        } else {
            composite::configure $this -totalcell $cell
        }
    }

    proc setTotalCell {this cell} {
        if {[info exists ($this,totalCell)]} {
            viewer::parse $($this,totalCell) array ignore ignore ignore
            viewer::unregisterTrace $this $array
            unset ($this,totalCell)
        }
        composite::configure $($this,total) -text {} -image {}
        if {[string length $cell] == 0} {
            set array {}
        } else {
            viewer::parse $cell array ignore ignore ignore
            viewer::registerTrace $this $array
            set ($this,totalCell) $cell
        }
        if {[info exists ($this,pie)]} {
            update $this $array
            updateTip $this
        }
    }

    proc dropRegion {this} {
        set X [winfo rootx $widget::($this,path)]; set Y [winfo rooty $widget::($this,path)]
        return [list $X $Y [expr {$X + $viewer::(limitAreaWidth)}] [expr {$Y + $viewer::(limitAreaHeight)}]]
    }

    proc initializationConfiguration {this} {
        set colors {}
        foreach slice $($this,slices) {
            lappend colors [switched::cget $slice -background]
        }
        return [list -total $composite::($this,-total) -totalcell $composite::($this,-totalcell) -cellcolors $colors]
    }

    proc totalEntered {this value} {
        if {[string length $value] == 0} {
            composite::configure $this -totalcell {}
        }
        composite::configure $this -total $value
    }

    proc updateTip {this} {
        if {[info exists ($this,totalCell)]} {
            viewer::parse $($this,totalCell) array row column type
            foreach {label incomplete} [viewer::label $array $row $column] {}
            if {$incomplete} {
                set ($this,relabelTip) {}
            } else {
                catch {unset ($this,relabelTip)}
            }
            set text [format [mc {total cell: %s}] $label]
        } elseif {[string length $composite::($this,-total)] > 0} {
            set text [format [mc {fixed total value set to %s}] $composite::($this,-total)]
        } else {
            set text [mc {set fixed total value or drop cell as dynamic total value here}]
        }
        foreach tip $($this,tips) {switched::configure $tip -text $text}
    }

    proc updateLabels {this} {
        foreach slice $($this,slices) {
            viewer::parse $($this,cell,$slice) array ignore ignore ignore
            set ($this,relabel,$slice) {}
            set update($array) {}
        }
        foreach array [array names update] {
            update $this $array
        }
        if {[info exists ($this,totalCell)]} {
            updateTip $this
        }
    }

}

class dataPieChart {

    class slice {

        proc slice {this pie colorsMenu args} switched {$args} {
            set ($this,pie) $pie
            set slice [pie::newSlice $pie]
            set ($this,slice) $slice
            set (this,$slice) $this
            if {[string length $colorsMenu] > 0} {
                $pie::($pie,canvas) bind [pie::sliceLabelTag $pie $slice] <ButtonPress-3>                    "set dataPieChart::slice::(clicked) $this; tk_popup $colorsMenu %X %Y"
            }
            switched::complete $this
        }

        proc ~slice {this} {
            pie::deleteSlice $($this,pie) $($this,slice)
            unset (this,$($this,slice))
            if {[string length $switched::($this,-deletecommand)] > 0} {
                uplevel #0 $switched::($this,-deletecommand)
            }
        }

        proc options {this} {
            return [list                [list -background {} {}]                [list -deletecommand {} {}]                [list -label {} {}]                [list -labelbackground {} {}]            ]
        }

        proc set-deletecommand {this value} {}

        proc set-label {this value} {
            pie::labelSlice $($this,pie) $($this,slice) $value
        }

        proc set-labelbackground {this value} {
            pie::setSliceLabelBackground $($this,pie) $($this,slice) $value
        }

        proc set-background {this value} {
            pie::setSliceBackground $($this,pie) $($this,slice) $value
        }

        proc update {this value string} {
            pie::sizeSlice $($this,pie) $($this,slice) $value $string
        }

        proc selected {pie} {
            set list {}
            foreach slice [pie::selectedSlices $pie] {
                lappend list $(this,$slice)
            }
            return $list
        }

        proc current {pie} {
            set slice [pie::currentSlice $pie]
            if {$slice == 0} {
                return 0
            } else {
                return $(this,$slice)
            }
        }

    }

}

class data2DPieChart {

    proc data2DPieChart {this parentPath args} dataPieChart {
        $parentPath 0 -width $global::viewerWidth -height $global::viewerHeight $args
    } {}

    proc ~data2DPieChart {this} {}

    proc iconData {} {
        return {
            R0lGODdhJAAkAKUAAPj4+Hh4eDBgIHBIAKDwePDYSJjwcOjQQJjocODIQJDgcODIOJDgaODAOIjgaNjAOIjYaNi4MIjYYNCwMIDQYMioKEBIQHjIWBBgeKjQ
            4HjAWKDI2HDAWJjI0HDAUJDA0HC4UIi4yPj8+Gi4UIC4yAAAAGiwUHiwwHh8eGiwSHCouICEgGCoSGiouIiQiGCgsJCYkGiguFiYsKCkoFiYqKisqLi8uMDE
            wMjQyNDY0ODk4Ojs6AAAAAAAAAAAAAAAACwAAAAAJAAkAAAG/kCAcCgMEI/G4zBZVBKZSijy6VxWAVKqFRvoer9dgVgwKIPP4GpSTGgLCvBCebpViw14vODA
            78+bdU4CCISFCHt9iQOAgGiDhoUCCZOUlANoXUoCCpydnQILoaKjl1pHAgypqqsCDa6vsA2LgUMCDre4uQIPvL2+D7ONXgIQxcbHEAIRy8zNy5dptRLT1NUS
            AhPZ2tvZwVICFOHi4+HY3OcTs9/k7BQCFfDx8vHqRWHt5O/z+xUDFl+1LggcSFAgmTIIEyY08q2gwwsYMkicSHEiBoanNGjcyFEDhg0gQ4oUeRGLvQACOKhc
            yZIDhg4wY8qUieGfFyICPOjcuRPD3IefQIMGvYjxFIijSJFiCMG0qVOnF0WY1DSiqtURGEho3cqVK1GpSUqIFSvAhNmzJjCcWMu2bVsMY+OimEtXQIq7eDGo
            2Mu3L18MdAOjWEG48AoBLBKzwNCisePHjgEPNkzYheXLlhEnxvCis+fPnSVjxgyjtGnTYjDEkMG6tWsMkk/LnkG7tu0ZsGno3q0bNt3bt2sIH05cOArYyJHT
            Lc68ho3n0KNHF0xXunXoN7Jr3869u/fvOMKLH0++vPnzOdKrX8++vfv3OuLLn0+/vv37O/Lr38+/v///QQAAOw==
        }
    }

    proc message {this} {
        return [mc "2D pie chart:\ndrop data cell(s)"]
    }

}

class data3DPieChart {

    proc data3DPieChart {this parentPath args} dataPieChart {
        $parentPath 20 -width $global::viewerWidth -height $global::viewerHeight $args
    } {}

    proc ~data3DPieChart {this} {}

    proc iconData {} {
        return {
            R0lGODdhJAAkAKUAAPj8+Hh4eDBgIHBIAKD0ePDcSJjwcOjUQJjscODMQJDocODIOJDkaNjAOIjgaNi8MIjcaNC0MIjYYNCwKIDUYMioKIDQYHh8eHjMWBBg
            eKjU4HjIWJjM2EBIQHjEWJDE0HDAUIjAyHC8UIC4yDh8KGi4UHi0wDB4kGi0SHCsuGCwSGiouGCoSGCsSGCgsAAAAFiYqICEgIiQiJCYkKCkoKisqLi8uMDE
            wMjQyNDY0ODk4Ojs6AAAAAAAAAAAAAAAACwAAAAAJAAkAAAG/kCAcCgMEI/G4zBZVBKZSijy6VxWAVKqFRvoer9dgVgwKA/A6G/VOCa4BYV4waxtXsWGvF5w
            6PsPZXaCSgIIhoeGAgmLjIwDWFpoAgqUlZUCC5mam2dpRwIMoaKjAg2mp6gNj1tEAg6vsLEOAg+1tre1q5CfEL2+vxACEcPExcO6SV4CEszNzswCE9LT1NOd
            XkMCFNvc3dsCFeHi4+KrUgIW6err6WRm7/ADF7vZGPb3+PYZGvz9/v0Z5iULs6GgwYMbMnBYyLBhwwwd1AgR4KGixYseMnzYyLFjxwxGzoEYSbIkiAwhUqpc
            uRIkvYkCRMicOTPDiJs4c+bM4HJg7AABJASUGEp0aAYTSJMqTZrhBESJAIAGRUG1KooMKbJq3Zq1qdOQn0iIFaCirNkMK9KqXbvC69eXE8UGZdGibgYXePPq
            deEWpEAhLwK/kDpWDIsMMBIrhsGT54nHTgULvkCZMmG5AhprdgvZaeXPMUKLviyWc+fTAS+IFi2jtWsZYuSSMH36cerXrmfo3q07dunanXlS5s2bhvHjyMfQ
            diqcMvLnNaJLnx79wubGn6lrt8G9u3fvnz9/H9/9hvnz6NOrX88eh/v38OPLn08/h/37+PPr389fh///AAYo4IAE7mDggQgmqOCCDAYBADs=
        }
    }

    proc message {this} {
        return [mc "3D pie chart:\ndrop data cell(s)"]
    }

}



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

    }


}



namespace eval formulas {

    class dialog {

        set (geometry) 500x480
        set (separator) 0

        proc dialog {this args} switched {$args} viewer {} {
            set dialog [::new dialogBox .                -buttons hoc -default o -title [mc {moodss: Formulas}] -otherbuttons {new test delete}                -helpcommand {generalHelpWindow #viewers.formulas} -x [winfo pointerx .] -y [winfo pointery .]                -grab release -enterreturn 0 -command "formulas::dialog::validated $this" -deletecommand "delete $this"            ]
            lappend ($this,objects) [linkedHelpWidgetTip $composite::($dialog,help,path)]
            composite::configure $dialog new -text [mc New] -command "formulas::dialog::new $this"
            set button $composite::($dialog,new,path)
            lappend ($this,objects) [::new widgetTip -path $button -text [mc {create a new empty formula}]]
            foreach {string underline} [underlineAmpersand [mc &Test]] {}
            composite::configure $dialog test -text $string -underline $underline -command "formulas::dialog::test $this"                -state disabled
            set button $composite::($dialog,test,path)
            lappend ($this,objects) [::new widgetTip -path $button -text [mc {test formula with current cell values}]]
            set ($this,testButton) $button
            foreach {string underline} [underlineAmpersand [mc &Delete]] {}
            composite::configure $dialog delete -text $string -underline $underline -command "formulas::dialog::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
            wm geometry $widget::($dialog,path) $(geometry)
            bind $widget::($dialog,path) <Configure> "set formulas::dialog::(geometry) \[wm geometry $widget::($dialog,path)\]"
            set frame [frame $widget::($dialog,path).frame]
            set header [frame $frame.header]
            grid columnconfigure $header 1 -weight 1
            grid columnconfigure $header 3 -weight 2
            grid $header -row 0 -column 0 -columnspan 2 -sticky ew
            set table [createTable $this $frame]
            set ($this,formulasDrop) [::new dropSite                -path $selectTable::($table,tablePath) -formats FORMULAS -command "formulas::dialog::handleDrop $this"            ]
            grid $widget::($table,path) -row 1 -column 0 -columnspan 2 -sticky nsew
            set ($this,commentLabel) [label $frame.commentLabel -font $font::(mediumBold) -text [mc Comment:] -state disabled]
            grid $($this,commentLabel) -row 2 -column 0 -sticky nw
            set comment [::new scroll text $frame -height 100]
            lappend ($this,objects) $comment
            set ($this,commentText) $composite::($comment,scrolled,path)
            $($this,commentText) configure -state disabled -background white -font $font::(mediumNormal) -wrap word
            setupTextBindings $($this,commentText)
            grid $widget::($comment,path) -row 2 -column 1 -columnspan 2 -sticky nsew
            set formula [createExpressionEntry $this $frame]
            grid $formula -row 3 -column 0 -columnspan 100 -sticky nsew
            set ($this,drop) [::new dropSite                 -path $($this,expressionText) -formats DATACELLS -command "formulas::dialog::handleDrop $this" -state disabled            ]
            grid rowconfigure $frame 1 -weight 3
            grid rowconfigure $frame 2 -weight 1
            grid columnconfigure $frame 1 -weight 1
            set ($this,table) $table
            set ($this,dialog) $dialog
            switched::complete $this
            if {$switched::($this,-initial)} {set widget entry} else {set widget label}
            grid [label $header.objectLabel -font $font::(mediumBold) -text [mc Object:]] -row 0 -column 0
            grid [$widget $header.objectEntry -textvariable formulas::dialog::($this,object)] -row 0 -column 1 -sticky ew
            grid [label $header.categoryLabel -font $font::(mediumBold) -text [mc Category:]] -row 0 -column 2
            grid [$widget $header.categoryEntry -textvariable formulas::dialog::($this,category)] -row 0 -column 3 -sticky ew
            if {!$switched::($this,-initial)} {
                $header.objectEntry configure -anchor w
                $header.categoryEntry configure -anchor w
            }
            dialogBox::display $dialog $frame
            foreach formula $switched::($this,-formulas) {
                set copy [::new $formula]; switched::configure $copy -deletecommand {}
                display $this $copy $formula
                foreach array [arrays $formula] {set arrays($array) {}}
            }
            selectTable::refreshBorders $table
            selectTable::adjustTableColumns $table
            foreach array [array names arrays] {
                update $this $array
            }
        }

        proc ~dialog {this} {
            variable ${this}data
            variable number
            variable ${this}registered

            foreach {name formula} [array get ${this}data "\[0-9\]*,$number(formula)"] {
                ::delete $formula
            }
            eval ::delete $($this,table) $($this,objects) $($this,drop) $($this,formulasDrop)
            catch {unset ${this}data}
            catch {unset ${this}registered}
            if {[string length $switched::($this,-deletecommand)] > 0} {
                uplevel #0 $switched::($this,-deletecommand)
            }
        }

        proc options {this} {
            return [list                [list -category {}]                [list -command {} {}]                [list -deletecommand {} {}]                [list -formulas {} {}]                [list -initial 1 1]                [list -object {}]            ]
        }

        proc set-command {this value} {}

        proc set-deletecommand {this value} {}

        proc set-formulas {this value} {
            if {$switched::($this,complete)} {
                error {option -formulas cannot be set dynamically}
            }
        }

        proc set-initial {this value} {
            if {$switched::($this,complete)} {
                error {option -initial cannot be set dynamically}
            }
        }

        proc set-object {this value} {
            if {$switched::($this,complete)} {
                error {option -object cannot be set dynamically}
            }
            set ($this,object) $value
        }

        proc set-category {this value} {
            if {$switched::($this,complete)} {
                error {option -category cannot be set dynamically}
            }
            set ($this,category) $value
        }

        proc raise {this} {
            ::raise $widget::($($this,dialog),path)
        }

        proc createTable {this parentPath} {
            variable ${this}data
            variable number

            set titles [list name formula input value]
            if {![info exists help]} {
                set help(name) [mc {formula name (editable)}]
                set help(value) [mc {formula value (forcibly updated when tested)}]
                set column 0
                foreach title $titles {
                    set number($title) $column
                    incr column
                }
                set (hiddenColumns) [expr {$number(value) - $number(name) - 1}]
            }
            set column 0
            foreach title $titles {
                set ${this}data(-1,$column) $title
                incr column
            }
            set table [::new selectTable $parentPath -titlerows 1 -roworigin -1 -columns [llength $titles]                -selectcommand "formulas::dialog::selected $this" -followfocus 0 -variable formulas::dialog::${this}data            ]
            set path $selectTable::($table,tablePath)
            foreach {cell title} [array get ${this}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)]
            }
            selectTable::spans $table -1,$number(name) 0,$(hiddenColumns)
            return $table
        }

        proc createExpressionEntry {this parentPath} {
            set panes [::new panner $parentPath -panes 2]
            set ($this,expressionLabel)                [label $panner::($panes,frame1).label -font $font::(mediumBold) -text [mc Expression:] -state disabled]
            pack $($this,expressionLabel) -anchor nw
            lappend ($this,objects) $panes
            set expression [::new scroll text $panner::($panes,frame1) -height 80]
            lappend ($this,objects) $expression
            set ($this,expressionText) $composite::($expression,scrolled,path)
            $($this,expressionText) configure -state disabled -background white -font $font::(fixedNormal)
            setupTextBindings $($this,expressionText)
            pack $widget::($expression,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 test [::new scroll text $panner::($panes,frame2) -height 120]
            lappend ($this,objects) $test
            set text $composite::($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::($test,path) -fill both -expand 1
            return $widget::($panes,path)
        }

        proc validated {this} {
            variable ${this}data
            variable number

            if {[string length $switched::($this,-command)] == 0} return
            if {[info exists ($this,selected)]} {
                synchronize $this [set ${this}data($($this,selected),$number(formula))]
            }
            set list {}
            foreach {name formula} [array get ${this}data "\[0-9\]*,$number(formula)"] {
                scan $name %u row
                set input [set ${this}data($row,$number(input))]
                if {$input == 0} {
                    lappend list [::new $formula]
                } else {
                    formulas::formula::copyOptions $input $formula
                    lappend list $input
                }
            }
            uplevel #0 $switched::($this,-command)                [list [string trim $($this,object)] [string trim $($this,category)] [lsort -integer $list]]
        }

        proc selected {this row} {
            variable ${this}data
            variable number

            set topPath $widget::($($this,dialog),path)
            catch {set selection [selection get]}
            if {[info exists ($this,selected)]} {
                set selected $($this,selected)
                synchronize $this [set formula [set ${this}data($selected,$number(formula))]]
                set value ?; catch {set value [formulas::formula::value $formula]}
                set ${this}data($selected,$number(value)) $value
            }
            set ($this,selected) $row
            set formula [set ${this}data($row,$number(formula))]
            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,commentLabel) configure -state normal
            $($this,commentText) configure -state normal
            $($this,commentText) delete 1.0 end
            $($this,commentText) insert 1.0 [switched::cget $formula -commenttext]
            $($this,expressionLabel) configure -state normal
            updateFormulaText $this $formula
            $($this,testLabel) configure -state normal
            $($this,testText) configure -state normal
            $($this,testText) delete 1.0 end
            $($this,testText) configure -state disabled
            switched::configure $($this,drop) -state normal
            if {[info exists selection]} {
                clipboard clear
                clipboard append $selection
            }
            return 1
        }

        proc deselect {this row} {
            set topPath $widget::($($this,dialog),path)
            unset ($this,selected)
            $($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> {}
            switched::configure $($this,drop) -state disabled
            $($this,commentLabel) configure -state disabled
            $($this,commentText) delete 1.0 end
            $($this,commentText) configure -state disabled
            $($this,expressionLabel) configure -state disabled
            $($this,expressionText) delete 1.0 end
            $($this,expressionText) configure -state disabled
            $($this,testLabel) configure -state disabled
            $($this,testText) configure -state normal
            $($this,testText) delete 1.0 end
            $($this,testText) configure -state disabled
        }

        proc new {this} {
            set table $($this,table)
            set formula [::new formulas::formula]
            set row [display $this $formula]
            selectTable::refreshBorders $table
            selectTable::adjustTableColumns $table
            after idle "selectTable::select $table $row"
        }

        proc display {this formula {input 0}} {
            variable ${this}data
            variable number

            set table $($this,table)
            set row [selectTable::rows $table]
            selectTable::rows $table [expr {$row + 1}]
            set ${this}data($row,$number(formula)) $formula
            set ${this}data($row,$number(input)) $input
            selectTable::spans $table $row,$number(name) 0,$(hiddenColumns)
            set ${this}data($row,$number(name)) [switched::cget $formula -name]
            set cell $row,$number(name)
            set path $selectTable::($table,tablePath)
            set entry $path.$formula,name
            entry $entry -font $font::(mediumNormal) -textvariable formulas::dialog::${this}data($cell) -borderwidth 0                -highlightthickness 0 -width 40
            bind $entry <FocusIn> "selectTable::select $table $row"
            selectTable::windowConfigure $table $cell -window $entry -padx 1 -pady 1 -sticky nsew
            set value ?
            if {[llength [switched::cget $formula -cells]] == 0} {
               catch {set value [formulas::formula::value $formula]}
            }
            set ${this}data($row,$number(value)) $value
            updateRegistration $this
            return $row
        }

        proc delete {this} {
            variable ${this}data
            variable number

            set table $($this,table)
            set row $($this,selected)
            deselect $this $row
            set formula [set ${this}data($row,$number(formula))]
            selectTable::delete $table $row
            ::delete $formula
            set rows [selectTable::rows $table]
            set path $selectTable::($table,tablePath)
            for {} {$row < $rows} {incr row} {
                set formula [set ${this}data($row,$number(formula))]
                set entry $path.$formula,name
                $entry configure -textvariable formulas::dialog::${this}data($row,$number(name))
                bind $entry <FocusIn> "selectTable::select $table $row"
            }
            array unset ${this}data $rows,\[0-9\]*
            selectTable::clear $table
            selectTable::refreshBorders $table
            selectTable::adjustTableColumns $table
        }

        proc test {this} {
            variable ${this}data
            variable number

            set row $($this,selected)
            set formula [set ${this}data($row,$number(formula))]
            synchronize $this $formula
            if {[catch {set value [formulas::formula::value $formula]} message]} {
                set value ?
                set message "[mc error:] $message"
            } else {
                set message "[mc result:] $value"
            }
            set ${this}data($row,$number(value)) $value
            set text $($this,testText)
            $text configure -state normal
            $text insert end \n$message\n
            $text window create end -window [frame $text.separator$(separator)                -relief sunken -borderwidth 1 -height 2 -width [expr {[winfo width $text] - $global::separatorCut}]            ]
            incr (separator)
            $text see end
            $text configure -state disabled
        }

        proc handleDrop {this} {
            variable ${this}data
            variable number

            if {![catch {set data $dragSite::data(FORMULAS)}]} {
                set selected [selectedFormula $this]
                set formulas {}
                foreach {name formula} [array get ${this}data "\[0-9\]*,$number(formula)"] {
                    if {$formula == $selected} {
                        synchronize $this [set formula [set temporary [::new $formula]]]
                    }
                    lappend formulas $formula
                }
                foreach formula $data {
                    set identical 0
                    foreach existing $formulas {
                        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
                    }
                    set copy [::new $formula]; switched::configure $copy -deletecommand {}
                    display $this $copy
                    foreach array [arrays $formula] {set arrays($array) {}}
                }
                if {[info exists temporary]} {::delete $temporary}
                selectTable::refreshBorders $($this,table)
                selectTable::adjustTableColumns $($this,table)
                if {[info exists arrays]} {
                    foreach array [array names arrays] {
                        update $this $array
                    }
                    updateRegistration $this
                }
            } elseif {![catch {set data $dragSite::data(DATACELLS)}]} {
                set path $($this,expressionText)
                set background [$path cget -background]
                foreach cell $data {
                    set label [::new label $path -background $background -cell $cell]
                    switched::configure $label -deletecommand "formulas::dialog::deletedLabel $this $label"
                    $path window create insert -window $label::($label,path)
                    label::update $label
                }
                focus $path
                updateRegistration $this
            }
        }

        proc synchronize {this formula} {
            variable ${this}data
            variable number

            set row $($this,selected)
            set text {}; set cells {}; set indexes {}
            foreach {key value index} [$($this,expressionText) dump 1.0 end] {
                switch $key {
                    text {
                        append text $value
                    }
                    window {
                        append text $
                        set label [label::labelFromPath $value]
                        if {$label > 0} {
                            lappend cells [switched::cget $label -cell]
                            lappend indexes $index
                        }
                    }
                }
            }
            set name [set ${this}data($row,$number(name))]
            set comment [string trim [$($this,commentText) get 1.0 end]]
            switched::configure $formula -cells $cells -cellindexes $indexes -commenttext $comment                -text [string trimright $text] -name [string trim $name]
        }

        proc updateFormulaText {this formula} {
            set path $($this,expressionText)
            $path configure -state normal
            $path delete 1.0 end
            $path insert 1.0 [switched::cget $formula -text]
            set background [$path cget -background]
            foreach cell [switched::cget $formula -cells] index [switched::cget $formula -cellindexes] {
                set label [::new label $path -background $background -cell $cell]
                switched::configure $label -deletecommand "formulas::dialog::deletedLabel $this $label"
                $path delete $index
                $path window create $index -window $label::($label,path)
                label::update $label
            }
        }

        proc deletedLabel {this label} {}

        proc arrays {formula} {
            foreach cell [switched::cget $formula -cells] {
                viewer::parse $cell array ignore ignore ignore
                set arrays($array) {}
            }
            return [array names arrays]
        }

        proc selectedFormula {this} {
            variable ${this}data
            variable number

            if {[info exists ($this,selected)]} {
                return [set ${this}data($($this,selected),$number(formula))]
            } else {
                return 0
            }
        }

        proc updateRegistration {this} {
            variable ${this}data
            variable number
            variable ${this}registered

            set selected [selectedFormula $this]
            foreach {name formula} [array get ${this}data "\[0-9\]*,$number(formula)"] {
                if {$formula == $selected} {
                    set arrays {}
                    foreach {key path index} [$($this,expressionText) dump -window 1.0 end] {
                        set label [label::labelFromPath $path]
                        if {$label > 0} {
                            viewer::parse [switched::cget $label -cell] array ignore ignore ignore
                            lappend arrays $array
                        }
                    }
                } else {
                    set arrays [arrays $formula]
                }
                foreach array $arrays {set current($array) {}}
            }
            foreach array [array names ${this}registered] {
                if {![info exists current($array)]} {
                    viewer::unregisterTrace $this $array
                    unset ${this}registered($array)
                }
            }
            foreach array [array names current] {
                if {![info exists ${this}registered($array)]} {
                    viewer::registerTrace $this $array
                    set ${this}registered($array) {}
                }
            }
        }


        proc update {this array} {
            variable ${this}data
            variable number

            set selected [selectedFormula $this]
            foreach {name formula} [array get ${this}data "\[0-9\]*,$number(formula)"] {
                scan $name %u row
                set value ?
                if {$formula == $selected} {
                    foreach {key path index} [$($this,expressionText) dump -window 1.0 end] {
                        set label [label::labelFromPath $path]
                        if {$label > 0} {label::update $label}
                    }
                    set temporary [::new $formula]
                    synchronize $this $temporary
                    catch {set value [formulas::formula::value $temporary]}
                    ::delete $temporary
                } else {
                    catch {set value [formulas::formula::value $formula]}
                }
                set ${this}data($row,$number(value)) $value
            }
        }

        proc cells {this} {
            return {}
        }

        proc manageable {this} {return 0}

        proc saved {this} {return 0}


        proc select {this formula} {
            variable ${this}data
            variable number

            if {$formula == [selectedFormula $this]} return
            foreach {name value} [array get ${this}data "\[0-9\]*,$number(input)"] {
                if {$value == $formula} {
                    scan $name %u row
                    selectTable::select $($this,table) $row
                    return
                }
            }
        }

    }


}



namespace eval formulas {


    class dialog {

        class label {

            proc label {this parentPath args} switched {$args} {
                set label [::label $parentPath.label$this                    -relief sunken -font $font::(mediumBold) -padx 0 -pady 0 -borderwidth 1 -cursor left_ptr                ]
                bind $label <Destroy> "delete $this"
                set ($this,path) $label
                switched::complete $this
            }

            proc ~label {this} {
                bind $($this,path) <Destroy> {}
                catch {delete $($this,tip)}
                if {[string length $switched::($this,-deletecommand)] > 0} {
                    uplevel #0 $switched::($this,-deletecommand)
                }
            }

            proc options {this} {
                return [list                    [list -background $widget::option(label,background) $widget::option(label,background)]                    [list -cell {} {}]                    [list -deletecommand {} {}]                ]
            }

            proc set-background {this value} {
                $($this,path) configure -background $value
            }

            proc set-cell {this value} {
                catch {delete $($this,tip)}
                if {[string length $value] == 0} return
                viewer::parse $value array row column ignore
                set ($this,tip) [new widgetTip -path $($this,path) -text [lindex [viewer::label $array $row $column] 0]]
            }

            proc set-deletecommand {this value} {}

            proc labelFromPath {path} {
                if {                    [scan [lindex [split $path .] end] label%u label] &&                    ![catch {set class [classof $label]}] && [string equal $class ::formulas::dialog::label]                } {
                    return $label
                } else {
                    return 0
                }
            }

            proc update {this} {
                set cell $switched::($this,-cell)
                if {[string length $cell] == 0} {
                    $($this,path) configure -text {}
                    return
                }
                if {[info exists $cell]} {
                    $($this,path) configure -text [set $cell]
                } else {
                    $($this,path) configure -text ?
                }

            }

        }

    }

}



class freeText {

    proc freeText {this parentPath args} composite {
        [new text $parentPath            -background $viewer::(background) -font $font::(mediumNormal) -wrap word -borderwidth 0 -highlightthickness 0        ] $args
    } viewer {} {
        set path $widget::($this,path)
        setupTextBindings $path
        viewer::setupDropSite $this $path
        set ($this,labels) {}
        $path tag configure bold -font $font::(mediumBold)
        $path tag configure italic -font $font::(mediumItalic)
        $path tag configure bolditalic -font $font::(mediumBoldItalic)
        $path tag configure underline -underline 1
        $path tag configure overstrike -overstrike 1
        if {$global::readOnly} {
            $path configure -state disabled
        } else {
            set bindings [new bindings $path 0]
            bindings::set $bindings <Control-b>                "catch {$path tag add bold sel.first sel.last; freeText::mergeBoldItalic $path}; break"
            bindings::set $bindings <Control-i>                "catch {$path tag add italic sel.first sel.last; freeText::mergeBoldItalic $path}; break"
            bindings::set $bindings <Control-o> "catch {$path tag add overstrike sel.first sel.last}; break"
            bindings::set $bindings <Control-u> "catch {$path tag add underline sel.first sel.last}; break"
            bindings::set $bindings <Control-r> "
                catch {foreach name {bold italic bolditalic overstrike underline} {$path tag remove \$name sel.first sel.last}}
                break
            "
            set ($this,bindings) $bindings
            set ($this,tip) [new widgetTip -path $path -text                [mc "selection formatting Control keys:\nB(old), I(talic), U(nderline), O(verstrike), R(eset)"]            ]
        }
        composite::complete $this
        initializeTags $this
        if {[string length $composite::($this,-endtext)] == 0} {
            centerMessage $path [mc "free text:\ndrop data cell(s), input text"] $viewer::(background) $global::viewerMessageColor
            set ($this,event) [after 2000 "centerMessage $path {}; unset freeText::($this,event)"]
        }
    }

    proc ~freeText {this} {
        catch {after cancel $($this,event)}
        if {[info exists ($this,bindings)]} {
            delete $($this,bindings) $($this,tip)
        }
        if {[info exists ($this,drag)]} {
            delete $($this,drag)
        }
        eval delete $($this,labels)
        if {[info exists ($this,selector)]} {
            delete $($this,selector)
        }
        if {[string length $composite::($this,-deletecommand)] > 0} {
            uplevel #0 $composite::($this,-deletecommand)
        }
    }

    proc iconData {} {
        return {
            R0lGODlhJAAkAMYAAAAAAAEBAQICAgMDAwQEBAUFBQYGBgcHBwgICAkJCQoKCgwMDA0NDQ4PDg8QDxAQEBISEhMTExUWFRgYGBobGh4fHiAhICIjIiMjIyYn
            JigpKC8vLy8wLzAxMDIzMjM0MzY3Njg4ODo8Oj4/Pj9AP0BBQENEQ0VHRUZIRk5PTk9QT1lbWVpbWmZoZnBycHJ0cnZ4dnh4eHd5d3h8eHt9e3x+fH2AfYCE
            gIKEgoaIhoeJh4iKiIiLiImMiYuNi4iQiI2PjY6RjpCTkJGUkZCYkJOWk5aZlpmcmZyfnJ6hnqCkoKSnpKisqKmtqa6yrrG0sbi8uLm8ubzAvMDEwMXIxcbK
            xsjQyMzQzM/Tz9DU0NHV0dLW0tDY0NPX09ba1tfb19jc2ODk4Ojs6Pj8+AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
            AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAJAAkAAAH/oBjgoOCMYSHhoeDiYWKhIyKkIiPjoMzlWOXlZqNYzExM6Gio6SlpqKf
            kpaYnIqtqoSth7KxlIcAuLm6u7y8nZ+hAJjDigCjkMLEymPJtMnLw83F0MQAhonAM8/FBtAAIaOE27fdy9ae05UA5crnqsJUKRACDidSzAYyCw8ugzkWAya8
            EOSukChhIwBIMJEBQAdmAAhwGABgx5ghABKUiADABjNwoZCNUYEiCpgqABBABAKGBwAOYzwAMDLmyQCYBW8JKsICRIN1zAJ0AaMFwIExC8YxuzZtBQARNZIA
            BSAUzJYA3ZIWY+rp4BgGAK6AWTIVQBAwPQBsGLMBgJAxrk4GfPiIStyYCwAwkFAQESKBDhSBjPFhtAQEADqWotPZRIOADEfAIgFQoEUCBzAG4agwgAINglzt
            UsOUc9do0rtGKT1NkNSN1zdWszYG+8aP2z9knzaG+weR30R6CR+eawZwIkqSJz/FvLlyJUyiS59Ovbr161Cya9/Ovbv371PCix9Pvrz581bSq1/Pvr3791zi
            y59Pv779+2Hy69/Pv7///2IEKOCABBZo4IGBAAA7
        }
    }

    proc options {this} {
        return [list            [list -cellindices {} {}]            [list -deletecommand {} {}]            [list -draggable 0 0]            [list -endtext {} {}]            [list -height 3]            [list -taginformation {} {}]            [list -width 40]        ]
    }

    proc set-cellindices {this value} {
        if {$composite::($this,complete)} {
            error {option -cellindices cannot be set dynamically}
        }
        set ($this,nextCellIndex) 0
    }

    proc set-endtext {this value} {
        set path $widget::($this,path)
        set state [$path cget -state]
        $path configure -state normal
        $path insert end $value
        $path configure -state $state
    }

    proc set-deletecommand {this value} {}

    proc set-draggable {this value} {
        if {$composite::($this,complete)} {
            error {option -draggable cannot be set dynamically}
        }
        if {!$value} return
        set ($this,drag) [new dragSite -path $widget::($this,path) -validcommand "freeText::validateDrag $this 0"]
        dragSite::provide $($this,drag) OBJECTS "freeText::dragData $this"
        set ($this,selector) [new selector -selectcommand "freeText::setLabelsState $this"]
    }

    foreach option {-height -width} {
        proc set$option {this value} "\$widget::(\$this,path) configure $option \$value"
    }

    proc set-taginformation {this value} {}

    proc initializeTags {this} {
        set path $widget::($this,path)
        foreach {action tag index} $composite::($this,-taginformation) {
            switch $action {
                tagon {
                    set first($tag) $index
                }
                tagoff {
                    if {[info exists first($tag)]} {
                        $path tag add $tag $first($tag) $index
                        unset first($tag)
                    }
                }
            }
        }
    }

    proc dragData {this format} {
        switch $format {
            OBJECTS {
                set list [selector::selected $($this,selector)]
                if {[llength $list] > 0} {
                    return $list
                } elseif {[empty $this]} {
                    return $this
                } else {
                    return {}
                }
            }
            DATACELLS {
                return [cellsFromLabels $this [selector::selected $($this,selector)]]
            }
        }
    }

    proc validateDrag {this label x y} {
        if {($label == 0) && [empty $this]} {
            return 1
        } elseif {[lsearch -exact [selector::selected $($this,selector)] $label] >= 0} {
            return 1
        } else {
            return 0
        }
    }

    proc supportedTypes {this} {
        return $global::dataTypes
    }

    proc monitorCell {this array row column} {
        set path $widget::($this,path)
        if {[info exists ($this,event)]} {centerMessage $path {}}
        viewer::registerTrace $this $array
        if {[info exists ($this,nextCellIndex)]} {
            set index [lindex $composite::($this,-cellindices) $($this,nextCellIndex)]
            if {[string length $index] == 0} {
                unset ($this,nextCellIndex)
                set index insert
            } else {
                incr ($this,nextCellIndex)
            }
        } else {
            set index insert
            $path insert $index "[lindex [viewer::label $array $row $column] 0]: "
        }
        set label [new label $path]
        set labelPath $label::($label,path)
        switched::configure $label -deletecommand "freeText::deletedLabel $this $array $label"
        if {$composite::($this,-draggable)} {
            set drag [new dragSite -path $labelPath -validcommand "freeText::validateDrag $this $label"]
            dragSite::provide $drag OBJECTS "freeText::dragData $this"
            dragSite::provide $drag DATACELLS "freeText::dragData $this"
            set ($this,drag,$label) $drag
            set selector $($this,selector)
            selector::add $selector $label
            bind $labelPath <ButtonPress-1> "freeText::buttonPress $selector $label"
            bind $labelPath <Control-ButtonPress-1> "selector::toggle $selector $label"
            bind $labelPath <Shift-ButtonPress-1> "freeText::extendSelection $this $label"
            bind $labelPath <ButtonRelease-1> "freeText::buttonRelease $selector $label 0"
            bind $labelPath <Control-ButtonRelease-1> "freeText::buttonRelease $selector $label 1"
            bind $labelPath <Shift-ButtonRelease-1> "freeText::buttonRelease $selector $label 1"
        }
        lappend ($this,labels) $label
        $path window create $index -window $labelPath
        set ($this,cell,$label) ${array}($row,$column)
    }

    proc update {this array} {
        foreach label $($this,labels) {
            set cell $($this,cell,$label)
            if {[string first $array $cell] != 0} continue
            if {[info exists $cell]} {
                switched::configure $label -text [set $cell]
            } else {
                switched::configure $label -text ?
            }
        }
    }

    proc deletedLabel {this array label} {
        if {$composite::($this,-draggable)} {
            delete $($this,drag,$label)
            selector::remove $($this,selector) $label
        }
        viewer::unregisterTrace $this $array
        ldelete ($this,labels) $label
        unset ($this,cell,$label)
    }

    proc cellsFromLabels {this labels} {
        set cells {}
        foreach label $labels {
            lappend cells $($this,cell,$label)
        }
        return $cells
    }

    proc cells {this} {
        return [cellsFromLabels $this $($this,labels)]
    }

    proc setLabelsState {this labels select} {
        foreach label $labels {
            label::select $label $select
        }
    }

    proc extendSelection {this endLabel} {
        set selector $($this,selector)
        if {[info exists selector::($selector,lastSelected)]} {
            foreach label $($this,labels) {
                set labelFromPath($label::($label,path)) $label
            }
            set list {}
            foreach {key path index} [$widget::($this,path) dump -window 1.0 end] {
                if {[string length $path] == 0} continue
                lappend list $labelFromPath($path)
            }
            set start [lsearch -exact $list $selector::($selector,lastSelected)]
            set end [lsearch -exact $list $endLabel]
            if {$end < $start} {
                set index $start
                set start $end
                set end $index
            }
            selector::clear $selector
            selector::set $selector [lrange $list $start $end] 1
        } else {
            selector::select $selector $endLabel
        }
    }

    proc empty {this} {
        return [expr {([llength $($this,labels)] == 0) && ([string length [string trim [$widget::($this,path) get 1.0 end]]] == 0)}]
    }

    proc initializationConfiguration {this} {
        set options {}
        set text {}
        foreach {key string index} [$widget::($this,path) dump -text 1.0 end] {
            append text $string
        }
        lappend options -endtext [string trimright $text \n]
        foreach {key path index} [$widget::($this,path) dump -window 1.0 end] {
            if {[string length $path] == 0} continue
            set position($path) $index
        }
        if {[info exists position]} {
            foreach label $($this,labels) {
                lappend indexes $position($label::($label,path))
            }
            lappend options -cellindices $indexes
        }
        set list {}
        foreach {action tag index} [$widget::($this,path) dump -tag 1.0 end] {
            if {[string equal $tag sel]} continue
            lappend list $action $tag $index
        }
        if {[llength $list] > 0} {
            lappend options -taginformation $list
        }
        return $options
    }

    proc setCellColor {this cell color} {
        foreach label $($this,labels) {
            if {[string equal $($this,cell,$label) $cell]} {
                switched::configure $label -background $color
            }
        }
    }

    proc monitored {this cell} {
        foreach label $($this,labels) {
            if {[string equal $($this,cell,$label) $cell]} {
                return 1
            }
        }
        return 0
    }

    proc mergeBoldItalic {path} {
        set end [$path index end]
        set index 1.0
        while {![string equal $index $end]} {
            set names [$path tag names $index]
            if {([lsearch -exact $names bold] >= 0) && ([lsearch -exact $names italic] >= 0)} {
                $path tag remove bold $index
                $path tag remove italic $index
                $path tag add bolditalic $index
            }
            set index [$path index $index+1c]
        }
    }

    proc buttonPress {selector label} {
        foreach selected [selector::selected $selector] {
            if {[string equal $selected $label]} return
        }
        selector::select $selector $label
    }

    proc buttonRelease {selector label extended} {
        if {$extended} return
        set list [selector::selected $selector]
        if {[llength $list] <= 1} return
        foreach selected $list {
            if {[string equal $selected $label]} {
                selector::select $selector $label
                return
            }
        }
    }

}


class freeText {

    class label {

        proc label {this parentPath args} switched {$args} {
            set label [new label $parentPath -font $font::(mediumBold) -padx 0 -pady 0 -borderwidth 1 -cursor left_ptr]
            bind $widget::($label,path) <Destroy> "delete $this"
            set ($this,path) $widget::($label,path)
            set ($this,label) $label
            switched::complete $this
        }

        proc ~label {this} {
            bind $($this,path) <Destroy> {}
            delete $($this,label)
            if {[string length $switched::($this,-deletecommand)] > 0} {
                uplevel #0 $switched::($this,-deletecommand)
            }
        }

        proc options {this} {
            return [list                [list -background {}]                [list -deletecommand {} {}]                [list -text {} {}]            ]
        }

        proc set-background {this value} {
            if {[string length $value] == 0} {
                $($this,path) configure -background $widget::option(label,background)
            } else {
                $($this,path) configure -background $value
            }
        }

        proc set-deletecommand {this value} {}

        proc set-text {this value} {
            $($this,path) configure -text $value
        }

        proc select {this select} {
            if {$select} {
                $($this,path) configure -relief sunken
            } else {
                $($this,path) configure -relief flat
            }
        }

    }

}



namespace eval images {

    proc load {name file data} {
        variable count

        if {![info exists count($name)]} {set count($name) 0}
        catch {image delete images($name)}
        if {[string length $file] == 0} {
            return [image create photo images($name) -data $data]
        } else {
            return [image create photo images($name) -file $file]
        }
    }

    proc use {name} {
        variable count

        incr count($name)
        return images($name)
    }

    proc release {name} {
        variable count

        if {[incr count($name) -1] <= 0} {
            image delete images($name)
            unset count($name)
        }
    }

    proc names {} {
        variable count

        return [lsort -dictionary [array names count]]
    }

    proc values {} {
        set list {}
        foreach name [names] {
            set data [images($name) cget -data]
            if {[string length $data] == 0} {
                set file [open [images($name) cget -file]]
                fconfigure $file -translation binary
                set data [base64::encode -maxlen 132 [read $file]]
                close $file
            }
            lappend list $name [images($name) cget -format] $data
        }
        return $list
    }

}



class canvas {


    class viewer {

        set (list) {}

        proc viewer {this parentPath tag} ::viewer {} {
            set ($this,canvas) $parentPath
            set ($this,tag) $tag
            set ($this,origin) [$parentPath create image 0 0 -tags $tag]
            viewer::setupDropSite $this $parentPath
            switched::configure $viewer::($this,drop) -regioncommand "canvas::viewer::dropRegion $this"
            lappend (list) $this
        }

        proc ~viewer {this} {
            if {[info exists ($this,menu)]} {destroy $($this,menu)}
            $($this,canvas) delete $($this,tag)
            ldelete (list) $this
        }

        proc supportedTypes {this} {
            return $global::dataTypes
        }

        proc validateDrag {canvas x y} {
            set drag $canvasWindowManager::($global::windowManager,drag)
            foreach viewer $(list) {
                if {[lsearch -exact [$canvas gettags current] $($viewer,tag)] >= 0} {
                    if {$composite::($viewer,-draggable)} {
                        dragSite::provide $drag OBJECTS "canvas::viewer::dragData $viewer"
                        if {[llength [cells $viewer]] > 0} {
                            dragSite::provide $drag DATACELLS "canvas::viewer::dragData $viewer"
                        }
                        dragSite::provide $drag CANVASVIEWER "canvas::viewer::dragData $viewer"
                        return 1
                    }
                }
            }
            return 0
        }

        proc dragData {viewer format} {
            switch $format {
                CANVASVIEWER - OBJECTS {return $viewer}
                DATACELLS {return [dragCells $viewer]}
            }
        }

        proc dropRegion {this} {
            set canvas $($this,canvas)
            foreach {left top right bottom} [$canvas cget -scrollregion] {}
            set xOffset [expr {$left + round([lindex [$canvas xview] 0] * ($right - $left))}]
            set yOffset [expr {$top + round([lindex [$canvas yview] 0] * ($bottom - $top))}]
            foreach {left top right bottom} [$canvas bbox $($this,tag)] {}
            incr left -$xOffset; incr top -$yOffset; incr right -$xOffset; incr bottom -$yOffset
            set X [winfo rootx $canvas]; set Y [winfo rooty $canvas]
            return [list [incr left $X] [incr top $Y] [incr right $X] [incr bottom $Y]]
        }

        virtual proc dragCells {this}

        virtual proc monitorCell {this array row column}

        virtual proc update {this array}

        virtual proc cells {this}

        proc manageable {this} {return 0}

        virtual proc initializationConfiguration {this} {
            return {}
        }

        virtual proc setCellColor {this cell color} {}

        virtual proc monitored {this cell}

        proc page {viewer} {
            if {[lsearch -exact $(list) $viewer] < 0} {return {}}
            return [pages::tagOrItemPage $($viewer,tag)]
        }

        proc moveAll {xMaximum} {
            foreach viewer $(list) {
                if {$composite::($viewer,-x) >= $xMaximum} {
                    composite::configure $viewer -x [expr {round($composite::($viewer,-x)) % $xMaximum}]
                }
            }
        }

        virtual proc flash {this}

        proc createPopupMenu {this} {
            set ($this,menu) [menu $($this,canvas).menu$this -tearoff 0]
            $($this,canvas) bind $($this,tag) <ButtonPress-3> "tk_popup $($this,menu) %X %Y"
        }

        virtual proc updateLabels {this}

    }


    class iconic {

        proc iconic {this parentPath args} composite {
            [new frame $parentPath -background {} -highlightthickness 0 -borderwidth 0 -width 0 -height 0] $args
        } canvas::viewer {$parentPath canvas::iconic($this)} {
            set tag $canvas::viewer::($this,tag)
            set ($this,image) [$parentPath create image 0 0 -anchor center -tags $tag]
            set ($this,text) [$parentPath create text 0 0 -font $font::(smallNormal) -justify center -anchor n -tags $tag]
            composite::complete $this
            set ($this,cell) {}
            if {!$global::readOnly} {
                canvas::viewer::createPopupMenu $this
                $canvas::viewer::($this,menu) add command -label [mc Image]... -command "canvas::iconic::changeImage $this"
            }
            if {!$composite::($this,-static)} {
                $parentPath bind $tag <ButtonPress-1> "canvas::iconic::select $this %x %y"
                $parentPath bind $tag <Button1-Motion> "canvas::iconic::moving $this %x %y"
                $parentPath bind $tag <ButtonRelease-1> "canvas::iconic::release $this"
            }
        }

        proc ~iconic {this} {
            freeImage $this
            if {[string length $composite::($this,-deletecommand)] > 0} {
                uplevel #0 $composite::($this,-deletecommand)
            }
        }

        proc freeImage {this} {
            if {[string length $composite::($this,-creationfile)] > 0} {
                images::release $composite::($this,-creationfile)
            }
        }

        proc iconData {} {
            return {
                R0lGODdhJAAkAOcAAAICAl2R2Iaz6PK2PvrcWk5Ohv6KCtLa0urWuv6AAv68UxISHu7ursqKKv7IZnp6emNjjWma4xJRtdK2koKKjqri/lJwsP7eqvKu
                NvTu2MWCJf7KdsLGwtbz/pqeriJeus6cOp7O+rrW/mKK0v7qZr56JqamunZ2fnZ6gp6+/uP0/NbW4rp6JLPO+V6GzrLK1iZiwnqKtgg+osDu/v6bGfX0
                226axvbevtLW3t7e7YqSiv765mqe1jJqurq+uv7ukn6Suv7osoaq0o7C8v7WcpK+6qamykpWmnp6lm6i3jZyyv7+s83N4n5+ntjq9sLC28Le9rS2zv7u
                pv724tLS5v6mGv7OTkF6x6CgwHFzm3Wk7GqCuv7mdpqatlpmoqLI6rnl/uLm4qeqxf7quJeYwVZamv766sjK2fKmJpKaktHR3v7utoSEoPrqzsre9P7W
                gvr++m1uqJam0v7yev7CQH6u4oey/np+ep+iuuru6pe6/kZ+zur0+urOov7mvu7uyO7ipoqLoXFypeLi7l5qsN7q/v72cr2+1f72usrSyoODpsju/v76
                7oqKtr7a9v6mKv768v7+n9Dm+/6aMnqq7vLy5vLksoqKut7u+v77hH5+gv7+zO7epv7mxzpeprLC1oKCsZKWrk5+uvb06np6rpaWthpClqKmoqaqvvy4
                SP6WBnJyraLO8mpqo/3alJC2/qjC8IaKpv7+/u7u9urq7v7qwqXJ+cLq/NLx/WRkqufp9PH09R5QokZ2xq7q/pi+/n5+t9HS4oq67oKu/qjR/l6a2vy6
                On2BmP7uzf7lrv7+ks7e/v6sOYaGtP7qnsLC0qquqgxGsP6iGJCQvP6TE1ZWlqGhx0qF0oGFgv6iJ5K67mJim3Km/rzQ/P6yNrfq/v7qzHys+4K66vfl
                xpbK9q2tzVxelo2Nr3qaysnZ+sDCzv7SfsbG3dLi/rq6zKvJ+ub6/vPdumZqirnd/tna54i2/nR2pH5+rI+6/mRmnXV2rfb2+qvO8+bm7pfC7t6+liwA
                AAAAJAAkAAAI/gDhCBwo8AHBgwYPDkxYUOC+fSbU7cOBh9YJE4f2BfOgZl8UPCd0lQrm0cNDSCf2wXn44KHAWIHcnYPW5RiemM3KnYvSaBqSaXjuRVml
                b+AdSAIhoSh4QhObZ7Rk0WOyLw+7frJyPNsH6QwVSIOsCUJxBwXZO2jvPHhwAg6jA+f2FVrWrm47unWX6XXjJl2hHKDoObwDz4zKtivhsDkjq0WKxyl+
                Rf5FWY/lV6/S7RMTRyUcg/Dg7FjqWV2gfe9+4fulh7UefK/xvbLzali3QaQ+MRK41GHvEydQKJr1rp5sfMhl15ttx86wcN2CxSGL4gHatWrvIFbkTpat
                esMo/mkZH65e82HPw4V7t6vLKoE17hBMyBVLKVnaBNhKVzcdLHTFJKFFONxEwA0sK+hDhmco7ACPg/KppNI0/RQiyYUX8vWJPltYQMgILhAiBxb56MJB
                LHDIEwgcqJiA2FpN3OcIPzSywg8x/NhiThleWLMjGfnk46MXjZjTSinmVAPBdSvFEoUs/HzxxTv+FDGENkKgA4osXHbpJSQP7cKEPSglBccugQwigo3E
                CCBAHZTYYM4hkHQCDjh24nnnnZ10Mos9sZC2UhSgQOIIMcQIk8SiSUTgBRmQ3ImMpHvaaSc9cRyC2Al3kMLOPvOEUEwxAZQagCgWABOppJPu2Won/kyU
                wal2btFzzyDzkHPNrrz2UsYzdY5zQzzjxHNDLX4kmywtoDSBmEo4gELLPBUM0cseVyihRA+egDLKODUwAskUoyCDQB/JJHPBBWfEEYZBEtrzxC5gVFCB
                LxUU88EHvBxhDSTIBCxwwOP848o6DtDTSjkJcYoEMIOA4Ysv33wjgAQYVxMFI8mMUcsY6SbjRzJvlJCKMbjJQxZifDRDzy0wL7IIK9FEI4MpoEwxxhhr
                XOCKK2+ss4EDxmhAxyH2wPEsJKuUQ4ski+DSwdS9yMCLxjs444zQGwytwNfMaDAAYLHAK1Apl+iyyNTw8KGCI/7cEsMlU/zgQCoKpJKK/jfeMOMNDWg0
                wMQ27CAGwOHbMOGECirwwccufLTzAhCNTDEHF8xko7nmj1ShShUsMFHAAocDsJYgwLBDxSBnsJPDCk+wo0Y1wYwzhyGZGDIJNQZQk4001NDAQg73QIAd
                NtgAo489cZARRxzNAJNFLtNsc4/tykSiTDYJGGAACTTQQUAD7CyJPDY66GBPEzo0YQ8FOqxijw7HxFEGFjVkv8QSCiSQgBUkUEUCMAACHLQiC/BLnw7S
                kIb0MbCBD0xDPrpQif1tYhNrmMQ6MsGMVBgABATAgSBO0EAdnOKEKEzhCT1wiljcIw81qEElKpGBP2SAAZxggCUmAAh25CMNwCiEximECA1UnMKIRhzi
                KarRimaw4xyXOAQoogiKabCDFF2Igj6qkYU0FNEHYAyjGMVYDXuwoQzNYEM1YkGKbYTCHmXoQhy24YFtxEEHYOSAOjiQRx9w4I+A3CM0oAFEVHiRkIPU
                wSCB+EA9JuKRkHwkByJJyUpaspIHSEQmM6nJR3IyETjoJChHSUocbBKSOBhEGFbJyla6kpWqfCUsXZmHPNDClrT4wy1pwcs/2LKWYfBlHsJwy1oO85jG
                5GVAAAA7
            }
        }

        proc options {this} {
            return [list                [list -creationfile {} {}]                [list -deletecommand {} {}]                [list -draggable 0 0]                [list -file {} {}]                [list -static 0 0]                [list -x 0 0] [list -y 0 0]            ]
        }

        proc set-deletecommand {this value} {}

        proc set-draggable {this value} {
            if {$composite::($this,complete)} {
                error {option -draggable cannot be set dynamically}
            }
        }

        proc set-static {this value} {
            if {$composite::($this,complete)} {
                error {option -static cannot be set dynamically}
            }
        }

        proc set-creationfile {this value} {
            $canvas::viewer::($this,canvas) itemconfigure $($this,image) -image [images::use $value]
            refresh $this
        }

        proc set-file {this value} {
            freeImage $this
            if {[package vcompare $::tcl_version 8.4] < 0} {
                if {[string length $value] > 0} {set value [file join [pwd] $value]}
            } else {
                set value [file normalize $value]
            }
            images::load $value $value {}
            composite::configure $this -creationfile $value
            fence $canvas::viewer::($this,canvas) $canvas::viewer::($this,tag)
            foreach {x y} [$canvas::viewer::($this,canvas) coords $canvas::viewer::($this,origin)] break
            composite::configure $this -x [expr {round($x)}] -y [expr {round($y)}]
        }

        proc set-x {this value} {
            set x [lindex [$canvas::viewer::($this,canvas) coords $canvas::viewer::($this,origin)] 0]
            $canvas::viewer::($this,canvas) move $canvas::viewer::($this,tag) [expr {$value - $x}] 0
        }
        proc set-y {this value} {
            set y [lindex [$canvas::viewer::($this,canvas) coords $canvas::viewer::($this,origin)] end]
            $canvas::viewer::($this,canvas) move $canvas::viewer::($this,tag) 0 [expr {$value - $y}]
        }

        proc monitorCell {this array row column} {
            set cell ${array}($row,$column)
            if {[string equal $cell $($this,cell)]} return
            if {[string length $($this,cell)] > 0} {
                viewer::parse $($this,cell) value ignore ignore ignore
                viewer::unregisterTrace $this $value
            }
            set ($this,cell) $cell
            viewer::registerTrace $this $array
            set canvas $canvas::viewer::($this,canvas)
            foreach [list ($this,label) incomplete] [viewer::label $array $row $column] {}
            $canvas itemconfigure $($this,text) -text $($this,label)
            if {$incomplete} {set ($this,relabel) {}}
        }

        proc update {this array}  {
            set cell $($this,cell)
            if {[string first $array $cell] != 0} return
            if {[info exists ($this,relabel)]} {
                viewer::parse $cell ignore row column ignore
                foreach [list ($this,label) incomplete] [viewer::label $array $row $column] {}
                if {!$incomplete} {unset ($this,relabel)}
            }
            set value ?; catch {set value [set $cell]}
            $canvas::viewer::($this,canvas) itemconfigure $($this,text) -text "$($this,label): $value"
        }

        proc cells {this} {
            if {[string length $($this,cell)] > 0} {
                return [list $($this,cell)]
            } else {
                return {}
            }
        }

        proc initializationConfiguration {this} {
            return [list -x $composite::($this,-x) -y $composite::($this,-y) -creationfile $composite::($this,-creationfile)]
        }

        proc monitored {this cell} {
            return [string equal $($this,cell) $cell]
        }

        proc refresh {this} {
            set canvas $canvas::viewer::($this,canvas)
            foreach {x y} [$canvas coords $canvas::viewer::($this,origin)] {}
            set image [$canvas itemcget $($this,image) -image]
            $canvas coords $($this,image) $x $y
            $canvas coords $($this,text) $x [expr {$y + ([image height $image] / 2.0) + 1}]
        }

        proc chooseFile {{current {}}} {
            if {[string length $current] == 0} {
                set directory .
            } else {
                set directory [file dirname $current]; set current [file tail $current]
            }
            set file [tk_getOpenFile                -title [mc {moodss: Icon image file}] -initialdir $directory -initialfile $current                -filetypes [list [list [mc {image files}] .gif]]            ]
            if {[string length $file] > 0} {
                if {[catch {set image [image create photo -file $file]} message]} {
                    tk_messageBox -title [mc {moodss: Icon image file error}] -type ok -icon error -message $message
                    return {}
                }
            }
            return $file
        }

        proc select {this x y} {
            lifoLabel::push $global::messenger {}
            set canvas $canvas::viewer::($this,canvas)
            foreach {(xFrom) (yFrom)} [$canvas coords $canvas::viewer::($this,origin)] {}
            set (xLast) $x; set (yLast) $y
            set (cursor) [$canvas cget -cursor]
            $canvas configure -cursor fleur
        }

        proc moving {this x y} {
            set canvas $canvas::viewer::($this,canvas)
            $canvas move $canvas::viewer::($this,tag) [expr {$x - $(xLast)}] [expr {$y - $(yLast)}]
            set (xLast) $x; set (yLast) $y
            fence $canvas $canvas::viewer::($this,tag)
            foreach {x y} [$canvas coords $canvas::viewer::($this,origin)] break
            lifoLabel::pop $global::messenger
            lifoLabel::push $global::messenger "[expr {round($x) - [lindex [$canvas cget -scrollregion] 0]}] [expr {round($y)}]"
        }

        proc release {this} {
            foreach {x y} [$canvas::viewer::($this,canvas) coords $canvas::viewer::($this,origin)] {}
            composite::configure $this -x [expr {round($x)}] -y [expr {round($y)}]
            $canvas::viewer::($this,canvas) configure -cursor $(cursor)
            lifoLabel::pop $global::messenger
        }

        proc dragCells {this} {
            foreach {(xLast) (yLast)} [$canvas::viewer::($this,canvas) coords $canvas::viewer::($this,origin)] {}
            composite::configure $this -x [expr {round($(xFrom))}] -y [expr {round($(yFrom))}]
            return [list $($this,cell)]
        }

        proc setCellColor {this cell color} {
            if {![string equal $cell $($this,cell)]} return
            set canvas $canvas::viewer::($this,canvas)
            if {[string length $color] == 0} {
                if {[info exists ($this,background)]} {
                    $canvas delete $($this,background)
                    unset ($this,background)
                }
            } else {
                if {![info exists ($this,background)]} {
                    foreach {left top right bottom} [$canvas bbox $($this,image)] {}
                    set ($this,background) [$canvas create polygon                        [expr {$left - 2}] [expr {$top - 1}] [expr {$right + 1}] [expr {$top - 1}]                        [expr {$right + 2}] $top [expr {$right + 2}] [expr {$bottom - 1}]                        [expr {$right + 1}] $bottom [expr {$left - 2}] $bottom                        [expr {$left - 3}] [expr {$bottom - 1}] [expr {$left - 3}] $top                        -tags $canvas::viewer::($this,tag) -width 1                    ]
                    $canvas lower $($this,background) $($this,image)
                }
                $canvas itemconfigure $($this,background) -fill $color -outline $color
            }
        }

        proc flash {this {seconds 1}} {
            set canvas $canvas::viewer::($this,canvas)
            foreach {left top right bottom} [$canvas bbox $canvas::viewer::($this,tag)] {}
            set highlight [new highlighter]
            highlighter::show $highlight [expr {[winfo rootx $canvas] + $left}] [expr {[winfo rooty $canvas] + $top}]                [expr {$right - $left}] [expr {$bottom - $top}]
            after [expr {$seconds * 1000}] "delete $highlight"
        }

        proc changeImage {this} {
            if {[string length [set name [chooseFile $composite::($this,-creationfile)]]] > 0} {
                composite::configure $this -file $name
            }
        }

        proc updateLabels {this} {
            if {[string length $($this,cell)] == 0} return
            viewer::parse $($this,cell) array ignore ignore ignore
            set ($this,relabel) {}
            update $this $array
        }

    }


}



class highlighter {

    proc highlighter {this {parentPath .}} {
        foreach side {left top right bottom} {
            set line [new toplevel $parentPath -background {} -highlightthickness 1 -highlightbackground black]
            wm withdraw $widget::($line,path)
            wm overrideredirect $widget::($line,path) 1
            set ($this,$side) $line
        }
    }

    proc ~highlighter {this} {
        foreach side {left top right bottom} {
            delete $($this,$side)
        }
    }

    proc show {this x y width height} {
        set path $widget::($($this,left),path)
        $path configure -width 1 -height $height
        wm geometry $path +$x+$y
        wm deiconify $path
        set path $widget::($($this,top),path)
        $path configure -width $width -height 1
        wm geometry $path +$x+$y
        wm deiconify $path
        set path $widget::($($this,right),path)
        $path configure -width 1 -height $height
        wm geometry $path +[expr {$x + $width}]+$y
        wm deiconify $path
        set path $widget::($($this,bottom),path)
        $path configure -width [expr {$width + 1}] -height 1
        wm geometry $path +$x+[expr {$y + $height}]
        wm deiconify $path
        update idletasks
    }

    proc hide {this} {
        foreach side {left top right bottom} {
            wm withdraw $widget::($($this,$side),path)
        }
    }

}


class dragSite {

    set (out) circle
    set (in) dot

    if {![info exists (grabber)]} {
        set (grabber) $widget::([new frame . -background {} -width 0 -height 0],path)
        place $(grabber) -x -1 -y -1
    }

    proc dragSite {this args} switched {$args} {
        switched::complete $this
    }

    proc ~dragSite {this} {
        variable ${this}provider
        variable draggable

        unset ${this}provider
        if {[string length $switched::($this,-path)] > 0} {
            delete $($this,bindings)
            unset draggable($switched::($this,-path))
        }
    }

    proc options {this} {
        return [list            [list -data {} {}]            [list -grab 1 1]            [list -path {} {}]            [list -validcommand {} {}]        ]
    }

    proc set-data {this value} {
        proc unformatted {this format} {return $switched::($this,-data)}
        provide $this {} "dragSite::unformatted $this"
    }

    proc set-grab {this value} {}

    proc set-path {this value} {
        variable draggable

        if {$switched::($this,complete)} {
            error {option -path cannot be set dynamically}
        }
        if {![winfo exists $value]} {
            error "invalid path: \"$value\""
        }
        if {[info exists draggable($value)]} {
            error "path \"$value\" is already a drag site"
        }
        set draggable($value) {}
        set ($this,bindings) [new bindings $value end]
        bindings::set $($this,bindings) <ButtonPress-1> "dragSite::button1Pressed $this"
    }

    proc set-validcommand {this value} {}

    proc provide {this {format {}} {command ?}} {
        variable ${this}provider

        if {[string length $format] == 0} {
            return [array names ${this}provider]
        }
        switch $command {
            ? {
                return [set ${this}provider($format)]
            }
            {} {
                catch {unset ${this}provider($format)}
            }
            default {
                set ${this}provider($format) $command
            }
        }
    }

    proc start {this xRoot yRoot} {
        variable ${this}provider

        if {![info exists (X)] || ![info exists (Y)]} return
        if {(abs($xRoot - $(X)) + abs($yRoot - $(Y))) < 5} return
        if {$switched::($this,-grab)} {
            grab $(grabber)
            update idletasks
        }
        set (highlight) [new highlighter]
        $(grabber) configure -cursor $(out)
        update idletasks
        set (dropRegions) [lsort -command dragSite::smaller [dropSite::regions [array names ${this}provider]]]
        set (lastSite) 0
        if {$switched::($this,-grab)} {
            bind $(grabber) <ButtonRelease-1> "dragSite::drop $this %X %Y"
            bind $(grabber) <Button1-Motion> "dragSite::track $this %X %Y"
        } else {
            bindings::set $($this,bindings) <ButtonRelease-1> "dragSite::drop $this %X %Y"
            bindings::set $($this,bindings) <Button1-Motion> "dragSite::track $this %X %Y"
        }
    }

    proc dropSite {xRoot yRoot} {
        set path [winfo containing $xRoot $yRoot]
        foreach region $(dropRegions) {
            foreach {site container left top right bottom} $region {}
            if {($xRoot < $left) || ($xRoot > $right) || ($yRoot < $top) || ($yRoot > $bottom)} continue
            if {[contains $container $path]} {
                return $region
            }
        }
        return [list 0 {} {} {} {}]
    }

    proc track {this xRoot yRoot} {
        foreach {site path left top right bottom} [dropSite $xRoot $yRoot] {}
        if {$site == $(lastSite)} {
            return
        } elseif {($site == 0) || [string equal $switched::($site,-path) $switched::($this,-path)]} {
            highlighter::hide $(highlight)
            $(grabber) configure -cursor $(out)
            update idletasks
        } else {
            highlighter::show $(highlight)                [expr {$left - 1}] [expr {$top - 1}] [expr {$right - $left + 2}] [expr {$bottom - $top + 2}]
            $(grabber) configure -cursor $(in)
            update idletasks
        }
        set (lastSite) $site
    }

    proc drop {this xRoot yRoot} {
        variable ${this}provider
        variable data

        if {$switched::($this,-grab)} {
            bind $(grabber) <ButtonRelease-1> {}
            bind $(grabber) <Button1-Motion> {}
            grab release $(grabber)
            update idletasks
        } else {
            bindings::set $($this,bindings) <ButtonRelease-1> {}
            bindings::set $($this,bindings) <Button1-Motion> {}
        }
        delete $(highlight); unset (highlight)
        $(grabber) configure -cursor $(out)
        update idletasks
        unset (lastSite)
        foreach {site path left top right bottom} [dropSite $xRoot $yRoot] {}
        unset (dropRegions)
        if {($site == 0) || [string equal $switched::($site,-path) $switched::($this,-path)]} {
            return
        }
        foreach format [switched::cget $site -formats] {
            if {[catch {set command [set ${this}provider($format)]}]} continue
            set data($format) [uplevel #0 $command [list $format]]
        }
        unset (X) (Y)
        dropSite::dropped $site
        catch {unset data}
    }

    proc contains {container path} {
        while {[string length $path] > 0} {
            if {[string equal $path $container]} {
                return 1
            }
            set path [winfo parent $path]
        }
        return 0
    }

    proc button1Pressed {this} {
        set path $switched::($this,-path)
        bindings::set $($this,bindings) <Button1-Motion> {}
        set command $switched::($this,-validcommand)
        set (X) [winfo pointerx .]
        set (Y) [winfo pointery .]
        if {            ([string length $command] > 0) &&            ![uplevel #0 $command [expr {$(X) - [winfo rootx $path]}] [expr {$(Y) - [winfo rooty $path]}]]        } return
        bindings::set $($this,bindings) <Button1-Motion> "dragSite::start $this %X %Y"
    }

    proc smaller {region1 region2} {
        foreach {site container left top right bottom} $region1 {}
        set area [expr {($right - $left) * ($bottom - $top)}]
        foreach {site container left top right bottom} $region2 {}
        return [expr {$area - (($right - $left) * ($bottom - $top))}]
    }

}



class dropSite {

    set (list) {}

    proc dropSite {this args} switched {$args} {
        lappend (list) $this
        switched::complete $this
        if {[string length $switched::($this,-path)] == 0} {
            error {-path option must be defined}
        }
    }

    proc ~dropSite {this} {
        set index [lsearch -exact $(list) $this]
        set (list) [lreplace $(list) $index $index]
        if {[string length $switched::($this,-path)] > 0} {
            delete $($this,bindings)
        }
    }

    proc options {this} {
        return [list            [list -command {} {}]            [list -formats {{}} {{}}]            [list -path {} {}]            [list -regioncommand {} {}]            [list -state normal]        ]
    }

    proc set-command {this value} {}
    proc set-formats {this value} {}

    proc set-state {this value} {
        switch $value {
            disabled {set ($this,enabled) 0}
            normal {set ($this,enabled) 1}
            default {
                error "bad state value \"$value\": must be normal or disabled"
            }
        }
    }

    proc set-regioncommand {this value} {}

    proc set-path {this value} {
        if {$switched::($this,complete)} {
            error {option -path cannot be set dynamically}
        }
        if {![winfo exists $value]} {
            error "invalid widget: \"$value\""
        }
        set ($this,bindings) [new bindings $value end]
        set ($this,visible) 1
        bindings::set $($this,bindings) <Visibility> "set ::dropSite::($this,visible) \[string compare %s VisibilityFullyObscured\]"
    }

    proc dropped {this} {
        if {[string length $switched::($this,-command)] > 0} {
            uplevel #0 $switched::($this,-command)
        }
    }

    proc regions {formats} {
        set regions {}
        foreach site $(list) {
            if {!$($site,enabled)} continue
            set path $switched::($site,-path)
            set region {}
            if {[string length $switched::($site,-regioncommand)] > 0} {
                set region [uplevel #0 $switched::($site,-regioncommand)]
            } else {
                if {[catch {set viewable [winfo viewable $path]}]} continue
                if {!$viewable || !$($site,visible)} continue
                set x [winfo rootx $path]
                set y [winfo rooty $path]
                set region [list $x $y [expr {$x + [winfo width $path]}] [expr {$y + [winfo height $path]}]]
            }
            foreach format $switched::($site,-formats) {
                if {[lsearch -exact $formats $format] < 0} continue
                if {[llength $region] > 0} {
                    lappend regions [concat $site $path $region]
                    break
                }
            }
        }
        return $regions
    }

}



bind Menu <<MenuSelect>> {menuContextHelp::menuSelected %W}

class menuContextHelp {

    proc menuContextHelp {this path} {
        variable identifier

        bind $path <Unmap> {catch {menuContextHelp::selected $menuContextHelp::identifier(%W) none}}
        ::set ($this,active) -1
        ::set ($this,path) $path
        ::set identifier($path) $this
    }

    proc ~menuContextHelp {this} {
        variable ${this}string
        variable identifier

        catch {unset ${this}string}
        unset identifier($($this,path))
    }

    proc set {this item string} {
        variable ${this}string

        ::set ${this}string($item) $string
    }

    proc menuSelected {path} {
        variable identifier

        ::set item [$path index active]
        if {[string match {.#*} $path]} {
            regsub -all # [lindex [split $path .] end] . path
        }
        if {![catch {::set object $identifier($path)}]} {
            selected $object $item
        }
    }

    proc selected {this item} {
        variable ${this}string

        if {[string equal $item none]} {
            ::set item -1
        }
        if {$item == $($this,active)} return
        lifoLabel::pop $global::messenger
        if {$item >= 0} {
            if {[catch {::set ${this}string($item)} string]} {
                lifoLabel::push $global::messenger $item
            } else {
                lifoLabel::push $global::messenger $string
            }
        }
        ::set ($this,active) $item
    }

}



namespace eval printerCapability {

    proc parseDatabase {aliasesName defaultName {fileName /etc/printcap}} {
        upvar 1 $aliasesName aliases $defaultName default

        if {[catch {set file [open $fileName]}]} return
        set find lp
        catch {set find [string trim $::env(PRINTER)]}
        set new 1
        while {[gets $file line] >= 0} {
            set line [string trim $line]
            if {[string match #* $line]} continue
            if {$new} {
                set index 0
                foreach alias [split [string trim $line {:\\}] |] {
                    set alias [string trim $alias]
                    if {$index == 0} {
                        set name $alias
                        set aliases($name) {}
                    } else {
                        lappend aliases($name) $alias
                    }
                    if {[string equal $alias $find]} {
                        set default $name
                    }
                    incr index
                }
            }
            set new [expr {![string match {*\\} $line]}]
        }
        close $file
    }

}



class printViewer {

    set ::env(DISPLAY) [winfo screen .]
    set (pixelsPerInch) [winfo pixels . 1i]
    set (pixelsPerMillimeter) [expr {$(pixelsPerInch) / 25.4}]
    set (margin) 10
    set (offset) 3
    set (pageHeight) 130
    set (pageWidth) 100

    proc printViewer {this parentPath args} composite {[new frame $parentPath -background gray] $args} {
        set path $widget::($this,path)
        set ($this,shadow) [frame $path.shadow -background black]
        set ($this,sheet) [frame $path.sheet -container 1 -background white]
        scan [winfo id $($this,sheet)] 0x%x ($this,id)
        set ($this,height) [expr {round($(pageHeight) * $(pixelsPerMillimeter))}]
        set ($this,width) [expr {round($(pageWidth) * $(pixelsPerMillimeter))}]
        composite::complete $this
    }

    proc ~printViewer {this} {
        terminateProcess $this
        if {$composite::($this,-deletefile)} {
            file delete $composite::($this,-file)
        }
    }

    proc options {this} {
        return [list            [list -deletefile 0 0]            [list -file {} {}]            [list -pageheight $(pageHeight)]            [list -pagewidth $(pageWidth)]            [list -zoom 1 1]        ]
    }

    proc set-deletefile {this value} {}

    proc set-file {this value} {}

    proc set-pageheight {this value} {
        set ($this,height) [expr {round($value * $(pixelsPerMillimeter))}]
        displaySheet $this
    }
    proc set-pagewidth {this value} {
        set ($this,width) [expr {round($value * $(pixelsPerMillimeter))}]
        displaySheet $this
    }

    proc set-zoom {this value} {}

    proc terminateProcess {this} {
        catch {puts $($this,channel) quit}
        catch {close $($this,channel)}
    }

    proc displaySheet {this} {
        set ratio $composite::($this,-zoom)
        set width [expr {round($($this,width) * $ratio)}]
        set height [expr {round($($this,height) * $ratio)}]
        place $($this,sheet) -x $(margin) -y $(margin) -width $width -height $height
        place $($this,shadow) -x [expr {$(margin) + $(offset)}] -y [expr {$(margin) + $(offset)}] -width $width -height $height
        $widget::($this,path) configure            -width [expr {$width + (2 * $(margin)) + $(offset)}] -height [expr {$height + (2 * $(margin)) + $(offset)}]
    }

    proc refresh {this} {
        if {[string length $composite::($this,-file)] == 0} return
        terminateProcess $this
        displaySheet $this
        set ratio $composite::($this,-zoom)
        set width [expr {round($($this,width) * $ratio)}]
        set height [expr {round($($this,height) * $ratio)}]
        set pixelsPerInch [expr {round($(pixelsPerInch) * $ratio)}]
        set ($this,channel) [open            "|gs -q -sDEVICE=x11 -dWindowID=$($this,id) -g${width}x$height -r$pixelsPerInch -dBATCH -dNOPROMPT                $composite::($this,-file)"            w        ]
        fconfigure $($this,channel) -blocking 0
    }

}



namespace eval print {

    variable dotsPerMillimeter [expr {72 / 25.4}]
    variable previewerWindow .grabber.printPreviewer


    proc printOrSaveCanvas {} {
        variable printToFile $global::printToFile
        variable printCommand $global::printCommand
        variable fileToPrintTo $global::fileToPrintTo
        variable orientations
        variable orientation
        variable palettes
        variable palette
        variable sizes
        variable size
        variable printPaperSize $global::printPaperSize
        variable printer

        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 $global::printOrientation]; if {$index < 0} {set index 0}
        set orientation [lindex $orientations $index]
        set index [lsearch -exact $global::printPalettes $global::printPalette]; if {$index < 0} {set index 0}
        set palette [lindex $palettes $index]
        set index [lsearch -exact $global::printPaperSizes $global::printPaperSize]; if {$index < 0} {set index 0}
        set size [lindex $sizes $index]
        set objects {}
        set dialog [new dialogBox .grabber            -buttons hoc -default o -title [mc {moodss: Print}] -die 0 -x [winfo pointerx .] -y [winfo pointery .]            -helpcommand {generalHelpWindow #menus.file.print} -deletecommand {grab release .grabber}        ]
        grab .grabber
        lappend objects [linkedHelpWidgetTip $composite::($dialog,help,path)]
        set toplevel $widget::($dialog,path)
        set frame [frame $toplevel.frame]
        set row 0
        message $frame.help -width [winfo screenwidth .] -font $font::(mediumNormal) -justify left            -text [mc {Print the window to a printer device or to a file, in Postscript}]
        grid $frame.help -pady 5 -row $row -column 0 -columnspan 3
        incr row
        radiobutton $frame.toCommand -variable print::printToFile -value 0
        grid $frame.toCommand -row $row -column 0 -sticky w
        if {[string first %P $printCommand] < 0} {
            $frame.toCommand configure -text [mc {with Command:}]
            entry $frame.command -textvariable print::printCommand
            grid $frame.command -row $row -column 1 -sticky ew
        } else {
            $frame.toCommand configure -text [mc {to Printer:}]
            printerCapability::parseDatabase aliases default
            catch {unset printer}
            catch {set printer [printerFormattedEntry $default $aliases($default)]}
            set entries {}
            foreach name [lsort -dictionary [array names aliases]] {
                lappend entries [printerFormattedEntry $name $aliases($name)]
            }
            set entry [new comboEntry $frame -font $widget::option(entry,font) -list $entries]
            lappend objects $entry
            composite::configure $entry entry -textvariable print::printer
            if {[llength $entries] <= 3} {
                composite::configure $entry button -listheight [llength $entries]
            }
            composite::configure $entry button scroll -selectmode single
            grid $widget::($entry,path) -row $row -column 1 -sticky ew
        }
        set button            [button $frame.preview -text [mc Preview]... -command "wm withdraw $toplevel; print::preview; wm deiconify $toplevel"]
        if {[catch {exec gs --version} version]} {
            $button configure -state disabled
            lappend objects [new widgetTip -path $button -text [mc {could not get gs version}]]
        } elseif {[package vcompare $version 5.20] < 0} {
            $button configure -state disabled
            lappend objects [new widgetTip -path $button -text [mc {requires gs version above 5.20}]]
        }
        grid $button -row $row -column 2 -sticky ew
        incr row
        radiobutton $frame.toFile -variable print::printToFile -value 1 -text [mc {or to File:}]
        grid $frame.toFile -row $row -column 0 -sticky w
        entry $frame.file -textvariable print::fileToPrintTo
        grid $frame.file -row $row -column 1 -sticky ew
        button $frame.browse -text [mc Browse]... -command "print::inquireFileToPrintTo $frame"
        grid $frame.browse -row $row -column 2 -sticky ew
        if {$printToFile} {
            $frame.toFile invoke
        } else {
            $frame.toCommand invoke
        }
        incr row
        grid [label $frame.orientation -text [mc Orientation:]] -row $row -column 0 -sticky w
        set entry [new comboEntry $frame -font $widget::option(entry,font) -list $orientations -editable 0]
        lappend objects $entry
        composite::configure $entry entry -textvariable print::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
        incr row
        grid [label $frame.palette -text [mc Palette:]] -row $row -column 0 -sticky w
        set entry [new comboEntry $frame -font $widget::option(entry,font) -list $palettes -editable 0]
        lappend objects $entry
        composite::configure $entry entry -textvariable print::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
        incr row
        grid [label $frame.size -text [mc {Paper size:}]] -row $row -column 0 -sticky w
        set entry [new comboEntry $frame -font $widget::option(entry,font) -list $sizes -editable 0]
        lappend objects $entry
        composite::configure $entry entry -textvariable print::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
        grid columnconfigure $frame 1 -weight 1
        dialogBox::display $dialog $frame
        widget::configure $dialog -command "delete $dialog; print::updateGlobals; update; print::print"
        bind $frame <Destroy> "print::cleanup $objects"
    }

    proc printerFormattedEntry {name aliases} {
        set string $name
        set first 1
        foreach alias $aliases {
            if {$first} {
                append string { (}
                set first 0
            } else {
                append string {, }
            }
            append string $alias
        }
        if {!$first} {
            append string )
        }
        return $string
    }

    proc cleanup {args} {
        variable previewerWindow

        catch {destroy $previewerWindow}
        eval delete $args
    }

    proc inquireFileToPrintTo {parentPath} {
        set file [tk_getSaveFile            -title [mc {moodss: Print to file}] -parent $parentPath -initialdir [file dirname $print::fileToPrintTo]            -defaultextension .ps -filetypes [list {Postscript .ps} [list [mc {All files}] *]] -initialfile $print::fileToPrintTo        ]
        if {[string length $file] > 0} {
            set print::fileToPrintTo $file
        }
    }

    proc updateGlobals {} {
        variable printToFile
        variable printCommand
        variable fileToPrintTo
        variable orientations
        variable orientation
        variable palettes
        variable palette
        variable sizes
        variable size

        set global::printToFile $printToFile
        set global::printCommand $printCommand
        set global::fileToPrintTo $fileToPrintTo
        set index [lsearch -exact $orientations $orientation]; if {$index < 0} {set index 0}
        set global::printOrientation [lindex $global::printOrientations $index]
        set index [lsearch -exact $palettes $palette]; if {$index < 0} {set index 0}
        set global::printPalette [lindex $global::printPalettes $index]
        set index [lsearch -exact $sizes $size]; if {$index < 0} {set index 0}
        set global::printPaperSize [lindex $global::printPaperSizes $index]
    }

    proc canvasPrintArea {} {
        set canvas $global::canvas
        foreach {left top right bottom} [$canvas cget -scrollregion] {}
        set width [expr {$right - $left}]
        set height [expr {$bottom - $top}]
        foreach {minimum maximum} [$canvas xview] {}
        set left [expr {$left + ($minimum * $width)}]
        foreach {minimum maximum} [$canvas yview] {}
        set top [expr {$top + ($minimum * $height)}]
        scan [winfo geometry $canvas] %ux%u width height
        set right [expr {$left + $width}]
        set bottom [expr {$top + $height}]
        set items {}
        foreach item [$canvas find all] {
            set print 1
            foreach tag [$canvas gettags $item] {
                if {[string match icon(*) $tag]} {
                    set print 0
                    break
                }
            }
            if {$print} {
                lappend items $item
            }
        }
        if {[llength $items] > 0} {
            foreach {boundsLeft boundsTop boundsRight boundsBottom} [eval $canvas bbox $items] {}
            if {$boundsLeft > $left} {set left $boundsLeft}
            if {$boundsRight < $right} {set right $boundsRight}
            if {$boundsTop > $top} {set top $boundsTop}
            if {$boundsBottom < $bottom} {set bottom $boundsBottom}
        }
        return [list $left $top [expr {$right - $left}] [expr {$bottom - $top}]]
    }

    proc postscriptOptions {{gsOutput 0} {pageWidthName {}} {pageHeightName {}}} {
        variable orientations
        variable orientation
        variable sizes
        variable size
        variable palettes
        variable palette
        variable dotsPerMillimeter

        if {[string length $pageWidthName] > 0} {
            upvar 1 $pageWidthName pageWidth
        }
        if {[string length $pageHeightName] > 0} {
            upvar 1 $pageHeightName pageHeight
        }
        update
        foreach {left top width height} [canvasPrintArea] {}
        set inch 25.4
        set margin [expr {$inch / 2}]
        set index [lsearch -exact $sizes $size]; if {$index < 0} {set index 0}
        switch -glob [lindex $global::printPaperSizes $index] {
            A3* {
                set pageWidth 297
                set pageHeight 420
            }
            A4* {
                set pageWidth 210
                set pageHeight 297
            }
            executive* {
                set pageWidth [expr {7.5 * $inch}]
                set pageHeight [expr {10 * $inch}]
            }
            legal* {
                set pageWidth [expr {8.5 * $inch}]
                set pageHeight [expr {14 * $inch}]
            }
            default {
                set pageWidth [expr {8.5 * $inch}]
                set pageHeight [expr {11 * $inch}]
            }
        }
        set pageX ${margin}m
        set index [lsearch -exact $orientations $orientation]; if {$index < 0} {set index 0}
        set rotate [string equal [lindex $global::printOrientations $index] landscape]
        if {$rotate} {
            set pageY ${margin}m
        } else {
            set pageY [expr {$pageHeight - $margin}]m
        }
        if {$rotate} {
            set value $pageWidth
            set pageWidth $pageHeight
            set pageHeight $value
            unset value
            if {$gsOutput} {
                set pageY [expr {$pageHeight - $margin}]m
            }
        }
        set printWidth [expr {($pageWidth - (2 * $margin)) * $dotsPerMillimeter}]
        set printHeight [expr {($pageHeight - (2 * $margin)) * $dotsPerMillimeter}]
        set ratio 1
        if {$printWidth < $width} {
            set ratio [expr {$printWidth / $width}]
        }
        if {($printHeight < $height) && (($printHeight / $height) < $ratio)} {
            set ratio [expr {$printHeight / $height}]
        }
        if {$gsOutput} {
            set rotate 0
        }
        set index [lsearch -exact $palettes $palette]; if {$index < 0} {set index 0}
        set options [list            -colormode [lindex $global::printPalettes $index] -rotate $rotate -x $left -y $top -width $width -height $height            -pageanchor nw -pagex $pageX -pagey $pageY        ]
        if {$ratio < 1} {
            lappend options -pagewidth [expr {$ratio * $width}] -pageheight [expr {$ratio * $height}]
        }
        return $options
    }

    proc print {} {
        variable printToFile
        variable fileToPrintTo
        variable printCommand
        variable printer

        busy 1
        set options [postscriptOptions]
        if {$printToFile} {
            lifoLabel::push $global::messenger [format [mc {printing to file %s...}] $fileToPrintTo]
        } else {
            lifoLabel::push $global::messenger [mc printing...]
        }
        update idletasks
        if {$printToFile} {
            lappend options -file $fileToPrintTo
            eval $global::canvas postscript $options
        } else {
            set data [eval $global::canvas postscript $options]
            if {[string first %P $printCommand] < 0} {
                set command $printCommand
            } else {
                regsub -all %P $printCommand [scan $printer %s] command
            }
            if {                [catch {set channel [open |$command w]} message] ||                [catch {puts -nonewline $channel $data} message] || [catch {close $channel} message]            } {
                tk_messageBox -title [mc {moodss: Error when printing}] -type ok -icon error -message "$command: $message"
            }
        }
        lifoLabel::pop $global::messenger
        busy 0
    }

    proc preview {} {
        variable previewerWindow
        variable viewer
        variable zoomRatio

        if {![winfo exists $previewerWindow]} {
            toplevel $previewerWindow
            wm resizable $previewerWindow 0 0
            wm group $previewerWindow .
            wm title $previewerWindow [mc {moodss: Print preview...}]
            set viewer [new printViewer $previewerWindow -deletefile 1]

            set menu [menu $previewerWindow.menu -tearoff 0]
            $previewerWindow configure -menu $menu
            menu $menu.zoom -tearoff 0
            foreach {string underline} [underlineAmpersand [mc &Zoom]] {}
            $menu add cascade -label $string -menu $menu.zoom -underline $underline
            set zoomRatio 100%
            foreach {label value} {10 0.1 25 0.25 50 0.5 75 0.75 100 1 200 2 500 5} {
                $menu.zoom add radiobutton -label $label% -variable ::print::zoomRatio                    -command "composite::configure $viewer -zoom $value; printViewer::refresh $viewer"
            }
            foreach {string underline} [underlineAmpersand [mc &Close]] {}
            $menu.zoom add command -label $string -underline $underline -command "destroy $previewerWindow"

            frame $previewerWindow.bound
            bind $previewerWindow.bound <Destroy> "delete $viewer"
            pack $widget::($viewer,path)
        }
        lower $previewerWindow
        busy 1
        lifoLabel::push $global::messenger [mc {previewing with gs...}]
        update idletasks
        set options [postscriptOptions 1 width height]
        lappend options -file [set file [temporaryFileName]]
        eval $global::canvas postscript $options
        wm deiconify $previewerWindow
        raise $previewerWindow
        composite::configure $viewer -file $file -pagewidth $width -pageheight $height
        printViewer::refresh $viewer
        lifoLabel::pop $global::messenger
        busy 0
    }

    proc createTemporaryCanvasShot {} {
        update idletasks
        foreach {left top width height} [canvasPrintArea] {}
        set file [temporaryFileName png]
        set channel [open            "|gs -q -dBATCH -dNOPROMPT -sDEVICE=png256 -g${width}x${height} -r$printViewer::(pixelsPerInch) -sOutputFile=$file -"            w        ]
        $global::canvas postscript -colormode color -x 0 -y 0 -width $width -height $height -pageanchor sw -pagex 0 -pagey 0            -channel $channel
        close $channel
        return $file
    }

}


class scroller {

    proc scroller {this parentPath args} composite {[new scroll canvas $parentPath] $args} {
        set ($this,canvasPath) $composite::($composite::($this,base),scrolled,path)
        composite::complete $this
    }

    proc ~scroller {this} {}

    proc options {this} {
        return [list            [list                -scrollbarelementborderwidth                $widget::option(scrollbar,elementborderwidth) $widget::option(scrollbar,elementborderwidth)            ]            [list -height 0 0]            [list -width 0 0]            [list -xscrollincrement $widget::option(canvas,xscrollincrement) $widget::option(canvas,xscrollincrement)]            [list -yscrollincrement $widget::option(canvas,yscrollincrement) $widget::option(canvas,yscrollincrement)]        ]
    }

    proc display {this path} {
        if {[string length $path]==0} {
            $($this,canvasPath) delete all
            bind $($this,displayed) <Configure> {}
            catch {unset ($this,displayed)}
            return
        }
        if {[info exists ($this,displayed)]} {
            error "scroller \"$this\" already displays widget \"$($this,displayed)\""
        }
        if {![string equal $widget::($this,path) [winfo parent $path]]} {
            error "displayed widget \"$path\" must be a child of scroller \"$this\" path"
        }
        set ($this,displayed) $path
        set canvas $($this,canvasPath)
        raise $path $canvas
        $canvas create window 0 0 -window $path -anchor nw
        bind $path <Configure> "$canvas configure -width %w -height %h -scrollregion {0 0 %w %h}"
    }

    foreach option {-scrollbarelementborderwidth -height -width} {
        proc set$option {this value} "composite::configure \$composite::(\$this,base) $option \$value"
    }

    proc set-xscrollincrement {this value} {
        $($this,canvasPath) configure -xscrollincrement $value
    }

    proc set-yscrollincrement {this value} {
        $($this,canvasPath) configure -yscrollincrement $value
    }

}



class moduleOperations {

    variable internal
    set internal(--daemon) {}

    proc moduleOperations {this action} {
        if {[info exists (displayed)]} {
            delete $($(displayed),dialog)
        }
        set (displayed) $this
        switch $action {
            display {set others {}}
            load {set others load}
            manage {set others {unload reload new}}
            default {error "bad action $action"}
        }
        set dialog [new dialogBox .            -buttons hx -default x -helpcommand "moduleOperations::help $this" -x [winfo pointerx .] -y [winfo pointery .]            -grab release -deletecommand "delete $this" -closecommand "moduleOperations::close $this" -otherbuttons $others        ]
        wm geometry $widget::($dialog,path) 400x200
        set frame [frame $widget::($dialog,path).frame]

        set ($this,label) [label $frame.label -font $font::(mediumNormal) -anchor nw]
        grid $($this,label) -row 0 -column 0 -sticky nw -columnspan 2
        set list [new scrollList $frame -font $font::(mediumBold) -width 0]
        grid $widget::($list,path) -row 1 -column 0 -sticky nws

        set entries [frame $frame.entries]
        set container [table $entries.container            -colstretchmode last -rows 0 -cols 2 -highlightthickness 0 -takefocus 0 -borderwidth 0 -cursor {} -bordercursor {}            -padx 1 -pady 1 -state disabled -exportselection 0        ]
        $container tag configure sel -background {}
        set scroll [scrollbar $entries.scroll -orient vertical -highlightthickness 0]
        $container configure -yscrollcommand "moduleOperations::updateScrollBar $scroll"
        $scroll configure -command "$container yview"
        grid rowconfigure $entries 0 -weight 1
        grid columnconfigure $entries 0 -weight 1
        grid $container -row 0 -column 0 -sticky nsew
        set ($this,container) $container

        grid rowconfigure $frame 1 -weight 1
        grid columnconfigure $frame 1 -weight 1
        grid $entries -row 1 -column 1 -columnspan 2 -sticky nsew

        dialogBox::display $dialog $frame
        set ($this,dialog) $dialog
        set ($this,frame) $frame
        set ($this,list) $list
        set ($this,action) $action
        set ($this,tips) {}
        lappend ($this,tips) [new widgetTip            -path $composite::($dialog,help,path) -text [mc {display help on this dialog box or on selected module}]        ]
        switch $action {
            display {
                composite::configure $dialog -title [mc {moodss: Loaded modules}]
                loaded $this
            }
            load {
                composite::configure $dialog -title [mc {moodss: Load modules}]
                composite::configure $dialog load -text [mc Load] -command "moduleOperations::load $this" -state disabled
                lappend ($this,tips)                    [new widgetTip -path $composite::($dialog,load,path) -text [mc {load selected module with specified options}]]
                discover $this
            }
            manage {
                composite::configure $dialog -title [mc {moodss: Manage modules}]
                composite::configure $dialog unload -text [mc Unload] -command "moduleOperations::unload $this"
                composite::configure $dialog reload -text [mc Reload] -command "moduleOperations::reload $this"
                composite::configure $dialog new -text [mc New]                    -command "moduleOperations::load $this; moduleOperations::loaded $this"
                lappend ($this,tips)                    [new widgetTip -path $composite::($dialog,unload,path) -text [mc {unload selected module}]]                    [new widgetTip -path $composite::($dialog,reload,path)                        -text [mc {unload the selected module then load a new instance using the updated parameters}]                    ]                    [new widgetTip -path $composite::($dialog,new,path)                        -text [mc {load a new instance of the selected module using the updated parameters}]                    ]
                loaded $this
            }
        }
        set ($this,index) {}
    }

    proc ~moduleOperations {this} {
        eval delete $($this,tips)
        delete $($this,list)
        unset (displayed)
    }

    proc discover {this} {
        variable internal

        if {![info exists (discoveredModules)]} {
            $($this,label) configure -text [mc {searching for modules...}]
            busy 1 $($this,frame)
            update
            set format [mc {scanning module %s...}]
            modules::available "
                lappend moduleOperations::(discoveredModules) %M
                set moduleOperations::(%M,discoveredSwitches) %S
                scrollList::insert $($this,list) 0 %M
                update idletasks
            " "
                $($this,label) configure -text \[format {$format} %M\]
                update idletasks
            "
            busy 0 $($this,frame)
        }
        if {[info exists (discoveredModules)]} {
            $($this,label) configure -text [mc {Select module (view its documentation with Help button):}]
            update idletasks
            set modules [lsort -dictionary $(discoveredModules)]
            set index 0
            foreach module $modules {
                set switches {}
                foreach {option argument} $($module,discoveredSwitches) {
                    if {[info exists internal($option)]} continue
                    lappend switches $option $argument
                }
                foreach {option argument} $switches {
                    if {[info exists (last,$module,$option)]} {
                        set ($this,$module,$option) $(last,$module,$option)
                    } elseif {$argument} {
                        set ($this,$module,$option) {}
                    } else {
                        set ($this,$module,$option) 0
                    }
                }
                set ($module,switches) $switches
                set ($this,indexNamespace,$index) $module
                incr index
            }
            composite::configure $($this,list) -list $modules
            bind $composite::($($this,list),listbox,path) <<ListboxSelect>> "moduleOperations::selection $this"
        } else {
            $($this,label) configure -text [mc {Found no modules:}]
        }
    }

    proc selection {this} {
        set index [lindex [scrollList::curselection $($this,list)] 0]
        if {([string length $index] == 0) || [string equal $index $($this,index)]} return

        if {[string equal $($this,action) manage] && ([string length $($this,index)] > 0) && [changed $this $($this,index)]} {
            scrollList::selection $($this,list) clear $index; scrollList::selection $($this,list) set $($this,index)
            if {![interactiveQuery                $this [mc {moodss: Module parameters}] [mc {Ignore changes and continue the selection of another module?}]            ]} return
            set module $($this,indexNamespace,$($this,index))
            foreach {option argument} $($module,switches) value $($this,values) {
                set ($this,$module,$option) $value
            }
            scrollList::selection $($this,list) clear $($this,index); scrollList::selection $($this,list) set $index
        }
        set module $($this,indexNamespace,$index)
        switch $($this,action) {
            display {
                set state disabled
            }
            load {
                set state normal
                composite::configure $($this,dialog) load -state normal
            }
            manage {
                set state normal
                composite::configure $($this,dialog) unload -state normal
                composite::configure $($this,dialog) reload -state normal
                composite::configure $($this,dialog) new -state normal
            }
        }
        cleanOptions $this
        set table $($this,container)
        $table configure -rows [expr {[llength $($module,switches)] / 2}]
        set row 0
        set width 0
        set ($this,values) {}
        foreach {option argument} $($module,switches) {
            set label [label $table.$row,0 -font $font::(mediumBold) -text $option]
            $table window configure $row,0 -window $label
            if {[winfo reqwidth $label] > $width} {
                set width [winfo reqwidth $label]
            }
            if {$argument} {
                set path [entry $table.$row,1                    -font $font::(mediumNormal) -width 0 -textvariable moduleOperations::($this,$module,$option) -state $state                ]
                if {[regexp $global::passwordOptionExpression $option]} {
                    $path configure -show *
                }
                $table window configure $row,1 -window $path -sticky ew
            } else {
                set path [checkbutton $table.$row,1 -variable moduleOperations::($this,$module,$option) -state $state]
                $table window configure $row,1 -window $path -sticky w
            }
            lappend ($this,values) $($this,$module,$option)
            incr row
        }
        if {$row == 0} {
            set label [label $table.$row,0 -font $font::(mediumItalic) -text [mc {no options}]]
            $table window configure $row,0 -window $label
            $table window configure $row,1 -window [label $table.$row,1] -sticky ew
            set width [winfo reqwidth $label]
        }
        $table width 0 -$width
        set ($this,index) $index
    }

    proc load {this} {
        set module $($this,indexNamespace,$($this,index))
        foreach {name index} [modules::decoded $module] {}
        array unset {} last,$name,*
        set string $name
        foreach {option argument} $($module,switches) {
            if {$argument} {
                if {[string length $($this,$module,$option)] > 0} {
                    append string " $option [list $($this,$module,$option)]"
                }
            } else {
                if {$($this,$module,$option)} {
                    append string " $option"
                }
            }
            set (last,$name,$option) $($this,$module,$option)
        }
        if {[catch {dynamicallyLoadModules $string} message]} {
            tk_messageBox -title [mc {moodss: Error loading module}]                 -type ok -icon error -message $message -parent $widget::($($this,dialog),path)
        }
    }

    proc loaded {this} {
        variable internal

        $($this,label) configure -text [mc {Select loaded module (view its documentation with Help button):}]
        cleanOptions $this
        set index 0
        foreach {namespace identifier options} [modulesData] {
            lappend list $identifier
            set switches {}
            foreach {switch argument value} $options {
                if {[info exists internal($switch)]} continue
                lappend switches $switch $argument
                set ($this,$namespace,$switch) $value
            }
            set ($namespace,switches) $switches
            set ($this,indexNamespace,$index) $namespace
            incr index
        }
        if {![info exists list]} {error {no loaded modules}}
        composite::configure $($this,list) -list {}
        set ($this,index) {}
        composite::configure $($this,list) -list $list
        bind $composite::($($this,list),listbox,path) <<ListboxSelect>> "moduleOperations::selection $this"
        if {[string equal $($this,action) manage]} {
            composite::configure $($this,dialog) unload -state disabled
            composite::configure $($this,dialog) reload -state disabled
            composite::configure $($this,dialog) new -state disabled
        }
    }

    proc unload {this} {
        dynamicallyUnloadModule $($this,indexNamespace,$($this,index))
        if {[llength [modulesData]] == 0} {
            after idle delete $($this,dialog)
        } else {
            loaded $this
            composite::configure $($this,dialog) unload -state disabled
        }
    }

    proc reload {this} {
        dynamicallyUnloadModule $($this,indexNamespace,$($this,index))
        load $this
        if {[llength [modulesData]] == 0} {
            after idle delete $($this,dialog)
        } else {
            loaded $this
        }
    }

    proc help {this} {
        if {[string length $($this,index)] > 0} {
            set module $($this,indexNamespace,$($this,index))
            foreach {name index} [modules::decoded $module] {}
            moduleHelpWindow $name [modules::helpHTMLData $name]
        } else {
            switch $($this,action) {
                display {generalHelpWindow #menus.file.modules.loaded}
                load {generalHelpWindow #menus.file.modules.load}
                manage {generalHelpWindow #menus.file.modules.manage}
            }
        }
    }

    proc updateScrollBar {widget beginning end} {
        $widget set $beginning $end
        if {($end - $beginning) < 1} {
            grid $widget -row 0 -column 1 -sticky ns
        } else {
            grid forget $widget
        }
    }

    proc cleanOptions {this} {
        set table $($this,container)
        foreach cell [$table window names] {
            destroy $table.$cell
        }
    }

    proc changed {this index} {
        set module $($this,indexNamespace,$index)
        foreach {option argument} $($module,switches) value $($this,values) {
            if {![string equal $($this,$module,$option) $value]} {
                return 1
            }
        }
        return 0
    }

    proc interactiveQuery {this title message} {
        return [string equal            [tk_messageBox -title $title -type yesno -icon question -parent $widget::($($this,dialog),path) -message $message] yes        ]
    }

    proc close {this} {
        if {![string equal $($this,action) manage]} {return 1}
        if {([string length $($this,index)] == 0) || ![changed $this $($this,index)]} {
            return 1
        } elseif {[interactiveQuery $this [mc {moodss: Module parameters}] [mc {Ignore changes and close the dialog box?}]]} {
            return 1
        } else {
            return 0
        }
    }

    proc modulesData {} {
        set list {}
        foreach {namespace identifier options} [modules::loaded] {
            if {[string equal [lindex [modules::decoded $namespace] 0] formulas]} continue
            regsub {<0>$} $identifier {} identifier
            lappend list $namespace $identifier $options
        }
        return $list
    }

}



class tableSelector {

    proc tableSelector {this args} selector {$args} {}

    proc ~tableSelector {this} {}


    proc extend {this cell} {
        if {[info exists selector::($this,lastSelected)]} {
            scan $selector::($this,lastSelected) %d,%d startRow startColumn
            scan $cell %d,%d lastRow lastColumn
            if {$lastRow < $startRow} {
                set last $startRow
                set startRow $lastRow
                set lastRow $last
            }
            if {$lastColumn < $startColumn} {
                set last $startColumn
                set startColumn $lastColumn
                set lastColumn $last
            }
            set list {}
            for {set row $startRow} {$row <= $lastRow} {incr row} {
                for {set column $startColumn} {$column <= $lastColumn} {incr column} {
                    lappend list $row,$column
                }
            }
            selector::clear $this
            selector::set $this $list 1
        } else {
            selector::select $this $cell
        }
    }

}



class dataTable {

    set (extreme,integer) $global::32BitIntegerMinimum
    set (extreme,real) -1.7976931348623158e308
    set (list) {}
    set (scrollbarBorderWidth) [expr {$widget::option(scrollbar,borderwidth) == 0? 0: 1}]
    set (scrollbarWidth) [expr {2 * $widget::option(scrollbar,width) / 3}]

    proc dataTable {this parentPath args} composite {
        [new scroll table $parentPath            -scrollbarwidth $(scrollbarWidth) -scrollbarelementborderwidth $(scrollbarBorderWidth)            -width $global::viewerWidth -height $global::viewerHeight        ] $args
    } {
        set path $composite::($composite::($this,base),scrolled,path)
        $path configure -font $font::(mediumNormal) -state disabled -colstretchmode last -variable dataTable::${this}data            -resizeborders col -cursor {} -highlightthickness 0 -takefocus 0 -ipadx 2
        $path tag configure sel -background {} -foreground black -borderwidth {2 1 2 1}
        bindtags $path [list $path [winfo toplevel $path] all]
        set ($this,tablePath) $path
        lappend (list) $this
        composite::complete $this

        bind $path <ButtonPress-1> "dataTable::buttonPress $this %x %y"
        bind $path <ButtonRelease-1> "dataTable::buttonRelease $this %x %y 0"
        bind $path <Control-ButtonRelease-1> "dataTable::buttonRelease $this %x %y 1"
        bind $path <Shift-ButtonRelease-1> "dataTable::buttonRelease $this %x %y 1"
        if {$composite::($this,-resizablecolumns)} {
            $path configure -bordercursor sb_h_double_arrow
            bind $path <Button1-Motion> "if {\[info exists ::dataTable::($this,borderHit)\]} {%W border dragto %x %y}"
        } else {
            $path configure -bordercursor {}
        }
        set ($this,swap) 0
        if {[string length $composite::($this,-view)] > 0} {
            catch {set ($this,swap) [set $composite::($this,-view)(swap)]}
        }
        $path tag configure lastcell -borderwidth 1
        $path tag configure lastcolumn -borderwidth {1 1 1 0}
        $path tag configure lastrow -background {} -borderwidth {1 0 1 1}
        if {$($this,swap)} {
            $path configure -cols 1 -titlecols 1 -colorigin -1
        } else {
            $path configure -rows 1 -titlerows 1 -roworigin -1
        }
        setupDataView $this
        set ($this,dataRows) {}
        set ($this,tipper) [new ::tk::table::rightColumnTipper $path]
    }

    proc ~dataTable {this} {
        variable ${this}data

        if {[string length $composite::($this,-data)] > 0} {
            dataTrace::unregister $this $composite::($this,-data)
        }
        catch {unset ${this}data}
        delete $($this,tipper)
        if {[info exists ($this,arrow)]} {delete $($this,arrow)}
        if {[info exists ($this,tips)]} {eval delete $($this,tips)}
        if {[info exists ($this,drag)]} {delete $($this,drag)}
        if {[info exists ($this,selector)]} {
            delete $($this,selector)
        }
        ldelete (list) $this
    }

    proc options {this} {
        return [list            [list -background {} {}]            [list -columnwidths {} {}]            [list -data {} {}]            [list -draggable 0 0]            [list -leftcolumn 0 0]            [list -resizablecolumns 0 0]            [list -toprow 0 0]            [list -view {} {}]        ]
    }

    proc set-background {this value} {
        $($this,tablePath) configure -background $value
    }

    proc set-columnwidths {this value} {
        if {$composite::($this,complete)} {
            updateColumnWidths $this
        }
    }

    proc set-data {this value} {
        if {$composite::($this,complete)} {
            error {option -data cannot be set dynamically}
        }
        if {![array exists $value]} {
            error "\"$value\" argument is not an existing array"
        }
    }

    proc set-draggable {this value} {
        if {$composite::($this,complete)} {
            error {option -draggable cannot be set dynamically}
        }
        if {!$value} return
        set path $($this,tablePath)
        set ($this,drag) [new dragSite -path $path -validcommand "dataTable::validateDrag $this"]
        dragSite::provide $($this,drag) DATACELLS "dataTable::dragData $this"

        set ($this,selector) [new tableSelector -selectcommand "dataTable::setCellsState $this"]
        bind $path <Control-ButtonPress-1> "dataTable::toggleSelection $this %x %y"
        bind $path <Shift-ButtonPress-1> "dataTable::extendSelection $this %x %y"
    }

    proc set-view {this value} {
        if {$composite::($this,complete)} {
            error {option -view cannot be set dynamically}
        }
        if {![array exists $value]} {
            error "\"$value\" argument is not an existing array"
        }
    }

    proc set-leftcolumn {this value} {
        if {$composite::($this,complete)} {
            error {option -leftcolumn cannot be set dynamically}
        }
        set ($this,leftColumn) $value
    }

    proc set-resizablecolumns {this value} {
        if {$composite::($this,complete)} {
            error {option -resizablecolumns cannot be set dynamically}
        }
    }

    proc set-toprow {this value} {
        if {$composite::($this,complete)} {
            error {option -toprow cannot be set dynamically}
        }
        set ($this,topRow) $value
    }

    proc selectable {this x y} {
        if {$($this,swap)} {set option cols} else {set option rows}
        if {[$($this,tablePath) cget -$option] <= 1} {return {}}
        set cell [$($this,tablePath) index @$x,$y]
        scan $cell %d,%d row column
        if {($row >= 0) && ($column >= 0)} {
            return $cell
        } else {
            return {}
        }
    }

    proc buttonPress {this x y} {
        if {$composite::($this,-resizablecolumns)} {
            foreach {row column} [$($this,tablePath) border mark $x $y] {}
            if {[info exists column] && ([string length $column] > 0) && ($column < ([$($this,tablePath) cget -cols] - 1))} {
                set ($this,borderHit) {}
                return
            }
        }
        if {$composite::($this,-draggable) && ([string length [set selected [selectable $this $x $y]]] > 0)} {
            foreach cell [selector::selected $($this,selector)] {
                if {[string equal $cell $selected]} return
            }
            selector::select $($this,selector) $selected
        }
    }

    proc buttonRelease {this x y extended} {
        if {[info exists ($this,borderHit)]} {
            unset ($this,borderHit)
        } elseif {$composite::($this,-draggable) && ([string length [set selected [selectable $this $x $y]]] > 0) && !$extended} {
            set cells [selector::selected $($this,selector)]
            foreach cell $cells {
                if {[string equal $cell $selected]} {
                    selector::select $($this,selector) $selected
                    return
                }
            }
        }
    }

    proc lineSort {this dataColumn} {
        if {$dataColumn == $($this,dataSortColumn)} {
            if {[string equal $($this,sortOrder) increasing]} {
                set ($this,sortOrder) decreasing
            } else {
                set ($this,sortOrder) increasing
            }
        } else {
            set ($this,dataSortColumn) $dataColumn
            set ($this,sortOrder) increasing
        }
        if {[info exists ($this,selector)]} {
            selector::clear $($this,selector)
        }
        update $this
    }

    proc update {this} {
        upvar #0 $composite::($this,-data) data

        set path $($this,tablePath)
        set lists {}
        set rows {}
        if {[catch {set dataSortColumn $($this,dataSortColumn)}]} {
            foreach name [array names data *,0] {
                scan $name %lu dataRow
                lappend rows $dataRow
            }
            set rows [sortRows $rows]
        } else {
            set type $data($dataSortColumn,type)
            switch $type {
                integer - real {
                    set extreme $(extreme,$type)
                    foreach name [array names data *,$dataSortColumn] {
                        scan $name %lu dataRow
                        if {[string equal $data($dataRow,$dataSortColumn) ?]} {
                            lappend lists [list $dataRow $extreme]
                        } else {
                            lappend lists [list $dataRow $data($dataRow,$dataSortColumn)]
                        }
                    }
                    foreach pair [lsort -$($this,sortOrder) -$type -index 1 $lists] {
                        lappend rows [lindex $pair 0]
                    }
                }
                default {
                    foreach name [array names data *,$dataSortColumn] {
                        scan $name %lu dataRow
                        lappend lists [list $dataRow $data($dataRow,$dataSortColumn)]
                    }
                    if {[string equal $type clock]} {
                        set list [lsort -$($this,sortOrder) -index 1 -command compareClocks $lists]
                    } else {
                        set list [lsort -$($this,sortOrder) -$type -index 1 $lists]
                    }
                    foreach pair $list {
                        lappend rows [lindex $pair 0]
                    }
                }
            }
        }
        set ($this,dataRows) $rows
        catch {$path tag cell {} [$path tag cell lastcell]}
        if {$($this,swap)} {
            catch {$path tag col {} [$path tag col lastcolumn]}
            foreach {old new} [swap $this $rows] {}
        } else {
            catch {$path tag row {} [$path tag row lastrow]}
            foreach {old new} [copy $this $rows] {}
        }
        if {[info exists ($this,selector)]} {
            set changed 0
            if {[llength $new] > 0} {
                selector::add $($this,selector) $new
                set changed 1
            }
            if {[llength $old] > 0} {
                selector::remove $($this,selector) $old
                set changed 1
            }
            if {$changed} {
                selector::clear $($this,selector)
            }
        }
        if {[info exists ($this,leftColumn)]} {
            $path xview $($this,leftColumn)
            unset ($this,leftColumn)
        }
        if {[info exists ($this,topRow)]} {
            $path yview $($this,topRow)
            unset ($this,topRow)
        }
        if {!$composite::($this,-resizablecolumns)} {
            adjustTableColumns $path
        }
        drawTableLimits $this
        updateCellsColor $this
    }

    proc copy {this dataRows} {
        variable ${this}data
        upvar #0 $composite::($this,-data) data

        set path $($this,tablePath)
        set row 0
        set rows {}
        foreach dataRow $dataRows {
            if {![info exists ${this}data($row,dataRow)]} {
                lappend rows $row
            }
            set ${this}data($row,dataRow) $dataRow
            set column 0
            set lines 1
            foreach dataColumn $($this,dataColumns) {
                set count [linesCount [set ${this}data($row,$column) $data($dataRow,$dataColumn)]]
                if {$count > $lines} {set lines $count}
                incr column
            }
            $path height $row $lines
            incr row
        }
        $path configure -rows [expr {$row + 1}]
        set newCells {}
        set columns [llength $($this,dataColumns)]
        if {[llength $rows] > 0} {
            foreach new $rows {
                for {set column 0} {$column < $columns} {incr column} {
                    lappend newCells $new,$column
                }
            }
        }
        set oldCells {}
        set rows {}
        while {[info exists ${this}data($row,dataRow)]} {
            lappend rows $row
            incr row
        }
        if {[llength $rows] > 0} {
            foreach old $rows {
                unset ${this}data($old,dataRow)
                for {set column 0} {$column < $columns} {incr column} {
                    lappend oldCells $old,$column
                    unset ${this}data($old,$column)
                }
            }
        }
        return [list $oldCells $newCells]
    }

    proc swap {this dataRows} {
        variable ${this}data
        upvar #0 $composite::($this,-data) data

        set path $($this,tablePath)
        set numberOfRows [llength $($this,dataColumns)]
        for {set row 0} {$row < $numberOfRows} {incr row} {
            set lines($row) $($this,height,$row)
        }
        set column 0
        set columns {}
        foreach dataRow $dataRows {
            if {![info exists ${this}data($column,dataRow)]} {
                lappend columns $column
            }
            set ${this}data($column,dataRow) $dataRow
            set row 0
            foreach dataColumn $($this,dataColumns) {
                set count [linesCount [set ${this}data($row,$column) $data($dataRow,$dataColumn)]]
                if {$count > $lines($row)} {
                    set lines($row) $count
                }
                incr row
            }
            incr column
        }
        for {set row 0} {$row < $numberOfRows} {incr row} {
            $path height $row $lines($row)
        }
        $path configure -cols [expr {$column + 1}]
        set newCells {}
        if {[llength $columns] > 0} {
            foreach new $columns {
                for {set row 0} {$row < $numberOfRows} {incr row} {
                    lappend newCells $row,$new
                }
            }
        }
        set oldCells {}
        set columns {}
        while {[info exists ${this}data($column,dataRow)]} {
            lappend columns $column
            incr column
        }
        if {[llength $columns] > 0} {
            foreach old $columns {
                unset ${this}data($old,dataRow)
                for {set row 0} {$row < $numberOfRows} {incr row} {
                    lappend oldCells $row,$old
                    unset ${this}data($row,$old)
                }
            }
        }
        return [list $oldCells $newCells]
    }

    proc dragData {this format} {
        variable ${this}data

        set data $composite::($this,-data)
        set coordinates {}
        foreach cell [selector::selected $($this,selector)] {
            scan $cell %d,%d row column
            lappend coordinates $row $column
        }
        set list {}
        if {$($this,swap)} {
            foreach {row column} $coordinates {
                lappend list ${data}([set ${this}data($column,dataRow)],[set ${this}data($row,dataColumn)])
            }
        } else {
            foreach {row column} $coordinates {
                lappend list ${data}([set ${this}data($row,dataRow)],[set ${this}data($column,dataColumn)])
            }
        }
        return $list
    }

    proc validateDrag {this x y} {
        if {[info exists ($this,borderHit)]} {
            return 0
        }
        if {            (!$($this,swap) && ([$($this,tablePath) cget -rows] <= 1)) || ($($this,swap) && ([$($this,tablePath) cget -cols] <= 1))        } {
            return 1
        }
        return [expr {[lsearch -exact [selector::selected $($this,selector)] [$($this,tablePath) index @$x,$y]] >= 0}]
    }

    proc setCellsState {this cells select} {
        set path $($this,tablePath)
        if {$select} {
            foreach cell $cells {
                $path selection set $cell
            }
        } else {
            foreach cell $cells {
                $path selection clear $cell
            }
        }
    }

    proc toggleSelection {this x y} {
        set cell [$($this,tablePath) index @$x,$y]
        scan $cell %d,%d row column
        if {($row < 0) || ($column < 0)} return
        selector::toggle $($this,selector) $cell
    }

    proc extendSelection {this x y} {
        set cell [$($this,tablePath) index @$x,$y]
        scan $cell %d,%d row column
        if {($row < 0) || ($column < 0)} return
        selector::extend $($this,selector) $cell
    }

    proc updateSortingArrow {this line} {
        set path $widget::($($this,arrow),path)
        set label $($this,tablePath).$line.label
        foreach event {<Enter> <Leave> <ButtonRelease-1>} {
            bind $path $event [bind $label $event]
        }
        array set direction {0,0 up 0,1 down 1,0 left 1,1 right}
        widget::configure $($this,arrow) -direction $direction($($this,swap),[string equal $($this,sortOrder) increasing])
        if {[string equal $::tcl_platform(platform) windows]} {
            widget::configure $($this,arrow) -height [winfo reqheight $label]
        }
        grid $path -in $($this,tablePath).$line -row 0 -column 1
    }

    proc createTitles {this} {
        upvar #0 $composite::($this,-data) data

        set path $($this,tablePath)
        set sortable [info exists ($this,dataSortColumn)]
        set sortTipText [mc {click to toggle sorting order}]
        set arrowWidth 12
        set line 0
        if {$($this,swap)} {
            $path configure -rows [llength $($this,dataColumns)]
        } else {
            $path configure -cols [llength $($this,dataColumns)]
        }
        set lines 1
        foreach dataColumn $($this,dataColumns) {
            set frame [frame $path.$line -cursor left_ptr]
            set label [label $path.$line.label -font $font::(mediumBold) -text $data($dataColumn,label) -cursor left_ptr -pady 0]
            grid columnconfigure $frame 0 -weight 1
            if {$sortable} {
                grid columnconfigure $frame 1 -minsize $arrowWidth
            }
            grid $label -row 0 -column 0 -sticky nsew
            set count [linesCount $data($dataColumn,label)]
            if {$($this,swap)} {
                set cell $line,-1
                set ($this,height,$line) $count
                if {$count > 1} {$path height $line $count}
            } else {
                set cell -1,$line
                if {$count > $lines} {$path height -1 [set lines $count]}
            }
            $path window configure $cell -window $frame -padx 2 -pady 1 -sticky nsew
            if {$sortable} {
                bind $frame <ButtonRelease-1> "dataTable::lineSort $this $dataColumn; dataTable::updateSortingArrow $this $line"
                bind $label <ButtonRelease-1> "dataTable::lineSort $this $dataColumn; dataTable::updateSortingArrow $this $line"
                bind $frame <Enter> "lifoLabel::push $global::messenger [list $sortTipText]"
                bind $frame <Leave> "lifoLabel::pop $global::messenger"
            }
            lappend ($this,tips) [new widgetTip -path $label -text $data($dataColumn,message)]
            incr line
        }
        updateColumnWidths $this
        if {$sortable} {
            set arrow [new arrowButton $path -state disabled -borderwidth 0 -highlightthickness 0 -width $arrowWidth]
            widget::configure $arrow -disabledforeground [widget::cget $arrow -foreground]
            set path $widget::($arrow,path)
            $path configure -cursor left_ptr
            bind $path <ButtonRelease-1> "dataTable::lineSort $this $dataColumn; dataTable::updateSortingArrow $this $line"
            lappend ($this,tips) [new widgetTip -path $widget::($arrow,path) -text $sortTipText]
            set ($this,arrow) $arrow
        }
    }

    proc setupDataView {this} {
        variable ${this}data

        if {[string length $composite::($this,-data)] == 0} return
        if {[string length $composite::($this,-view)] > 0} {
            upvar #0 $composite::($this,-view) data
        } else {
            upvar #0 $composite::($this,-data) data
        }
        catch {set columns $data(visibleColumns)}
        catch {set columns $data(indices)}
        if {![info exists columns]} {
            set columns {}
            foreach name [array names data *,label] {
                if {[scan $name %u column] > 0} {
                    lappend columns $column
                }
            }
        }
        set ($this,dataColumns) [lsort -integer $columns]
        if {[info exists data(sort)]} {
            set ($this,dataSortColumn) [lindex $data(sort) 0]
            if {[lsearch -exact $columns $($this,dataSortColumn)] < 0} {
                error "sort column $($this,dataSortColumn) is not visible"
            }
            set ($this,sortOrder) [lindex $data(sort) 1]
        }
        set line 0
        foreach dataColumn $($this,dataColumns) {
            set ${this}data($line,dataColumn) $dataColumn
            if {[info exists ($this,dataSortColumn)] && ($dataColumn == $($this,dataSortColumn))} {
                set sortLineIndex $line
            }
            incr line
        }
        catch {composite::configure $this -swap $data(swap)}
        createTitles $this
        drawTableLimits $this
        if {[info exists sortLineIndex]} {
            updateSortingArrow $this $sortLineIndex
        }
        setupLinesAnchoring $this
        dataTrace::register $this $composite::($this,-data) "dataTable::update $this"
    }

    proc updateColumnWidths {this} {
        if {!$composite::($this,-resizablecolumns)} return
        set path $($this,tablePath)
        if {$($this,swap)} {
            set column -1
        } else {
            set column 0
        }
        foreach width $composite::($this,-columnwidths) {
            $path width $column $width
            if {[incr column] >= [$path cget -cols]} return
        }
    }

    proc initializationConfiguration {this} {
        set path $($this,tablePath)
        if {$($this,swap)} {
            set column -1
        } else {
            set column 0
        }
        for {} {$column < [$path cget -cols]} {incr column} {
            lappend widths [$path width $column]
        }
        if {$composite::($this,-resizablecolumns)} {
            set list [list -columnwidths $widths]
        } else {
            set list {}
        }
        set row [expr {round([lindex [$path yview] 0] * [$path cget -rows])}]
        if {$row != 0} {
            lappend list -toprow $row
        }
        set column [expr {round([lindex [$path xview] 0] * [$path cget -cols])}]
        if {$column != 0} {
            lappend list -leftcolumn $column
        }
        return $list
    }

    proc setupLinesAnchoring {this} {
        upvar #0 $composite::($this,-data) data

        set line -1
        set path $($this,tablePath)
        foreach dataColumn $($this,dataColumns) {
            incr line
            if {[catch {set anchor $data($dataColumn,anchor)}]} continue
            switch $anchor {
                center {
                    continue
                }
                left - right {}
                default {
                    error "bad anchor value \"$anchor\": must be center, left or right"
                }
            }
            if {![$path tag exists $anchor]} {
                array set convert {left w right e}
                $path tag configure $anchor -anchor $convert($anchor)
            }
            if {$($this,swap)} {
                if {$line == [$path index end row]} {
                    $path tag configure lastrow -anchor $convert($anchor)
                } else {
                    $path tag row $anchor $line
                }
            } else {
                if {$line == [$path index end col]} {
                    $path tag configure lastcolumn -anchor $convert($anchor)
                } else {
                    $path tag col $anchor $line
                }
            }
        }
    }

    proc cellThresholdCondition {array row column} {
        set color [viewer::cellThresholdColor $array $row $column]
        foreach table $(list) {
            if {[string equal $composite::($table,-data) $array]} {
                setCellColor $table $row $column $color
            }
        }
    }

    proc setCellColor {this dataRow dataColumn color} {
        variable ${this}color

        set row [lsearch -exact $($this,dataRows) $dataRow]
        if {$row < 0} return
        set column [lsearch -exact $($this,dataColumns) $dataColumn]
        if {$column < 0} return
        if {$($this,swap)} {
            set index $row
            set row $column
            set column $index
        }
        set path $($this,tablePath)
        set corner [expr {($row == [$path index end row]) && ($column == [$path index end col])}]
        if {[string length $color] == 0} {
            $path tag cell {} $row,$column
            if {$corner} {
                $path tag cell lastcell $row,$column
            }
            catch {unset ${this}color($dataRow,$dataColumn)}
        } else {
            $path tag configure color$color -background $color
            if {$corner} {
                $path tag raise color$color
                $path tag configure color$color -borderwidth 1
            }
            $path tag cell color$color $row,$column
            set ${this}color($dataRow,$dataColumn) $color
        }
    }

    proc updateCellsColor {this} {
        variable ${this}color

        set path $($this,tablePath)
        foreach tag [$path tag names color*] {
            $path tag delete $tag
        }
        foreach {cell color} [array get ${this}color] {
            scan $cell %lu,%u dataRow dataColumn
            setCellColor $this $dataRow $dataColumn $color
        }
    }

    proc drawTableLimits {this} {
        set path $($this,tablePath)
        set row [$path index end row]
        set column [$path index end col]
        if {$($this,swap)} {
            $path tag row lastrow [$path index end row]
            if {$column < 0} {
                $path configure -borderwidth {1 1 1 0}
                $path window configure $row,-1 -borderwidth 1
            } else {
                $path configure -borderwidth {1 0 1 0}
                $path window configure $row,-1 -borderwidth {1 0 1 1}
                $path tag col lastcolumn $column
                $path tag cell lastcell $row,$column
            }
        } else {
            $path tag col lastcolumn [$path index end col]
            if {$row < 0} {
                $path configure -borderwidth {1 0 1 1}
                $path window configure -1,$column -borderwidth 1
            } else {
                $path configure -borderwidth {1 0 1 0}
                $path window configure -1,$column -borderwidth {1 1 1 0}
                $path tag row lastrow $row
                $path tag cell lastcell $row,$column
            }
        }
    }

if {[package vcompare $::tcl_version 8.4] < 0} {
    proc sortRows {list} {
        return [lsort -real $list]
    }
} else {
    proc compareUnsigned64Bits {value1 value2} {
        return [expr {$value1 == $value2? 0: (($value1 ^ $value2) > 0? ($value1 < $value2? -1: 1): ($value1 < 0? 1: -1))}]
    }
    proc sortRows {list} {
        return [lsort -command compareUnsigned64Bits $list]
    }
}

    proc monitoring {cell} {
        set tables {}
        foreach table $(list) {
            if {[monitored $table $cell]} {
                lappend tables $table
            }
        }
        return $tables
    }

    proc monitored {this cell} {
        viewer::parse $cell array row column type
        return [expr {            [string equal $composite::($this,-data) $array] &&            ([lsearch -exact $($this,dataRows) $row] >= 0) && ([lsearch -exact $($this,dataColumns) $column] >= 0)        }]
    }

    proc updateTitleLabels {this} {
        upvar #0 $composite::($this,-data) data

        set path $($this,tablePath)
        set line 0
        foreach dataColumn $($this,dataColumns) {
            $path.$line.label configure -text $data($dataColumn,label)
            incr line
        }
        updateColumnWidths $this
    }

    proc dataRow {this row} {
        variable ${this}data

        set return {}
        catch {set return [set ${this}data($row,dataRow)]}
        return $return
    }

}


class lastWish {

    proc lastWish {this command} {
        set ($this,command) $command
    }

    proc ~lastWish {this} {
        uplevel #0 $($this,command)
    }

}
# Simple HTML display library by Stephen Uhler (stephen.uhler@sun.com)
# Copyright (c) 1995 by Sun Microsystems
# Version 0.3 Fri Sep  1 10:47:17 PDT 1995
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# To use this package,  create a text widget (say, .text)
# and set a variable full of html, (say $html), and issue:
#	HMinit_win .text
#	HMparse_html $html "HMrender .text"
# You also need to supply the routine:
#   proc HMlink_callback {win href} { ...}
#      win:  The name of the text widget
#      href  The name of the link
# which will be called anytime the user "clicks" on a link.
# The supplied version just prints the link to stdout.
# In addition, if you wish to use embedded images, you will need to write
#   proc HMset_image {handle src}
#      handle  an arbitrary handle (not really)
#      src     The name of the image
# Which calls
#	HMgot_image $handle $image
# with the TK image.
#
# To return a "used" text widget to its initialized state, call:
#   HMreset_win .text
# See "sample.tcl" for sample usage
##################################################################
############################################
# mapping of html tags to text tag properties
# properties beginning with "T" map directly to text tags

# These are Defined in HTML 2.0



set ::htmlLibraryCode {


array set HMtag_map {
	b      {weight bold}
	blockquote	{style i indent 1 Trindent rindent}
	bq		{style i indent 1 Trindent rindent}
	cite   {style i}
	code   {family courier}
	dfn    {style i}
	dir    {indent 1}
	dl     {indent 1}
	em     {style i}
	h1     {size 24 weight bold}
	h2     {size 22}
	h3     {size 20}
	h4     {size 18}
	h5     {size 16}
	h6     {style i}
	i      {style i}
	kbd    {family courier weight bold}
	menu     {indent 1}
	ol     {indent 1}
	pre    {fill 0 family courier Tnowrap nowrap}
	samp   {family courier}
	strong {weight bold}
	tt     {family courier}
	u	 {Tunderline underline}
	ul     {indent 1}
	var    {style i}
}

# These are in common(?) use, but not defined in html2.0

array set HMtag_map {
	center {Tcenter center}
	strike {Tstrike strike}
	u	   {Tunderline underline}
}

# initial values

set HMtag_map(hmstart) {
	family times   weight medium   style r   size 14
	Tcenter ""   Tlink ""   Tnowrap ""   Tunderline ""   list list
	fill 1   indent "" counter 0 adjust 0
}

# html tags that insert white space

array set HMinsert_map {
	blockquote "\n\n" /blockquote "\n"
	br	"\n"
	dd	"\n" /dd	"\n"
	dl	"\n" /dl	"\n"
	dt	"\n"
	form "\n"	/form "\n"
	h1	"\n\n"	/h1	"\n"
	h2	"\n\n"	/h2	"\n"
	h3	"\n\n"	/h3	"\n"
	h4	"\n"	/h4	"\n"
	h5	"\n"	/h5	"\n"
	h6	"\n"	/h6	"\n"
	li   "\n"
	/dir "\n"
	/ul "\n"
	/ol "\n"
	/menu "\n"
	p	"\n\n"
	pre "\n"	/pre "\n"
}

# tags that are list elements, that support "compact" rendering

array set HMlist_elements {
	ol 1   ul 1   menu 1   dl 1   dir 1
}
############################################
# initialize the window and stack state

proc HMinit_win {win} {
	upvar #0 HM$win var

	HMinit_state $win
	$win tag configure underline -underline 1
	$win tag configure center -justify center
	$win tag configure nowrap -wrap none
	$win tag configure rindent -rmargin $var(S_tab)c
	$win tag configure strike -overstrike 1
	$win tag configure mark -foreground red		;# list markers
	$win tag configure list -spacing1 3p -spacing3 3p		;# regular lists
	$win tag configure compact -spacing1 0p		;# compact lists
	$win tag configure link -borderwidth 2 -foreground blue	;# hypertext links
	HMset_indent $win $var(S_tab)
	$win configure -wrap word

	# configure the text insertion point
	$win mark set $var(S_insert) 1.0

	# for horizontal rules
	$win tag configure thin -font [HMx_font times 2 medium r]
	$win tag configure hr -relief sunken -borderwidth 2 -wrap none 		-tabs [winfo width $win]
	bind $win <Configure> {
		%W tag configure hr -tabs %w
		%W tag configure last -spacing3 %h
	}

	# generic link enter callback

	$win tag bind link <1> "HMlink_hit $win %x %y"
}

# set the indent spacing (in cm) for lists
# TK uses a "weird" tabbing model that causes \t to insert a single
# space if the current line position is past the tab setting

proc HMset_indent {win cm} {
	set tabs [expr {$cm/2.0}]
	$win configure -tabs ${tabs}c
	foreach i {1 2 3 4 5 6 7 8 9} {
		set tab [expr {$i*$cm}]
		$win tag configure indent$i -lmargin1 ${tab}c -lmargin2 ${tab}c 			-tabs "[expr {$tab+$tabs}]c [expr {$tab+2*$tabs}]c"
	}
}

# reset the state of window - get ready for the next page
# remove all but the font tags, and remove all form state

proc HMreset_win {win} {
	upvar #0 HM$win var
	regsub -all { +[^L ][^ ]*} " [$win tag names] " {} tags
	catch "$win tag delete $tags"
	eval $win mark unset [$win mark names]
	$win delete 0.0 end
	$win tag configure hr -tabs [winfo width $win]

	# configure the text insertion point
	$win mark set $var(S_insert) 1.0

	# remove form state.  If any check/radio buttons still exists,
	# their variables will be magically re-created, and never get
	# cleaned up.
	catch unset [info globals HM$win.form*]

	HMinit_state $win
	return HM$win
}

# initialize the window's state array
# Parameters beginning with S_ are NOT reset
#  adjust_size:		global font size adjuster
#  unknown:		character to use for unknown entities
#  tab:			tab stop (in cm)
#  stop:		enabled to stop processing
#  update:		how many tags between update calls
#  tags:		number of tags processed so far
#  symbols:		Symbols to use on un-ordered lists

proc HMinit_state {win} {
	upvar #0 HM$win var
	array set tmp [array get var S_*]
	catch {unset var}
	array set var {
		stop 0
		tags 0
		fill 0
		list list
		S_adjust_size 0
		S_tab 1.0
		S_unknown \xb7
		S_update 10
		S_symbols O*=+-o\xd7\xb0>:\xb7
		S_insert Insert
	}
	array set var [array get tmp]
}

# alter the parameters of the text state
# this allows an application to over-ride the default settings
# it is called as: HMset_state -param value -param value ...

array set HMparam_map {
	-update S_update
	-tab S_tab
	-unknown S_unknown
	-stop S_stop
	-size S_adjust_size
	-symbols S_symbols
    -insert S_insert
}

proc HMset_state {win args} {
	upvar #0 HM$win var
	global HMparam_map
	set bad 0
	if {[catch {array set params $args}]} {return 0}
	foreach i [array names params] {
		incr bad [catch {set var($HMparam_map($i)) $params($i)}]
	}
	return [expr {$bad==0}]
}

############################################
# manage the display of html

# HMrender gets called for every html tag
#   win:   The name of the text widget to render into
#   tag:   The html tag (in arbitrary case)
#   not:   a "/" or the empty string
#   param: The un-interpreted parameter list
#   text:  The plain text until the next html tag

proc HMrender {win tag not param text} {
    if {![winfo exists $win]} return
	upvar #0 HM$win var
	if {$var(stop)} return
	global HMtag_map HMinsert_map HMlist_elements
	set tag [string tolower $tag]
	set text [HMmap_esc $text]

	# manage compact rendering of lists
	if {[info exists HMlist_elements($tag)]} {
		set list "list [expr {[HMextract_param $param compact] ? "compact" : "list"}]"
	} else {
		set list ""
	}

	# Allow text to be diverted to a different window (for tables)
	# this is not currently used
	if {[info exists var(divert)]} {
		set win $var(divert)
		upvar #0 HM$win var
	}

	# adjust (push or pop) tag state
	catch {HMstack $win $not "$HMtag_map($tag) $list"}

	# insert white space (with current font)
	# adding white space can get a bit tricky.  This isn't quite right
	set bad [catch {$win insert $var(S_insert) $HMinsert_map($not$tag) "space $var(font)"}]
	if {!$bad && [lindex $var(fill) end]} {
		set text [string trimleft $text]
	}

	# to fill or not to fill
	if {[lindex $var(fill) end]} {
		set text [HMzap_white $text]
	}

	# generic mark hook
	catch {HMmark $not$tag $win $param text} err

	# do any special tag processing
	catch {HMtag_$not$tag $win $param text} msg


	# add the text with proper tags

	set tags [HMcurrent_tags $win]
	$win insert $var(S_insert) $text $tags

	# We need to do an update every so often to insure interactive response.
	# This can cause us to re-enter the event loop, and cause recursive
	# invocations of HMrender, so we need to be careful.
	if {!([incr var(tags)] % $var(S_update))} {
		update
	}
}

# html tags requiring special processing
# Procs of the form HMtag_<tag> or HMtag_</tag> get called just before
# the text for this tag is displayed.  These procs are called inside a
# "catch" so it is OK to fail.
#   win:   The name of the text widget to render into
#   param: The un-interpreted parameter list
#   text:  A pass-by-reference name of the plain text until the next html tag
#          Tag commands may change this to affect what text will be inserted
#          next.

# A pair of pseudo tags are added automatically as the 1st and last html
# tags in the document.  The default is <HMstart> and </HMstart>.
# Append enough blank space at the end of the text widget while
# rendering so HMgoto can place the target near the top of the page,
# then remove the extra space when done rendering.

proc HMtag_hmstart {win param text} {
	upvar #0 HM$win var
	$win mark gravity $var(S_insert) left
	$win insert end "\n " last
	$win mark gravity $var(S_insert) right
}

proc HMtag_/hmstart {win param text} {
	$win delete last.first end
}

# put the document title in the window banner, and remove the title text
# from the document

proc HMtag_title {win param text} {
	upvar 1 $text data
	wm title [winfo toplevel $win] $data
	set data ""
}

proc HMtag_hr {win param text} {
	upvar #0 HM$win var
	$win insert $var(S_insert) "\n" space "\n" thin "\t" "thin hr" "\n" thin
}

# list element tags

proc HMtag_ol {win param text} {
	upvar #0 HM$win var
	set var(count$var(level)) 0
}

proc HMtag_ul {win param text} {
	upvar #0 HM$win var
	catch {unset var(count$var(level))}
}

proc HMtag_menu {win param text} {
	upvar #0 HM$win var
	set var(menu) ->
	set var(compact) 1
}

proc HMtag_/menu {win param text} {
	upvar #0 HM$win var
	catch {unset var(menu)}
	catch {unset var(compact)}
}

proc HMtag_dt {win param text} {
	upvar #0 HM$win var
	upvar 1 $text data
	set level $var(level)
	incr level -1
	$win insert $var(S_insert) "$data" 		"hi [lindex $var(list) end] indent$level $var(font)"
	set data {}
}

proc HMtag_li {win param text} {
	upvar #0 HM$win var
	set level $var(level)
	incr level -1
	set x [string index $var(S_symbols)+-+-+-+-" $level]
	catch {set x [incr var(count$level)]}
	catch {set x $var(menu)}
	$win insert $var(S_insert) \t$x\t "mark [lindex $var(list) end] indent$level $var(font)"
}

# Manage hypertext "anchor" links.  A link can be either a source (href)
# a destination (name) or both.  If its a source, register it via a callback,
# and set its default behavior.  If its a destination, check to see if we need
# to go there now, as a result of a previous HMgoto request.  If so, schedule
# it to happen with the closing </a> tag, so we can highlight the text up to
# the </a>.

proc HMtag_a {win param text} {
	upvar #0 HM$win var

	# a source

	if {[HMextract_param $param href]} {
		set var(Tref) [list L:$href]
		HMstack $win "" "Tlink link"
		HMlink_setup $win $href
	}

	# a destination

	if {[HMextract_param $param name]} {
		set var(Tname) [list N:$name]
		HMstack $win "" "Tanchor anchor"
		$win mark set N:$name "$var(S_insert) - 1 chars"
		$win mark gravity N:$name left
		if {[info exists var(goto)] && $var(goto) == $name} {
			unset var(goto)
			set var(going) $name
		}
	}
}

# The application should call here with the fragment name
# to cause the display to go to this spot.
# If the target exists, go there (and do the callback),
# otherwise schedule the goto to happen when we see the reference.

proc HMgoto {win where {callback HMwent_to}} {
	upvar #0 HM$win var
	if {[regexp N:$where [$win mark names]]} {
		$win yview N:$where
		update
		eval $callback $win [list $where]
		return 1
	} else {
		set var(goto) $where
		return 0
	}
}

# We actually got to the spot, so highlight it!
# This should/could be replaced by the application
# We'll flash it orange a couple of times.

proc HMwent_to {win where {count 0} {color orange}} {
	upvar #0 HM$win var
	if {$count > 5} return
	catch {$win tag configure N:$where -foreground $color}
	update
	after 200 [list HMwent_to $win $where [incr count] 				[expr {$color=="orange" ? "" : "orange"}]]
}

proc HMtag_/a {win param text} {
	upvar #0 HM$win var
	if {[info exists var(Tref)]} {
		unset var(Tref)
		HMstack $win / "Tlink link"
	}

	# goto this link, then invoke the call-back.

	if {[info exists var(going)]} {
		$win yview N:$var(going)
		update
		HMwent_to $win $var(going)
		unset var(going)
	}

	if {[info exists var(Tname)]} {
		unset var(Tname)
		HMstack $win / "Tanchor anchor"
	}
}

#           Inline Images
# This interface is subject to change
# Most of the work is getting around a limitation of TK that prevents
# setting the size of a label to a widthxheight in pixels
#
# Images have the following parameters:
#    align:  top,middle,bottom
#    alt:    alternate text
#    ismap:  A clickable image map
#    src:    The URL link
# Netscape supports (and so do we)
#    width:  A width hint (in pixels)
#    height:  A height hint (in pixels)
#    border: The size of the window border

proc HMtag_img {win param text} {
	upvar #0 HM$win var

	# get alignment
	array set align_map {top top    middle center    bottom bottom}
	set align bottom		;# The spec isn't clear what the default should be
	HMextract_param $param align
	catch {set align $align_map([string tolower $align])}

	# get alternate text
	set alt "<image>"
	HMextract_param $param alt
	set alt [HMmap_esc $alt]

	# get the border width
	set border 1
	HMextract_param $param border

	# see if we have an image size hint
	# If so, make a frame the "hint" size to put the label in
	# otherwise just make the label
	set item $win.$var(tags)
	# catch {destroy $item}
	if {[HMextract_param $param width] && [HMextract_param $param height]} {
		frame $item -width $width -height $height
		pack propagate $item 0
		set label $item.label
		label $label
		pack $label -expand 1 -fill both
	} else {
		set label $item
		label $label
	}

	$label configure -relief ridge -fg orange -text $alt
	catch {$label configure -bd $border}
	$win window create $var(S_insert) -align $align -window $item -pady 2 -padx 2

	# add in all the current tags (this is overkill)
	set tags [HMcurrent_tags $win]
	foreach tag $tags {
		$win tag add $tag $item
	}

	# set imagemap callbacks
	if {[HMextract_param $param ismap]} {
		# regsub -all {[^L]*L:([^ ]*).*}  $tags {\1} link
		set link [lindex $tags [lsearch -glob $tags L:*]]
		regsub L: $link {} link
		global HMevents
		regsub -all {%} $link {%%} link2
		foreach i [array names HMevents] {
			bind $label <$i> "catch \{%W configure $HMevents($i)\}"
		}
		bind $label <1> "+HMlink_callback $win $link2?%x,%y"
	}

	# now callback to the application
	set src ""
	HMextract_param $param src
	HMset_image $win $label $src
	return $label	;# used by the forms package for input_image types
}

# The app needs to supply one of these
proc HMset_image {win handle src} {
	HMgot_image $handle "can't get\n$src"
}

# When the image is available, the application should call back here.
# If we have the image, put it in the label, otherwise display the error
# message.  If we don't get a callback, the "alt" text remains.
# if we have a clickable image, arrange for a callback

proc HMgot_image {win image_error} {
	# if we're in a frame turn on geometry propogation
	if {[string equal [winfo name $win] label]} {
		pack propagate [winfo parent $win] 1
	}
	if {[catch {$win configure -image $image_error}]} {
		$win configure -image {}
		$win configure -text $image_error
	}
}

# Sample hypertext link callback routine - should be replaced by app
# This proc is called once for each <A> tag.
# Applications can overwrite this procedure, as required, or
# replace the HMevents array
#   win:   The name of the text widget to render into
#   href:  The HREF link for this <a> tag.

array set HMevents {
	Enter	{-borderwidth 2 -relief raised }
	Leave	{-borderwidth 2 -relief flat }
	1		{-borderwidth 2 -relief sunken}
	ButtonRelease-1	{-borderwidth 2 -relief raised}
}

# We need to escape any %'s in the href tag name so the bind command
# doesn't try to substitute them.

proc HMlink_setup {win href} {
	global HMevents
	regsub -all {%} $href {%%} href2
	foreach i [array names HMevents] {
		eval {$win tag bind  L:$href <$i>} 			\{$win tag configure \{L:$href2\} $HMevents($i)\}
	}
}

# generic link-hit callback
# This gets called upon button hits on hypertext links
# Applications are expected to supply ther own HMlink_callback routine
#   win:   The name of the text widget to render into
#   x,y:   The cursor position at the "click"

proc HMlink_hit {win x y} {
	set tags [$win tag names @$x,$y]
	set link [lindex $tags [lsearch -glob $tags L:*]]
	# regsub -all {[^L]*L:([^ ]*).*}  $tags {\1} link
	regsub L: $link {} link
	HMlink_callback $win $link
}

# replace this!
#   win:   The name of the text widget to render into
#   href:  The HREF link for this <a> tag.

proc HMlink_callback {win href} {
	puts "Got hit on $win, link $href"
}

# extract a value from parameter list (this needs a re-do)
# returns "1" if the keyword is found, "0" otherwise
#   param:  A parameter list.  It should alredy have been processed to
#           remove any entity references
#   key:    The parameter name
#   val:    The variable to put the value into (use key as default)

proc HMextract_param {param key {val ""}} {

	if {[string length $val]==0} {
		upvar 1 $key result
	} else {
		upvar 1 $val result
	}
    set ws "    \n\r"

    # look for name=value combinations.  Either (') or (") are valid delimeters
    if {
      [regsub -nocase [format {.*%s[%s]*=[%s]*"([^"]*).*} $key $ws $ws] $param {\1} value] ||
      [regsub -nocase [format {.*%s[%s]*=[%s]*'([^']*).*} $key $ws $ws] $param {\1} value] ||
      [regsub -nocase [format {.*%s[%s]*=[%s]*([^%s]+).*} $key $ws $ws $ws] $param {\1} value] } {
        set result $value
        return 1
    }

	# now look for valueless names
	# I should strip out name=value pairs, so we don't end up with "name"
	# inside the "value" part of some other key word - some day

	set bad \[^a-zA-Z\]+
	if {[regexp -nocase  "$bad$key$bad" -$param-]} {
		return 1
	} else {
		return 0
	}
}

# These next two routines manage the display state of the page.

# Push or pop tags to/from stack.
# Each orthogonal text property has its own stack, stored as a list.
# The current (most recent) tag is the last item on the list.
# Push is {} for pushing and {/} for popping

proc HMstack {win push list} {
	upvar #0 HM$win var
	array set tags $list
	if {[string length $push]==0} {
		foreach tag [array names tags] {
			lappend var($tag) $tags($tag)
		}
	} else {
		foreach tag [array names tags] {
			# set cnt [regsub { *[^ ]+$} $var($tag) {} var($tag)]
			set var($tag) [lreplace $var($tag) end end]
		}
	}
}

# extract set of current text tags
# tags starting with T map directly to text tags, all others are
# handled specially.  There is an application callback, HMset_font
# to allow the application to do font error handling

proc HMcurrent_tags {win} {
	upvar #0 HM$win var
	set font font
	foreach i {family size weight style} {
		set $i [lindex $var($i) end]
		append font :[set $i]
	}
	set xfont [HMx_font $family $size $weight $style $var(S_adjust_size)]
	HMset_font $win $font $xfont
	set indent [llength $var(indent)]
	incr indent -1
	lappend tags $font indent$indent
	foreach tag [array names var T*] {
		lappend tags [lindex $var($tag) end]	;# test
	}
	set var(font) $font
	set var(xfont) [$win tag cget $font -font]
	set var(level) $indent
	return $tags
}

# allow the application to do do better font management
# by overriding this procedure

proc HMset_font {win tag font} {
	catch {$win tag configure $tag -font $font} msg
}

# generate an X font name
proc HMx_font {family size weight style {adjust_size 0}} {
#	catch {incr size $adjust_size}
#	return "-*-$family-$weight-$style-normal-*-*-${size}0-*-*-*-*-*-*"
    ### use size in pixels as it is more precise:
	catch {incr size [expr {$adjust_size / 10}]}
	return "-*-$family-$weight-$style-normal-*-$size-*-*-*-*-*-*-*"
}

# Optimize HMrender (hee hee)
# This is experimental

proc HMoptimize {} {
	regsub -all "\n\[ 	\]*#\[^\n\]*" [info body HMrender] {} body
	regsub -all ";\[ 	\]*#\[^\n]*" $body {} body
	regsub -all "\n\n+" $body \n body
	proc HMrender {win tag not param text} $body
}
############################################
# Turn HTML into TCL commands
#   html    A string containing an html document
#   cmd		A command to run for each html tag found
#   start	The name of the dummy html start/stop tags

proc HMparse_html {html {cmd HMtest_parse} {start hmstart}} {
	regsub -all \{ $html {\&ob;} html
	regsub -all \} $html {\&cb;} html
	set w " \t\r\n"	;# white space
	proc HMcl x {return "\[$x\]"}
	set exp <(/?)([HMcl ^$w>]+)[HMcl $w]*([HMcl ^>]*)>
	set sub "\}\n$cmd {\\2} {\\1} {\\3} \{"
	regsub -all $exp $html $sub html
	eval "$cmd {$start} {} {} \{ $html \}"
	eval "$cmd {$start} / {} {}"
}

proc HMtest_parse {command tag slash text_after_tag} {
	puts "==> $command $tag $slash $text_after_tag"
}

# Convert multiple white space into a single space

proc HMzap_white {data} {
	regsub -all "\[ \t\r\n\]+" $data " " data
	return $data
}

# find HTML escape characters of the form &xxx;

proc HMmap_esc {text} {
	if {![regexp & $text]} {return $text}
	regsub -all {([][$\\])} $text {\\\1} new
	regsub -all {&#([0-9][0-9]?[0-9]?);?} 		$new {[format %c [scan \1 %d tmp;set tmp]]} new
	regsub -all {&([a-zA-Z]+);?} $new {[HMdo_map \1]} new
	return [subst $new]
}

# convert an HTML escape sequence into character

proc HMdo_map {text {unknown ?}} {
	global HMesc_map
	set result $unknown
	catch {set result $HMesc_map($text)}
	return $result
}

# table of escape characters (ISO latin-1 esc's are in a different table)

array set HMesc_map {
   lt <   gt >   amp &   quot \"   copy \xa9
   reg \xae   ob \x7b   cb \x7d   nbsp \xa0
}
#############################################################
# ISO Latin-1 escape codes

array set HMesc_map {
	nbsp \xa0 iexcl \xa1 cent \xa2 pound \xa3 curren \xa4
	yen \xa5 brvbar \xa6 sect \xa7 uml \xa8 copy \xa9
	ordf \xaa laquo \xab not \xac shy \xad reg \xae
	hibar \xaf deg \xb0 plusmn \xb1 sup2 \xb2 sup3 \xb3
	acute \xb4 micro \xb5 para \xb6 middot \xb7 cedil \xb8
	sup1 \xb9 ordm \xba raquo \xbb frac14 \xbc frac12 \xbd
	frac34 \xbe iquest \xbf Agrave \xc0 Aacute \xc1 Acirc \xc2
	Atilde \xc3 Auml \xc4 Aring \xc5 AElig \xc6 Ccedil \xc7
	Egrave \xc8 Eacute \xc9 Ecirc \xca Euml \xcb Igrave \xcc
	Iacute \xcd Icirc \xce Iuml \xcf ETH \xd0 Ntilde \xd1
	Ograve \xd2 Oacute \xd3 Ocirc \xd4 Otilde \xd5 Ouml \xd6
	times \xd7 Oslash \xd8 Ugrave \xd9 Uacute \xda Ucirc \xdb
	Uuml \xdc Yacute \xdd THORN \xde szlig \xdf agrave \xe0
	aacute \xe1 acirc \xe2 atilde \xe3 auml \xe4 aring \xe5
	aelig \xe6 ccedil \xe7 egrave \xe8 eacute \xe9 ecirc \xea
	euml \xeb igrave \xec iacute \xed icirc \xee iuml \xef
	eth \xf0 ntilde \xf1 ograve \xf2 oacute \xf3 ocirc \xf4
	otilde \xf5 ouml \xf6 divide \xf7 oslash \xf8 ugrave \xf9
	uacute \xfa ucirc \xfb uuml \xfc yacute \xfd thorn \xfe
	yuml \xff
}

##########################################################
# html forms management commands

# As each form element is located, it is created and rendered.  Additional
# state is stored in a form specific global variable to be processed at
# the end of the form, including the "reset" and "submit" options.
# Remember, there can be multiple forms existing on multiple pages.  When
# HTML tables are added, a single form could be spread out over multiple
# text widgets, which makes it impractical to hang the form state off the
# HM$win structure.  We don't need to check for the existance of required
# parameters, we just "fail" and get caught in HMrender

# This causes line breaks to be preserved in the inital values
# of text areas
array set HMtag_map {
	textarea    {fill 0}
}

##########################################################
# html isindex tag.  Although not strictly forms, they're close enough
# to be in this file

# is-index forms
# make a frame with a label, entry, and submit button

proc HMtag_isindex {win param text} {
	upvar #0 HM$win var

	set item $win.$var(tags)
	if {[winfo exists $item]} {
		destroy $item
	}
	frame $item -relief ridge -bd 3
	set prompt "Enter search keywords here"
	HMextract_param $param prompt
	label $item.label -text [HMmap_esc $prompt] -font $var(xfont)
	entry $item.entry
	bind $item.entry <Return> "$item.submit invoke"
	button $item.submit -text search -font $var(xfont) -command 		[format {HMsubmit_index %s {%s} [HMmap_reply [%s get]]} 		$win $param $item.entry]
	pack $item.label -side top
	pack $item.entry $item.submit -side left

	# insert window into text widget

	$win insert $var(S_insert) \n isindex
	HMwin_install $win $item
	$win insert $var(S_insert) \n isindex
	bind $item <Visibility> {focus %W.entry}
}

# This is called when the isindex form is submitted.
# The default version calls HMlink_callback.  Isindex tags should either
# be deprecated, or fully supported (e.g. they need an href parameter)

proc HMsubmit_index {win param text} {
	HMlink_callback $win ?$text
}

# initialize form state.  All of the state for this form is kept
# in a global array whose name is stored in the form_id field of
# the main window array.
# Parameters: ACTION, METHOD, ENCTYPE

proc HMtag_form {win param text} {
	upvar #0 HM$win var

	# create a global array for the form
	set id HM$win.form$var(tags)
	upvar #0 $id form

	# missing /form tag, simulate it
	if {[info exists var(form_id)]} {
		puts "Missing end-form tag !!!! $var(form_id)"
		HMtag_/form $win {} {}
	}
	catch {unset form}
	set var(form_id) $id

	set form(param) $param		;# form initial parameter list
	set form(reset) ""			;# command to reset the form
	set form(reset_button) ""	;# list of all reset buttons
	set form(submit) ""			;# command to submit the form
	set form(submit_button) ""	;# list of all submit buttons
}

# Where we're done try to get all of the state into the widgets so
# we can free up the form structure here.  Unfortunately, we can't!

proc HMtag_/form {win param text} {
	upvar #0 HM$win var
	upvar #0 $var(form_id) form

	# make submit button entries for all radio buttons
	foreach name [array names form radio_*] {
		regsub radio_ $name {} name
		lappend form(submit) [list $name \$form(radio_$name)]
	}

	# process the reset button(s)

	foreach item $form(reset_button) {
		$item configure -command $form(reset)
	}

	# no submit button - add one
	if {[string length $form(submit_button)]==0} {
		HMinput_submit $win {}
	}

	# process the "submit" command(s)
	# each submit button could have its own name,value pair

	foreach item $form(submit_button) {
		set submit $form(submit)
		catch {lappend submit $form(submit_$item)}
		$item configure -command  				[list HMsubmit_button $win $var(form_id) $form(param) 				$submit]
	}

	# unset all unused fields here
	unset form(reset) form(submit) form(reset_button) form(submit_button)
	unset var(form_id)
}

###################################################################
# handle form input items
# each item type is handled in a separate procedure
# Each "type" procedure needs to:
# - create the window
# - initialize it
# - add the "submit" and "reset" commands onto the proper Q's
#   "submit" is subst'd
#   "reset" is eval'd

proc HMtag_input {win param text} {
	upvar #0 HM$win var

	set type text	;# the default
	HMextract_param $param type
	set type [string tolower $type]
	if {[catch {HMinput_$type $win $param} err]} {
		puts stderr $err
	}
}

# input type=text
# parameters NAME (reqd), MAXLENGTH, SIZE, VALUE

proc HMinput_text {win param {show {}}} {
	upvar #0 HM$win var
	upvar #0 $var(form_id) form

	# make the entry
	HMextract_param $param name		;# required
	set item $win.input_text,$var(tags)
	set size 20; HMextract_param $param size
	set maxlength 0; HMextract_param $param maxlength
	entry $item -width $size -show $show

	# set the initial value
	set value ""; HMextract_param $param value
	$item insert 0 $value

	# insert the entry
	HMwin_install $win $item

	# set the "reset" and "submit" commands
	append form(reset) ";$item delete 0 end;$item insert 0 [list $value]"
	lappend form(submit) [list $name "\[$item get]"]

	# handle the maximum length (broken - no way to cleanup bindtags state)
	if {$maxlength} {
		bindtags $item "[bindtags $item] max$maxlength"
		bind max$maxlength <KeyPress> "%W delete $maxlength end"
	}
}

# password fields - same as text, only don't show data
# parameters NAME (reqd), MAXLENGTH, SIZE, VALUE

proc HMinput_password {win param} {
	HMinput_text $win $param *
}

# checkbuttons are missing a "get" option, so we must use a global
# variable to store the value.
# Parameters NAME, VALUE, (reqd), CHECKED

proc HMinput_checkbox {win param} {
	upvar #0 HM$win var
	upvar #0 $var(form_id) form

	HMextract_param $param name
	HMextract_param $param value

	# Set the global variable, don't use the "form" alias as it is not
	# defined in the global scope of the button
	set variable $var(form_id)(check_$var(tags))
	set item $win.input_checkbutton,$var(tags)
	checkbutton $item -variable $variable -off {} -on $value -text "  "
	if {[HMextract_param $param checked]} {
		$item select
		append form(reset) ";$item select"
	} else {
		append form(reset) ";$item deselect"
	}

	HMwin_install $win $item
	lappend form(submit) [list $name \$form(check_$var(tags))]
}

# radio buttons.  These are like check buttons, but only one can be selected

proc HMinput_radio {win param} {
	upvar #0 HM$win var
	upvar #0 $var(form_id) form

	HMextract_param $param name
	HMextract_param $param value

	set first [expr {![info exists form(radio_$name)]}]
	set variable $var(form_id)(radio_$name)
	set variable $var(form_id)(radio_$name)
	set item $win.input_radiobutton,$var(tags)
	radiobutton $item -variable $variable -value $value -text " "

	HMwin_install $win $item

	if {$first || [HMextract_param $param checked]} {
		$item select
		append form(reset) ";$item select"
	} else {
		append form(reset) ";$item deselect"
	}

	# do the "submit" actions in /form so we only end up with 1 per button grouping
	# contributing to the submission
}

# hidden fields, just append to the "submit" data
# params: NAME, VALUE (reqd)

proc HMinput_hidden {win param} {
	upvar #0 HM$win var
	upvar #0 $var(form_id) form
	HMextract_param $param name
	HMextract_param $param value
	lappend form(submit) [list $name $value]
}

# handle input images.  The spec isn't very clear on these, so I'm not
# sure its quite right
# Use std image tag, only set up our own callbacks
#  (e.g. make sure ismap isn't set)
# params: NAME, SRC (reqd) ALIGN

proc HMinput_image {win param} {
	upvar #0 HM$win var
	upvar #0 $var(form_id) form
	HMextract_param $param name
	set name		;# barf if no name is specified
	set item [HMtag_img $win $param {}]
	$item configure -relief raised -bd 2 -bg blue

	# make a dummy "submit" button, and invoke it to send the form.
	# We have to get the %x,%y in the value somehow, so calculate it during
	# binding, and save it in the form array for later processing

	set submit $win.dummy_submit,$var(tags)
	if {[winfo exists $submit]} {
		destroy $submit
	}
	button $submit	-takefocus 0;# this never gets mapped!
	lappend form(submit_button) $submit
	set form(submit_$submit) [list $name $name.\$form(X).\$form(Y)]

	$item configure -takefocus 1
	bind $item <FocusIn> "catch \{$win see $item\}"
	bind $item <1> "$item configure -relief sunken"
	bind $item <Return> "
		set $var(form_id)(X) 0
		set $var(form_id)(Y) 0
		$submit invoke
	"
	bind $item <ButtonRelease-1> "
		set $var(form_id)(X) %x
		set $var(form_id)(Y) %y
		$item configure -relief raised
		$submit invoke
	"
}

# Set up the reset button.  Wait for the /form to attach
# the -command option.  There could be more that 1 reset button
# params VALUE

proc HMinput_reset {win param} {
	upvar #0 HM$win var
	upvar #0 $var(form_id) form

	set value reset
	HMextract_param $param value

	set item $win.input_reset,$var(tags)
	button $item -text [HMmap_esc $value]
	HMwin_install $win $item
	lappend form(reset_button) $item
}

# Set up the submit button.  Wait for the /form to attach
# the -command option.  There could be more that 1 submit button
# params: NAME, VALUE

proc HMinput_submit {win param} {
	upvar #0 HM$win var
	upvar #0 $var(form_id) form

	HMextract_param $param name
	set value submit
	HMextract_param $param value
	set item $win.input_submit,$var(tags)
	button $item -text [HMmap_esc $value] -fg blue
	HMwin_install $win $item
	lappend form(submit_button) $item
	# need to tie the "name=value" to this button
	# save the pair and do it when we finish the submit button
	catch {set form(submit_$item) [list $name $value]}
}

#########################################################################
# selection items
# They all go into a list box.  We don't what to do with the listbox until
# we know how many items end up in it.  Gather up the data for the "options"
# and finish up in the /select tag
# params: NAME (reqd), MULTIPLE, SIZE

proc HMtag_select {win param text} {
	upvar #0 HM$win var
	upvar #0 $var(form_id) form

	HMextract_param $param name
	set size 5;  HMextract_param $param size
	set form(select_size) $size
	set form(select_name) $name
	set form(select_values) ""		;# list of values to submit
	if {[HMextract_param $param multiple]} {
		set mode multiple
	} else {
		set mode single
	}
	set item $win.select,$var(tags)
    frame $item
    set form(select_frame) $item
	listbox $item.list -selectmode $mode -width 0 -exportselection 0
	HMwin_install $win $item
}

# select options
# The values returned in the query may be different from those
# displayed in the listbox, so we need to keep a separate list of
# query values.
#  form(select_default) - contains the default query value
#  form(select_frame) - name of the listbox's containing frame
#  form(select_values)  - list of query values
# params: VALUE, SELECTED

proc HMtag_option {win param text} {
	upvar #0 HM$win var
	upvar #0 $var(form_id) form
	upvar 1 $text data
	set frame $form(select_frame)

	# set default option (or options)
	if {[HMextract_param $param selected]} {
        lappend form(select_default) [$form(select_frame).list size]
    }
    set value [string trimright $data " \n"]
    $frame.list insert end $value
	HMextract_param $param value
	lappend form(select_values) $value
	set data ""
}

# do most of the work here!
# if SIZE>1, make the listbox.  Otherwise make a "drop-down"
# listbox with a label in it
# If the # of items > size, add a scroll bar
# This should probably be broken up into callbacks to make it
# easier to override the "look".

proc HMtag_/select {win param text} {
	upvar #0 HM$win var
	upvar #0 $var(form_id) form
	set frame $form(select_frame)
	set size $form(select_size)
	set items [$frame.list size]

	# set the defaults and reset button
	append form(reset) ";$frame.list selection clear 0  $items"
	if {[info exists form(select_default)]} {
		foreach i $form(select_default) {
			$frame.list selection set $i
			append form(reset) ";$frame.list selection set $i"
		}
	} else {
		$frame.list selection set 0
		append form(reset) ";$frame.list selection set 0"
	}

	# set up the submit button. This is the general case.  For single
	# selections we could be smarter

	for {set i 0} {$i < $size} {incr i} {
		set value [format {[expr {[%s selection includes %s] ? {%s} : {}}]} 				$frame.list $i [lindex $form(select_values) $i]]
		lappend form(submit) [list $form(select_name) $value]
	}

	# show the listbox - no scroll bar

	if {$size > 1 && $items <= $size} {
		$frame.list configure -height $items
		pack $frame.list

	# Listbox with scrollbar

	} elseif {$size > 1} {
		scrollbar $frame.scroll -command "$frame.list yview"  				-orient v -takefocus 0
		$frame.list configure -height $size 			-yscrollcommand "$frame.scroll set"
		pack $frame.list $frame.scroll -side right -fill y

	# This is a joke!

	} else {
		scrollbar $frame.scroll -command "$frame.list yview"  			-orient h -takefocus 0
		$frame.list configure -height 1 			-yscrollcommand "$frame.scroll set"
		pack $frame.list $frame.scroll -side top -fill x
	}

	# cleanup

	foreach i [array names form select_*] {
		unset form($i)
	}
}

# do a text area (multi-line text)
# params: COLS, NAME, ROWS (all reqd, but default rows and cols anyway)

proc HMtag_textarea {win param text} {
	upvar #0 HM$win var
	upvar #0 $var(form_id) form
	upvar 1 $text data

	set rows 5; HMextract_param $param rows
	set cols 30; HMextract_param $param cols
	HMextract_param $param name
	set item $win.textarea,$var(tags)
	frame $item
	text $item.text -width $cols -height $rows -wrap none 			-yscrollcommand "$item.scroll set" -padx 3 -pady 3
	scrollbar $item.scroll -command "$item.text yview"  -orient v
	$item.text insert 1.0 $data
	HMwin_install $win $item
	pack $item.text $item.scroll -side right -fill y
	lappend form(submit) [list $name "\[$item.text get 0.0 end]"]
	append form(reset) ";$item.text delete 1.0 end; 			$item.text insert 1.0 [list $data]"
	set data ""
}

# procedure to install windows into the text widget
# - win:  name of the text widget
# - item: name of widget to install

proc HMwin_install {win item} {
	upvar #0 HM$win var
	$win window create $var(S_insert) -window $item -align bottom
	$win tag add indent$var(level) $item
	set focus [string compare [winfo class $item] Frame]
	$item configure -takefocus $focus
	bind $item <FocusIn> "$win see $item"
}

#####################################################################
# Assemble and submit the query
# each list element in "stuff" is a name/value pair
# - The names are the NAME parameters of the various fields
# - The values get run through "subst" to extract the values
# - We do the user callback with the list of name value pairs

proc HMsubmit_button {win form_id param stuff} {
	upvar #0 HM$win var
	upvar #0 $form_id form
	set query ""
	foreach pair $stuff {
		set value [subst [lindex $pair 1]]
		if {[string length $value]>0} {
			set item [lindex $pair 0]
			lappend query $item $value
		}
	}
	# this is the user callback.
	HMsubmit_form $win $param $query
}

# sample user callback for form submission
# should be replaced by the application
# Sample version generates a string suitable for http

proc HMsubmit_form {win param query} {
	set result ""
	set sep ""
	foreach i $query {
		append result  $sep [HMmap_reply $i]
		if {![string equal $sep =]} {set sep =} else {set sep &}
	}
	puts $result
}

# do x-www-urlencoded character mapping
# The spec says: "non-alphanumeric characters are replaced by '%HH'"

set HMalphanumeric	a-zA-Z0-9	;# definition of alphanumeric character class
for {set i 1} {$i <= 256} {incr i} {
    set c [format %c $i]
    if {![string match \[$HMalphanumeric\] $c]} {
        set HMform_map($c) %[format %.2x $i]
    }
}

# These are handled specially
array set HMform_map {
    " " +   \n %0d%0a
}

# 1 leave alphanumerics characters alone
# 2 Convert every other character to an array lookup
# 3 Escape constructs that are "special" to the tcl parser
# 4 "subst" the result, doing all the array substitutions

proc HMmap_reply {string} {
    global HMform_map HMalphanumeric
    regsub -all \[^$HMalphanumeric\] $string {$HMform_map(&)} string
    regsub -all \n $string {\\n} string
    regsub -all \t $string {\\t} string
    regsub -all {[][{})\\]\)} $string {\\&} string
    return [subst $string]
}

# convert a x-www-urlencoded string int a a list of name/value pairs

# 1  convert a=b&c=d... to {a} {b} {c} {d}...
# 2, convert + to  " "
# 3, convert %xx to char equiv

proc HMcgiDecode {data} {
	set data [split $data "&="]
	foreach i $data {
		lappend result [cgiMap $i]
	}
	return $result
}

proc HMcgiMap {data} {
	regsub -all {\+} $data " " data

	if {[regexp % $data]} {
		regsub -all {([][$\\])} $data {\\\1} data
		regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data  {[format %c 0x\1]} data
		return [subst $data]
	} else {
		return $data
	}
}

}



set ::htmlLibraryAdditionalCode {

    array set HMtag_map {
        h1 {size 22 weight bold}
        h2 {size 20 weight bold}
        h3 {size 18 weight bold}
        h4 {size 16 weight bold}
        h5 {size 14 weight bold}
        h6 {weight bold}
    }

    array set HMinsert_map {
        h1 \n\n /h1 \n\n h2 \n\n /h2 \n\n h3 \n\n /h3 \n\n h4 \n\n /h4 \n\n h5 \n\n /h5 \n\n h6 \n\n /h6 \n\n pre \n\n /ul {} /ol {}
    }

    unset HMevents(Enter)
    unset HMevents(Leave)
    unset HMevents(1)
    set HMevents(ButtonRelease-1) {-foreground darkblue}

    proc HMset_image {widget label source} {
        if {![catch {image create photo -file $source} image]} {
            bind $label <Destroy> "image delete $image"
            HMgot_image $label $image
            $label configure -borderwidth 0 -background [[winfo parent $label] cget -background]
        }
    }

}

append ::htmlLibraryAdditionalCode "
    set HMtag_map(hmstart) {family [list $global::fontFamily]}
    lappend HMtag_map(hmstart) weight medium style r size $global::fontSize Tcenter {} Tlink {} Tnowrap {} Tunderline {} list list        fill 1 indent {} counter 0 adjust 0
"

proc HMlink_hit {path x y} {
    $::htmlViewer::interpreterFromPath($path) eval "HMlink_hit $path $x $y"
}


class htmlViewer {

    proc htmlViewer {this parentPath args} composite {[new scroll text $parentPath] $args} {
        variable interpreterFromPath

        set path $composite::($composite::($this,base),scrolled,path)
        $path configure -highlightthickness 0 -state disabled -padx 2 -background white -cursor {}
        set interpreter [interp create]
        $interpreter eval "set ::auto_path [list $::auto_path]"
        $interpreter eval $::htmlLibraryCode
        $interpreter eval $::htmlLibraryAdditionalCode
        $interpreter alias $path $path
        $interpreter alias formulasHelpWindow formulasHelpWindow
        foreach command {bind bindtags image pack update winfo} {
            $interpreter alias $command $command
        }
        foreach command {button frame label scrollbar text} {
            $interpreter alias $command ::htmlViewer::widget $command $interpreter
        }
        $interpreter eval "HMinit_win $path"
        $path tag configure mark -foreground black
        $path tag configure link -borderwidth 1 -foreground blue -underline 1
        $interpreter eval "set ::HM${path}(S_symbols) {oooooo\xd7\xb0>:\xb7}"
        set ($this,interpreter) $interpreter
        set ($this,textPath) $path
        set interpreterFromPath($path) $interpreter

        composite::complete $this
    }

    proc ~htmlViewer {this} {
        variable interpreterFromPath

        $($this,interpreter) eval "HMset_state $($this,textPath) -stop 1"
        unset interpreterFromPath($($this,textPath))
        interp delete $($this,interpreter)
    }

    proc options {this} {
        return [list            [list -data {} {}]            [list -file {} {}]            [list -linkto $this]        ]
    }

    proc set-data {this value} {
        if {[info exists ($this,loaded)]} {
            error {data can only be loaded once}
        }
        load $this $value
    }

    proc set-file {this value} {
        if {[info exists ($this,loaded)]} {
            error {data can only be loaded once}
        }
        set file [open $value]
        load $this [read $file]
        close $file
    }

    proc set-linkto {this viewer} {
        if {$viewer == $this} {
            $($this,interpreter) eval {
                proc HMlink_callback {widget reference} {
                    switch -glob -- [string tolower [file tail $reference]] {
                        formulas.htm - formulas-*.htm {
                            formulasHelpWindow
                        }
                    }
                    if {![string match #* $reference]} return
                    HMgoto $widget [string trimleft $reference #]
                }
            }
        } else {
            $($this,interpreter) alias HMlink_callback ::htmlViewer::linkCallbackRedirect $viewer
        }
    }

    proc load {this data} {
        set ($this,loaded) {}
        set path $($this,textPath)
        busy 1 $path
        $path configure -state normal
        catch {$($this,interpreter) eval "HMparse_html {$data} {HMrender $path}"}
        if {![winfo exists $path]} return
        $($this,interpreter) eval "HMset_state $path -stop 1"
        $path configure -state disabled
        busy 0 $path
    }

    proc widget {type interpreter args} {
        set path [eval ::$type $args]
        $interpreter alias $path $path
        return $path
    }

    proc linkCallbackRedirect {viewer widget reference} {
        $($viewer,interpreter) eval "HMlink_callback $($viewer,textPath) $reference"
    }


    proc goTo {this url} {
        catch {$($this,interpreter) eval "HMlink_callback $($this,textPath) $url"}
    }

}



set global::fileCloseImage [image create photo -data {
    R0lGODlhFgAWAMYAALGxuYmJmYmJmIiImLCwuM/P0YqKmkREYTw8XEFBYEdHZkZGZT8/Xzk5WEBAXIeHls7O0Lu7wVlZcz4+XnNzkcLC0uvr8PX198zM2oaG
    oVNTbLm5v0VFY05Obr+/0Obm7cnJ11xcfD09WU1Nbb29ztbW4dPT383N2lhYeFFRaZ+ft8XF1Lm5y/Pz9rq6y/7+/9zc5bS0xz09XYSEk2Jigbe3yeTk7LOz
    xnJykDk5VYWFoKKiudvb5d7e566uwn5+mmNjglJScjIyUK6utYuLppCQqtXV4ODg6F1dfTg4V4ODks7O24KCkWtripmZscDA0IKCkFlZeZKSrDU1U4GBkFNT
    c1RUdI+PqS0tS62ttEpKaldXd+Hh6ZiYsDQ0UDo6WWBgf2Rkg6Cgt+Pj625ujMfH1oGBj1NTa3Bwjp+ftnp6l6iovUREY0pKYc3Nz3h4lX19mXd3lElJaTQ0
    T7e3vTs7WmdnhomJo2VlhDY2VEhIaGFhgP///////////////yH5BAEKAH8ALAAAAAAWABYAAAf+gH+Cg4SFhoeCAAECAgMEiIUFBgcICQoLDA0ODxCQERIT
    FBUWF6UYGQ0aG4cRHB0eH7GysSAhIquEBRIjJCUmJcDBvycoKZ2DBhMqKywtFivQKy4vMCsxMjOEBzQxNS0vLzYxMTfgLxgxODmDAAg6Ozs85j0+5jY/QEFC
    Q4IBCURFAhoxZ+4IkiAIkygRJGDBj4cPlxA0iBBhAiaCBixowpGjE4JPKiJkACUjgygoo0ghCC5kxSlUBBFoUMWKlSsFn5h7UqUnliyDHGjZ0sQcFxpbKpjr
    skWBF0IPvoAJI+bFGDJhspZ5USYMGCFmCEE4owUNmjRqzKpdY5ZNGzc5hTaI6PAGjt27duPImUPn0IYUdezcGUwYT542fRFBmJEjj549YBYI8WIGLqRBQ5Qw
    oUIF6OXPiAIBADs=
}]

proc displayHelpWindow {topLevelName name title} {
    upvar 1 $topLevelName toplevel

    set toplevel .grabber.help${name}
    if {[winfo exists $toplevel]} {
        wm deiconify $toplevel
        raise $toplevel
        return 0
    }
    toplevel $toplevel
    wm group $toplevel .
    wm title $toplevel $title
    frame $toplevel.bound
    return 1
}

proc generalHelpWindow {{url {}}} {
    static bottom 0

    if {[displayHelpWindow toplevel moodss [mc {moodss: Global help}]]} {
        loadHelpData
        set bottom [helpWindow $toplevel $::htmlHelpContents $::htmlHelpData]
    }
    if {([string length $url] > 0) && ![catch {classof $bottom}]} {
        htmlViewer::goTo $bottom $url
    }
}

proc formulasHelpWindow {{url {}}} {
    static bottom 0

    if {[displayHelpWindow toplevel formulas [mc {moodss: Formulas help}]]} {
        loadHelpData
        set bottom [helpWindow $toplevel $::htmlFormulasHelpContents $::htmlFormulasHelpData]
    }
    if {([string length $url] > 0) && ![catch {classof $bottom}]} {
        htmlViewer::goTo $bottom $url
    }
}

proc loadHelpData {} {
    if {        ([info exists ::env(LC_ALL)] && [string match ja* $::env(LC_ALL)]) ||        ([info exists ::env(LANG)] && [string match ja* $::env(LANG)])    } {
        package require moodsshelp-ja
    } else {
        package require moodsshelp
    }
}

proc helpWindow {toplevel htmlContents htmlData} {
    set panes [new panner $toplevel -panes 2]
    pack $widget::($panes,path) -fill both -expand 1
    set top [new htmlViewer $panner::($panes,frame1)]
    composite::configure $top base -height 100 -width 500
    pack $widget::($top,path) -fill both -expand 1
    set bottom [new htmlViewer $panner::($panes,frame2)]
    composite::configure $top -linkto $bottom
    composite::configure $bottom base -height 400
    focus $htmlViewer::($bottom,textPath)
    pack $widget::($bottom,path) -fill both -expand 1
    bind $toplevel.bound <Destroy> "delete $bottom $top $panes"
    set button [button $toplevel.close -image $global::fileCloseImage -command "destroy $toplevel"]
    place $button -in $htmlViewer::($top,textPath) -relx 1 -anchor ne
    busy 1 $htmlViewer::($top,textPath)
    composite::configure $top -data $htmlContents
    if {![winfo exists $toplevel]} {
        return 0
    }
    composite::configure $bottom -data $htmlData
    catch {busy 0 $htmlViewer::($top,textPath)}
    return $bottom
}

proc moduleHelpWindow {name text} {
    if {![displayHelpWindow toplevel $name [format [mc {moodss: %s module help}] $name]]} return
    set viewer [new htmlViewer $toplevel]
    composite::configure $viewer base -height 300 -width 500
    pack $widget::($viewer,path) -fill both -expand 1
    bind $toplevel.bound <Destroy> "delete $viewer"
    composite::configure $viewer -data $text
    set button [button $toplevel.close -image $global::fileCloseImage -command "destroy $toplevel"]
    place $button -in $htmlViewer::($viewer,textPath) -relx 1 -anchor ne
}
if {1} {
# ----------------------------------------------------------------------------
#  utils.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: utils.tcl,v 1.10 2003/10/20 21:23:53 damonc Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#     - GlobalVar::exists
#     - GlobalVar::setvarvar
#     - GlobalVar::getvarvar
#     - BWidget::assert
#     - BWidget::clonename
#     - BWidget::get3dcolor
#     - BWidget::XLFDfont
#     - BWidget::place
#     - BWidget::grab
#     - BWidget::focus
# ----------------------------------------------------------------------------

namespace eval GlobalVar {
    proc use {} {}
}


namespace eval BWidget {
    variable _top
    variable _gstack {}
    variable _fstack {}
    proc use {} {}
}


# ----------------------------------------------------------------------------
#  Command GlobalVar::exists
# ----------------------------------------------------------------------------
proc GlobalVar::exists { varName } {
    return [uplevel \#0 [list info exists $varName]]
}


# ----------------------------------------------------------------------------
#  Command GlobalVar::setvar
# ----------------------------------------------------------------------------
proc GlobalVar::setvar { varName value } {
    return [uplevel \#0 [list set $varName $value]]
}


# ----------------------------------------------------------------------------
#  Command GlobalVar::getvar
# ----------------------------------------------------------------------------
proc GlobalVar::getvar { varName } {
    return [uplevel \#0 [list set $varName]]
}


# ----------------------------------------------------------------------------
#  Command GlobalVar::tracevar
# ----------------------------------------------------------------------------
proc GlobalVar::tracevar { cmd varName args } {
    return [uplevel \#0 [list trace $cmd $varName] $args]
}



# ----------------------------------------------------------------------------
#  Command BWidget::lreorder
# ----------------------------------------------------------------------------
proc BWidget::lreorder { list neworder } {
    set pos     0
    set newlist {}
    foreach e $neworder {
        if { [lsearch -exact $list $e] != -1 } {
            lappend newlist $e
            set tabelt($e)  1
        }
    }
    set len [llength $newlist]
    if { !$len } {
        return $list
    }
    if { $len == [llength $list] } {
        return $newlist
    }
    set pos 0
    foreach e $list {
        if { ![info exists tabelt($e)] } {
            set newlist [linsert $newlist $pos $e]
        }
        incr pos
    }
    return $newlist
}


# ----------------------------------------------------------------------------
#  Command BWidget::assert
# ----------------------------------------------------------------------------
proc BWidget::assert { exp {msg ""}} {
    set res [uplevel 1 expr $exp]
    if { !$res} {
        if { $msg == "" } {
            return -code error "Assertion failed: {$exp}"
        } else {
            return -code error $msg
        }
    }
}


# ----------------------------------------------------------------------------
#  Command BWidget::clonename
# ----------------------------------------------------------------------------
proc BWidget::clonename { menu } {
    set path     ""
    set menupath ""
    set found    0
    foreach widget [lrange [split $menu "."] 1 end] {
        if { $found || [winfo class "$path.$widget"] == "Menu" } {
            set found 1
            append menupath "#" $widget
            append path "." $menupath
        } else {
            append menupath "#" $widget
            append path "." $widget
        }
    }
    return $path
}


# ----------------------------------------------------------------------------
#  Command BWidget::getname
# ----------------------------------------------------------------------------
proc BWidget::getname { name } {
    if { [string length $name] } {
        set text [option get . "${name}Name" ""]
        if { [string length $text] } {
            return [parsetext $text]
        }
    }
    return {}
 }


# ----------------------------------------------------------------------------
#  Command BWidget::parsetext
# ----------------------------------------------------------------------------
proc BWidget::parsetext { text } {
    set result ""
    set index  -1
    set start  0
    while { [string length $text] } {
        set idx [string first "&" $text]
        if { $idx == -1 } {
            append result $text
            set text ""
        } else {
            set char [string index $text [expr {$idx+1}]]
            if { $char == "&" } {
                append result [string range $text 0 $idx]
                set    text   [string range $text [expr {$idx+2}] end]
                set    start  [expr {$start+$idx+1}]
            } else {
                append result [string range $text 0 [expr {$idx-1}]]
                set    text   [string range $text [expr {$idx+1}] end]
                incr   start  $idx
                set    index  $start
            }
        }
    }
    return [list $result $index]
}


# ----------------------------------------------------------------------------
#  Command BWidget::get3dcolor
# ----------------------------------------------------------------------------
proc BWidget::get3dcolor { path bgcolor } {
    foreach val [winfo rgb $path $bgcolor] {
        lappend dark [expr {60*$val/100}]
        set tmp1 [expr {14*$val/10}]
        if { $tmp1 > 65535 } {
            set tmp1 65535
        }
        set tmp2 [expr {(65535+$val)/2}]
        lappend light [expr {($tmp1 > $tmp2) ? $tmp1:$tmp2}]
    }
    return [list [eval format "#%04x%04x%04x" $dark] [eval format "#%04x%04x%04x" $light]]
}


# ----------------------------------------------------------------------------
#  Command BWidget::XLFDfont
# ----------------------------------------------------------------------------
proc BWidget::XLFDfont { cmd args } {
    switch -- $cmd {
        create {
            set font "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"
        }
        configure {
            set font [lindex $args 0]
            set args [lrange $args 1 end]
        }
        default {
            return -code error "XLFDfont: commande incorrect: $cmd"
        }
    }
    set lfont [split $font "-"]
    if { [llength $lfont] != 15 } {
        return -code error "XLFDfont: description XLFD incorrect: $font"
    }

    foreach {option value} $args {
        switch -- $option {
            -foundry { set index 1 }
            -family  { set index 2 }
            -weight  { set index 3 }
            -slant   { set index 4 }
            -size    { set index 7 }
            default  { return -code error "XLFDfont: option incorrecte: $option" }
        }
        set lfont [lreplace $lfont $index $index $value]
    }
    return [join $lfont "-"]
}



# ----------------------------------------------------------------------------
#  Command BWidget::place
# ----------------------------------------------------------------------------
#
# Notes:
#  For Windows systems with more than one monitor the available screen area may
#  have negative positions. Geometry settings with negative numbers are used
#  under X to place wrt the right or bottom of the screen. On windows, Tk
#  continues to do this. However, a geometry such as 100x100+-200-100 can be
#  used to place a window onto a secondary monitor. Passing the + gets Tk
#  to pass the remainder unchanged so the Windows manager then handles -200
#  which is a position on the left hand monitor.
#  I've tested this for left, right, above and below the primary monitor.
#  Currently there is no way to ask Tk the extent of the Windows desktop in 
#  a multi monitor system. Nor what the legal co-ordinate range might be.
#
proc BWidget::place { path w h args } {
    variable _top

    update idletasks
    set reqw [winfo reqwidth  $path]
    set reqh [winfo reqheight $path]
    if { $w == 0 } {set w $reqw}
    if { $h == 0 } {set h $reqh}

    set arglen [llength $args]
    if { $arglen > 3 } {
        return -code error "BWidget::place: bad number of argument"
    }

    if { $arglen > 0 } {
        set where [lindex $args 0]
	set list  [list "at" "center" "left" "right" "above" "below"]
        set idx   [lsearch $list $where]
        if { $idx == -1 } {
	    return -code error [BWidget::badOptionString position $where $list]
        }
        if { $idx == 0 } {
            set err [catch {
                # purposely removed the {} around these expressions - [PT]
                set x [expr int([lindex $args 1])]
                set y [expr int([lindex $args 2])]
            }]
            if { $err } {
                return -code error "BWidget::place: incorrect position"
            }
            if {$::tcl_platform(platform) == "windows"} {
                # handle windows multi-screen. -100 != +-100
                if {[string index [lindex $args 1] 0] != "-"} {
                    set x "+$x"
                }
                if {[string index [lindex $args 2] 0] != "-"} {
                    set y "+$y"
                }
            } else {
                if { $x >= 0 } {
                    set x "+$x"
                }
                if { $y >= 0 } {
                    set y "+$y"
                }
            }
        } else {
            if { $arglen == 2 } {
                set widget [lindex $args 1]
                if { ![winfo exists $widget] } {
                    return -code error "BWidget::place: \"$widget\" does not exist"
                }
	    } else {
		set widget .
	    }
            set sw [winfo screenwidth  $path]
            set sh [winfo screenheight $path]
            if { $idx == 1 } {
                if { $arglen == 2 } {
                    # center to widget
                    set x0 [expr {[winfo rootx $widget] + ([winfo width  $widget] - $w)/2}]
                    set y0 [expr {[winfo rooty $widget] + ([winfo height $widget] - $h)/2}]
                } else {
                    # center to screen
                    set x0 [expr {([winfo screenwidth  $path] - $w)/2 - [winfo vrootx $path]}]
                    set y0 [expr {([winfo screenheight $path] - $h)/2 - [winfo vrooty $path]}]
                }
                set x "+$x0"
                set y "+$y0"
                if {$::tcl_platform(platform) != "windows"} {
                    if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
                    if { $x0 < 0 }      {set x "+0"}
                    if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
                    if { $y0 < 0 }      {set y "+0"}
                }
            } else {
                set x0 [winfo rootx $widget]
                set y0 [winfo rooty $widget]
                set x1 [expr {$x0 + [winfo width  $widget]}]
                set y1 [expr {$y0 + [winfo height $widget]}]
                if { $idx == 2 || $idx == 3 } {
                    set y "+$y0"
                    if {$::tcl_platform(platform) != "windows"} {
                        if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
                        if { $y0 < 0 }      {set y "+0"}
                    }
                    if { $idx == 2 } {
                        # try left, then right if out, then 0 if out
                        if { $x0 >= $w } {
                            set x "+[expr {$x0-$sw}]"
                        } elseif { $x1+$w <= $sw } {
                            set x "+$x1"
                        } else {
                            set x "+0"
                        }
                    } else {
                        # try right, then left if out, then 0 if out
                        if { $x1+$w <= $sw } {
                            set x "+$x1"
                        } elseif { $x0 >= $w } {
                            set x "+[expr {$x0-$sw}]"
                        } else {
                            set x "-0"
                        }
                    }
                } else {
                    set x "+$x0"
                    if {$::tcl_platform(platform) != "windows"} {
                        if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
                        if { $x0 < 0 }      {set x "+0"}
                    }
                    if { $idx == 4 } {
                        # try top, then bottom, then 0
                        if { $h <= $y0 } {
                            set y "+[expr {$y0-$sh}]"
                        } elseif { $y1+$h <= $sh } {
                            set y "+$y1"
                        } else {
                            set y "+0"
                        }
                    } else {
                        # try bottom, then top, then 0
                        if { $y1+$h <= $sh } {
                            set y "+$y1"
                        } elseif { $h <= $y0 } {
                            set y "+[expr {$y0-$sh}]"
                        } else {
                            set y "-0"
                        }
                    }
                }
            }
        }
        wm geometry $path "${w}x${h}${x}${y}"
    } else {
        wm geometry $path "${w}x${h}"
    }
    update idletasks
}


# ----------------------------------------------------------------------------
#  Command BWidget::grab
# ----------------------------------------------------------------------------
proc BWidget::grab { option path } {
    variable _gstack

    if { $option == "release" } {
        catch {::grab release $path}
        while { [llength $_gstack] } {
            set grinfo  [lindex $_gstack end]
            set _gstack [lreplace $_gstack end end]
            foreach {oldg mode} $grinfo {
                if { ![string equal $oldg $path] && [winfo exists $oldg] } {
                    if { $mode == "global" } {
                        catch {::grab -global $oldg}
                    } else {
                        catch {::grab $oldg}
                    }
                    return
                }
            }
        }
    } else {
        set oldg [::grab current]
        if { $oldg != "" } {
            lappend _gstack [list $oldg [::grab status $oldg]]
        }
        if { $option == "global" } {
            ::grab -global $path
        } else {
            ::grab $path
        }
    }
}


# ----------------------------------------------------------------------------
#  Command BWidget::focus
# ----------------------------------------------------------------------------
proc BWidget::focus { option path {refocus 1} } {
    variable _fstack

    if { $option == "release" } {
        while { [llength $_fstack] } {
            set oldf [lindex $_fstack end]
            set _fstack [lreplace $_fstack end end]
            if { ![string equal $oldf $path] && [winfo exists $oldf] } {
                if {$refocus} {catch {::focus -force $oldf}}
                return
            }
        }
    } elseif { $option == "set" } {
        lappend _fstack [::focus]
        ::focus -force $path
    }
}

# BWidget::refocus --
#
#	Helper function used to redirect focus from a container frame in 
#	a megawidget to a component widget.  Only redirects focus if
#	focus is already on the container.
#
# Arguments:
#	container	container widget to redirect from.
#	component	component widget to redirect to.
#
# Results:
#	None.

proc BWidget::refocus {container component} {
    if { [string equal $container [::focus]] } {
	::focus $component
    }
    return
}

# BWidget::badOptionString --
#
#	Helper function to return a proper error string when an option
#       doesn't match a list of given options.
#
# Arguments:
#	type	A string that represents the type of option.
#	value	The value that is in-valid.
#       list	A list of valid options.
#
# Results:
#	None.
proc BWidget::badOptionString {type value list} {
    set last [lindex $list end]
    set list [lreplace $list end end]
    return "bad $type \"$value\": must be [join $list ", "], or $last"
}


proc BWidget::wrongNumArgsString { string } {
    return "wrong # args: should be \"$string\""
}


proc BWidget::read_file { file } {
    set fp [open $file]
    set x  [read $fp [file size $file]]
    close $fp
    return $x
}


proc BWidget::classes { class } {
    variable use

    ${class}::use
    set classes [list $class]
    if {![info exists use($class)]} { return }
    foreach class $use($class) {
	eval lappend classes [classes $class]
    }
    return [lsort -unique $classes]
}


proc BWidget::library { args } {
    variable use

    set libs    [list widget init utils]
    set classes [list]
    foreach class $args {
	${class}::use
        eval lappend classes [classes $class]
    }

    eval lappend libs [lsort -unique $classes]

    set library ""
    foreach lib $libs {
	if {![info exists use($lib,file)]} {
	    set file [file join $::BWIDGET::LIBRARY $lib.tcl]
	} else {
	    set file [file join $::BWIDGET::LIBRARY $use($lib,file).tcl]
	}
        append library [read_file $file]
    }

    return $library
}


proc BWidget::inuse { class } {
    variable ::Widget::_inuse

    if {![info exists _inuse($class)]} { return 0 }
    return [expr $_inuse($class) > 0]
}


proc BWidget::write { filename {mode w} } {
    variable use

    if {![info exists use(classes)]} { return }

    set classes [list]
    foreach class $use(classes) {
	if {![inuse $class]} { continue }
	lappend classes $class
    }

    set fp [open $filename $mode]
    puts $fp [eval library $classes]
    close $fp

    return
}


# BWidget::bindMouseWheel --
#
#	Bind mouse wheel actions to a given widget.
#
# Arguments:
#	widget - The widget to bind.
#
# Results:
#	None.
proc BWidget::bindMouseWheel { widget } {
    bind $widget <MouseWheel>         {%W yview scroll [expr {-%D/24}]  units}
    bind $widget <Shift-MouseWheel>   {%W yview scroll [expr {-%D/120}] pages}
    bind $widget <Control-MouseWheel> {%W yview scroll [expr {-%D/120}] units}

    bind $widget <Button-4> {event generate %W <MouseWheel> -delta  120}
    bind $widget <Button-5> {event generate %W <MouseWheel> -delta -120}
}
# ----------------------------------------------------------------------------
#  widget.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: widget.tcl,v 1.27 2003/10/28 05:03:17 damonc Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#     - Widget::tkinclude
#     - Widget::bwinclude
#     - Widget::declare
#     - Widget::addmap
#     - Widget::init
#     - Widget::destroy
#     - Widget::setoption
#     - Widget::configure
#     - Widget::cget
#     - Widget::subcget
#     - Widget::hasChanged
#     - Widget::options
#     - Widget::_get_tkwidget_options
#     - Widget::_test_tkresource
#     - Widget::_test_bwresource
#     - Widget::_test_synonym
#     - Widget::_test_string
#     - Widget::_test_flag
#     - Widget::_test_enum
#     - Widget::_test_int
#     - Widget::_test_boolean
# ----------------------------------------------------------------------------
# Each megawidget gets a namespace of the same name inside the Widget namespace
# Each of these has an array opt, which contains information about the 
# megawidget options.  It maps megawidget options to a list with this format:
#     {optionType defaultValue isReadonly {additionalOptionalInfo}}
# Option types and their additional optional info are:
#	TkResource	{genericTkWidget genericTkWidgetOptionName}
#	BwResource	{nothing}
#	Enum		{list of enumeration values}
#	Int		{Boundary information}
#	Boolean		{nothing}
#	String		{nothing}
#	Flag		{string of valid flag characters}
#	Synonym		{nothing}
#	Color		{nothing}
#
# Next, each namespace has an array map, which maps class options to their
# component widget options:
#	map(-foreground) => {.e -foreground .f -foreground}
#
# Each has an array ${path}:opt, which contains the value of each megawidget
# option for a particular instance $path of the megawidget, and an array
# ${path}:mod, which stores the "changed" status of configuration options.

# Steps for creating a bwidget megawidget:
# 1. parse args to extract subwidget spec
# 2. Create frame with appropriate class and command line options
# 3. Get initialization options from optionDB, using frame
# 4. create subwidgets

# Uses newer string operations
package require Tcl 8.1.1

namespace eval Widget {
    variable _optiontype
    variable _class
    variable _tk_widget

    array set _optiontype {
        TkResource Widget::_test_tkresource
        BwResource Widget::_test_bwresource
        Enum       Widget::_test_enum
        Int        Widget::_test_int
        Boolean    Widget::_test_boolean
        String     Widget::_test_string
        Flag       Widget::_test_flag
        Synonym    Widget::_test_synonym
        Color      Widget::_test_color
        Padding    Widget::_test_padding
    }

    proc use {} {}
}



# ----------------------------------------------------------------------------
#  Command Widget::tkinclude
#     Includes tk widget resources to BWidget widget.
#  class      class name of the BWidget
#  tkwidget   tk widget to include
#  subpath    subpath to configure
#  args       additionnal args for included options
# ----------------------------------------------------------------------------
proc Widget::tkinclude { class tkwidget subpath args } {
    foreach {cmd lopt} $args {
        # cmd can be
        #   include      options to include            lopt = {opt ...}
        #   remove       options to remove             lopt = {opt ...}
        #   rename       options to rename             lopt = {opt newopt ...}
        #   prefix       options to prefix             lopt = {pref opt opt ..}
        #   initialize   set default value for options lopt = {opt value ...}
        #   readonly     set readonly flag for options lopt = {opt flag ...}
        switch -- $cmd {
            remove {
                foreach option $lopt {
                    set remove($option) 1
                }
            }
            include {
                foreach option $lopt {
                    set include($option) 1
                }
            }
            prefix {
                set prefix [lindex $lopt 0]
                foreach option [lrange $lopt 1 end] {
                    set rename($option) "-$prefix[string range $option 1 end]"
                }
            }
            rename     -
            readonly   -
            initialize {
                array set $cmd $lopt
            }
            default {
                return -code error "invalid argument \"$cmd\""
            }
        }
    }

    namespace eval $class {}
    upvar 0 ${class}::opt classopt
    upvar 0 ${class}::map classmap
    upvar 0 ${class}::map$subpath submap
    upvar 0 ${class}::optionExports exports

    set foo [$tkwidget ".ericFoo###"]
    # create resources informations from tk widget resources
    foreach optdesc [_get_tkwidget_options $tkwidget] {
        set option [lindex $optdesc 0]
        if { (![info exists include] || [info exists include($option)]) &&
             ![info exists remove($option)] } {
            if { [llength $optdesc] == 3 } {
                # option is a synonym
                set syn [lindex $optdesc 1]
                if { ![info exists remove($syn)] } {
                    # original option is not removed
                    if { [info exists rename($syn)] } {
                        set classopt($option) [list Synonym $rename($syn)]
                    } else {
                        set classopt($option) [list Synonym $syn]
                    }
                }
            } else {
                if { [info exists rename($option)] } {
                    set realopt $option
                    set option  $rename($option)
                } else {
                    set realopt $option
                }
                if { [info exists initialize($option)] } {
                    set value $initialize($option)
                } else {
                    set value [lindex $optdesc 1]
                }
                if { [info exists readonly($option)] } {
                    set ro $readonly($option)
                } else {
                    set ro 0
                }
                set classopt($option) 			[list TkResource $value $ro [list $tkwidget $realopt]]

		# Add an option database entry for this option
		set optionDbName ".[lindex [_configure_option $option ""] 0]"
		if { ![string equal $subpath ":cmd"] } {
		    set optionDbName "$subpath$optionDbName"
		}
		option add *${class}$optionDbName $value widgetDefault
		lappend exports($option) "$optionDbName"

		# Store the forward and backward mappings for this
		# option <-> realoption pair
                lappend classmap($option) $subpath "" $realopt
		set submap($realopt) $option
            }
        }
    }
    ::destroy $foo
}


# ----------------------------------------------------------------------------
#  Command Widget::bwinclude
#     Includes BWidget resources to BWidget widget.
#  class    class name of the BWidget
#  subclass BWidget class to include
#  subpath  subpath to configure
#  args     additionnal args for included options
# ----------------------------------------------------------------------------
proc Widget::bwinclude { class subclass subpath args } {
    foreach {cmd lopt} $args {
        # cmd can be
        #   include      options to include            lopt = {opt ...}
        #   remove       options to remove             lopt = {opt ...}
        #   rename       options to rename             lopt = {opt newopt ...}
        #   prefix       options to prefix             lopt = {prefix opt opt ...}
        #   initialize   set default value for options lopt = {opt value ...}
        #   readonly     set readonly flag for options lopt = {opt flag ...}
        switch -- $cmd {
            remove {
                foreach option $lopt {
                    set remove($option) 1
                }
            }
            include {
                foreach option $lopt {
                    set include($option) 1
                }
            }
            prefix {
                set prefix [lindex $lopt 0]
                foreach option [lrange $lopt 1 end] {
                    set rename($option) "-$prefix[string range $option 1 end]"
                }
            }
            rename     -
            readonly   -
            initialize {
                array set $cmd $lopt
            }
            default {
                return -code error "invalid argument \"$cmd\""
            }
        }
    }

    namespace eval $class {}
    upvar 0 ${class}::opt classopt
    upvar 0 ${class}::map classmap
    upvar 0 ${class}::map$subpath submap
    upvar 0 ${class}::optionExports exports
    upvar 0 ${subclass}::opt subclassopt
    upvar 0 ${subclass}::optionExports subexports

    # create resources informations from BWidget resources
    foreach {option optdesc} [array get subclassopt] {
	set subOption $option
        if { (![info exists include] || [info exists include($option)]) &&
             ![info exists remove($option)] } {
            set type [lindex $optdesc 0]
            if { [string equal $type "Synonym"] } {
                # option is a synonym
                set syn [lindex $optdesc 1]
                if { ![info exists remove($syn)] } {
                    if { [info exists rename($syn)] } {
                        set classopt($option) [list Synonym $rename($syn)]
                    } else {
                        set classopt($option) [list Synonym $syn]
                    }
                }
            } else {
                if { [info exists rename($option)] } {
                    set realopt $option
                    set option  $rename($option)
                } else {
                    set realopt $option
                }
                if { [info exists initialize($option)] } {
                    set value $initialize($option)
                } else {
                    set value [lindex $optdesc 1]
                }
                if { [info exists readonly($option)] } {
                    set ro $readonly($option)
                } else {
                    set ro [lindex $optdesc 2]
                }
                set classopt($option) 			[list $type $value $ro [lindex $optdesc 3]]

		# Add an option database entry for this option
		foreach optionDbName $subexports($subOption) {
		    if { ![string equal $subpath ":cmd"] } {
			set optionDbName "$subpath$optionDbName"
		    }
		    # Only add the option db entry if we are overriding the
		    # normal widget default
		    if { [info exists initialize($option)] } {
			option add *${class}$optionDbName $value 				widgetDefault
		    }
		    lappend exports($option) "$optionDbName"
		}

		# Store the forward and backward mappings for this
		# option <-> realoption pair
                lappend classmap($option) $subpath $subclass $realopt
		set submap($realopt) $option
            }
        }
    }
}


# ----------------------------------------------------------------------------
#  Command Widget::declare
#    Declares new options to BWidget class.
# ----------------------------------------------------------------------------
proc Widget::declare { class optlist } {
    variable _optiontype

    namespace eval $class {}
    upvar 0 ${class}::opt classopt
    upvar 0 ${class}::optionExports exports
    upvar 0 ${class}::optionClass optionClass

    foreach optdesc $optlist {
        set option  [lindex $optdesc 0]
        set optdesc [lrange $optdesc 1 end]
        set type    [lindex $optdesc 0]

        if { ![info exists _optiontype($type)] } {
            # invalid resource type
            return -code error "invalid option type \"$type\""
        }

        if { [string equal $type "Synonym"] } {
            # test existence of synonym option
            set syn [lindex $optdesc 1]
            if { ![info exists classopt($syn)] } {
                return -code error "unknow option \"$syn\" for Synonym \"$option\""
            }
            set classopt($option) [list Synonym $syn]
            continue
        }

        # all other resource may have default value, readonly flag and
        # optional arg depending on type
        set value [lindex $optdesc 1]
        set ro    [lindex $optdesc 2]
        set arg   [lindex $optdesc 3]

        if { [string equal $type "BwResource"] } {
            # We don't keep BwResource. We simplify to type of sub BWidget
            set subclass    [lindex $arg 0]
            set realopt     [lindex $arg 1]
            if { ![string length $realopt] } {
                set realopt $option
            }

            upvar 0 ${subclass}::opt subclassopt
            if { ![info exists subclassopt($realopt)] } {
                return -code error "unknow option \"$realopt\""
            }
            set suboptdesc $subclassopt($realopt)
            if { $value == "" } {
                # We initialize default value
                set value [lindex $suboptdesc 1]
            }
            set type [lindex $suboptdesc 0]
            set ro   [lindex $suboptdesc 2]
            set arg  [lindex $suboptdesc 3]
	    set optionDbName ".[lindex [_configure_option $option ""] 0]"
	    option add *${class}${optionDbName} $value widgetDefault
	    set exports($option) $optionDbName
            set classopt($option) [list $type $value $ro $arg]
            continue
        }

        # retreive default value for TkResource
        if { [string equal $type "TkResource"] } {
            set tkwidget [lindex $arg 0]
	    set foo [$tkwidget ".ericFoo##"]
            set realopt  [lindex $arg 1]
            if { ![string length $realopt] } {
                set realopt $option
            }
            set tkoptions [_get_tkwidget_options $tkwidget]
            if { ![string length $value] } {
                # We initialize default value
		set ind [lsearch $tkoptions [list $realopt *]]
                set value [lindex [lindex $tkoptions $ind] end]
            }
	    set optionDbName ".[lindex [_configure_option $option ""] 0]"
	    option add *${class}${optionDbName} $value widgetDefault
	    set exports($option) $optionDbName
            set classopt($option) [list TkResource $value $ro 		    [list $tkwidget $realopt]]
	    set optionClass($option) [lindex [$foo configure $realopt] 1]
	    ::destroy $foo
            continue
        }

	set optionDbName ".[lindex [_configure_option $option ""] 0]"
	option add *${class}${optionDbName} $value widgetDefault
	set exports($option) $optionDbName
        # for any other resource type, we keep original optdesc
        set classopt($option) [list $type $value $ro $arg]
    }
}


proc Widget::define { class filename args } {
    variable ::BWidget::use
    set use($class)      $args
    set use($class,file) $filename
    lappend use(classes) $class

    if {[set x [lsearch -exact $args "-classonly"]] > -1} {
	set args [lreplace $args $x $x]
    } else {
	interp alias {} ::${class} {} ${class}::create
	proc ::${class}::use {} {}

	bind $class <Destroy> [list Widget::destroy %W]
    }

    foreach class $args { ${class}::use }
}


proc Widget::create { class path {rename 1} } {
    if {$rename} { rename $path ::$path:cmd }
    proc ::$path { cmd args }     	[subst {return \[eval \[linsert \$args 0 ${class}::\$cmd [list $path]\]\]}]
    return $path
}


# ----------------------------------------------------------------------------
#  Command Widget::addmap
# ----------------------------------------------------------------------------
proc Widget::addmap { class subclass subpath options } {
    upvar 0 ${class}::opt classopt
    upvar 0 ${class}::optionExports exports
    upvar 0 ${class}::optionClass optionClass
    upvar 0 ${class}::map classmap
    upvar 0 ${class}::map$subpath submap

    foreach {option realopt} $options {
        if { ![string length $realopt] } {
            set realopt $option
        }
	set val [lindex $classopt($option) 1]
	set optDb ".[lindex [_configure_option $realopt ""] 0]"
	if { ![string equal $subpath ":cmd"] } {
	    set optDb "$subpath$optDb"
	}
	option add *${class}${optDb} $val widgetDefault
	lappend exports($option) $optDb
	# Store the forward and backward mappings for this
	# option <-> realoption pair
        lappend classmap($option) $subpath $subclass $realopt
	set submap($realopt) $option
    }
}


# ----------------------------------------------------------------------------
#  Command Widget::syncoptions
# ----------------------------------------------------------------------------
proc Widget::syncoptions { class subclass subpath options } {
    upvar 0 ${class}::sync classync

    foreach {option realopt} $options {
        if { ![string length $realopt] } {
            set realopt $option
        }
        set classync($option) [list $subpath $subclass $realopt]
    }
}


# ----------------------------------------------------------------------------
#  Command Widget::init
# ----------------------------------------------------------------------------
proc Widget::init { class path options } {
    variable _inuse

    upvar 0 ${class}::opt classopt
    upvar 0 ${class}::$path:opt  pathopt
    upvar 0 ${class}::$path:mod  pathmod
    upvar 0 ${class}::map classmap
    upvar 0 ${class}::$path:init pathinit

    if { [info exists pathopt] } {
	unset pathopt
    }
    if { [info exists pathmod] } {
	unset pathmod
    }
    # We prefer to use the actual widget for option db queries, but if it
    # doesn't exist yet, do the next best thing:  create a widget of the
    # same class and use that.
    set fpath $path
    set rdbclass [string map [list :: ""] $class]
    if { ![winfo exists $path] } {
	set fpath ".#BWidgetClass#$class"
	if { ![winfo exists $fpath] } {
	    frame $fpath -class $rdbclass
	}
    }
    foreach {option optdesc} [array get classopt] {
        set pathmod($option) 0
	if { [info exists classmap($option)] } {
	    continue
	}
        set type [lindex $optdesc 0]
        if { [string equal $type "Synonym"] } {
	    continue
        }
        if { [string equal $type "TkResource"] } {
            set alt [lindex [lindex $optdesc 3] 1]
        } else {
            set alt ""
        }
        set optdb [lindex [_configure_option $option $alt] 0]
        set def   [option get $fpath $optdb $rdbclass]
        if { [string length $def] } {
            set pathopt($option) $def
        } else {
            set pathopt($option) [lindex $optdesc 1]
        }
    }

    if {![info exists _inuse($class)]} { set _inuse($class) 0 }
    incr _inuse($class)

    set Widget::_class($path) $class
    foreach {option value} $options {
        if { ![info exists classopt($option)] } {
            unset pathopt
            unset pathmod
            return -code error "unknown option \"$option\""
        }
        set optdesc $classopt($option)
        set type    [lindex $optdesc 0]
        if { [string equal $type "Synonym"] } {
            set option  [lindex $optdesc 1]
            set optdesc $classopt($option)
            set type    [lindex $optdesc 0]
        }
        set pathopt($option) [$Widget::_optiontype($type) $option $value [lindex $optdesc 3]]
	set pathinit($option) $pathopt($option)
    }
}

# Bastien Chevreux (bach@mwgdna.com)
#
# copyinit performs basically the same job as init, but it uses a
#  existing template to initialize its values. So, first a perferct copy
#  from the template is made just to be altered by any existing options
#  afterwards.
# But this still saves time as the first initialization parsing block is
#  skipped.
# As additional bonus, items that differ in just a few options can be
#  initialized faster by leaving out the options that are equal.

# This function is currently used only by ListBox::multipleinsert, but other
#  calls should follow :)

# ----------------------------------------------------------------------------
#  Command Widget::copyinit
# ----------------------------------------------------------------------------
proc Widget::copyinit { class templatepath path options } {
    upvar 0 ${class}::opt classopt 	    ${class}::$path:opt	 pathopt 	    ${class}::$path:mod	 pathmod 	    ${class}::$path:init pathinit 	    ${class}::$templatepath:opt	  templatepathopt 	    ${class}::$templatepath:mod	  templatepathmod 	    ${class}::$templatepath:init  templatepathinit

    if { [info exists pathopt] } {
	unset pathopt
    }
    if { [info exists pathmod] } {
	unset pathmod
    }

    # We use the template widget for option db copying, but it has to exist!
    array set pathmod  [array get templatepathmod]
    array set pathopt  [array get templatepathopt]
    array set pathinit [array get templatepathinit]

    set Widget::_class($path) $class
    foreach {option value} $options {
	if { ![info exists classopt($option)] } {
	    unset pathopt
	    unset pathmod
	    return -code error "unknown option \"$option\""
	}
	set optdesc $classopt($option)
	set type    [lindex $optdesc 0]
	if { [string equal $type "Synonym"] } {
	    set option	[lindex $optdesc 1]
	    set optdesc $classopt($option)
	    set type	[lindex $optdesc 0]
	}
	set pathopt($option) [$Widget::_optiontype($type) $option $value [lindex $optdesc 3]]
	set pathinit($option) $pathopt($option)
    }
}

# Widget::parseArgs --
#
#	Given a widget class and a command-line spec, cannonize and validate
#	the given options, and return a keyed list consisting of the 
#	component widget and its masked portion of the command-line spec, and
#	one extra entry consisting of the portion corresponding to the 
#	megawidget itself.
#
# Arguments:
#	class	widget class to parse for.
#	options	command-line spec
#
# Results:
#	result	keyed list of portions of the megawidget and that segment of
#		the command line in which that portion is interested.

proc Widget::parseArgs {class options} {
    upvar 0 ${class}::opt classopt
    upvar 0 ${class}::map classmap
    
    foreach {option val} $options {
	if { ![info exists classopt($option)] } {
	    error "unknown option \"$option\""
	}
        set optdesc $classopt($option)
        set type    [lindex $optdesc 0]
        if { [string equal $type "Synonym"] } {
            set option  [lindex $optdesc 1]
            set optdesc $classopt($option)
            set type    [lindex $optdesc 0]
        }
	if { [string equal $type "TkResource"] } {
	    # Make sure that the widget used for this TkResource exists
	    Widget::_get_tkwidget_options [lindex [lindex $optdesc 3] 0]
	}
	set val [$Widget::_optiontype($type) $option $val [lindex $optdesc 3]]
		
	if { [info exists classmap($option)] } {
	    foreach {subpath subclass realopt} $classmap($option) {
		lappend maps($subpath) $realopt $val
	    }
	} else {
	    lappend maps($class) $option $val
	}
    }
    return [array get maps]
}

# Widget::initFromODB --
#
#	Initialize a megawidgets options with information from the option
#	database and from the command-line arguments given.
#
# Arguments:
#	class	class of the widget.
#	path	path of the widget -- should already exist.
#	options	command-line arguments.
#
# Results:
#	None.

proc Widget::initFromODB {class path options} {
    variable _inuse
    variable _class

    upvar 0 ${class}::$path:opt  pathopt
    upvar 0 ${class}::$path:mod  pathmod
    upvar 0 ${class}::map classmap

    if { [info exists pathopt] } {
	unset pathopt
    }
    if { [info exists pathmod] } {
	unset pathmod
    }
    # We prefer to use the actual widget for option db queries, but if it
    # doesn't exist yet, do the next best thing:  create a widget of the
    # same class and use that.
    set fpath [_get_window $class $path]
    set rdbclass [string map [list :: ""] $class]
    if { ![winfo exists $path] } {
	set fpath ".#BWidgetClass#$class"
	if { ![winfo exists $fpath] } {
	    frame $fpath -class $rdbclass
	}
    }

    foreach {option optdesc} [array get ${class}::opt] {
        set pathmod($option) 0
	if { [info exists classmap($option)] } {
	    continue
	}
        set type [lindex $optdesc 0]
        if { [string equal $type "Synonym"] } {
	    continue
        }
	if { [string equal $type "TkResource"] } {
            set alt [lindex [lindex $optdesc 3] 1]
        } else {
            set alt ""
        }
        set optdb [lindex [_configure_option $option $alt] 0]
        set def   [option get $fpath $optdb $rdbclass]
        if { [string length $def] } {
            set pathopt($option) $def
        } else {
            set pathopt($option) [lindex $optdesc 1]
        }
    }

    if {![info exists _inuse($class)]} { set _inuse($class) 0 }
    incr _inuse($class)

    set _class($path) $class
    array set pathopt $options
}



# ----------------------------------------------------------------------------
#  Command Widget::destroy
# ----------------------------------------------------------------------------
proc Widget::destroy { path } {
    variable _class
    variable _inuse

    if {![info exists _class($path)]} { return }

    set class $_class($path)
    upvar 0 ${class}::$path:opt pathopt
    upvar 0 ${class}::$path:mod pathmod
    upvar 0 ${class}::$path:init pathinit

    if {[info exists _inuse($class)]} { incr _inuse($class) -1 }

    if {[info exists pathopt]} {
        unset pathopt
    }
    if {[info exists pathmod]} {
        unset pathmod
    }
    if {[info exists pathinit]} {
        unset pathinit
    }

    if {![string equal [info commands $path] ""]} { rename $path "" }

    ## Unset any variables used in this widget.
    foreach var [info vars ::${class}::$path:*] { unset $var }

    unset _class($path)
}


# ----------------------------------------------------------------------------
#  Command Widget::configure
# ----------------------------------------------------------------------------
proc Widget::configure { path options } {
    set len [llength $options]
    if { $len <= 1 } {
        return [_get_configure $path $options]
    } elseif { $len % 2 == 1 } {
        return -code error "incorrect number of arguments"
    }

    variable _class
    variable _optiontype

    set class $_class($path)
    upvar 0 ${class}::opt  classopt
    upvar 0 ${class}::map  classmap
    upvar 0 ${class}::$path:opt pathopt
    upvar 0 ${class}::$path:mod pathmod

    set window [_get_window $class $path]
    foreach {option value} $options {
        if { ![info exists classopt($option)] } {
            return -code error "unknown option \"$option\""
        }
        set optdesc $classopt($option)
        set type    [lindex $optdesc 0]
        if { [string equal $type "Synonym"] } {
            set option  [lindex $optdesc 1]
            set optdesc $classopt($option)
            set type    [lindex $optdesc 0]
        }
        if { ![lindex $optdesc 2] } {
            set newval [$_optiontype($type) $option $value [lindex $optdesc 3]]
            if { [info exists classmap($option)] } {
		set window [_get_window $class $window]
                foreach {subpath subclass realopt} $classmap($option) {
                    if { [string length $subclass] } {
			set curval [${subclass}::cget $window$subpath $realopt]
                        ${subclass}::configure $window$subpath $realopt $newval
                    } else {
			set curval [$window$subpath cget $realopt]
                        $window$subpath configure $realopt $newval
                    }
                }
            } else {
		set curval $pathopt($option)
		set pathopt($option) $newval
	    }
	    set pathmod($option) [expr {![string equal $newval $curval]}]
        }
    }

    return {}
}


# ----------------------------------------------------------------------------
#  Command Widget::cget
# ----------------------------------------------------------------------------
proc Widget::cget { path option } {
    if { ![info exists ::Widget::_class($path)] } {
        return -code error "unknown widget $path"
    }

    set class $::Widget::_class($path)
    if { ![info exists ${class}::opt($option)] } {
        return -code error "unknown option \"$option\""
    }

    set optdesc [set ${class}::opt($option)]
    set type    [lindex $optdesc 0]
    if {[string equal $type "Synonym"]} {
        set option [lindex $optdesc 1]
    }

    if { [info exists ${class}::map($option)] } {
	foreach {subpath subclass realopt} [set ${class}::map($option)] {break}
	set path "[_get_window $class $path]$subpath"
	return [$path cget $realopt]
    }
    upvar 0 ${class}::$path:opt pathopt
    set pathopt($option)
}


# ----------------------------------------------------------------------------
#  Command Widget::subcget
# ----------------------------------------------------------------------------
proc Widget::subcget { path subwidget } {
    set class $::Widget::_class($path)
    upvar 0 ${class}::$path:opt pathopt
    upvar 0 ${class}::map$subwidget submap
    upvar 0 ${class}::$path:init pathinit

    set result {}
    foreach realopt [array names submap] {
	if { [info exists pathinit($submap($realopt))] } {
	    lappend result $realopt $pathopt($submap($realopt))
	}
    }
    return $result
}


# ----------------------------------------------------------------------------
#  Command Widget::hasChanged
# ----------------------------------------------------------------------------
proc Widget::hasChanged { path option pvalue } {
    upvar    $pvalue value
    set class $::Widget::_class($path)
    upvar 0 ${class}::$path:mod pathmod

    set value   [Widget::cget $path $option]
    set result  $pathmod($option)
    set pathmod($option) 0

    return $result
}

proc Widget::hasChangedX { path option args } {
    set class $::Widget::_class($path)
    upvar 0 ${class}::$path:mod pathmod

    set result  $pathmod($option)
    set pathmod($option) 0
    foreach option $args {
	lappend result $pathmod($option)
	set pathmod($option) 0
    }

    set result
}


# ----------------------------------------------------------------------------
#  Command Widget::setoption
# ----------------------------------------------------------------------------
proc Widget::setoption { path option value } {
#    variable _class

#    set class $_class($path)
#    upvar 0 ${class}::$path:opt pathopt

#    set pathopt($option) $value
    Widget::configure $path [list $option $value]
}


# ----------------------------------------------------------------------------
#  Command Widget::getoption
# ----------------------------------------------------------------------------
proc Widget::getoption { path option } {
#    set class $::Widget::_class($path)
#    upvar 0 ${class}::$path:opt pathopt

#    return $pathopt($option)
    return [Widget::cget $path $option]
}

# Widget::getMegawidgetOption --
#
#	Bypass the superfluous checks in cget and just directly peer at the
#	widget's data space.  This is much more fragile than cget, so it 
#	should only be used with great care, in places where speed is critical.
#
# Arguments:
#	path	widget to lookup options for.
#	option	option to retrieve.
#
# Results:
#	value	option value.

proc Widget::getMegawidgetOption {path option} {
    set class $::Widget::_class($path)
    upvar 0 ${class}::${path}:opt pathopt
    set pathopt($option)
}

# Widget::setMegawidgetOption --
#
#	Bypass the superfluous checks in cget and just directly poke at the
#	widget's data space.  This is much more fragile than configure, so it 
#	should only be used with great care, in places where speed is critical.
#
# Arguments:
#	path	widget to lookup options for.
#	option	option to retrieve.
#	value	option value.
#
# Results:
#	value	option value.

proc Widget::setMegawidgetOption {path option value} {
    set class $::Widget::_class($path)
    upvar 0 ${class}::${path}:opt pathopt
    set pathopt($option) $value
}

# ----------------------------------------------------------------------------
#  Command Widget::_get_window
#  returns the window corresponding to widget path
# ----------------------------------------------------------------------------
proc Widget::_get_window { class path } {
    set idx [string last "#" $path]
    if { $idx != -1 && [string equal [string range $path [expr {$idx+1}] end] $class] } {
        return [string range $path 0 [expr {$idx-1}]]
    } else {
        return $path
    }
}


# ----------------------------------------------------------------------------
#  Command Widget::_get_configure
#  returns the configuration list of options
#  (as tk widget do - [$w configure ?option?])
# ----------------------------------------------------------------------------
proc Widget::_get_configure { path options } {
    variable _class

    set class $_class($path)
    upvar 0 ${class}::opt classopt
    upvar 0 ${class}::map classmap
    upvar 0 ${class}::$path:opt pathopt
    upvar 0 ${class}::$path:mod pathmod

    set len [llength $options]
    if { !$len } {
        set result {}
        foreach option [lsort [array names classopt]] {
            set optdesc $classopt($option)
            set type    [lindex $optdesc 0]
            if { [string equal $type "Synonym"] } {
                set syn     $option
                set option  [lindex $optdesc 1]
                set optdesc $classopt($option)
                set type    [lindex $optdesc 0]
            } else {
                set syn ""
            }
            if { [string equal $type "TkResource"] } {
                set alt [lindex [lindex $optdesc 3] 1]
            } else {
                set alt ""
            }
            set res [_configure_option $option $alt]
            if { $syn == "" } {
                lappend result [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
            } else {
                lappend result [list $syn [lindex $res 0]]
            }
        }
        return $result
    } elseif { $len == 1 } {
        set option  [lindex $options 0]
        if { ![info exists classopt($option)] } {
            return -code error "unknown option \"$option\""
        }
        set optdesc $classopt($option)
        set type    [lindex $optdesc 0]
        if { [string equal $type "Synonym"] } {
            set option  [lindex $optdesc 1]
            set optdesc $classopt($option)
            set type    [lindex $optdesc 0]
        }
        if { [string equal $type "TkResource"] } {
            set alt [lindex [lindex $optdesc 3] 1]
        } else {
            set alt ""
        }
        set res [_configure_option $option $alt]
        return [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
    }
}


# ----------------------------------------------------------------------------
#  Command Widget::_configure_option
# ----------------------------------------------------------------------------
proc Widget::_configure_option { option altopt } {
    variable _optiondb
    variable _optionclass

    if { [info exists _optiondb($option)] } {
        set optdb $_optiondb($option)
    } else {
        set optdb [string range $option 1 end]
    }
    if { [info exists _optionclass($option)] } {
        set optclass $_optionclass($option)
    } elseif { [string length $altopt] } {
        if { [info exists _optionclass($altopt)] } {
            set optclass $_optionclass($altopt)
        } else {
            set optclass [string range $altopt 1 end]
        }
    } else {
        set optclass [string range $option 1 end]
    }
    return [list $optdb $optclass]
}


# ----------------------------------------------------------------------------
#  Command Widget::_get_tkwidget_options
# ----------------------------------------------------------------------------
proc Widget::_get_tkwidget_options { tkwidget } {
    variable _tk_widget
    variable _optiondb
    variable _optionclass
    
    set widget ".#BWidget#$tkwidget"
    if { ![winfo exists $widget] || ![info exists _tk_widget($tkwidget)] } {
	set widget [$tkwidget $widget]
	# JDC: Withdraw toplevels, otherwise visible
	if {[string equal $tkwidget "toplevel"]} {
	    wm withdraw $widget
	}
	set config [$widget configure]
	foreach optlist $config {
	    set opt [lindex $optlist 0]
	    if { [llength $optlist] == 2 } {
		set refsyn [lindex $optlist 1]
		# search for class
		set idx [lsearch $config [list * $refsyn *]]
		if { $idx == -1 } {
		    if { [string index $refsyn 0] == "-" } {
			# search for option (tk8.1b1 bug)
			set idx [lsearch $config [list $refsyn * *]]
		    } else {
			# last resort
			set idx [lsearch $config [list -[string tolower $refsyn] * *]]
		    }
		    if { $idx == -1 } {
			# fed up with "can't read classopt()"
			return -code error "can't find option of synonym $opt"
		    }
		}
		set syn [lindex [lindex $config $idx] 0]
		# JDC: used 4 (was 3) to get def from optiondb
		set def [lindex [lindex $config $idx] 4]
		lappend _tk_widget($tkwidget) [list $opt $syn $def]
	    } else {
		# JDC: used 4 (was 3) to get def from optiondb
		set def [lindex $optlist 4]
		lappend _tk_widget($tkwidget) [list $opt $def]
		set _optiondb($opt)    [lindex $optlist 1]
		set _optionclass($opt) [lindex $optlist 2]
	    }
	}
    }
    return $_tk_widget($tkwidget)
}


# ----------------------------------------------------------------------------
#  Command Widget::_test_tkresource
# ----------------------------------------------------------------------------
proc Widget::_test_tkresource { option value arg } {
#    set tkwidget [lindex $arg 0]
#    set realopt  [lindex $arg 1]
    foreach {tkwidget realopt} $arg break
    set path     ".#BWidget#$tkwidget"
    set old      [$path cget $realopt]
    $path configure $realopt $value
    set res      [$path cget $realopt]
    $path configure $realopt $old

    return $res
}


# ----------------------------------------------------------------------------
#  Command Widget::_test_bwresource
# ----------------------------------------------------------------------------
proc Widget::_test_bwresource { option value arg } {
    return -code error "bad option type BwResource in widget"
}


# ----------------------------------------------------------------------------
#  Command Widget::_test_synonym
# ----------------------------------------------------------------------------
proc Widget::_test_synonym { option value arg } {
    return -code error "bad option type Synonym in widget"
}

# ----------------------------------------------------------------------------
#  Command Widget::_test_color
# ----------------------------------------------------------------------------
proc Widget::_test_color { option value arg } {
    if {[catch {winfo rgb . $value} color]} {
        return -code error "bad $option value \"$value\": must be a colorname 		or #RRGGBB triplet"
    }

    return $value
}


# ----------------------------------------------------------------------------
#  Command Widget::_test_string
# ----------------------------------------------------------------------------
proc Widget::_test_string { option value arg } {
    set value
}


# ----------------------------------------------------------------------------
#  Command Widget::_test_flag
# ----------------------------------------------------------------------------
proc Widget::_test_flag { option value arg } {
    set len [string length $value]
    set res ""
    for {set i 0} {$i < $len} {incr i} {
        set c [string index $value $i]
        if { [string first $c $arg] == -1 } {
            return -code error "bad [string range $option 1 end] value \"$value\": characters must be in \"$arg\""
        }
        if { [string first $c $res] == -1 } {
            append res $c
        }
    }
    return $res
}


# -----------------------------------------------------------------------------
#  Command Widget::_test_enum
# -----------------------------------------------------------------------------
proc Widget::_test_enum { option value arg } {
    if { [lsearch $arg $value] == -1 } {
        set last [lindex   $arg end]
        set sub  [lreplace $arg end end]
        if { [llength $sub] } {
            set str "[join $sub ", "] or $last"
        } else {
            set str $last
        }
        return -code error "bad [string range $option 1 end] value \"$value\": must be $str"
    }
    return $value
}


# -----------------------------------------------------------------------------
#  Command Widget::_test_int
# -----------------------------------------------------------------------------
proc Widget::_test_int { option value arg } {
    if { ![string is int -strict $value] || 	    ([string length $arg] && 	    ![expr [string map [list %d $value] $arg]]) } {
		    return -code error "bad $option value			    \"$value\": must be integer ($arg)"
    }
    return $value
}


# -----------------------------------------------------------------------------
#  Command Widget::_test_boolean
# -----------------------------------------------------------------------------
proc Widget::_test_boolean { option value arg } {
    if { ![string is boolean -strict $value] } {
        return -code error "bad $option value \"$value\": must be boolean"
    }

    # Get the canonical form of the boolean value (1 for true, 0 for false)
    return [string is true $value]
}


# -----------------------------------------------------------------------------
#  Command Widget::_test_padding
# -----------------------------------------------------------------------------
proc Widget::_test_padding { option values arg } {
    set len [llength $values]
    if {$len < 1 || $len > 2} {
        return -code error "bad pad value \"$values\":                        must be positive screen distance"
    }

    foreach value $values {
        if { ![string is int -strict $value] ||             ([string length $arg] &&             ![expr [string map [list %d $value] $arg]]) } {
                return -code error "bad pad value \"$value\":                                must be positive screen distance ($arg)"
        }
    }
    return $values
}


# Widget::_get_padding --
#
#       Return the requesting padding value for a padding option.
#
# Arguments:
#	path		Widget to get the options for.
#       option          The name of the padding option.
#	index		The index of the padding.  If the index is empty,
#                       the first padding value is returned.
#
# Results:
#	Return a numeric value that can be used for padding.
proc Widget::_get_padding { path option {index 0} } {
    set pad [Widget::cget $path $option]
    set val [lindex $pad $index]
    if {$val == ""} { set val [lindex $pad 0] }
    return $val
}


# -----------------------------------------------------------------------------
#  Command Widget::focusNext
#  Same as tk_focusNext, but call Widget::focusOK
# -----------------------------------------------------------------------------
proc Widget::focusNext { w } {
    set cur $w
    while 1 {

	# Descend to just before the first child of the current widget.

	set parent $cur
	set children [winfo children $cur]
	set i -1

	# Look for the next sibling that isn't a top-level.

	while 1 {
	    incr i
	    if {$i < [llength $children]} {
		set cur [lindex $children $i]
		if {[winfo toplevel $cur] == $cur} {
		    continue
		} else {
		    break
		}
	    }

	    # No more siblings, so go to the current widget's parent.
	    # If it's a top-level, break out of the loop, otherwise
	    # look for its next sibling.

	    set cur $parent
	    if {[winfo toplevel $cur] == $cur} {
		break
	    }
	    set parent [winfo parent $parent]
	    set children [winfo children $parent]
	    set i [lsearch -exact $children $cur]
	}
	if {($cur == $w) || [focusOK $cur]} {
	    return $cur
	}
    }
}


# -----------------------------------------------------------------------------
#  Command Widget::focusPrev
#  Same as tk_focusPrev, but call Widget::focusOK
# -----------------------------------------------------------------------------
proc Widget::focusPrev { w } {
    set cur $w
    while 1 {

	# Collect information about the current window's position
	# among its siblings.  Also, if the window is a top-level,
	# then reposition to just after the last child of the window.
    
	if {[winfo toplevel $cur] == $cur}  {
	    set parent $cur
	    set children [winfo children $cur]
	    set i [llength $children]
	} else {
	    set parent [winfo parent $cur]
	    set children [winfo children $parent]
	    set i [lsearch -exact $children $cur]
	}

	# Go to the previous sibling, then descend to its last descendant
	# (highest in stacking order.  While doing this, ignore top-levels
	# and their descendants.  When we run out of descendants, go up
	# one level to the parent.

	while {$i > 0} {
	    incr i -1
	    set cur [lindex $children $i]
	    if {[winfo toplevel $cur] == $cur} {
		continue
	    }
	    set parent $cur
	    set children [winfo children $parent]
	    set i [llength $children]
	}
	set cur $parent
	if {($cur == $w) || [focusOK $cur]} {
	    return $cur
	}
    }
}


# ----------------------------------------------------------------------------
#  Command Widget::focusOK
#  Same as tk_focusOK, but handles -editable option and whole tags list.
# ----------------------------------------------------------------------------
proc Widget::focusOK { w } {
    set code [catch {$w cget -takefocus} value]
    if { $code == 1 } {
        return 0
    }
    if {($code == 0) && ($value != "")} {
	if {$value == 0} {
	    return 0
	} elseif {$value == 1} {
	    return [winfo viewable $w]
	} else {
	    set value [uplevel \#0 $value $w]
            if {$value != ""} {
		return $value
	    }
        }
    }
    if {![winfo viewable $w]} {
	return 0
    }
    set code [catch {$w cget -state} value]
    if {($code == 0) && ($value == "disabled")} {
	return 0
    }
    set code [catch {$w cget -editable} value]
    if {($code == 0) && ($value == 0)} {
        return 0
    }

    set top [winfo toplevel $w]
    foreach tags [bindtags $w] {
        if { ![string equal $tags $top]  &&
             ![string equal $tags "all"] &&
             [regexp Key [bind $tags]] } {
            return 1
        }
    }
    return 0
}


proc Widget::traverseTo { w } {
    set focus [focus]
    if {![string equal $focus ""]} {
	event generate $focus <<TraverseOut>>
    }
    focus $w

    event generate $w <<TraverseIn>>
}


# Widget::varForOption --
#
#	Retrieve a fully qualified variable name for the option specified.
#	If the option is not one for which a variable exists, throw an error 
#	(ie, those options that map directly to widget options).
#
# Arguments:
#	path	megawidget to get an option var for.
#	option	option to get a var for.
#
# Results:
#	varname	name of the variable, fully qualified, suitable for tracing.

proc Widget::varForOption {path option} {
    variable _class
    variable _optiontype

    set class $_class($path)
    upvar 0 ${class}::$path:opt pathopt

    if { ![info exists pathopt($option)] } {
	error "unable to find variable for option \"$option\""
    }
    set varname "::Widget::${class}::$path:opt($option)"
    return $varname
}

# Widget::getVariable --
#
#       Get a variable from within the namespace of the widget.
#
# Arguments:
#	path		Megawidget to get the variable for.
#	varName		The variable name to retrieve.
#       newVarName	The variable name to refer to in the calling proc.
#
# Results:
#	Creates a reference to newVarName in the calling proc.
proc Widget::getVariable { path varName {newVarName ""} } {
    variable _class
    set class $_class($path)
    if {![string length $newVarName]} { set newVarName $varName }
    uplevel 1 [list upvar \#0 ${class}::$path:$varName $newVarName]
}

# Widget::options --
#
#       Return a key-value list of options for a widget.  This can
#       be used to serialize the options of a widget and pass them
#       on to a new widget with the same options.
#
# Arguments:
#	path		Widget to get the options for.
#	args		A list of options.  If empty, all options are returned.
#
# Results:
#	Returns list of options as: -option value -option value ...
proc Widget::options { path args } {
    if {[llength $args]} {
        foreach option $args {
            lappend options [_get_configure $path $option]
        }
    } else {
        set options [_get_configure $path {}]
    }

    set result [list]
    foreach list $options {
        if {[llength $list] < 5} { continue }
        lappend result [lindex $list 0] [lindex $list end]
    }
    return $result
}


# Widget::getOption --
#
#	Given a list of widgets, determine which option value to use.
#	The widgets are given to the command in order of highest to
#	lowest.  Starting with the lowest widget, whichever one does
#	not match the default option value is returned as the value.
#	If all the widgets are default, we return the highest widget's
#	value.
#
# Arguments:
#	option		The option to check.
#	default		The default value.  If any widget in the list
#			does not match this default, its value is used.
#	args		A list of widgets.
#
# Results:
#	Returns the value of the given option to use.
#
proc Widget::getOption { option default args } {
    for {set i [expr [llength $args] -1]} {$i >= 0} {incr i -1} {
	set widget [lindex $args $i]
	set value  [Widget::cget $widget $option]
	if {[string equal $value $default]} { continue }
	return $value
    }
    return $value
}


proc Widget::nextIndex { path node } {
    Widget::getVariable $path autoIndex
    if {![info exists autoIndex]} { set autoIndex -1 }
    return [string map [list #auto [incr autoIndex]] $node]
}


proc Widget::exists { path } {
    variable _class
    return [info exists _class($path)]
}
# ----------------------------------------------------------------------------
#  dynhelp.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: dynhelp.tcl,v 1.13 2003/10/20 21:23:52 damonc Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#     - DynamicHelp::configure
#     - DynamicHelp::include
#     - DynamicHelp::sethelp
#     - DynamicHelp::register
#     - DynamicHelp::_motion_balloon
#     - DynamicHelp::_motion_info
#     - DynamicHelp::_leave_info
#     - DynamicHelp::_menu_info
#     - DynamicHelp::_show_help
#     - DynamicHelp::_init
# ----------------------------------------------------------------------------

# JDC: allow variable and ballon help at the same timees

namespace eval DynamicHelp {
    Widget::define DynamicHelp dynhelp -classonly

    Widget::declare DynamicHelp {
        {-foreground     TkResource black         0 label}
        {-topbackground  TkResource black         0 {label -foreground}}
        {-background     TkResource "#FFFFC0"     0 label}
        {-borderwidth    TkResource 1             0 label}
        {-justify        TkResource left          0 label}
        {-font           TkResource "helvetica 8" 0 label}
        {-delay          Int        600           0 "%d >= 100 & %d <= 2000"}
	{-state          Enum       "normal"      0 {normal disabled}}
        {-padx           TkResource 1             0 label}
        {-pady           TkResource 1             0 label}
        {-bd             Synonym    -borderwidth}
        {-bg             Synonym    -background}
        {-fg             Synonym    -foreground}
        {-topbg          Synonym    -topbackground}
    }

    proc use {} {}

    variable _registered
    variable _canvases

    variable _top     ".help_shell"
    variable _id      ""
    variable _delay   600
    variable _current_balloon ""
    variable _current_variable ""
    variable _saved

    Widget::init DynamicHelp $_top {}

    bind BwHelpBalloon <Enter>   {DynamicHelp::_motion_balloon enter  %W %X %Y}
    bind BwHelpBalloon <Motion>  {DynamicHelp::_motion_balloon motion %W %X %Y}
    bind BwHelpBalloon <Leave>   {DynamicHelp::_motion_balloon leave  %W %X %Y}
    bind BwHelpBalloon <Button>  {DynamicHelp::_motion_balloon button %W %X %Y}
    bind BwHelpBalloon <Destroy> {DynamicHelp::_unset_help %W}

    bind BwHelpVariable <Enter>   {DynamicHelp::_motion_info %W}
    bind BwHelpVariable <Motion>  {DynamicHelp::_motion_info %W}
    bind BwHelpVariable <Leave>   {DynamicHelp::_leave_info  %W}
    bind BwHelpVariable <Destroy> {DynamicHelp::_unset_help  %W}

    bind BwHelpMenu <<MenuSelect>> {DynamicHelp::_menu_info select %W}
    bind BwHelpMenu <Unmap>        {DynamicHelp::_menu_info unmap  %W}
    bind BwHelpMenu <Destroy>      {DynamicHelp::_unset_help %W}
}


# ----------------------------------------------------------------------------
#  Command DynamicHelp::configure
# ----------------------------------------------------------------------------
proc DynamicHelp::configure { args } {
    variable _top
    variable _delay

    set res [Widget::configure $_top $args]
    if { [Widget::hasChanged $_top -delay val] } {
        set _delay $val
    }

    return $res
}


# ----------------------------------------------------------------------------
#  Command DynamicHelp::include
# ----------------------------------------------------------------------------
proc DynamicHelp::include { class type } {
    set helpoptions [list 	    [list -helptext String "" 0] 	    [list -helpvar  String "" 0] 	    [list -helptype Enum $type 0 [list balloon variable]] 	    ]
    Widget::declare $class $helpoptions
}


# ----------------------------------------------------------------------------
#  Command DynamicHelp::sethelp
# ----------------------------------------------------------------------------
proc DynamicHelp::sethelp { path subpath {force 0}} {
    foreach {ctype ctext cvar} [Widget::hasChangedX $path 	    -helptype -helptext -helpvar] break
    if { $force || $ctype || $ctext || $cvar } {
	set htype [Widget::cget $path -helptype]
        switch $htype {
            balloon {
                return [register $subpath balloon 			[Widget::cget $path -helptext]]
            }
            variable {
                return [register $subpath variable 			[Widget::cget $path -helpvar] 			[Widget::cget $path -helptext]]
            }
        }
        return [register $subpath $htype]
    }
}

# ----------------------------------------------------------------------------
#  Command DynamicHelp::register
#
#  DynamicHelp::register path balloon  ?itemOrTag? text
#  DynamicHelp::register path variable ?itemOrTag? text varName
#  DynamicHelp::register path menu varName
#  DynamicHelp::register path menuentry index text
# ----------------------------------------------------------------------------
proc DynamicHelp::register { path type args } {
    variable _registered

    set len [llength $args]
    if {$type == "balloon"  && $len > 1} { set type canvasBalloon  }
    if {$type == "variable" && $len > 2} { set type canvasVariable }

    if { ![winfo exists $path] } {
        _unset_help $path
        return 0
    }

    switch $type {
        balloon {
            set text [lindex $args 0]
	    if {$text == ""} {
		if {[info exists _registered($path,balloon)]} {
		    unset _registered($path,balloon)
		}
		return 0
	    }

	    _add_balloon $path $text
        }

        canvasBalloon {
            set tagOrItem  [lindex $args 0]
            set text       [lindex $args 1]
	    if {$text == ""} {
		if {[info exists _registered($path,$tagOrItem,balloon)]} {
		    unset _registered($path,$tagOrItem,balloon)
		}
		return 0
	    }

	    _add_canvas_balloon $path $text $tagOrItem
        }

        variable {
            set var  [lindex $args 0]
            set text [lindex $args 1]
	    if {$text == "" || $var == ""} {
		if {[info exists _registered($path,variable)]} {
		    unset _registered($path,variable)
		}
		return 0
	    }

	    _add_variable $path $text $var
        }

        canvasVariable {
            set tagOrItem  [lindex $args 0]
            set var        [lindex $args 1]
            set text       [lindex $args 2]
	    if {$text == "" || $var == ""} {
		if {[info exists _registered($path,$tagOrItem,variable)]} {
		    unset _registered($path,$tagOrItem,variable)
		}
		return 0
	    }

	    _add_canvas_variable $path $text $var $tagOrItem
        }

        menu {
            set var [lindex $args 0]
	    if {$var == ""} {
		set cpath [BWidget::clonename $path]
		if {[winfo exists $cpath]} { set path $cpath }
		if {[info exists _registered($path)]} {
		    unset _registered($path)
		}
		return 0
	    }

	    _add_menu $path $var
        }

        menuentry {
            set cpath [BWidget::clonename $path]
            if { [winfo exists $cpath] } { set path $cpath }
            if {![info exists _registered($path)]} { return 0 }

            set text  [lindex $args 1]
            set index [lindex $args 0]
	    if {$text == "" || $index == ""} {
		set idx [lsearch $_registed($path) [list $index *]]
		set _registered($path) [lreplace $_registered($path) $idx $idx]
		return 0
	    }

	    _add_menuentry $path $text $index
        }

        default {
            _unset_help $path
	    return 0
        }
    }

    return 1
}


proc DynamicHelp::add { path args } {
    variable _registered

    array set data {
        -type     balloon
        -text     ""
        -item     ""
        -index    -1
        -command  ""
        -variable ""
    }
    if {[winfo exists $path] && [winfo class $path] == "Menu"} {
	set data(-type) menu
    }
    array set data $args

    set item $path

    switch -- $data(-type) {
        "balloon" {
            if {$data(-item) != ""} {
                _add_canvas_balloon $path $data(-text) $data(-item)
                set item $path,$data(-item)
            } else {
                _add_balloon $path $data(-text)
            }

	    if {$data(-variable) != ""} {
		set _registered($item,balloonVar) $data(-variable)
	    }
        }

        "variable" {
            set var $data(-variable)
            if {$data(-item) != ""} {
                _add_canvas_variable $path $data(-text) $var $data(-item)
                set item $path,$data(-item)
            } else {
                _add_variable $path $data(-text) $var
            }
        }

        "menu" {
            if {$data(-index) != -1} {
                set cpath [BWidget::clonename $path]
                if { [winfo exists $cpath] } { set path $cpath }
                if {![info exists _registered($path)]} { return 0 }
                _add_menuentry $path $data(-text) $data(-index)
                set item $path,$data(-index)
            } else {
                _add_menu $path $data(-variable)
            }
        }

        default {
            return 0
        }
    }

    if {$data(-command) != ""} {set _registered($item,command) $data(-command)}

    return 1
}


proc DynamicHelp::delete { path } {
    _unset_help $path
}


proc DynamicHelp::_add_bind_tag { path tag } {
    set evt [bindtags $path]
    set idx [lsearch $evt $tag]
    set evt [lreplace $evt $idx $idx]
    lappend evt $tag
    bindtags $path $evt
}


proc DynamicHelp::_add_balloon { path text } {
    variable _registered
    set _registered($path,balloon) $text
    _add_bind_tag $path BwHelpBalloon
}


proc DynamicHelp::_add_canvas_balloon { path text tagOrItem } {
    variable _canvases
    variable _registered

    set _registered($path,$tagOrItem,balloon) $text

    if {![info exists _canvases($path,balloon)]} {
        ## This canvas doesn't have the bindings yet.

        _add_bind_tag $path BwHelpBalloon

        $path bind BwHelpBalloon <Enter>             {DynamicHelp::_motion_balloon enter  %W %X %Y 1}
        $path bind BwHelpBalloon <Motion>             {DynamicHelp::_motion_balloon motion %W %X %Y 1}
        $path bind BwHelpBalloon <Leave>             {DynamicHelp::_motion_balloon leave  %W %X %Y 1}
        $path bind BwHelpBalloon <Button>             {DynamicHelp::_motion_balloon button %W %X %Y 1}

        set _canvases($path,balloon) 1
    }

    $path addtag BwHelpBalloon withtag $tagOrItem
}

proc DynamicHelp::_add_variable { path text varName } {
    variable _registered
    set _registered($path,variable) [list $varName $text]
    _add_bind_tag $path BwHelpVariable
}


proc DynamicHelp::_add_canvas_variable { path text varName tagOrItem } {
    variable _canvases
    variable _registered

    set _registered($path,$tagOrItem,variable) [list $varName $text]

    if {![info exists _canvases($path,variable)]} {
        ## This canvas doesn't have the bindings yet.

        _add_bind_tag $path BwHelpVariable

        $path bind BwHelpVariable <Enter>             {DynamicHelp::_motion_info %W 1}
        $path bind BwHelpVariable <Motion>             {DynamicHelp::_motion_info %W 1}
        $path bind BwHelpVariable <Leave>             {DynamicHelp::_leave_info  %W 1}

        set _canvases($path,variable) 1
    }

    $path addtag BwHelpVariable withtag $tagOrItem
}


proc DynamicHelp::_add_menu { path varName } {
    variable _registered

    set cpath [BWidget::clonename $path]
    if { [winfo exists $cpath] } { set path $cpath }

    set _registered($path) [list $varName]
    _add_bind_tag $path BwHelpMenu
}


proc DynamicHelp::_add_menuentry { path text index } {
    variable _registered

    set idx  [lsearch $_registered($path) [list $index *]]
    set list [list $index $text]
    if { $idx == -1 } {
	lappend _registered($path) $list
    } else {
	set _registered($path) 	    [lreplace $_registered($path) $idx $idx $list]
    }
}


# ----------------------------------------------------------------------------
#  Command DynamicHelp::_motion_balloon
# ----------------------------------------------------------------------------
proc DynamicHelp::_motion_balloon { type path x y {isCanvasItem 0} } {
    variable _top
    variable _id
    variable _delay
    variable _current_balloon

    set w $path
    if {$isCanvasItem} { set path [_get_canvas_path $path balloon] }

    if { $_current_balloon != $path && $type == "enter" } {
        set _current_balloon $path
        set type "motion"
        destroy $_top
    }
    if { $_current_balloon == $path } {
        if { $_id != "" } {
            after cancel $_id
            set _id ""
        }
        if { $type == "motion" } {
            if { ![winfo exists $_top] } {
                set cmd [list DynamicHelp::_show_help $path $w $x $y]
                set _id [after $_delay $cmd]
            }
        } else {
            destroy $_top
            set _current_balloon ""
        }
    }
}


# ----------------------------------------------------------------------------
#  Command DynamicHelp::_motion_info
# ----------------------------------------------------------------------------
proc DynamicHelp::_motion_info { path {isCanvasItem 0} } {
    variable _saved
    variable _registered
    variable _current_variable

    if {$isCanvasItem} { set path [_get_canvas_path $path variable] }

    if { $_current_variable != $path
        && [info exists _registered($path,variable)] } {

        set varName [lindex $_registered($path,variable) 0]
        if {![info exists _saved]} { set _saved [GlobalVar::getvar $varName] }
        set string [lindex $_registered($path,variable) 1]
        if {[info exists _registered($path,command)]} {
            set string [eval $_registered($path,command)]
        }
        GlobalVar::setvar $varName $string
        set _current_variable $path
    }
}


# ----------------------------------------------------------------------------
#  Command DynamicHelp::_leave_info
# ----------------------------------------------------------------------------
proc DynamicHelp::_leave_info { path {isCanvasItem 0} } {
    variable _saved
    variable _registered
    variable _current_variable

    if {$isCanvasItem} { set path [_get_canvas_path $path variable] }

    if { [info exists _registered($path,variable)] } {
        set varName [lindex $_registered($path,variable) 0]
        GlobalVar::setvar $varName $_saved
    }
    unset _saved
    set _current_variable ""
}


# ----------------------------------------------------------------------------
#  Command DynamicHelp::_menu_info
#    Version of R1v1 restored, due to lack of [winfo ismapped] and <Unmap>
#    under windows for menu.
# ----------------------------------------------------------------------------
proc DynamicHelp::_menu_info { event path } {
    variable _registered

    if { [info exists _registered($path)] } {
        set index   [$path index active]
        set varName [lindex $_registered($path) 0]
        if { ![string equal $index "none"] &&
             [set idx [lsearch $_registered($path) [list $index *]]] != -1 } {
	    set string [lindex [lindex $_registered($path) $idx] 1]
	    if {[info exists _registered($path,$index,command)]} {
		set string [eval $_registered($path,$index,command)]
	    }
            GlobalVar::setvar $varName $string
        } else {
            GlobalVar::setvar $varName ""
        }
    }
}


# ----------------------------------------------------------------------------
#  Command DynamicHelp::_show_help
# ----------------------------------------------------------------------------
proc DynamicHelp::_show_help { path w x y } {
    variable _top
    variable _registered
    variable _id
    variable _delay

    if { [Widget::getoption $_top -state] == "disabled" } { return }

    if { [info exists _registered($path,balloon)] } {
        destroy  $_top

        set string $_registered($path,balloon)

	if {[info exists _registered($path,balloonVar)]} {
	    upvar #0 $_registered($path,balloonVar) var
	    if {[info exists var]} { set string $var }
	}

        if {[info exists _registered($path,command)]} {
            set string [eval $_registered($path,command)]
        }

	if {$string == ""} { return }

        toplevel $_top -relief flat             -bg [Widget::getoption $_top -topbackground]             -bd [Widget::getoption $_top -borderwidth]             -screen [winfo screen $w]

        wm overrideredirect $_top 1
        wm transient $_top
        wm withdraw $_top

	catch { wm attributes $_top -topmost 1 }

        label $_top.label -text $string             -relief flat -bd 0 -highlightthickness 0 	    -padx       [Widget::getoption $_top -padx] 	    -pady       [Widget::getoption $_top -pady]             -foreground [Widget::getoption $_top -foreground]             -background [Widget::getoption $_top -background]             -font       [Widget::getoption $_top -font]             -justify    [Widget::getoption $_top -justify]


        pack $_top.label -side left
        update idletasks

	if {![winfo exists $_top]} {return}

        set  scrwidth  [winfo vrootwidth  .]
        set  scrheight [winfo vrootheight .]
        set  width     [winfo reqwidth  $_top]
        set  height    [winfo reqheight $_top]
        incr y 12
        incr x 8

        if { $x+$width > $scrwidth } {
            set x [expr {$scrwidth - $width}]
        }
        if { $y+$height > $scrheight } {
            set y [expr {$y - 12 - $height}]
        }

        wm geometry  $_top "+$x+$y"
        update idletasks

	if {![winfo exists $_top]} { return }
        wm deiconify $_top
        raise $_top
    }
}

# ----------------------------------------------------------------------------
#  Command DynamicHelp::_unset_help
# ----------------------------------------------------------------------------
proc DynamicHelp::_unset_help { path } {
    variable _canvases
    variable _registered

    if {[info exists _registered($path)]} { unset _registered($path) }
    if {[winfo exists $path]} {
	set cpath [BWidget::clonename $path]
	if {[info exists _registered($cpath)]} { unset _registered($cpath) }
    }
    array unset _canvases   $path,*
    array unset _registered $path,*
}

# ----------------------------------------------------------------------------
#  Command DynamicHelp::_get_canvas_path
# ----------------------------------------------------------------------------
proc DynamicHelp::_get_canvas_path { path type {item ""} } {
    variable _registered

    if {$item == ""} { set item [$path find withtag current] }

    ## Check the tags related to this item for the one that
    ## represents our text.  If we have text specific to this
    ## item or for 'all' items, they override any other tags.
    eval [list lappend tags $item all] [$path itemcget $item -tags]
    foreach tag $tags {
	set check $path,$tag
	if {![info exists _registered($check,$type)]} { continue }
	return $check
    }
}
# ------------------------------------------------------------------------------
#  arrow.tcl
#  This file is part of Unifix BWidget Toolkit
# ------------------------------------------------------------------------------
#  Index of commands:
#   Public commands
#     - ArrowButton::create
#     - ArrowButton::configure
#     - ArrowButton::cget
#     - ArrowButton::invoke
#   Private commands (redraw commands)
#     - ArrowButton::_redraw
#     - ArrowButton::_redraw_state
#     - ArrowButton::_redraw_relief
#     - ArrowButton::_redraw_whole
#   Private commands (event bindings)
#     - ArrowButton::_destroy
#     - ArrowButton::_enter
#     - ArrowButton::_leave
#     - ArrowButton::_press
#     - ArrowButton::_release
#     - ArrowButton::_repeat
# ------------------------------------------------------------------------------

namespace eval ArrowButton {
    Widget::define ArrowButton arrow DynamicHelp

    Widget::tkinclude ArrowButton button .c 	    include [list 		-borderwidth -bd 		-relief -highlightbackground 		-highlightcolor -highlightthickness -takefocus]

    Widget::declare ArrowButton [list 	    [list -type		Enum button 0 [list arrow button]] 	    [list -dir		Enum top    0 [list top bottom left right]] 	    [list -width	Int	15	0	"%d >= 0"] 	    [list -height	Int	15	0	"%d >= 0"] 	    [list -ipadx	Int	0	0	"%d >= 0"] 	    [list -ipady	Int	0	0	"%d >= 0"] 	    [list -clean	Int	2	0	"%d >= 0 && %d <= 2"] 	    [list -activeforeground	TkResource	""	0 button] 	    [list -activebackground	TkResource	""	0 button] 	    [list -disabledforeground 	TkResource	""	0 button] 	    [list -foreground		TkResource	""	0 button] 	    [list -background		TkResource	""	0 button] 	    [list -state		TkResource	""	0 button] 	    [list -troughcolor		TkResource	""	0 scrollbar] 	    [list -arrowbd	Int	1	0	"%d >= 0 && %d <= 2"] 	    [list -arrowrelief	Enum	raised	0	[list raised sunken]] 	    [list -command		String	""	0] 	    [list -armcommand		String	""	0] 	    [list -disarmcommand	String	""	0] 	    [list -repeatdelay		Int	0	0	"%d >= 0"] 	    [list -repeatinterval	Int	0	0	"%d >= 0"] 	    [list -fg	Synonym	-foreground] 	    [list -bg	Synonym	-background] 	    ]
    DynamicHelp::include ArrowButton balloon

    bind BwArrowButtonC <Enter>           {ArrowButton::_enter %W}
    bind BwArrowButtonC <Leave>           {ArrowButton::_leave %W}
    bind BwArrowButtonC <ButtonPress-1>   {ArrowButton::_press %W}
    bind BwArrowButtonC <ButtonRelease-1> {ArrowButton::_release %W}
    bind BwArrowButtonC <Key-space>       {ArrowButton::invoke %W; break}
    bind BwArrowButtonC <Return>          {ArrowButton::invoke %W; break}
    bind BwArrowButton <Configure>       {ArrowButton::_redraw_whole %W %w %h}
    bind BwArrowButton <Destroy>         {ArrowButton::_destroy %W}

    variable _grab
    variable _moved

    array set _grab {current "" pressed "" oldstate "" oldrelief ""}
}


# -----------------------------------------------------------------------------
#  Command ArrowButton::create
# -----------------------------------------------------------------------------
proc ArrowButton::create { path args } {
    # Initialize configuration mappings and parse arguments
    array set submaps [list ArrowButton [list ] .c [list ]]
    array set submaps [Widget::parseArgs ArrowButton $args]

    # Create the class frame (so we can do the option db queries)
    frame $path -class ArrowButton -borderwidth 0 -highlightthickness 0 
    Widget::initFromODB ArrowButton $path $submaps(ArrowButton)

    # Create the canvas with the initial options
    eval canvas $path.c $submaps(.c)

    # Compute the width and height of the canvas from the width/height
    # of the ArrowButton and the borderwidth/hightlightthickness.
    set w   [Widget::getMegawidgetOption $path -width]
    set h   [Widget::getMegawidgetOption $path -height]
    set bd  [Widget::cget $path -borderwidth]
    set ht  [Widget::cget $path -highlightthickness]
    set pad [expr {2*($bd+$ht)}]

    $path.c configure -width [expr {$w-$pad}] -height [expr {$h-$pad}]
    bindtags $path [list $path BwArrowButton [winfo toplevel $path] all]
    bindtags $path.c [list $path.c BwArrowButtonC [winfo toplevel $path.c] all]
    pack $path.c -expand yes -fill both

    DynamicHelp::sethelp $path $path.c 1

    set ::ArrowButton::_moved($path) 0

    return [Widget::create ArrowButton $path]
}


# -----------------------------------------------------------------------------
#  Command ArrowButton::configure
# -----------------------------------------------------------------------------
proc ArrowButton::configure { path args } {
    set res [Widget::configure $path $args]

    set ch1 [expr {[Widget::hasChanged $path -width  w] |
                   [Widget::hasChanged $path -height h] |
                   [Widget::hasChanged $path -borderwidth bd] |
                   [Widget::hasChanged $path -highlightthickness ht]}]
    set ch2 [expr {[Widget::hasChanged $path -type    val] |
                   [Widget::hasChanged $path -ipadx   val] |
                   [Widget::hasChanged $path -ipady   val] |
                   [Widget::hasChanged $path -arrowbd val] |
                   [Widget::hasChanged $path -clean   val] |
                   [Widget::hasChanged $path -dir     val]}]

    if { $ch1 } {
        set pad [expr {2*($bd+$ht)}]
        $path.c configure             -width [expr {$w-$pad}] -height [expr {$h-$pad}]             -borderwidth $bd -highlightthickness $ht
	set ch2 1
    }
    if { $ch2 } {
        _redraw_whole $path [winfo width $path] [winfo height $path]
    } else {
        _redraw_relief $path
        _redraw_state $path
    }
    DynamicHelp::sethelp $path $path.c

    return $res
}


# -----------------------------------------------------------------------------
#  Command ArrowButton::cget
# -----------------------------------------------------------------------------
proc ArrowButton::cget { path option } {
    return [Widget::cget $path $option]
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::invoke
# ------------------------------------------------------------------------------
proc ArrowButton::invoke { path } {
    if { ![string equal [winfo class $path] "ArrowButton"] } {
	set path [winfo parent $path]
    }
    if { ![string equal [Widget::getoption $path -state] "disabled"] } {
        set oldstate [Widget::getoption $path -state]
        if { [string equal [Widget::getoption $path -type] "button"] } {
            set oldrelief [Widget::getoption $path -relief]
            configure $path -state active -relief sunken
        } else {
            set oldrelief [Widget::getoption $path -arrowrelief]
            configure $path -state active -arrowrelief sunken
        }
	update idletasks
        if { [set cmd [Widget::getoption $path -armcommand]] != "" } {
            uplevel \#0 $cmd
        }
	after 10
        if { [string equal [Widget::getoption $path -type] "button"] } {
            configure $path -state $oldstate -relief $oldrelief
        } else {
            configure $path -state $oldstate -arrowrelief $oldrelief
        }
        if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } {
            uplevel \#0 $cmd
        }
        if { [set cmd [Widget::getoption $path -command]] != "" } {
            uplevel \#0 $cmd
        }
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_redraw
# ------------------------------------------------------------------------------
proc ArrowButton::_redraw { path width height } {
    variable _moved

    set _moved($path) 0
    set type  [Widget::getoption $path -type]
    set dir   [Widget::getoption $path -dir]
    set bd    [expr {[$path.c cget -borderwidth] + [$path.c cget -highlightthickness] + 1}]
    set clean [Widget::getoption $path -clean]
    if { [string equal $type "arrow"] } {
        if { [set id [$path.c find withtag rect]] == "" } {
            $path.c create rectangle $bd $bd [expr {$width-$bd-1}] [expr {$height-$bd-1}] -tags rect
        } else {
            $path.c coords $id $bd $bd [expr {$width-$bd-1}] [expr {$height-$bd-1}]
        }
        $path.c lower rect
        set arrbd [Widget::getoption $path -arrowbd]
        set bd    [expr {$bd+$arrbd-1}]
    } else {
        $path.c delete rect
    }
    # w and h are max width and max height of arrow
    set w [expr {$width  - 2*([Widget::getoption $path -ipadx]+$bd)}]
    set h [expr {$height - 2*([Widget::getoption $path -ipady]+$bd)}]

    if { $w < 2 } {set w 2}
    if { $h < 2 } {set h 2}

    if { $clean > 0 } {
        # arrange for base to be odd
        if { [string equal $dir "top"] ||
             [string equal $dir "bottom"] } {
            if { !($w % 2) } {
                incr w -1
            }
            if { $clean == 2 } {
                # arrange for h = (w+1)/2
                set h2 [expr {($w+1)/2}]
                if { $h2 > $h } {
                    set w [expr {2*$h-1}]
                } else {
                    set h $h2
                }
            }
        } else {
            if { !($h % 2) } {
                incr h -1
            }
            if { $clean == 2 } {
                # arrange for w = (h+1)/2
                set w2 [expr {($h+1)/2}]
                if { $w2 > $w } {
                    set h [expr {2*$w-1}]
                } else {
                    set w $w2
                }
            }
        }
    }

    set x0 [expr {($width-$w)/2}]
    set y0 [expr {($height-$h)/2}]
    set x1 [expr {$x0+$w-1}]
    set y1 [expr {$y0+$h-1}]

    switch $dir {
        top {
            set xd [expr {($x0+$x1)/2}]
            if { [set id [$path.c find withtag poly]] == "" } {
                $path.c create polygon $x0 $y1 $x1 $y1 $xd $y0 -tags poly
            } else {
                $path.c coords $id $x0 $y1 $x1 $y1 $xd $y0
            }
            if { [string equal $type "arrow"] } {
                if { [set id [$path.c find withtag bot]] == "" } {
                    $path.c create line $x0 $y1 $x1 $y1 $xd $y0 -tags bot
                } else {
                    $path.c coords $id $x0 $y1 $x1 $y1 $xd $y0
                }
                if { [set id [$path.c find withtag top]] == "" } {
                    $path.c create line $x0 $y1 $xd $y0 -tags top
                } else {
                    $path.c coords $id $x0 $y1 $xd $y0
                }
                $path.c itemconfigure top -width $arrbd
                $path.c itemconfigure bot -width $arrbd
            } else {
                $path.c delete top
                $path.c delete bot
            }
        }
        bottom {
            set xd [expr {($x0+$x1)/2}]
            if { [set id [$path.c find withtag poly]] == "" } {
                $path.c create polygon $x1 $y0 $x0 $y0 $xd $y1 -tags poly
            } else {
                $path.c coords $id $x1 $y0 $x0 $y0 $xd $y1
            }
            if { [string equal $type "arrow"] } {
                if { [set id [$path.c find withtag top]] == "" } {
                    $path.c create line $x1 $y0 $x0 $y0 $xd $y1 -tags top
                } else {
                    $path.c coords $id $x1 $y0 $x0 $y0 $xd $y1
                }
                if { [set id [$path.c find withtag bot]] == "" } {
                    $path.c create line $x1 $y0 $xd $y1 -tags bot
                } else {
                    $path.c coords $id $x1 $y0 $xd $y1
                }
                $path.c itemconfigure top -width $arrbd
                $path.c itemconfigure bot -width $arrbd
            } else {
                $path.c delete top
                $path.c delete bot
            }
        }
        left {
            set yd [expr {($y0+$y1)/2}]
            if { [set id [$path.c find withtag poly]] == "" } {
                $path.c create polygon $x1 $y0 $x1 $y1 $x0 $yd -tags poly
            } else {
                $path.c coords $id $x1 $y0 $x1 $y1 $x0 $yd
            }
            if { [string equal $type "arrow"] } {
                if { [set id [$path.c find withtag bot]] == "" } {
                    $path.c create line $x1 $y0 $x1 $y1 $x0 $yd -tags bot
                } else {
                    $path.c coords $id $x1 $y0 $x1 $y1 $x0 $yd
                }
                if { [set id [$path.c find withtag top]] == "" } {
                    $path.c create line $x1 $y0 $x0 $yd -tags top
                } else {
                    $path.c coords $id $x1 $y0 $x0 $yd
                }
                $path.c itemconfigure top -width $arrbd
                $path.c itemconfigure bot -width $arrbd
            } else {
                $path.c delete top
                $path.c delete bot
            }
        }
        right {
            set yd [expr {($y0+$y1)/2}]
            if { [set id [$path.c find withtag poly]] == "" } {
                $path.c create polygon $x0 $y1 $x0 $y0 $x1 $yd -tags poly
            } else {
                $path.c coords $id $x0 $y1 $x0 $y0 $x1 $yd
            }
            if { [string equal $type "arrow"] } {
                if { [set id [$path.c find withtag top]] == "" } {
                    $path.c create line $x0 $y1 $x0 $y0 $x1 $yd -tags top
                } else {
                    $path.c coords $id $x0 $y1 $x0 $y0 $x1 $yd
                }
                if { [set id [$path.c find withtag bot]] == "" } {
                    $path.c create line $x0 $y1 $x1 $yd -tags bot
                } else {
                    $path.c coords $id $x0 $y1 $x1 $yd
                }
                $path.c itemconfigure top -width $arrbd
                $path.c itemconfigure bot -width $arrbd
            } else {
                $path.c delete top
                $path.c delete bot
            }
        }
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_redraw_state
# ------------------------------------------------------------------------------
proc ArrowButton::_redraw_state { path } {
    set state [Widget::getoption $path -state]
    if { [string equal [Widget::getoption $path -type] "button"] } {
        switch $state {
            normal   {set bg -background;       set fg -foreground}
            active   {set bg -activebackground; set fg -activeforeground}
            disabled {set bg -background;       set fg -disabledforeground}
        }
        set fg [Widget::getoption $path $fg]
        $path.c configure -background [Widget::getoption $path $bg]
        $path.c itemconfigure poly -fill $fg -outline $fg
    } else {
        switch $state {
            normal   {set stipple "";     set bg [Widget::getoption $path -background] }
            active   {set stipple "";     set bg [Widget::getoption $path -activebackground] }
            disabled {set stipple gray50; set bg black }
        }
        set thrc [Widget::getoption $path -troughcolor]
        $path.c configure -background [Widget::getoption $path -background]
        $path.c itemconfigure rect -fill $thrc -outline $thrc
        $path.c itemconfigure poly -fill $bg   -outline $bg -stipple $stipple
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_redraw_relief
# ------------------------------------------------------------------------------
proc ArrowButton::_redraw_relief { path } {
    variable _moved

    if { [string equal [Widget::getoption $path -type] "button"] } {
        if { [string equal [Widget::getoption $path -relief] "sunken"] } {
            if { !$_moved($path) } {
                $path.c move poly 1 1
                set _moved($path) 1
            }
        } else {
            if { $_moved($path) } {
                $path.c move poly -1 -1
                set _moved($path) 0
            }
        }
    } else {
        set col3d [BWidget::get3dcolor $path [Widget::getoption $path -background]]
        switch [Widget::getoption $path -arrowrelief] {
            raised {set top [lindex $col3d 1]; set bot [lindex $col3d 0]}
            sunken {set top [lindex $col3d 0]; set bot [lindex $col3d 1]}
        }
        $path.c itemconfigure top -fill $top
        $path.c itemconfigure bot -fill $bot
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_redraw_whole
# ------------------------------------------------------------------------------
proc ArrowButton::_redraw_whole { path width height } {
    _redraw $path $width $height
    _redraw_relief $path
    _redraw_state $path
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_enter
# ------------------------------------------------------------------------------
proc ArrowButton::_enter { path } {
    variable _grab
    set path [winfo parent $path]
    set _grab(current) $path
    if { ![string equal [Widget::getoption $path -state] "disabled"] } {
        set _grab(oldstate) [Widget::getoption $path -state]
        configure $path -state active
        if { $_grab(pressed) == $path } {
            if { [string equal [Widget::getoption $path -type] "button"] } {
                set _grab(oldrelief) [Widget::getoption $path -relief]
                configure $path -relief sunken
            } else {
                set _grab(oldrelief) [Widget::getoption $path -arrowrelief]
                configure $path -arrowrelief sunken
            }
        }
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_leave
# ------------------------------------------------------------------------------
proc ArrowButton::_leave { path } {
    variable _grab
    set path [winfo parent $path]
    set _grab(current) ""
    if { ![string equal [Widget::getoption $path -state] "disabled"] } {
        configure $path -state $_grab(oldstate)
        if { $_grab(pressed) == $path } {
            if { [string equal [Widget::getoption $path -type] "button"] } {
                configure $path -relief $_grab(oldrelief)
            } else {
                configure $path -arrowrelief $_grab(oldrelief)
            }
        }
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_press
# ------------------------------------------------------------------------------
proc ArrowButton::_press { path } {
    variable _grab
    set path [winfo parent $path]
    if { ![string equal [Widget::getoption $path -state] "disabled"] } {
        set _grab(pressed) $path
            if { [string equal [Widget::getoption $path -type] "button"] } {
            set _grab(oldrelief) [Widget::getoption $path -relief]
            configure $path -relief sunken
        } else {
            set _grab(oldrelief) [Widget::getoption $path -arrowrelief]
            configure $path -arrowrelief sunken
        }
        if { [set cmd [Widget::getoption $path -armcommand]] != "" } {
            uplevel \#0 $cmd
            if { [set delay [Widget::getoption $path -repeatdelay]]    > 0 ||
                 [set delay [Widget::getoption $path -repeatinterval]] > 0 } {
                after $delay "ArrowButton::_repeat $path"
            }
        }
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_release
# ------------------------------------------------------------------------------
proc ArrowButton::_release { path } {
    variable _grab
    set path [winfo parent $path]
    if { $_grab(pressed) == $path } {
        set _grab(pressed) ""
            if { [string equal [Widget::getoption $path -type] "button"] } {
            configure $path -relief $_grab(oldrelief)
        } else {
            configure $path -arrowrelief $_grab(oldrelief)
        }
        if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } {
            uplevel \#0 $cmd
        }
        if { $_grab(current) == $path &&
             ![string equal [Widget::getoption $path -state] "disabled"] &&
             [set cmd [Widget::getoption $path -command]] != "" } {
            uplevel \#0 $cmd
        }
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_repeat
# ------------------------------------------------------------------------------
proc ArrowButton::_repeat { path } {
    variable _grab
    if { $_grab(current) == $path && $_grab(pressed) == $path &&
         ![string equal [Widget::getoption $path -state] "disabled"] &&
         [set cmd [Widget::getoption $path -armcommand]] != "" } {
        uplevel \#0 $cmd
    }
    if { $_grab(pressed) == $path &&
         ([set delay [Widget::getoption $path -repeatinterval]] > 0 ||
          [set delay [Widget::getoption $path -repeatdelay]]    > 0) } {
        after $delay "ArrowButton::_repeat $path"
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_destroy
# ------------------------------------------------------------------------------
proc ArrowButton::_destroy { path } {
    variable _moved
    Widget::destroy $path
    unset _moved($path)
}
# ---------------------------------------------------------------------------
#  notebook.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: notebook.tcl,v 1.20 2003/11/26 18:42:24 hobbs Exp $
# ---------------------------------------------------------------------------
#  Index of commands:
#     - NoteBook::create
#     - NoteBook::configure
#     - NoteBook::cget
#     - NoteBook::compute_size
#     - NoteBook::insert
#     - NoteBook::delete
#     - NoteBook::itemconfigure
#     - NoteBook::itemcget
#     - NoteBook::bindtabs
#     - NoteBook::raise
#     - NoteBook::see
#     - NoteBook::page
#     - NoteBook::pages
#     - NoteBook::index
#     - NoteBook::getframe
#     - NoteBook::_test_page
#     - NoteBook::_itemconfigure
#     - NoteBook::_compute_width
#     - NoteBook::_get_x_page
#     - NoteBook::_xview
#     - NoteBook::_highlight
#     - NoteBook::_select
#     - NoteBook::_redraw
#     - NoteBook::_draw_page
#     - NoteBook::_draw_arrows
#     - NoteBook::_draw_area
#     - NoteBook::_resize
# ---------------------------------------------------------------------------

namespace eval NoteBook {
    Widget::define NoteBook notebook ArrowButton DynamicHelp

    namespace eval Page {
        Widget::declare NoteBook::Page {
            {-state      Enum       normal 0 {normal disabled}}
            {-createcmd  String     ""     0}
            {-raisecmd   String     ""     0}
            {-leavecmd   String     ""     0}
            {-image      TkResource ""     0 label}
            {-text       String     ""     0}
            {-foreground         String     ""     0}
            {-background         String     ""     0}
            {-activeforeground   String     ""     0}
            {-activebackground   String     ""     0}
            {-disabledforeground String     ""     0}
        }
    }

    DynamicHelp::include NoteBook::Page balloon

    Widget::bwinclude NoteBook ArrowButton .c.fg 	    include {-foreground -background -activeforeground 		-activebackground -disabledforeground -repeatinterval 		-repeatdelay -borderwidth} 	    initialize {-borderwidth 1}
    Widget::bwinclude NoteBook ArrowButton .c.fd 	    include {-foreground -background -activeforeground 		-activebackground -disabledforeground -repeatinterval 		-repeatdelay -borderwidth} 	    initialize {-borderwidth 1}

    Widget::declare NoteBook {
	{-foreground		TkResource "" 0 button}
        {-background		TkResource "" 0 button}
        {-activebackground	TkResource "" 0 button}
        {-activeforeground	TkResource "" 0 button}
        {-disabledforeground	TkResource "" 0 button}
        {-font			TkResource "" 0 button}
        {-side			Enum       top 0 {top bottom}}
        {-homogeneous		Boolean 0   0}
        {-borderwidth		Int 1   0 "%d >= 1 && %d <= 2"}
 	{-internalborderwidth	Int 10  0 "%d >= 0"}
        {-width			Int 0   0 "%d >= 0"}
        {-height		Int 0   0 "%d >= 0"}

        {-repeatdelay        BwResource ""  0 ArrowButton}
        {-repeatinterval     BwResource ""  0 ArrowButton}

        {-fg                 Synonym -foreground}
        {-bg                 Synonym -background}
        {-bd                 Synonym -borderwidth}
        {-ibd                Synonym -internalborderwidth}

	{-arcradius          Int     2     0 "%d >= 0 && %d <= 8"}
	{-tabbevelsize       Int     0     0 "%d >= 0 && %d <= 8"}
        {-tabpady            Padding {0 6} 0 "%d >= 0"}
    }

    Widget::addmap NoteBook "" .c {-background {}}

    variable _warrow 12

    bind NoteBook <Configure> [list NoteBook::_resize  %W]
    bind NoteBook <Destroy>   [list NoteBook::_destroy %W]
}


# ---------------------------------------------------------------------------
#  Command NoteBook::create
# ---------------------------------------------------------------------------
proc NoteBook::create { path args } {
    variable $path
    upvar 0  $path data

    Widget::init NoteBook $path $args

    set data(base)     0
    set data(select)   ""
    set data(pages)    {}
    set data(pages)    {}
    set data(cpt)      0
    set data(realized) 0
    set data(wpage)    0

    _compute_height $path

    # Create the canvas
    set w [expr {[Widget::cget $path -width]+4}]
    set h [expr {[Widget::cget $path -height]+$data(hpage)+4}]

    frame $path -class NoteBook -borderwidth 0 -highlightthickness 0 	    -relief flat
    eval [list canvas $path.c] [Widget::subcget $path .c] 	    [list -relief flat -borderwidth 0 -highlightthickness 0 	    -width $w -height $h]
    pack $path.c -expand yes -fill both

    # Removing the Canvas global bindings from our canvas as
    # application specific bindings on that tag may interfere with its
    # operation here. [SF item #459033]

    set bindings [bindtags $path.c]
    set pos [lsearch -exact $bindings Canvas]
    if {$pos >= 0} {
	set bindings [lreplace $bindings $pos $pos]
    }
    bindtags $path.c $bindings

    # Create the arrow button
    eval [list ArrowButton::create $path.c.fg] [Widget::subcget $path .c.fg] 	    [list -highlightthickness 0 -type button -dir left 	    -armcommand [list NoteBook::_xview $path -1]]

    eval [list ArrowButton::create $path.c.fd] [Widget::subcget $path .c.fd] 	    [list -highlightthickness 0 -type button -dir right 	    -armcommand [list NoteBook::_xview $path 1]]

    Widget::create NoteBook $path

    set bg [Widget::cget $path -background]
    foreach {data(dbg) data(lbg)} [BWidget::get3dcolor $path $bg] {break}

    return $path
}


# ---------------------------------------------------------------------------
#  Command NoteBook::configure
# ---------------------------------------------------------------------------
proc NoteBook::configure { path args } {
    variable $path
    upvar 0  $path data

    set res [Widget::configure $path $args]
    set redraw 0
    set opts [list -font -homogeneous -tabpady]
    foreach {cf ch cp} [eval Widget::hasChangedX $path $opts] {break}
    if {$cf || $ch || $cp} {
        if { $cf || $cp } {
            _compute_height $path
        }
        _compute_width $path
        set redraw 1
    }
    set chibd [Widget::hasChanged $path -internalborderwidth ibd]
    set chbg  [Widget::hasChanged $path -background bg]
    if {$chibd || $chbg} {
        foreach page $data(pages) {
            $path.f$page configure                 -borderwidth $ibd -background $bg
        }
    }

    if {$chbg} {
        set col [BWidget::get3dcolor $path $bg]
        set data(dbg)  [lindex $col 0]
        set data(lbg)  [lindex $col 1]
        set redraw 1
    }
    if { [Widget::hasChanged $path -foreground  fg] ||
         [Widget::hasChanged $path -borderwidth bd] ||
	 [Widget::hasChanged $path -arcradius radius] ||
         [Widget::hasChanged $path -tabbevelsize bevel] ||
         [Widget::hasChanged $path -side side] } {
        set redraw 1
    }
    set wc [Widget::hasChanged $path -width  w]
    set hc [Widget::hasChanged $path -height h]
    if { $wc || $hc } {
        $path.c configure 		-width  [expr {$w + 4}] 		-height [expr {$h + $data(hpage) + 4}]
    }
    if { $redraw } {
        _redraw $path
    }

    return $res
}


# ---------------------------------------------------------------------------
#  Command NoteBook::cget
# ---------------------------------------------------------------------------
proc NoteBook::cget { path option } {
    return [Widget::cget $path $option]
}


# ---------------------------------------------------------------------------
#  Command NoteBook::compute_size
# ---------------------------------------------------------------------------
proc NoteBook::compute_size { path } {
    variable $path
    upvar 0  $path data

    set wmax 0
    set hmax 0
    update idletasks
    foreach page $data(pages) {
        set w    [winfo reqwidth  $path.f$page]
        set h    [winfo reqheight $path.f$page]
        set wmax [expr {$w>$wmax ? $w : $wmax}]
        set hmax [expr {$h>$hmax ? $h : $hmax}]
    }
    configure $path -width $wmax -height $hmax
    # Sven... well ok so this is called twice in some cases...
    NoteBook::_redraw $path
    # Sven end
}


# ---------------------------------------------------------------------------
#  Command NoteBook::insert
# ---------------------------------------------------------------------------
proc NoteBook::insert { path index page args } {
    variable $path
    upvar 0  $path data

    if { [lsearch -exact $data(pages) $page] != -1 } {
        return -code error "page \"$page\" already exists"
    }

    set f $path.f$page
    Widget::init NoteBook::Page $f $args

    set data(pages) [linsert $data(pages) $index $page]
    # If the page doesn't exist, create it; if it does reset its bg and ibd
    if { ![winfo exists $f] } {
        frame $f 	    -relief      flat 	    -background  [Widget::cget $path -background] 	    -borderwidth [Widget::cget $path -internalborderwidth]
        set data($page,realized) 0
    } else {
	$f configure 	    -background  [Widget::cget $path -background] 	    -borderwidth [Widget::cget $path -internalborderwidth]
    }
    _compute_height $path
    _compute_width  $path
    _draw_page $path $page 1
    _set_help  $path $page
    _redraw $path

    return $f
}


# ---------------------------------------------------------------------------
#  Command NoteBook::delete
# ---------------------------------------------------------------------------
proc NoteBook::delete { path page {destroyframe 1} } {
    variable $path
    upvar 0  $path data

    set pos [_test_page $path $page]
    set data(pages) [lreplace $data(pages) $pos $pos]
    _compute_width $path
    $path.c delete p:$page
    if { $data(select) == $page } {
        set data(select) ""
    }
    if { $pos < $data(base) } {
        incr data(base) -1
    }
    if { $destroyframe } {
        destroy $path.f$page
    }
    _redraw $path
}


# ---------------------------------------------------------------------------
#  Command NoteBook::itemconfigure
# ---------------------------------------------------------------------------
proc NoteBook::itemconfigure { path page args } {
    _test_page $path $page
    set res [_itemconfigure $path $page $args]
    _redraw $path

    return $res
}


# ---------------------------------------------------------------------------
#  Command NoteBook::itemcget
# ---------------------------------------------------------------------------
proc NoteBook::itemcget { path page option } {
    _test_page $path $page
    return [Widget::cget $path.f$page $option]
}


# ---------------------------------------------------------------------------
#  Command NoteBook::bindtabs
# ---------------------------------------------------------------------------
proc NoteBook::bindtabs { path event script } {
    if { $script != "" } {
	append script " \[NoteBook::_get_page_name [list $path] current 1\]"
        $path.c bind "page" $event $script
    } else {
        $path.c bind "page" $event {}
    }
}


# ---------------------------------------------------------------------------
#  Command NoteBook::move
# ---------------------------------------------------------------------------
proc NoteBook::move { path page index } {
    variable $path
    upvar 0  $path data

    set pos [_test_page $path $page]
    set data(pages) [linsert [lreplace $data(pages) $pos $pos] $index $page]
    _redraw $path
}


# ---------------------------------------------------------------------------
#  Command NoteBook::raise
# ---------------------------------------------------------------------------
proc NoteBook::raise { path {page ""} } {
    variable $path
    upvar 0  $path data

    if { $page != "" } {
        _test_page $path $page
        _select $path $page
    }
    return $data(select)
}


# ---------------------------------------------------------------------------
#  Command NoteBook::see
# ---------------------------------------------------------------------------
proc NoteBook::see { path page } {
    variable $path
    upvar 0  $path data

    set pos [_test_page $path $page]
    if { $pos < $data(base) } {
        set data(base) $pos
        _redraw $path
    } else {
        set w     [expr {[winfo width $path]-1}]
        set fpage [expr {[_get_x_page $path $pos] + $data($page,width) + 6}]
        set idx   $data(base)
        while { $idx < $pos && $fpage > $w } {
            set fpage [expr {$fpage - $data([lindex $data(pages) $idx],width)}]
            incr idx
        }
        if { $idx != $data(base) } {
            set data(base) $idx
            _redraw $path
        }
    }
}


# ---------------------------------------------------------------------------
#  Command NoteBook::page
# ---------------------------------------------------------------------------
proc NoteBook::page { path first {last ""} } {
    variable $path
    upvar 0  $path data

    if { $last == "" } {
        return [lindex $data(pages) $first]
    } else {
        return [lrange $data(pages) $first $last]
    }
}


# ---------------------------------------------------------------------------
#  Command NoteBook::pages
# ---------------------------------------------------------------------------
proc NoteBook::pages { path {first ""} {last ""}} {
    variable $path
    upvar 0  $path data

    if { ![string length $first] } {
	return $data(pages)
    }

    if { ![string length $last] } {
        return [lindex $data(pages) $first]
    } else {
        return [lrange $data(pages) $first $last]
    }
}


# ---------------------------------------------------------------------------
#  Command NoteBook::index
# ---------------------------------------------------------------------------
proc NoteBook::index { path page } {
    variable $path
    upvar 0  $path data

    return [lsearch -exact $data(pages) $page]
}


# ---------------------------------------------------------------------------
#  Command NoteBook::_destroy
# ---------------------------------------------------------------------------
proc NoteBook::_destroy { path } {
    variable $path
    upvar 0  $path data

    foreach page $data(pages) {
        Widget::destroy $path.f$page
    }
    Widget::destroy $path
    unset data
}


# ---------------------------------------------------------------------------
#  Command NoteBook::getframe
# ---------------------------------------------------------------------------
proc NoteBook::getframe { path page } {
    return $path.f$page
}


# ---------------------------------------------------------------------------
#  Command NoteBook::_test_page
# ---------------------------------------------------------------------------
proc NoteBook::_test_page { path page } {
    variable $path
    upvar 0  $path data

    if { [set pos [lsearch -exact $data(pages) $page]] == -1 } {
        return -code error "page \"$page\" does not exists"
    }
    return $pos
}

proc NoteBook::_getoption { path page option } {
    set value [Widget::cget $path.f$page $option]
    if {![string length $value]} {
        set value [Widget::cget $path $option]
    }
    return $value
}

# ---------------------------------------------------------------------------
#  Command NoteBook::_itemconfigure
# ---------------------------------------------------------------------------
proc NoteBook::_itemconfigure { path page lres } {
    variable $path
    upvar 0  $path data

    set res [Widget::configure $path.f$page $lres]
    if { [Widget::hasChanged $path.f$page -text foo] } {
        _compute_width $path
    } elseif  { [Widget::hasChanged $path.f$page -image foo] } {
        _compute_height $path
        _compute_width  $path
    }
    if { [Widget::hasChanged $path.f$page -state state] &&
         $state == "disabled" && $data(select) == $page } {
        set data(select) ""
    }
    return $res
}


# ---------------------------------------------------------------------------
#  Command NoteBook::_compute_width
# ---------------------------------------------------------------------------
proc NoteBook::_compute_width { path } {
    variable $path
    upvar 0  $path data

    set wmax 0
    set wtot 0
    set hmax $data(hpage)
    set font [Widget::cget $path -font]
    if { ![info exists data(textid)] } {
        set data(textid) [$path.c create text 0 -100 -font $font -anchor nw]
    }
    set id $data(textid)
    $path.c itemconfigure $id -font $font
    foreach page $data(pages) {
        $path.c itemconfigure $id -text [Widget::cget $path.f$page -text]
	# Get the bbox for this text to determine its width, then substract
	# 6 from the width to account for canvas bbox oddness w.r.t. widths of
	# simple text.
	foreach {x1 y1 x2 y2} [$path.c bbox $id] break
	set x2 [expr {$x2 - 6}]
        set wtext [expr {$x2 - $x1 + 20}]
        if { [set img [Widget::cget $path.f$page -image]] != "" } {
            set wtext [expr {$wtext + [image width $img] + 4}]
            set himg  [expr {[image height $img] + 6}]
            if { $himg > $hmax } {
                set hmax $himg
            }
        }
        set  wmax  [expr {$wtext > $wmax ? $wtext : $wmax}]
        incr wtot  $wtext
        set  data($page,width) $wtext
    }
    if { [Widget::cget $path -homogeneous] } {
        foreach page $data(pages) {
            set data($page,width) $wmax
        }
        set wtot [expr {$wmax * [llength $data(pages)]}]
    }
    set data(hpage) $hmax
    set data(wpage) $wtot
}


# ---------------------------------------------------------------------------
#  Command NoteBook::_compute_height
# ---------------------------------------------------------------------------
proc NoteBook::_compute_height { path } {
    variable $path
    upvar 0  $path data

    set font    [Widget::cget $path -font]
    set pady0   [Widget::_get_padding $path -tabpady 0]
    set pady1   [Widget::_get_padding $path -tabpady 1]
    set metrics [font metrics $font -linespace]
    set imgh    0
    set lines   1
    foreach page $data(pages) {
        set img  [Widget::cget $path.f$page -image]
        set text [Widget::cget $path.f$page -text]
        set len [llength [split $text \n]]
        if {$len > $lines} { set lines $len}
        if {$img != ""} {
            set h [image height $img]
            if {$h > $imgh} { set imgh $h }
        }
    }
    set height [expr {$metrics * $lines}]
    if {$imgh > $height} { set height $imgh }
    set data(hpage) [expr {$height + $pady0 + $pady1}]
}


# ---------------------------------------------------------------------------
#  Command NoteBook::_get_x_page
# ---------------------------------------------------------------------------
proc NoteBook::_get_x_page { path pos } {
    variable _warrow
    variable $path
    upvar 0  $path data

    set base $data(base)
    # notebook tabs start flush with the left side of the notebook
    set x 0
    if { $pos < $base } {
        foreach page [lrange $data(pages) $pos [expr {$base-1}]] {
            incr x [expr {-$data($page,width)}]
        }
    } elseif { $pos > $base } {
        foreach page [lrange $data(pages) $base [expr {$pos-1}]] {
            incr x $data($page,width)
        }
    }
    return $x
}


# ---------------------------------------------------------------------------
#  Command NoteBook::_xview
# ---------------------------------------------------------------------------
proc NoteBook::_xview { path inc } {
    variable $path
    upvar 0  $path data

    if { $inc == -1 } {
        set base [expr {$data(base)-1}]
        set dx $data([lindex $data(pages) $base],width)
    } else {
        set dx [expr {-$data([lindex $data(pages) $data(base)],width)}]
        set base [expr {$data(base)+1}]
    }

    if { $base >= 0 && $base < [llength $data(pages)] } {
        set data(base) $base
        $path.c move page $dx 0
        _draw_area   $path
        _draw_arrows $path
    }
}


# ---------------------------------------------------------------------------
#  Command NoteBook::_highlight
# ---------------------------------------------------------------------------
proc NoteBook::_highlight { type path page } {
    variable $path
    upvar 0  $path data

    if { [string equal [Widget::cget $path.f$page -state] "disabled"] } {
        return
    }

    switch -- $type {
        on {
            $path.c itemconfigure "$page:poly" 		    -fill [_getoption $path $page -activebackground]
            $path.c itemconfigure "$page:text" 		    -fill [_getoption $path $page -activeforeground]
        }
        off {
            $path.c itemconfigure "$page:poly" 		    -fill [_getoption $path $page -background]
            $path.c itemconfigure "$page:text" 		    -fill [_getoption $path $page -foreground]
        }
    }
}


# ---------------------------------------------------------------------------
#  Command NoteBook::_select
# ---------------------------------------------------------------------------
proc NoteBook::_select { path page } {
    variable $path
    upvar 0  $path data

    if {![string equal [Widget::cget $path.f$page -state] "normal"]} { return }

    set oldsel $data(select)

    if {[string equal $page $oldsel]} { return }

    if { ![string equal $oldsel ""] } {
	set cmd [Widget::cget $path.f$oldsel -leavecmd]
	if { ![string equal $cmd ""] } {
	    set code [catch {uplevel \#0 $cmd} res]
	    if { $code == 1 || $res == 0 } {
		return -code $code $res
	    }
	}
	set data(select) ""
	_draw_page $path $oldsel 0
    }

    set data(select) $page
    if { ![string equal $page ""] } {
	if { !$data($page,realized) } {
	    set data($page,realized) 1
	    set cmd [Widget::cget $path.f$page -createcmd]
	    if { ![string equal $cmd ""] } {
		uplevel \#0 $cmd
	    }
	}
	set cmd [Widget::cget $path.f$page -raisecmd]
	if { ![string equal $cmd ""] } {
	    uplevel \#0 $cmd
	}
	_draw_page $path $page 0
    }

    _draw_area $path
}


# -----------------------------------------------------------------------------
#  Command NoteBook::_redraw
# -----------------------------------------------------------------------------
proc NoteBook::_redraw { path } {
    variable $path
    upvar 0  $path data

    if { !$data(realized) } { return }

    _compute_height $path

    foreach page $data(pages) {
        _draw_page $path $page 0
    }
    _draw_area   $path
    _draw_arrows $path
}


# ----------------------------------------------------------------------------
#  Command NoteBook::_draw_page
# ----------------------------------------------------------------------------
proc NoteBook::_draw_page { path page create } {
    variable $path
    upvar 0  $path data

    # --- calcul des coordonnees et des couleurs de l'onglet ------------------
    set pos [lsearch -exact $data(pages) $page]
    set bg  [_getoption $path $page -background]

    # lookup the tab colors
    set fgt   $data(lbg)
    set fgb   $data(dbg)

    set h   $data(hpage)
    set xd  [_get_x_page $path $pos]
    set xf  [expr {$xd + $data($page,width)}]

    # Set the initial text offsets -- a few pixels down, centered left-to-right
    set textOffsetY [expr [Widget::_get_padding $path -tabpady 0] + 3]
    set textOffsetX 9

    # Coordinates of the tab corners are:
    #     c3        c4
    #
    # c2                c5
    #
    # c1                c6
    #
    # where
    # c1 = $xd,	  $h
    # c2 = $xd+$xBevel,	           $arcRadius+2
    # c3 = $xd+$xBevel+$arcRadius, $arcRadius
    # c4 = $xf+1-$xBevel,          $arcRadius
    # c5 = $xf+$arcRadius-$xBevel, $arcRadius+2
    # c6 = $xf+$arcRadius,         $h

    set top		2
    set arcRadius	[Widget::cget $path -arcradius]
    set xBevel		[Widget::cget $path -tabbevelsize]

    if { $data(select) != $page } {
	if { $pos == 0 } {
	    # The leftmost page is a special case -- it is drawn with its
	    # tab a little indented.  To achieve this, we incr xd.  We also
	    # decr textOffsetX, so that the text doesn't move left/right.
	    incr xd 2
	    incr textOffsetX -2
	}
    } else {
	# The selected page's text is raised higher than the others
	incr top -2
    }

    # Precompute some coord values that we use a lot
    set topPlusRadius	[expr {$top + $arcRadius}]
    set rightPlusRadius	[expr {$xf + $arcRadius}]
    set leftPlusRadius	[expr {$xd + $arcRadius}]

    # Sven
    set side [Widget::cget $path -side]
    set tabsOnBottom [string equal $side "bottom"]

    set h1 [expr {[winfo height $path]}]
    set bd [Widget::cget $path -borderwidth]
    if {$bd < 1} { set bd 1 }

    if { $tabsOnBottom } {
incr h1 -1
	set top [expr {$top * -1}]
	set topPlusRadius [expr {$topPlusRadius * -1}]
	# Hrm... the canvas has an issue with drawing diagonal segments
	# of lines from the bottom to the top, so we have to draw this line
	# backwards (ie, lt is actually the bottom, drawn from right to left)
        set lt  [list 		$rightPlusRadius			[expr {$h1-$h-1}] 		[expr {$rightPlusRadius - $xBevel}]	[expr {$h1 + $topPlusRadius}] 		[expr {$xf - $xBevel}]			[expr {$h1 + $top}] 		[expr {$leftPlusRadius + $xBevel}]	[expr {$h1 + $top}] 		]
        set lb  [list 		[expr {$leftPlusRadius + $xBevel}]	[expr {$h1 + $top}] 		[expr {$xd + $xBevel}]			[expr {$h1 + $topPlusRadius}] 		$xd					[expr {$h1-$h-1}] 		]
	# Because we have to do this funky reverse order thing, we have to
	# swap the top/bottom colors too.
	set tmp $fgt
	set fgt $fgb
	set fgb $tmp
    } else {
	set lt [list 		$xd					$h 		[expr {$xd + $xBevel}]			$topPlusRadius 		[expr {$leftPlusRadius + $xBevel}]	$top 		[expr {$xf + 1 - $xBevel}]		$top 		]
	set lb [list 		[expr {$xf + 1 - $xBevel}] 		[expr {$top + 1}] 		[expr {$rightPlusRadius - $xBevel}]	$topPlusRadius 		$rightPlusRadius			$h 		]
    }

    set img [Widget::cget $path.f$page -image]

    set ytext $top
    if { $tabsOnBottom } {
	# The "+ 2" below moves the text closer to the bottom of the tab,
	# so it doesn't look so cramped.  I should be able to achieve the
	# same goal by changing the anchor of the text and using this formula:
	# ytext = $top + $h1 - $textOffsetY
	# but that doesn't quite work (I think the linespace from the text
	# gets in the way)
	incr ytext [expr {$h1 - $h + 2}]
    }
    incr ytext $textOffsetY

    set xtext [expr {$xd + $textOffsetX}]
    if { $img != "" } {
	# if there's an image, put it on the left and move the text right
	set ximg $xtext
	incr xtext [expr {[image width $img] + 2}]
    }
	
    if { $data(select) == $page } {
        set bd    [Widget::cget $path -borderwidth]
	if {$bd < 1} { set bd 1 }
        set fg    [_getoption $path $page -foreground]
    } else {
        set bd    1
        if { [Widget::cget $path.f$page -state] == "normal" } {
            set fg [_getoption $path $page -foreground]
        } else {
            set fg [_getoption $path $page -disabledforeground]
        }
    }

    # --- creation ou modification de l'onglet --------------------------------
    # Sven
    if { $create } {
	# Create the tab region
        eval [list $path.c create polygon] [concat $lt $lb] [list 		-tags		[list page p:$page $page:poly] 		-outline	$bg 		-fill		$bg 		]
        eval [list $path.c create line] $lt [list             -tags [list page p:$page $page:top top] -fill $fgt -width $bd]
        eval [list $path.c create line] $lb [list             -tags [list page p:$page $page:bot bot] -fill $fgb -width $bd]
        $path.c create text $xtext $ytext 					-text	[Widget::cget $path.f$page -text]			-font	[Widget::cget $path -font]				-fill	$fg							-anchor	nw							-tags	[list page p:$page $page:text]

        $path.c bind p:$page <ButtonPress-1> 		[list NoteBook::_select $path $page]
        $path.c bind p:$page <Enter> 		[list NoteBook::_highlight on  $path $page]
        $path.c bind p:$page <Leave> 		[list NoteBook::_highlight off $path $page]
    } else {
        $path.c coords "$page:text" $xtext $ytext

        $path.c itemconfigure "$page:text"             -text [Widget::cget $path.f$page -text]             -font [Widget::cget $path -font]             -fill $fg
    }
    eval [list $path.c coords "$page:poly"] [concat $lt $lb]
    eval [list $path.c coords "$page:top"]  $lt
    eval [list $path.c coords "$page:bot"]  $lb
    $path.c itemconfigure "$page:poly" -fill $bg  -outline $bg
    $path.c itemconfigure "$page:top"  -fill $fgt -width $bd
    $path.c itemconfigure "$page:bot"  -fill $fgb -width $bd
    
    # Sven end

    if { $img != "" } {
        # Sven
	set id [$path.c find withtag $page:img]
	if { [string equal $id ""] } {
	    set id [$path.c create image $ximg $ytext 		    -anchor nw    		    -tags   [list page p:$page $page:img]]
        }
        $path.c coords $id $ximg $ytext
        $path.c itemconfigure $id -image $img
        # Sven end
    } else {
        $path.c delete $page:img
    }

    if { $data(select) == $page } {
        $path.c raise p:$page
    } elseif { $pos == 0 } {
        if { $data(select) == "" } {
            $path.c raise p:$page
        } else {
            $path.c lower p:$page p:$data(select)
        }
    } else {
        set pred [lindex $data(pages) [expr {$pos-1}]]
        if { $data(select) != $pred || $pos == 1 } {
            $path.c lower p:$page p:$pred
        } else {
            $path.c lower p:$page p:[lindex $data(pages) [expr {$pos-2}]]
        }
    }
}


# -----------------------------------------------------------------------------
#  Command NoteBook::_draw_arrows
# -----------------------------------------------------------------------------
proc NoteBook::_draw_arrows { path } {
    variable _warrow
    variable $path
    upvar 0  $path data

    set w       [expr {[winfo width $path]-1}]
    set h       [expr {$data(hpage)-1}]
    set nbpages [llength $data(pages)]
    set xl      0
    set xr      [expr {$w-$_warrow+1}]
    # Sven
    set side [Widget::cget $path -side]
    if { [string equal $side "bottom"] } {
        set h1 [expr {[winfo height $path]-1}]
        set bd [Widget::cget $path -borderwidth]
	if {$bd < 1} { set bd 1 }
        set y0 [expr {$h1 - $data(hpage) + $bd}]
    } else {
        set y0 1
    }
    # Sven end (all y positions where replaced with $y0 later)

    if { $data(base) > 0 } {
        # Sven 
        if { ![llength [$path.c find withtag "leftarrow"]] } {
            $path.c create window $xl $y0                 -width  $_warrow                            -height $h                                  -anchor nw                                  -window $path.c.fg                            -tags   "leftarrow"
        } else {
            $path.c coords "leftarrow" $xl $y0
            $path.c itemconfigure "leftarrow" -width $_warrow -height $h
        }
        # Sven end
    } else {
        $path.c delete "leftarrow"
    }

    if { $data(base) < $nbpages-1 &&
         $data(wpage) + [_get_x_page $path 0] + 6 > $w } {
        # Sven
        if { ![llength [$path.c find withtag "rightarrow"]] } {
            $path.c create window $xr $y0                 -width  $_warrow                            -height $h                                  -window $path.c.fd                            -anchor nw                                  -tags   "rightarrow"
        } else {
            $path.c coords "rightarrow" $xr $y0
            $path.c itemconfigure "rightarrow" -width $_warrow -height $h
        }
        # Sven end
    } else {
        $path.c delete "rightarrow"
    }
}


# -----------------------------------------------------------------------------
#  Command NoteBook::_draw_area
# -----------------------------------------------------------------------------
proc NoteBook::_draw_area { path } {
    variable $path
    upvar 0  $path data

    set w   [expr {[winfo width  $path] - 1}]
    set h   [expr {[winfo height $path] - 1}]
    set bd  [Widget::cget $path -borderwidth]
    if {$bd < 1} { set bd 1 }
    set x0  [expr {$bd - 1}]

    set arcRadius [Widget::cget $path -arcradius]

    # Sven
    set side [Widget::cget $path -side]
    if {"$side" == "bottom"} {
        set y0 0
        set y1 [expr {$h - $data(hpage)}]
        set yo $y1
    } else {
        set y0 $data(hpage)
        set y1 $h
        set yo [expr {$h-$y0}]
    }
    # Sven end
    set dbg $data(dbg)
    set sel $data(select)
    if {  $sel == "" } {
        set xd  [expr {$w/2}]
        set xf  $xd
        set lbg $data(dbg)
    } else {
        set xd [_get_x_page $path [lsearch -exact $data(pages) $data(select)]]
        set xf [expr {$xd + $data($sel,width) + $arcRadius + 1}]
        set lbg $data(lbg)
    }

    # Sven
    if { [llength [$path.c find withtag rect]] == 0} {
        $path.c create line $xd $y0 $x0 $y0 $x0 $y1             -tags "rect toprect1" 
        $path.c create line $w $y0 $xf $y0             -tags "rect toprect2"
        $path.c create line 1 $h $w $h $w $y0             -tags "rect botrect"
    }
    if {"$side" == "bottom"} {
        $path.c coords "toprect1" $w $y0 $x0 $y0 $x0 $y1
        $path.c coords "toprect2" $x0 $y1 $xd $y1
        $path.c coords "botrect"  $xf $y1 $w $y1 $w $y0
        $path.c itemconfigure "toprect1" -fill $lbg -width $bd
        $path.c itemconfigure "toprect2" -fill $dbg -width $bd
        $path.c itemconfigure "botrect" -fill $dbg -width $bd
    } else {
        $path.c coords "toprect1" $xd $y0 $x0 $y0 $x0 $y1
        $path.c coords "toprect2" $w $y0 $xf $y0
        $path.c coords "botrect"  $x0 $h $w $h $w $y0
        $path.c itemconfigure "toprect1" -fill $lbg -width $bd
        $path.c itemconfigure "toprect2" -fill $lbg -width $bd
        $path.c itemconfigure "botrect" -fill $dbg -width $bd
    }
    $path.c raise "rect"
    # Sven end

    if { $sel != "" } {
        # Sven
        if { [llength [$path.c find withtag "window"]] == 0 } {
            $path.c create window 2 [expr {$y0+1}]                 -width  [expr {$w-3}]                           -height [expr {$yo-3}]                          -anchor nw                                      -tags   "window"                                -window $path.f$sel
        }
        $path.c coords "window" 2 [expr {$y0+1}]
        $path.c itemconfigure "window"                -width  [expr {$w-3}]                       -height [expr {$yo-3}]                      -window $path.f$sel
        # Sven end
    } else {
        $path.c delete "window"
    }
}


# -----------------------------------------------------------------------------
#  Command NoteBook::_resize
# -----------------------------------------------------------------------------
proc NoteBook::_resize { path } {
    variable $path
    upvar 0  $path data

    if {!$data(realized)} {
	if { [set width  [Widget::cget $path -width]]  == 0 ||
	     [set height [Widget::cget $path -height]] == 0 } {
	    compute_size $path
	}
	set data(realized) 1
    }

    NoteBook::_redraw $path
}


# Tree::_set_help --
#
#	Register dynamic help for a node in the tree.
#
# Arguments:
#	path		Tree to query
#	node		Node in the tree
#       force		Optional argument to force a reset of the help
#
# Results:
#	none
# Tree::_set_help --
#
#	Register dynamic help for a node in the tree.
#
# Arguments:
#	path		Tree to query
#	node		Node in the tree
#       force		Optional argument to force a reset of the help
#
# Results:
#	none
proc NoteBook::_set_help { path page } {
    Widget::getVariable $path help

    set item $path.f$page
    set opts [list -helptype -helptext -helpvar]
    foreach {cty ctx cv} [eval [list Widget::hasChangedX $item] $opts] break
    set text [Widget::getoption $item -helptext]

    ## If we've never set help for this item before, and text is not blank,
    ## we need to setup help.  We also need to reset help if any of the
    ## options have changed.
    if { (![info exists help($page)] && $text != "") || $cty || $ctx || $cv } {
	set help($page) 1
	set type [Widget::getoption $item -helptype]
        switch $type {
            balloon {
		DynamicHelp::register $path.c balloon p:$page $text
            }
            variable {
		set var [Widget::getoption $item -helpvar]
		DynamicHelp::register $path.c variable p:$page $var $text
            }
        }
    }
}


proc NoteBook::_get_page_name { path {item current} {tagindex end-1} } {
    return [string range [lindex [$path.c gettags $item] $tagindex] 2 end]
}
    namespace eval BWIDGET {set LIBRARY {}}
# ------------------------------------------------------------------------------
#  dragsite.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: dragsite.tcl,v 1.8 2003/10/20 21:23:52 damonc Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - DragSite::include
#     - DragSite::setdrag
#     - DragSite::register
#     - DragSite::_begin_drag
#     - DragSite::_init_drag
#     - DragSite::_end_drag
#     - DragSite::_update_operation
# ----------------------------------------------------------------------------

namespace eval DragSite {
    Widget::define DragSite dragsite -classonly

    Widget::declare DragSite [list 	    [list	-dragevent	Enum	1	0	[list 1 2 3]] 	    [list	-draginitcmd	String	""	0] 	    [list	-dragendcmd	String	""	0] 	    ]

    variable _topw ".drag"
    variable _tabops
    variable _state
    variable _x0
    variable _y0

    bind BwDrag1 <ButtonPress-1> {DragSite::_begin_drag press  %W %s %X %Y}
    bind BwDrag1 <B1-Motion>     {DragSite::_begin_drag motion %W %s %X %Y}
    bind BwDrag2 <ButtonPress-2> {DragSite::_begin_drag press  %W %s %X %Y}
    bind BwDrag2 <B2-Motion>     {DragSite::_begin_drag motion %W %s %X %Y}
    bind BwDrag3 <ButtonPress-3> {DragSite::_begin_drag press  %W %s %X %Y}
    bind BwDrag3 <B3-Motion>     {DragSite::_begin_drag motion %W %s %X %Y}

    proc use {} {}
}


# ----------------------------------------------------------------------------
#  Command DragSite::include
# ----------------------------------------------------------------------------
proc DragSite::include { class type event } {
    set dragoptions [list 	    [list	-dragenabled	Boolean	0	0] 	    [list	-draginitcmd	String	""	0] 	    [list	-dragendcmd	String	""	0] 	    [list	-dragtype	String	$type	0] 	    [list	-dragevent	Enum	$event	0	[list 1 2 3]] 	    ]
    Widget::declare $class $dragoptions
}


# ----------------------------------------------------------------------------
#  Command DragSite::setdrag
#  Widget interface to register
# ----------------------------------------------------------------------------
proc DragSite::setdrag { path subpath initcmd endcmd {force 0}} {
    set cen       [Widget::hasChanged $path -dragenabled en]
    set cdragevt  [Widget::hasChanged $path -dragevent   dragevt]
    if { $en } {
        if { $force || $cen || $cdragevt } {
            register $subpath                 -draginitcmd $initcmd                 -dragendcmd  $endcmd                  -dragevent   $dragevt
        }
    } else {
        register $subpath
    }
}


# ----------------------------------------------------------------------------
#  Command DragSite::register
# ----------------------------------------------------------------------------
proc DragSite::register { path args } {
    upvar \#0 DragSite::$path drag

    if { [info exists drag] } {
        bind $path $drag(evt) {}
        unset drag
    }
    Widget::init DragSite .drag$path $args
    set event   [Widget::getMegawidgetOption .drag$path -dragevent]
    set initcmd [Widget::getMegawidgetOption .drag$path -draginitcmd]
    set endcmd  [Widget::getMegawidgetOption .drag$path -dragendcmd]
    set tags    [bindtags $path]
    set idx     [lsearch $tags "BwDrag*"]
    Widget::destroy .drag$path
    if { $initcmd != "" } {
        if { $idx != -1 } {
            bindtags $path [lreplace $tags $idx $idx BwDrag$event]
        } else {
            bindtags $path [concat $tags BwDrag$event]
        }
        set drag(initcmd) $initcmd
        set drag(endcmd)  $endcmd
        set drag(evt)     $event
    } elseif { $idx != -1 } {
        bindtags $path [lreplace $tags $idx $idx]
    }
}


# ----------------------------------------------------------------------------
#  Command DragSite::_begin_drag
# ----------------------------------------------------------------------------
proc DragSite::_begin_drag { event source state X Y } {
    variable _x0
    variable _y0
    variable _state

    switch -- $event {
        press {
            set _x0    $X
            set _y0    $Y
            set _state "press"
        }
        motion {
            if { ![info exists _state] } {
                # This is just extra protection. There seem to be
                # rare cases where the motion comes before the press.
                return
            }
            if { [string equal $_state "press"] } {
                if { abs($_x0-$X) > 3 || abs($_y0-$Y) > 3 } {
                    set _state "done"
                    _init_drag $source $state $X $Y
                }
            }
        }
    }
}


# ----------------------------------------------------------------------------
#  Command DragSite::_init_drag
# ----------------------------------------------------------------------------
proc DragSite::_init_drag { source state X Y } {
    variable _topw
    upvar \#0 DragSite::$source drag

    destroy  $_topw
    toplevel $_topw
    wm withdraw $_topw
    wm overrideredirect $_topw 1

    set info [uplevel \#0 $drag(initcmd) [list $source $X $Y .drag]]
    if { $info != "" } {
        set type [lindex $info 0]
        set ops  [lindex $info 1]
        set data [lindex $info 2]

        if { [winfo children $_topw] == "" } {
            if { [string equal $type "BITMAP"] || [string equal $type "IMAGE"] } {
                label $_topw.l -image [Bitmap::get dragicon] -relief flat -bd 0
            } else {
                label $_topw.l -image [Bitmap::get dragfile] -relief flat -bd 0
            }
            pack  $_topw.l
        }
        wm geometry $_topw +[expr {$X+1}]+[expr {$Y+1}]
        wm deiconify $_topw
        if {[catch {tkwait visibility $_topw}]} {
            return
        }
        BWidget::grab  set $_topw
        BWidget::focus set $_topw

        bindtags $_topw [list $_topw DragTop]
        DropSite::_init_drag $_topw $drag(evt) $source $state $X $Y $type $ops $data
    } else {
        destroy $_topw
    }
}


# ----------------------------------------------------------------------------
#  Command DragSite::_end_drag
# ----------------------------------------------------------------------------
proc DragSite::_end_drag { source target op type data result } {
    variable _topw
    upvar \#0 DragSite::$source drag

    BWidget::grab  release $_topw
    BWidget::focus release $_topw
    destroy $_topw
    if { $drag(endcmd) != "" } {
        uplevel \#0 $drag(endcmd) [list $source $target $op $type $data $result]
    }
}


# ------------------------------------------------------------------------------
#  dropsite.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: dropsite.tcl,v 1.7 2003/10/20 21:23:52 damonc Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - DropSite::include
#     - DropSite::setdrop
#     - DropSite::register
#     - DropSite::setcursor
#     - DropSite::setoperation
#     - DropSite::_update_operation
#     - DropSite::_compute_operation
#     - DropSite::_draw_operation
#     - DropSite::_init_drag
#     - DropSite::_motion
#     - DropSite::_release
# ----------------------------------------------------------------------------


namespace eval DropSite {
    Widget::define DropSite dropsite -classonly

    Widget::declare DropSite [list 	    [list -dropovercmd String "" 0] 	    [list -dropcmd     String "" 0] 	    [list -droptypes   String "" 0] 	    ]

    proc use {} {}

    variable _top  ".drag"
    variable _opw  ".drag.\#op"
    variable _target  ""
    variable _status  0
    variable _tabops
    variable _defops
    variable _source
    variable _type
    variable _data
    variable _evt
    # key       win    unix
    # shift       1   |   1    ->  1
    # control     4   |   4    ->  4
    # alt         8   |  16    -> 24
    # meta            |  64    -> 88

    array set _tabops {
        mod,none    0
        mod,shift   1
        mod,control 4
        mod,alt     24
        ops,copy    1
        ops,move    1
        ops,link    1
    }

    if { $tcl_platform(platform) == "unix" } {
        set _tabops(mod,alt) 8
    } else {
        set _tabops(mod,alt) 16
    }
    array set _defops         [list              copy,mod  shift                move,mod  control              link,mod  alt                  copy,img  @[file join $::BWIDGET::LIBRARY "images" "opcopy.xbm"]              move,img  @[file join $::BWIDGET::LIBRARY "images" "opmove.xbm"]              link,img  @[file join $::BWIDGET::LIBRARY "images" "oplink.xbm"]]

    bind DragTop <KeyPress-Shift_L>     {DropSite::_update_operation [expr %s | 1]}
    bind DragTop <KeyPress-Shift_R>     {DropSite::_update_operation [expr %s | 1]}
    bind DragTop <KeyPress-Control_L>   {DropSite::_update_operation [expr %s | 4]}
    bind DragTop <KeyPress-Control_R>   {DropSite::_update_operation [expr %s | 4]}
    if { $tcl_platform(platform) == "unix" } {
        bind DragTop <KeyPress-Alt_L>       {DropSite::_update_operation [expr %s | 8]}
        bind DragTop <KeyPress-Alt_R>       {DropSite::_update_operation [expr %s | 8]}
    } else {
        bind DragTop <KeyPress-Alt_L>       {DropSite::_update_operation [expr %s | 16]}
        bind DragTop <KeyPress-Alt_R>       {DropSite::_update_operation [expr %s | 16]}
    }

    bind DragTop <KeyRelease-Shift_L>   {DropSite::_update_operation [expr %s & ~1]}
    bind DragTop <KeyRelease-Shift_R>   {DropSite::_update_operation [expr %s & ~1]}
    bind DragTop <KeyRelease-Control_L> {DropSite::_update_operation [expr %s & ~4]}
    bind DragTop <KeyRelease-Control_R> {DropSite::_update_operation [expr %s & ~4]}
    if { $tcl_platform(platform) == "unix" } {
        bind DragTop <KeyRelease-Alt_L>     {DropSite::_update_operation [expr %s & ~8]}
        bind DragTop <KeyRelease-Alt_R>     {DropSite::_update_operation [expr %s & ~8]}
    } else {
        bind DragTop <KeyRelease-Alt_L>     {DropSite::_update_operation [expr %s & ~16]}
        bind DragTop <KeyRelease-Alt_R>     {DropSite::_update_operation [expr %s & ~16]}
    }
}


# ----------------------------------------------------------------------------
#  Command DropSite::include
# ----------------------------------------------------------------------------
proc DropSite::include { class types } {
    set dropoptions [list 	    [list	-dropenabled	Boolean	0	0] 	    [list	-dropovercmd	String	""	0] 	    [list	-dropcmd	String	""	0] 	    [list	-droptypes	String	$types	0] 	    ]
    Widget::declare $class $dropoptions
}


# ----------------------------------------------------------------------------
#  Command DropSite::setdrop
#  Widget interface to register
# ----------------------------------------------------------------------------
proc DropSite::setdrop { path subpath dropover drop {force 0}} {
    set cen    [Widget::hasChanged $path -dropenabled en]
    set ctypes [Widget::hasChanged $path -droptypes   types]
    if { $en } {
        if { $force || $cen || $ctypes } {
            register $subpath                 -droptypes   $types                 -dropcmd     $drop                  -dropovercmd $dropover
        }
    } else {
        register $subpath
    }
}


# ----------------------------------------------------------------------------
#  Command DropSite::register
# ----------------------------------------------------------------------------
proc DropSite::register { path args } {
    variable _tabops
    variable _defops
    upvar \#0 DropSite::$path drop

    Widget::init DropSite .drop$path $args
    if { [info exists drop] } {
        unset drop
    }
    set dropcmd [Widget::getMegawidgetOption .drop$path -dropcmd]
    set types   [Widget::getMegawidgetOption .drop$path -droptypes]
    set overcmd [Widget::getMegawidgetOption .drop$path -dropovercmd]
    Widget::destroy .drop$path
    if { $dropcmd != "" && $types != "" } {
        set drop(dropcmd) $dropcmd
        set drop(overcmd) $overcmd
        foreach {type ops} $types {
            set drop($type,ops) {}
            foreach {descop lmod} $ops {
                if { ![llength $descop] || [llength $descop] > 3 } {
                    return -code error "invalid operation description \"$descop\""
                }
                foreach {subop baseop imgop} $descop {
                    set subop [string trim $subop]
                    if { ![string length $subop] } {
                        return -code error "sub operation is empty"
                    }
                    if { ![string length $baseop] } {
                        set baseop $subop
                    }
                    if { [info exists drop($type,ops,$subop)] } {
                        return -code error "operation \"$subop\" already defined"
                    }
                    if { ![info exists _tabops(ops,$baseop)] } {
                        return -code error "invalid base operation \"$baseop\""
                    }
                    if { ![string equal $subop $baseop] &&
                         [info exists _tabops(ops,$subop)] } {
                        return -code error "sub operation \"$subop\" is a base operation"
                    }
                    if { ![string length $imgop] } {
                        set imgop $_defops($baseop,img)
                    }
                }
                if { [string equal $lmod "program"] } {
                    set drop($type,ops,$subop) $baseop
                    set drop($type,img,$subop) $imgop
                } else {
                    if { ![string length $lmod] } {
                        set lmod $_defops($baseop,mod)
                    }
                    set mask 0
                    foreach mod $lmod {
                        if { ![info exists _tabops(mod,$mod)] } {
                            return -code error "invalid modifier \"$mod\""
                        }
                        set mask [expr {$mask | $_tabops(mod,$mod)}]
                    }
                    if { ($mask == 0) != ([string equal $subop "default"]) } {
                        return -code error "sub operation default can only be used with modifier \"none\""
                    }
                    set drop($type,mod,$mask)  $subop
                    set drop($type,ops,$subop) $baseop
                    set drop($type,img,$subop) $imgop
                    lappend masklist $mask
                }
            }
            if { ![info exists drop($type,mod,0)] } {
                set drop($type,mod,0)       default
                set drop($type,ops,default) copy
                set drop($type,img,default) $_defops(copy,img)
                lappend masklist 0
            }
            set drop($type,ops,force) copy
            set drop($type,img,force) $_defops(copy,img)
            foreach mask [lsort -integer -decreasing $masklist] {
                lappend drop($type,ops) $mask $drop($type,mod,$mask)
            }
        }
    }
}


# ----------------------------------------------------------------------------
#  Command DropSite::setcursor
# ----------------------------------------------------------------------------
proc DropSite::setcursor { cursor } {
    catch {.drag configure -cursor $cursor}
}


# ----------------------------------------------------------------------------
#  Command DropSite::setoperation
# ----------------------------------------------------------------------------
proc DropSite::setoperation { op } {
    variable _curop
    variable _dragops
    variable _target
    variable _type
    upvar \#0 DropSite::$_target drop

    if { [info exist drop($_type,ops,$op)] &&
         $_dragops($drop($_type,ops,$op)) } {
        set _curop $op
    } else {
        # force to a copy operation
        set _curop force
    }
}


# ----------------------------------------------------------------------------
#  Command DropSite::_init_drag
# ----------------------------------------------------------------------------
proc DropSite::_init_drag { top evt source state X Y type ops data } {
    variable _top
    variable _source
    variable _type
    variable _data
    variable _target
    variable _status
    variable _state
    variable _dragops
    variable _opw
    variable _evt

    if {[info exists _dragops]} {
        unset _dragops
    }
    array set _dragops {copy 1 move 0 link 0}
    foreach op $ops {
        set _dragops($op) 1
    }
    set _target ""
    set _status  0
    set _top     $top
    set _source  $source
    set _type    $type
    set _data    $data

    label $_opw -relief flat -bd 0 -highlightthickness 0         -foreground black -background white

    bind $top <ButtonRelease-$evt> {DropSite::_release %X %Y}
    bind $top <B$evt-Motion>       {DropSite::_motion  %X %Y}
    bind $top <Motion>             {DropSite::_release %X %Y}
    set _state $state
    set _evt   $evt
    _motion $X $Y
}


# ----------------------------------------------------------------------------
#  Command DropSite::_update_operation
# ----------------------------------------------------------------------------
proc DropSite::_update_operation { state } {
    variable _top
    variable _status
    variable _state

    if { $_status & 3 } {
        set _state $state
        _motion [winfo pointerx $_top] [winfo pointery $_top]
    }
}


# ----------------------------------------------------------------------------
#  Command DropSite::_compute_operation
# ----------------------------------------------------------------------------
proc DropSite::_compute_operation { target state type } {
    variable  _curop
    variable  _dragops
    upvar \#0 DropSite::$target drop

    foreach {mask op} $drop($type,ops) {
        if { ($state & $mask) == $mask } {
            if { $_dragops($drop($type,ops,$op)) } {
                set _curop $op
                return
            }
        }
    }
    set _curop force
}


# ----------------------------------------------------------------------------
#  Command DropSite::_draw_operation
# ----------------------------------------------------------------------------
proc DropSite::_draw_operation { target type } {
    variable _opw
    variable _curop
    variable _dragops
    variable _tabops
    variable _status

    upvar \#0 DropSite::$target drop

    if { !($_status & 1) } {
        catch {place forget $_opw}
        return
    }

    if { 0 } {
    if { ![info exist drop($type,ops,$_curop)] ||
         !$_dragops($drop($type,ops,$_curop)) } {
        # force to a copy operation
        set _curop copy
        catch {
            $_opw configure -bitmap $_tabops(img,copy)
            place $_opw -relx 1 -rely 1 -anchor se
        }
    }
    } elseif { [string equal $_curop "default"] } {
        catch {place forget $_opw}
    } else {
        catch {
            $_opw configure -bitmap $drop($type,img,$_curop)
            place $_opw -relx 1 -rely 1 -anchor se
        }
    }
}


# ----------------------------------------------------------------------------
#  Command DropSite::_motion
# ----------------------------------------------------------------------------
proc DropSite::_motion { X Y } {
    variable _top
    variable _target
    variable _status
    variable _state
    variable _curop
    variable _type
    variable _data
    variable _source
    variable _evt

    set script [bind $_top <B$_evt-Motion>]
    bind $_top <B$_evt-Motion> {}
    bind $_top <Motion>        {}
    wm geometry $_top "+[expr {$X+1}]+[expr {$Y+1}]"
    update
    if { ![winfo exists $_top] } {
        return
    }
    set path [winfo containing $X $Y]
    if { ![string equal $path $_target] } {
        # path != current target
        if { $_status & 2 } {
            # current target is valid and has recall status
            # generate leave event
            upvar   \#0 DropSite::$_target drop
            uplevel \#0 $drop(overcmd) [list $_target $_source leave $X $Y $_curop $_type $_data]
        }
        set _target $path
        upvar \#0 DropSite::$_target drop
        if { [info exists drop($_type,ops)] } {
            # path is a valid target
            _compute_operation $_target $_state $_type
            if { $drop(overcmd) != "" } {
                set arg     [list $_target $_source enter $X $Y $_curop $_type $_data]
                set _status [uplevel \#0 $drop(overcmd) $arg]
            } else {
                set _status 1
                catch {$_top configure -cursor based_arrow_down}
            }
            _draw_operation $_target $_type
            update
            catch {
                bind $_top <B$_evt-Motion> {DropSite::_motion  %X %Y}
                bind $_top <Motion>        {DropSite::_release %X %Y}
            }
            return
        } else {
            set _status 0
            catch {$_top configure -cursor dot}
            _draw_operation "" ""
        }
    } elseif { $_status & 2 } {
        upvar \#0 DropSite::$_target drop
        _compute_operation $_target $_state $_type
        set arg     [list $_target $_source motion $X $Y $_curop $_type $_data]
        set _status [uplevel \#0 $drop(overcmd) $arg]
        _draw_operation $_target $_type
    }
    update
    catch {
        bind $_top <B$_evt-Motion> {DropSite::_motion  %X %Y}
        bind $_top <Motion>        {DropSite::_release %X %Y}
    }
}



# ----------------------------------------------------------------------------
#  Command DropSite::_release
# ----------------------------------------------------------------------------
proc DropSite::_release { X Y } {
    variable _target
    variable _status
    variable _curop
    variable _source
    variable _type
    variable _data

    if { $_status & 1 } {
        upvar \#0 DropSite::$_target drop

        set res [uplevel \#0 $drop(dropcmd) [list $_target $_source $X $Y $_curop $_type $_data]]
        DragSite::_end_drag $_source $_target $drop($_type,ops,$_curop) $_type $_data $res
    } else {
        if { $_status & 2 } {
            # notify leave event
            upvar \#0 DropSite::$_target drop
            uplevel \#0 $drop(overcmd) [list $_target $_source leave $X $Y $_curop $_type $_data]
        }
        DragSite::_end_drag $_source "" "" $_type $_data 0
    }
}
# ----------------------------------------------------------------------------
#  tree.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: tree.tcl,v 1.48 2003/10/20 21:23:53 damonc Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#     - Tree::create
#     - Tree::configure
#     - Tree::cget
#     - Tree::insert
#     - Tree::itemconfigure
#     - Tree::itemcget
#     - Tree::bindText
#     - Tree::bindImage
#     - Tree::delete
#     - Tree::move
#     - Tree::reorder
#     - Tree::selection
#     - Tree::exists
#     - Tree::parent
#     - Tree::index
#     - Tree::nodes
#     - Tree::see
#     - Tree::opentree
#     - Tree::closetree
#     - Tree::edit
#     - Tree::xview
#     - Tree::yview
#     - Tree::_update_edit_size
#     - Tree::_destroy
#     - Tree::_see
#     - Tree::_recexpand
#     - Tree::_subdelete
#     - Tree::_update_scrollregion
#     - Tree::_cross_event
#     - Tree::_draw_node
#     - Tree::_draw_subnodes
#     - Tree::_update_nodes
#     - Tree::_draw_tree
#     - Tree::_redraw_tree
#     - Tree::_redraw_selection
#     - Tree::_redraw_idle
#     - Tree::_drag_cmd
#     - Tree::_drop_cmd
#     - Tree::_over_cmd
#     - Tree::_auto_scroll
#     - Tree::_scroll
# ----------------------------------------------------------------------------

namespace eval Tree {
    Widget::define Tree tree DragSite DropSite DynamicHelp

    namespace eval Node {
        Widget::declare Tree::Node {
            {-text       String     ""      0}
            {-font       TkResource ""      0 listbox}
            {-image      TkResource ""      0 label}
            {-window     String     ""      0}
            {-fill       TkResource black   0 {listbox -foreground}}
            {-data       String     ""      0}
            {-open       Boolean    0       0}
	    {-selectable Boolean    1       0}
            {-drawcross  Enum       auto    0 {auto allways never}}
	    {-padx       Int        -1      0 "%d >= -1"}
	    {-deltax     Int        -1      0 "%d >= -1"}
	    {-anchor     String     "w"     0 ""}
        }
    }

    DynamicHelp::include Tree::Node balloon

    Widget::tkinclude Tree canvas .c 	    remove     {
	-insertwidth -insertbackground -insertborderwidth -insertofftime
	-insertontime -selectborderwidth -closeenough -confine -scrollregion
	-xscrollincrement -yscrollincrement -width -height
    } 	    initialize {
	-relief sunken -borderwidth 2 -takefocus 1
	-highlightthickness 1 -width 200
    }

    Widget::declare Tree {
        {-deltax           Int 10 0 "%d >= 0"}
        {-deltay           Int 15 0 "%d >= 0"}
        {-padx             Int 20 0 "%d >= 0"}
        {-background       TkResource "" 0 listbox}
        {-selectbackground TkResource "" 0 listbox}
        {-selectforeground TkResource "" 0 listbox}
	{-selectcommand    String     "" 0}
        {-width            TkResource "" 0 listbox}
        {-height           TkResource "" 0 listbox}
        {-selectfill       Boolean 0  0}
        {-showlines        Boolean 1  0}
        {-linesfill        TkResource black  0 {listbox -foreground}}
        {-linestipple      TkResource ""     0 {label -bitmap}}
	{-crossfill        TkResource black  0 {listbox -foreground}}
        {-redraw           Boolean 1  0}
        {-opencmd          String  "" 0}
        {-closecmd         String  "" 0}
        {-dropovermode     Flag    "wpn" 0 "wpn"}
        {-bg               Synonym -background}

        {-crossopenimage    String  ""  0}
        {-crosscloseimage   String  ""  0}
        {-crossopenbitmap   String  ""  0}
        {-crossclosebitmap  String  ""  0}
    }

    DragSite::include Tree "TREE_NODE" 1
    DropSite::include Tree {
        TREE_NODE {copy {} move {}}
    }

    Widget::addmap Tree "" .c {-deltay -yscrollincrement}

    # Trees on windows have a white (system window) background
    if { $::tcl_platform(platform) == "windows" } {
	option add *Tree.c.background SystemWindow widgetDefault
	option add *TreeNode.fill SystemWindowText widgetDefault
    }

    bind Tree <FocusIn>   [list after idle {BWidget::refocus %W %W.c}]
    bind Tree <Destroy>   [list Tree::_destroy %W]
    bind Tree <Configure> [list Tree::_update_scrollregion %W]


    bind TreeSentinalStart <Button-1> {
	if { $::Tree::sentinal(%W) } {
	    set ::Tree::sentinal(%W) 0
	    break
	}
    }

    bind TreeSentinalEnd <Button-1> {
	set ::Tree::sentinal(%W) 0
    }

    bind TreeFocus <Button-1> [list focus %W]

    variable _edit
}


# ----------------------------------------------------------------------------
#  Command Tree::create
# ----------------------------------------------------------------------------
proc Tree::create { path args } {
    variable $path
    upvar 0  $path data

    Widget::init Tree $path $args
    set ::Tree::sentinal($path.c) 0

    if {[Widget::cget $path -crossopenbitmap] == ""} {
        set file [file join $::BWIDGET::LIBRARY images "minus.xbm"]
        Widget::configure $path [list -crossopenbitmap @$file]
    }
    if {[Widget::cget $path -crossclosebitmap] == ""} {
        set file [file join $::BWIDGET::LIBRARY images "plus.xbm"]
        Widget::configure $path [list -crossclosebitmap @$file]
    }

    set data(root)         {{}}
    set data(selnodes)     {}
    set data(upd,level)    0
    set data(upd,nodes)    {}
    set data(upd,afterid)  ""
    set data(dnd,scroll)   ""
    set data(dnd,afterid)  ""
    set data(dnd,selnodes) {}
    set data(dnd,node)     ""

    frame $path -class Tree -bd 0 -highlightthickness 0 -relief flat 	    -takefocus 0
    # For 8.4+ we don't want to inherit the padding
    catch {$path configure -padx 0 -pady 0}
    eval [list canvas $path.c] [Widget::subcget $path .c] -xscrollincrement 8
    bindtags $path.c [list TreeSentinalStart TreeFocus $path.c Canvas 	    [winfo toplevel $path] all TreeSentinalEnd]
    pack $path.c -expand yes -fill both
    $path.c bind cross <ButtonPress-1> [list Tree::_cross_event $path]

    # Added by ericm@scriptics.com
    # These allow keyboard traversal of the tree
    bind $path.c <KeyPress-Up>    [list Tree::_keynav up $path]
    bind $path.c <KeyPress-Down>  [list Tree::_keynav down $path]
    bind $path.c <KeyPress-Right> [list Tree::_keynav right $path]
    bind $path.c <KeyPress-Left>  [list Tree::_keynav left $path]
    bind $path.c <KeyPress-space> [list +Tree::_keynav space $path]

    # These allow keyboard control of the scrolling
    bind $path.c <Control-KeyPress-Up>    [list $path.c yview scroll -1 units]
    bind $path.c <Control-KeyPress-Down>  [list $path.c yview scroll  1 units]
    bind $path.c <Control-KeyPress-Left>  [list $path.c xview scroll -1 units]
    bind $path.c <Control-KeyPress-Right> [list $path.c xview scroll  1 units]
    # ericm@scriptics.com

    BWidget::bindMouseWheel $path.c

    DragSite::setdrag $path $path.c Tree::_init_drag_cmd 	    [Widget::cget $path -dragendcmd] 1
    DropSite::setdrop $path $path.c Tree::_over_cmd Tree::_drop_cmd 1

    Widget::create Tree $path

    set w [Widget::cget $path -width]
    set h [Widget::cget $path -height]
    set dy [Widget::cget $path -deltay]
    $path.c configure -width [expr {$w*8}] -height [expr {$h*$dy}]

    # ericm
    # Bind <Button-1> to select the clicked node -- no reason not to, right?

    ## Bind button 1 to select the node via the _mouse_select command.
    ## This command will generate the proper <<TreeSelect>> virtual event
    ## when necessary.
    set selectcmd Tree::_mouse_select
    Tree::bindText  $path <Button-1>         [list $selectcmd $path set]
    Tree::bindImage $path <Button-1>         [list $selectcmd $path set]
    Tree::bindText  $path <Control-Button-1> [list $selectcmd $path toggle]
    Tree::bindImage $path <Control-Button-1> [list $selectcmd $path toggle]


    # Add sentinal bindings for double-clicking on items, to handle the 
    # gnarly Tk bug wherein:
    # ButtonClick
    # ButtonClick
    # On a canvas item translates into button click on the item, button click
    # on the canvas, double-button on the item, single button click on the
    # canvas (which can happen if the double-button on the item causes some
    # other event to be handled in between when the button clicks are examined
    # for the canvas)
    $path.c bind TreeItemSentinal <Double-Button-1> 	[list set ::Tree::sentinal($path.c) 1]
    # ericm

    return $path
}


# ----------------------------------------------------------------------------
#  Command Tree::configure
# ----------------------------------------------------------------------------
proc Tree::configure { path args } {
    variable $path
    upvar 0  $path data

    set res [Widget::configure $path $args]

    set ch1 [expr {[Widget::hasChanged $path -deltax val] |
                   [Widget::hasChanged $path -deltay dy]  |
                   [Widget::hasChanged $path -padx val]   |
                   [Widget::hasChanged $path -showlines val]}]

    set ch2 [expr {[Widget::hasChanged $path -selectbackground val] |
                   [Widget::hasChanged $path -selectforeground val]}]

    if { [Widget::hasChanged $path -linesfill   fill] |
         [Widget::hasChanged $path -linestipple stipple] } {
        $path.c itemconfigure line  -fill $fill -stipple $stipple
    }

    if { [Widget::hasChanged $path -crossfill fill] } {
        $path.c itemconfigure cross -foreground $fill
    }

    if {[Widget::hasChanged $path -selectfill fill]} {
	# Make sure that the full-width boxes have either all or none
	# of the standard node bindings
	if {$fill} {
	    foreach event [$path.c bind "node"] {
		$path.c bind "box" $event [$path.c bind "node" $event]
	    }
	} else {
	    foreach event [$path.c bind "node"] {
		$path.c bind "box" $event {}
	    }
	}
    }

    if { $ch1 } {
        _redraw_idle $path 3
    } elseif { $ch2 } {
        _redraw_idle $path 1
    }

    if { [Widget::hasChanged $path -height h] } {
        $path.c configure -height [expr {$h*$dy}]
    }
    if { [Widget::hasChanged $path -width w] } {
        $path.c configure -width [expr {$w*8}]
    }

    if { [Widget::hasChanged $path -redraw bool] && $bool } {
        set upd $data(upd,level)
        set data(upd,level) 0
        _redraw_idle $path $upd
    }

    set force [Widget::hasChanged $path -dragendcmd dragend]
    DragSite::setdrag $path $path.c Tree::_init_drag_cmd $dragend $force
    DropSite::setdrop $path $path.c Tree::_over_cmd Tree::_drop_cmd

    return $res
}


# ----------------------------------------------------------------------------
#  Command Tree::cget
# ----------------------------------------------------------------------------
proc Tree::cget { path option } {
    return [Widget::cget $path $option]
}


# ----------------------------------------------------------------------------
#  Command Tree::insert
# ----------------------------------------------------------------------------
proc Tree::insert { path index parent node args } {
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    set node [Widget::nextIndex $path $node]

    if { [info exists data($node)] } {
        return -code error "node \"$node\" already exists"
    }
    if { ![info exists data($parent)] } {
        return -code error "node \"$parent\" does not exist"
    }

    Widget::init Tree::Node $path.$node $args
    if {[string equal $index "end"]} {
        lappend data($parent) $node
    } else {
        incr index
        set data($parent) [linsert $data($parent) $index $node]
    }
    set data($node) [list $parent]

    if { [string equal $parent "root"] } {
        _redraw_idle $path 3
    } elseif { [visible $path $parent] } {
        # parent is visible...
        if { [Widget::getMegawidgetOption $path.$parent -open] } {
            # ...and opened -> redraw whole
            _redraw_idle $path 3
        } else {
            # ...and closed -> redraw cross
            lappend data(upd,nodes) $parent 8
            _redraw_idle $path 2
        }
    }

    return $node
}


# ----------------------------------------------------------------------------
#  Command Tree::itemconfigure
# ----------------------------------------------------------------------------
proc Tree::itemconfigure { path node args } {
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    if { [string equal $node "root"] || ![info exists data($node)] } {
        return -code error "node \"$node\" does not exist"
    }

    set result [Widget::configure $path.$node $args]

    _set_help $path $node

    if { [visible $path $node] } {
        set lopt   {}
        set flag   0
        foreach opt {-window -image -drawcross -font -text -fill} {
            set flag [expr {$flag << 1}]
            if { [Widget::hasChanged $path.$node $opt val] } {
                set flag [expr {$flag | 1}]
            }
        }

        if { [Widget::hasChanged $path.$node -open val] } {
            if {[llength $data($node)] > 1} {
                # node have subnodes - full redraw
                _redraw_idle $path 3
            } else {
                # force a redraw of the plus/minus sign
                set flag [expr {$flag | 8}]
            }
        }

	if {$data(upd,level) < 3 && [Widget::hasChanged $path.$node -padx x]} {
	    _redraw_idle $path 3
	}

	if { $data(upd,level) < 3 && $flag } {
            if { [set idx [lsearch -exact $data(upd,nodes) $node]] == -1 } {
                lappend data(upd,nodes) $node $flag
            } else {
                incr idx
                set flag [expr {[lindex $data(upd,nodes) $idx] | $flag}]
                set data(upd,nodes) [lreplace $data(upd,nodes) $idx $idx $flag]
            }
            _redraw_idle $path 2
        }
    }
    return $result
}


# ----------------------------------------------------------------------------
#  Command Tree::itemcget
# ----------------------------------------------------------------------------
proc Tree::itemcget { path node option } {
    # Instead of upvar'ing $path as data for this test, just directly refer to
    # it, as that is faster.
    set node [_node_name $path $node]
    if { [string equal $node "root"] || 	    ![info exists ::Tree::${path}($node)] } {
        return -code error "node \"$node\" does not exist"
    }

    return [Widget::cget $path.$node $option]
}


# ----------------------------------------------------------------------------
#  Command Tree::bindText
# ----------------------------------------------------------------------------
proc Tree::bindText { path event script } {
    if {[string length $script]} {
	append script " \[Tree::_get_node_name [list $path] current 2\]"
    }
    $path.c bind "node" $event $script
    if {[Widget::getoption $path -selectfill]} {
	$path.c bind "box" $event $script
    } else {
	$path.c bind "box" $event {}
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::bindImage
# ----------------------------------------------------------------------------
proc Tree::bindImage { path event script } {
    if {[string length $script]} {
	append script " \[Tree::_get_node_name [list $path] current 2\]"
    }
    $path.c bind "img" $event $script
    if {[Widget::getoption $path -selectfill]} {
	$path.c bind "box" $event $script
    } else {
	$path.c bind "box" $event {}
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::delete
# ----------------------------------------------------------------------------
proc Tree::delete { path args } {
    variable $path
    upvar 0  $path data

    foreach lnodes $args {
	foreach node $lnodes {
            set node [_node_name $path $node]
	    if { ![string equal $node "root"] && [info exists data($node)] } {
		set parent [lindex $data($node) 0]
		set idx	   [lsearch -exact $data($parent) $node]
		set data($parent) [lreplace $data($parent) $idx $idx]
		_subdelete $path [list $node]
	    }
	}
    }

    _redraw_idle $path 3
}


# ----------------------------------------------------------------------------
#  Command Tree::move
# ----------------------------------------------------------------------------
proc Tree::move { path parent node index } {
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    if { [string equal $node "root"] || ![info exists data($node)] } {
        return -code error "node \"$node\" does not exist"
    }
    if { ![info exists data($parent)] } {
        return -code error "node \"$parent\" does not exist"
    }
    set p $parent
    while { ![string equal $p "root"] } {
        if { [string equal $p $node] } {
            return -code error "node \"$parent\" is a descendant of \"$node\""
        }
        set p [parent $path $p]
    }

    set oldp        [lindex $data($node) 0]
    set idx         [lsearch -exact $data($oldp) $node]
    set data($oldp) [lreplace $data($oldp) $idx $idx]
    set data($node) [concat [list $parent] [lrange $data($node) 1 end]]
    if { [string equal $index "end"] } {
        lappend data($parent) $node
    } else {
        incr index
        set data($parent) [linsert $data($parent) $index $node]
    }
    if { ([string equal $oldp "root"] ||
          ([visible $path $oldp] && [Widget::getoption $path.$oldp   -open])) ||
         ([string equal $parent "root"] ||
          ([visible $path $parent] && [Widget::getoption $path.$parent -open])) } {
        _redraw_idle $path 3
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::reorder
# ----------------------------------------------------------------------------
proc Tree::reorder { path node neworder } {
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    if { ![info exists data($node)] } {
        return -code error "node \"$node\" does not exist"
    }
    set children [lrange $data($node) 1 end]
    if { [llength $children] } {
        set children [BWidget::lreorder $children $neworder]
        set data($node) [linsert $children 0 [lindex $data($node) 0]]
        if { [visible $path $node] && [Widget::getoption $path.$node -open] } {
            _redraw_idle $path 3
        }
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::selection
# ----------------------------------------------------------------------------
proc Tree::selection { path cmd args } {
    variable $path
    upvar 0  $path data

    switch -- $cmd {
	toggle {
            foreach node $args {
                set node [_node_name $path $node]
                if {![info exists data($node)]} {
		    return -code error 			    "$path selection toggle: Cannot toggle unknown node \"$node\"."
		}
	    }
            foreach node $args {
                set node [_node_name $path $node]
		if {[$path selection includes $node]} {
		    $path selection remove $node
		} else {
		    $path selection add $node
		}
            }
	}
        set {
            foreach node $args {
                set node [_node_name $path $node]
                if {![info exists data($node)]} {
		    return -code error 			    "$path selection set: Cannot select unknown node \"$node\"."
		}
	    }
            set data(selnodes) {}
            foreach node $args {
                set node [_node_name $path $node]
		if { [Widget::getoption $path.$node -selectable] } {
		    if { [lsearch -exact $data(selnodes) $node] == -1 } {
			lappend data(selnodes) $node
		    }
		}
            }
	    __call_selectcmd $path
        }
        add {
            foreach node $args {
                set node [_node_name $path $node]
                if {![info exists data($node)]} {
		    return -code error 			    "$path selection add: Cannot select unknown node \"$node\"."
		}
	    }
            foreach node $args {
                set node [_node_name $path $node]
		if { [Widget::getoption $path.$node -selectable] } {
		    if { [lsearch -exact $data(selnodes) $node] == -1 } {
			lappend data(selnodes) $node
		    }
		}
            }
	    __call_selectcmd $path
        }
	range {
	    # Here's our algorithm:
	    #    make a list of all nodes, then take the range from node1
	    #    to node2 and select those nodes
	    #
	    # This works because of how this widget handles redraws:
	    #    The tree is always completely redrawn, and always from
	    #    top to bottom. So the list of visible nodes *is* the
	    #    list of nodes, and we can use that to decide which nodes
	    #    to select.

	    if {[llength $args] != 2} {
		return -code error 			"wrong#args: Expected $path selection range node1 node2"
	    }

	    foreach {node1 node2} $args break

            set node1 [_node_name $path $node1]
            set node2 [_node_name $path $node2]
	    if {![info exists data($node1)]} {
		return -code error 			"$path selection range: Cannot start range at unknown node \"$node1\"."
	    }
	    if {![info exists data($node2)]} {
		return -code error 			"$path selection range: Cannot end range at unknown node \"$node2\"."
	    }

	    set nodes {}
	    foreach nodeItem [$path.c find withtag node] {
		set node [Tree::_get_node_name $path $nodeItem 2]
		if { [Widget::getoption $path.$node -selectable] } {
		    lappend nodes $node
		}
	    }
	    # surles: Set the root string to the first element on the list.
	    if {$node1 == "root"} {
		set node1 [lindex $nodes 0]
	    }
	    if {$node2 == "root"} {
		set node2 [lindex $nodes 0]
	    }

	    # Find the first visible ancestor of node1, starting with node1
	    while {[set index1 [lsearch -exact $nodes $node1]] == -1} {
		set node1 [lindex $data($node1) 0]
	    }
	    # Find the first visible ancestor of node2, starting with node2
	    while {[set index2 [lsearch -exact $nodes $node2]] == -1} {
		set node2 [lindex $data($node2) 0]
	    }
	    # If the nodes were given in backwards order, flip the
	    # indices now
	    if { $index2 < $index1 } {
		incr index1 $index2
		set index2 [expr {$index1 - $index2}]
		set index1 [expr {$index1 - $index2}]
	    }
	    set data(selnodes) [lrange $nodes $index1 $index2]
	    __call_selectcmd $path
	}
        remove {
            foreach node $args {
                set node [_node_name $path $node]
                if { [set idx [lsearch -exact $data(selnodes) $node]] != -1 } {
                    set data(selnodes) [lreplace $data(selnodes) $idx $idx]
                }
            }
	    __call_selectcmd $path
        }
        clear {
	    if {[llength $args] != 0} {
		return -code error 			"wrong#args: Expected $path selection clear"
	    }
            set data(selnodes) {}
	    __call_selectcmd $path
        }
        get {
	    if {[llength $args] != 0} {
		return -code error 			"wrong#args: Expected $path selection get"
	    }
            return $data(selnodes)
        }
        includes {
	    if {[llength $args] != 1} {
		return -code error 			"wrong#args: Expected $path selection includes node"
	    }
	    set node [lindex $args 0]
            set node [_node_name $path $node]
            return [expr {[lsearch -exact $data(selnodes) $node] != -1}]
        }
        default {
            return
        }
    }
    _redraw_idle $path 1
}


proc Tree::getcanvas { path } {
    return $path.c
}


proc Tree::__call_selectcmd { path } {
    variable $path
    upvar 0  $path data

    set selectcmd [Widget::getoption $path -selectcommand]
    if {[llength $selectcmd]} {
	lappend selectcmd $path
	lappend selectcmd $data(selnodes)
	uplevel \#0 $selectcmd
    }
    return
}

# ----------------------------------------------------------------------------
#  Command Tree::exists
# ----------------------------------------------------------------------------
proc Tree::exists { path node } {
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    return [info exists data($node)]
}


# ----------------------------------------------------------------------------
#  Command Tree::visible
# ----------------------------------------------------------------------------
proc Tree::visible { path node } {
    set node [_node_name $path $node]
    set idn [$path.c find withtag n:$node]
    return [llength $idn]
}


# ----------------------------------------------------------------------------
#  Command Tree::parent
# ----------------------------------------------------------------------------
proc Tree::parent { path node } {
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    if { ![info exists data($node)] } {
        return -code error "node \"$node\" does not exist"
    }
    return [lindex $data($node) 0]
}


# ----------------------------------------------------------------------------
#  Command Tree::index
# ----------------------------------------------------------------------------
proc Tree::index { path node } {
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    if { [string equal $node "root"] || ![info exists data($node)] } {
        return -code error "node \"$node\" does not exist"
    }
    set parent [lindex $data($node) 0]
    return [expr {[lsearch -exact $data($parent) $node] - 1}]
}


# ----------------------------------------------------------------------------
#  Tree::find
#     Returns the node given a position.
#  findInfo     @x,y ?confine?
#               lineNumber
# ----------------------------------------------------------------------------
proc Tree::find {path findInfo {confine ""}} {
    if {[regexp -- {^@([0-9]+),([0-9]+)$} $findInfo match x y]} {
        set x [$path.c canvasx $x]
        set y [$path.c canvasy $y]
    } elseif {[regexp -- {^[0-9]+$} $findInfo lineNumber]} {
        set dy [Widget::getoption $path -deltay]
        set y  [expr {$dy*($lineNumber+0.5)}]
        set confine ""
    } else {
        return -code error "invalid find spec \"$findInfo\""
    }

    set found  0
    set region [$path.c bbox all]
    if {[llength $region]} {
        set xi [lindex $region 0]
        set xs [lindex $region 2]
        foreach id [$path.c find overlapping $xi $y $xs $y] {
            set ltags [$path.c gettags $id]
            set item  [lindex $ltags 1]
            if { [string equal $item "node"] ||
                 [string equal $item "img"]  ||
                 [string equal $item "win"] } {
                # item is the label or image/window of the node
                set node  [Tree::_get_node_name $path $id 2]
                set found 1
                break
            }
        }
    }

    if {$found} {
        if {[string equal $confine "confine"]} {
            # test if x stand inside node bbox
	    set padx [_get_node_padx $path $node]
            set xi [expr {[lindex [$path.c coords n:$node] 0] - $padx}]
            set xs [lindex [$path.c bbox n:$node] 2]
            if {$x >= $xi && $x <= $xs} {
                return $node
            }
        } else {
            return $node
        }
    }
    return ""
}


# ----------------------------------------------------------------------------
#  Command Tree::line
#     Returns the line where is drawn a node.
# ----------------------------------------------------------------------------
proc Tree::line {path node} {
    set node [_node_name $path $node]
    set item [$path.c find withtag n:$node]
    if {[string length $item]} {
        set dy   [Widget::getoption $path -deltay]
        set y    [lindex [$path.c coords $item] 1]
        set line [expr {int($y/$dy)}]
    } else {
        set line -1
    }
    return $line
}


# ----------------------------------------------------------------------------
#  Command Tree::nodes
# ----------------------------------------------------------------------------
proc Tree::nodes { path node {first ""} {last ""} } {
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    if { ![info exists data($node)] } {
        return -code error "node \"$node\" does not exist"
    }

    if { ![string length $first] } {
        return [lrange $data($node) 1 end]
    }

    if { ![string length $last] } {
        return [lindex [lrange $data($node) 1 end] $first]
    } else {
        return [lrange [lrange $data($node) 1 end] $first $last]
    }
}


# Tree::visiblenodes --
#
#	Retrieve a list of all the nodes in a tree.
#
# Arguments:
#	path	tree to retrieve nodes for.
#
# Results:
#	nodes	list of nodes in the tree.

proc Tree::visiblenodes { path } {
    variable $path
    upvar 0  $path data

    # Root is always open (?), so all of its children automatically get added
    # to the result, and to the stack.
    set st [lrange $data(root) 1 end]
    set result $st

    while {[llength $st]} {
	set node [lindex $st end]
	set st [lreplace $st end end]
	# Danger, danger!  Using getMegawidgetOption is fragile, but much
	# much faster than going through cget.
	if { [Widget::getMegawidgetOption $path.$node -open] } {
	    set nodes [lrange $data($node) 1 end]
	    set result [concat $result $nodes]
	    set st [concat $st $nodes]
	}
    }
    return $result
}

# ----------------------------------------------------------------------------
#  Command Tree::see
# ----------------------------------------------------------------------------
proc Tree::see { path node } {
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } {
        after cancel $data(upd,afterid)
        _redraw_tree $path
    }
    set idn [$path.c find withtag n:$node]
    if { $idn != "" } {
        Tree::_see $path $idn
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::opentree
# ----------------------------------------------------------------------------
# JDC: added option recursive
proc Tree::opentree { path node {recursive 1} } {
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    if { [string equal $node "root"] || ![info exists data($node)] } {
        return -code error "node \"$node\" does not exist"
    }

    _recexpand $path $node 1 $recursive [Widget::getoption $path -opencmd]
    _redraw_idle $path 3
}


# ----------------------------------------------------------------------------
#  Command Tree::closetree
# ----------------------------------------------------------------------------
proc Tree::closetree { path node {recursive 1} } {
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    if { [string equal $node "root"] || ![info exists data($node)] } {
        return -code error "node \"$node\" does not exist"
    }

    _recexpand $path $node 0 $recursive [Widget::getoption $path -closecmd]
    _redraw_idle $path 3
}


proc Tree::toggle { path node } {
    if {[$path itemcget $node -open]} {
        $path closetree $node 0
    } else {
        $path opentree $node 0
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::edit
# ----------------------------------------------------------------------------
proc Tree::edit { path node text {verifycmd ""} {clickres 0} {select 1}} {
    variable _edit
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } {
        after cancel $data(upd,afterid)
        _redraw_tree $path
    }
    set idn [$path.c find withtag n:$node]
    if { $idn != "" } {
        Tree::_see $path $idn

        set oldfg  [$path.c itemcget $idn -fill]
        set sbg    [Widget::getoption $path -selectbackground]
        set coords [$path.c coords $idn]
        set x      [lindex $coords 0]
        set y      [lindex $coords 1]
        set bd     [expr {[$path.c cget -borderwidth]+[$path.c cget -highlightthickness]}]
        set w      [expr {[winfo width $path] - 2*$bd}]
        set wmax   [expr {[$path.c canvasx $w]-$x}]

        set _edit(text) $text
        set _edit(wait) 0

        $path.c itemconfigure $idn    -fill [Widget::getoption $path -background]
        $path.c itemconfigure s:$node -fill {} -outline {}

        set frame  [frame $path.edit                         -relief flat -borderwidth 0 -highlightthickness 0                         -background [Widget::getoption $path -background]]
        set ent    [entry $frame.edit                         -width              0                             -relief             solid                         -borderwidth        1                             -highlightthickness 0                             -foreground         [Widget::getoption $path.$node -fill]                         -background         [Widget::getoption $path -background]                         -selectforeground   [Widget::getoption $path -selectforeground]                         -selectbackground   $sbg                          -font               [Widget::getoption $path.$node -font]                         -textvariable       Tree::_edit(text)]
        pack $ent -ipadx 8 -anchor w

        set idw [$path.c create window $x $y -window $frame -anchor w]
        trace variable Tree::_edit(text) w 	    [list Tree::_update_edit_size $path $ent $idw $wmax]
        tkwait visibility $ent
        grab  $frame
        BWidget::focus set $ent

        _update_edit_size $path $ent $idw $wmax
        update
        if { $select } {
            $ent selection range 0 end
            $ent icursor end
            $ent xview end
        }

        bindtags $ent [list $ent Entry]
        bind $ent <Escape> {set Tree::_edit(wait) 0}
        bind $ent <Return> {set Tree::_edit(wait) 1}
        if { $clickres == 0 || $clickres == 1 } {
            bind $frame <Button>  [list set Tree::_edit(wait) $clickres]
        }

        set ok 0
        while { !$ok } {
            tkwait variable Tree::_edit(wait)
            if { !$_edit(wait) || $verifycmd == "" ||
                 [uplevel \#0 $verifycmd [list $_edit(text)]] } {
                set ok 1
            }
        }

        trace vdelete Tree::_edit(text) w 	    [list Tree::_update_edit_size $path $ent $idw $wmax]
        grab release $frame
        BWidget::focus release $ent
        destroy $frame
        $path.c delete $idw
        $path.c itemconfigure $idn    -fill $oldfg
        $path.c itemconfigure s:$node -fill $sbg -outline $sbg

        if { $_edit(wait) } {
            return $_edit(text)
        }
    }
    return ""
}


# ----------------------------------------------------------------------------
#  Command Tree::xview
# ----------------------------------------------------------------------------
proc Tree::xview { path args } {
    return [eval [list $path.c xview] $args]
}


# ----------------------------------------------------------------------------
#  Command Tree::yview
# ----------------------------------------------------------------------------
proc Tree::yview { path args } {
    return [eval [list $path.c yview] $args]
}


# ----------------------------------------------------------------------------
#  Command Tree::_update_edit_size
# ----------------------------------------------------------------------------
proc Tree::_update_edit_size { path entry idw wmax args } {
    set entw [winfo reqwidth $entry]
    if { $entw+8 >= $wmax } {
        $path.c itemconfigure $idw -width $wmax
    } else {
        $path.c itemconfigure $idw -width 0
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::_see
# ----------------------------------------------------------------------------
proc Tree::_see { path idn } {
    set bbox [$path.c bbox $idn]
    set scrl [$path.c cget -scrollregion]

    set ymax [lindex $scrl 3]
    set dy   [$path.c cget -yscrollincrement]
    set yv   [$path yview]
    set yv0  [expr {round([lindex $yv 0]*$ymax/$dy)}]
    set yv1  [expr {round([lindex $yv 1]*$ymax/$dy)}]
    set y    [expr {int([lindex [$path.c coords $idn] 1]/$dy)}]
    if { $y < $yv0 } {
        $path.c yview scroll [expr {$y-$yv0}] units
    } elseif { $y >= $yv1 } {
        $path.c yview scroll [expr {$y-$yv1+1}] units
    }

    set xmax [lindex $scrl 2]
    set dx   [$path.c cget -xscrollincrement]
    set xv   [$path xview]
    set x0   [expr {int([lindex $bbox 0]/$dx)}]
    set xv0  [expr {round([lindex $xv 0]*$xmax/$dx)}]
    set xv1  [expr {round([lindex $xv 1]*$xmax/$dx)}]
    if { $x0 >= $xv1 || $x0 < $xv0 } {
	$path.c xview scroll [expr {$x0-$xv0}] units
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::_recexpand
# ----------------------------------------------------------------------------
# JDC : added option recursive
proc Tree::_recexpand { path node expand recursive cmd } {
    variable $path
    upvar 0  $path data

    if { [Widget::getoption $path.$node -open] != $expand } {
        Widget::setoption $path.$node -open $expand
        if { $cmd != "" } {
            uplevel \#0 $cmd [list $node]
        }
    }

    if { $recursive } {
	foreach subnode [lrange $data($node) 1 end] {
	    _recexpand $path $subnode $expand $recursive $cmd
	}
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::_subdelete
# ----------------------------------------------------------------------------
proc Tree::_subdelete { path lnodes } {
    variable $path
    upvar 0  $path data

    set sel $data(selnodes)

    while { [llength $lnodes] } {
        set lsubnodes [list]
        foreach node $lnodes {
            foreach subnode [lrange $data($node) 1 end] {
                lappend lsubnodes $subnode
            }
            unset data($node)
	    set idx [lsearch -exact $sel $node]
	    if { $idx >= 0 } {
		set sel [lreplace $sel $idx $idx]
	    }
            if { [set win [Widget::getoption $path.$node -window]] != "" } {
                destroy $win
            }
            Widget::destroy $path.$node
        }
        set lnodes $lsubnodes
    }

    set data(selnodes) $sel
}


# ----------------------------------------------------------------------------
#  Command Tree::_update_scrollregion
# ----------------------------------------------------------------------------
proc Tree::_update_scrollregion { path } {
    set bd   [expr {2*([$path.c cget -borderwidth]+[$path.c cget -highlightthickness])}]
    set w    [expr {[winfo width  $path] - $bd}]
    set h    [expr {[winfo height $path] - $bd}]
    set xinc [$path.c cget -xscrollincrement]
    set yinc [$path.c cget -yscrollincrement]
    set bbox [$path.c bbox node]
    if { [llength $bbox] } {
        set xs [lindex $bbox 2]
        set ys [lindex $bbox 3]

        if { $w < $xs } {
            set w [expr {int($xs)}]
            if { [set r [expr {$w % $xinc}]] } {
                set w [expr {$w+$xinc-$r}]
            }
        }
        if { $h < $ys } {
            set h [expr {int($ys)}]
            if { [set r [expr {$h % $yinc}]] } {
                set h [expr {$h+$yinc-$r}]
            }
        }
    }

    $path.c configure -scrollregion [list 0 0 $w $h]

    if {[Widget::getoption $path -selectfill]} {
        _redraw_selection $path
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::_cross_event
# ----------------------------------------------------------------------------
proc Tree::_cross_event { path } {
    variable $path
    upvar 0  $path data

    set node [Tree::_get_node_name $path current 1]
    if { [Widget::getoption $path.$node -open] } {
        Tree::itemconfigure $path $node -open 0
        if { [set cmd [Widget::getoption $path -closecmd]] != "" } {
            uplevel \#0 $cmd [list $node]
        }
    } else {
        Tree::itemconfigure $path $node -open 1
        if { [set cmd [Widget::getoption $path -opencmd]] != "" } {
            uplevel \#0 $cmd [list $node]
        }
    }
}


proc Tree::_draw_cross { path node open x y } {
    set idc [$path.c find withtag c:$node]

    if { $open } {
        set img [Widget::cget $path -crossopenimage]
        set bmp [Widget::cget $path -crossopenbitmap]
    } else {
        set img [Widget::cget $path -crosscloseimage]
        set bmp [Widget::cget $path -crossclosebitmap]
    }

    ## If we already have a cross for this node, we just adjust the image.
    if {$idc != ""} {
        if {$img == ""} {
            $path.c itemconfigure $idc -bitmap $bmp
        } else {
            $path.c itemconfigure $idc -image $img
        }
        return
    }

    ## Create a new image for the cross.  If the user has specified an
    ## image, it overrides a bitmap.
    if {$img == ""} {
        $path.c create bitmap $x $y             -bitmap     $bmp             -background [$path.c cget -background]             -foreground [Widget::getoption $path -crossfill]             -tags       [list cross c:$node] -anchor c
    } else {
        $path.c create image $x $y             -image      $img             -tags       [list cross c:$node] -anchor c
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::_draw_node
# ----------------------------------------------------------------------------
proc Tree::_draw_node { path node x0 y0 deltax deltay padx showlines } {
    global   env
    variable $path
    upvar 0  $path data

    set x1 [expr {$x0+$deltax+5}]
    set y1 $y0
    if { $showlines } {
        $path.c create line $x0 $y0 $x1 $y0             -fill    [Widget::getoption $path -linesfill]               -stipple [Widget::getoption $path -linestipple]             -tags    line
    }
    $path.c create text [expr {$x1+$padx}] $y0         -text   [Widget::getoption $path.$node -text]         -fill   [Widget::getoption $path.$node -fill]         -font   [Widget::getoption $path.$node -font]         -anchor w     	-tags   [Tree::_get_node_tags $path $node [list node n:$node]]
    set len [expr {[llength $data($node)] > 1}]
    set dc  [Widget::getoption $path.$node -drawcross]
    set exp [Widget::getoption $path.$node -open]

    if { $len && $exp } {
        set y1 [_draw_subnodes $path [lrange $data($node) 1 end]                     [expr {$x0+$deltax}] $y0 $deltax $deltay $padx $showlines]
    }

    if {![string equal $dc "never"] && ($len || [string equal $dc "allways"])} {
        _draw_cross $path $node $exp $x0 $y0
    }

    if { [set win [Widget::getoption $path.$node -window]] != "" } {
	set a [Widget::cget $path.$node -anchor]
        $path.c create window $x1 $y0 -window $win -anchor $a 		-tags [Tree::_get_node_tags $path $node [list win i:$node]]
    } elseif { [set img [Widget::getoption $path.$node -image]] != "" } {
	set a [Widget::cget $path.$node -anchor]
        $path.c create image $x1 $y0 -image $img -anchor $a 		-tags   [Tree::_get_node_tags $path $node [list img i:$node]]
    }
    set box [$path.c bbox n:$node i:$node]
    set id [$path.c create rect 0 [lindex $box 1] 		[winfo screenwidth $path] [lindex $box 3] 		-tags [Tree::_get_node_tags $path $node [list box b:$node]] 		-fill {} -outline {}]
    $path.c lower $id

    _set_help $path $node

    return $y1
}


# ----------------------------------------------------------------------------
#  Command Tree::_draw_subnodes
# ----------------------------------------------------------------------------
proc Tree::_draw_subnodes { path nodes x0 y0 deltax deltay padx showlines } {
    set y1 $y0
    foreach node $nodes {
	set padx   [_get_node_padx $path $node]
	set deltax [_get_node_deltax $path $node]
        set yp $y1
        set y1 [_draw_node $path $node $x0 [expr {$y1+$deltay}] $deltax $deltay $padx $showlines]
    }
    if { $showlines && [llength $nodes] } {
        set id [$path.c create line $x0 $y0 $x0 [expr {$yp+$deltay}]                     -fill    [Widget::getoption $path -linesfill]                       -stipple [Widget::getoption $path -linestipple]                     -tags    line]

        $path.c lower $id
    }
    return $y1
}


# ----------------------------------------------------------------------------
#  Command Tree::_update_nodes
# ----------------------------------------------------------------------------
proc Tree::_update_nodes { path } {
    global   env
    variable $path
    upvar 0  $path data

    set deltax [Widget::getoption $path -deltax]
    set padx   [Widget::getoption $path -padx]
    foreach {node flag} $data(upd,nodes) {
        set idn [$path.c find withtag "n:$node"]
        if { $idn == "" } {
            continue
        }
	set padx   [_get_node_padx $path $node]
	set deltax [_get_node_deltax $path $node]
        set c  [$path.c coords $idn]
        set x0 [expr {[lindex $c 0]-$padx}]
        set y0 [lindex $c 1]
        if { $flag & 48 } {
            # -window or -image modified
            set win  [Widget::getoption $path.$node -window]
            set img  [Widget::getoption $path.$node -image]
            set idi  [$path.c find withtag i:$node]
            set type [lindex [$path.c gettags $idi] 1]
            if { [string length $win] } {
                if { [string equal $type "win"] } {
                    $path.c itemconfigure $idi -window $win
                } else {
                    $path.c delete $idi
                    $path.c create window $x0 $y0 -window $win -anchor w 			    -tags [Tree::_get_node_tags $path $node 			    	[list win i:$node]]
                }
            } elseif { [string length $img] } {
                if { [string equal $type "img"] } {
                    $path.c itemconfigure $idi -image $img
                } else {
                    $path.c delete $idi
                    $path.c create image $x0 $y0 -image $img -anchor w 			    -tags [Tree::_get_node_tags $path $node 			    	[list img i:$node]]
                }
            } else {
                $path.c delete $idi
            }
        }

        if { $flag & 8 } {
            # -drawcross modified
            set len [expr {[llength $data($node)] > 1}]
            set dc  [Widget::getoption $path.$node -drawcross]
            set exp [Widget::getoption $path.$node -open]

            if {![string equal $dc "never"]
                && ($len || [string equal $dc "allways"])} {
                _draw_cross $path $node $exp $x0 $y0
            } else {
		set idc [$path.c find withtag c:$node]
                $path.c delete $idc
            }
        }

        if { $flag & 7 } {
            # -font, -text or -fill modified
            $path.c itemconfigure $idn                 -text [Widget::getoption $path.$node -text]                 -fill [Widget::getoption $path.$node -fill]                 -font [Widget::getoption $path.$node -font]
        }
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::_draw_tree
# ----------------------------------------------------------------------------
proc Tree::_draw_tree { path } {
    variable $path
    upvar 0  $path data

    $path.c delete all
    set cursor [$path.c cget -cursor]
    $path.c configure -cursor watch
    _draw_subnodes $path [lrange $data(root) 1 end] 8         [expr {-[Widget::getoption $path -deltay]/2}]         [Widget::getoption $path -deltax]         [Widget::getoption $path -deltay]         [Widget::getoption $path -padx]           [Widget::getoption $path -showlines]
    $path.c configure -cursor $cursor
}


# ----------------------------------------------------------------------------
#  Command Tree::_redraw_tree
# ----------------------------------------------------------------------------
proc Tree::_redraw_tree { path } {
    variable $path
    upvar 0  $path data

    if { [Widget::getoption $path -redraw] } {
        if { $data(upd,level) == 2 } {
            _update_nodes $path
        } elseif { $data(upd,level) == 3 } {
            _draw_tree $path
        }
        _redraw_selection $path
        _update_scrollregion $path
        set data(upd,nodes)   {}
        set data(upd,level)   0
        set data(upd,afterid) ""
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::_redraw_selection
# ----------------------------------------------------------------------------
proc Tree::_redraw_selection { path } {
    variable $path
    upvar 0  $path data

    set selbg [Widget::getoption $path -selectbackground]
    set selfg [Widget::getoption $path -selectforeground]
    set fill  [Widget::getoption $path -selectfill]
    if {$fill} {
        set scroll [$path.c cget -scrollregion]
        if {[llength $scroll]} {
            set xmax [expr {[lindex $scroll 2]-1}]
        } else {
            set xmax [winfo width $path]
        }
    }
    foreach id [$path.c find withtag sel] {
        set node [Tree::_get_node_name $path $id 1]
        $path.c itemconfigure "n:$node" -fill [Widget::getoption $path.$node -fill]
    }
    $path.c delete sel
    foreach node $data(selnodes) {
        set bbox [$path.c bbox "n:$node"]
        if { [llength $bbox] } {
            if {$fill} {
		# get the image to (if any), as it may have different height
		set bbox [$path.c bbox "n:$node" "i:$node"]
                set bbox [list 0 [lindex $bbox 1] $xmax [lindex $bbox 3]]
            }
            set id [$path.c create rectangle $bbox -tags [list sel s:$node] 			-fill $selbg -outline $selbg]
            $path.c itemconfigure "n:$node" -fill $selfg
            $path.c lower $id
        }
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::_redraw_idle
# ----------------------------------------------------------------------------
proc Tree::_redraw_idle { path level } {
    variable $path
    upvar 0  $path data

    if { [Widget::getoption $path -redraw] && $data(upd,afterid) == "" } {
        set data(upd,afterid) [after idle Tree::_redraw_tree $path]
    }
    if { $level > $data(upd,level) } {
        set data(upd,level) $level
    }
    return ""
}


# ----------------------------------------------------------------------------
#  Command Tree::_init_drag_cmd
# ----------------------------------------------------------------------------
proc Tree::_init_drag_cmd { path X Y top } {
    set path [winfo parent $path]
    set ltags [$path.c gettags current]
    set item  [lindex $ltags 1]
    if { [string equal $item "node"] ||
         [string equal $item "img"]  ||
         [string equal $item "win"] } {
        set node [Tree::_get_node_name $path current 2]
        if { [set cmd [Widget::getoption $path -draginitcmd]] != "" } {
            return [uplevel \#0 $cmd [list $path $node $top]]
        }
        if { [set type [Widget::getoption $path -dragtype]] == "" } {
            set type "TREE_NODE"
        }
        if { [set img [Widget::getoption $path.$node -image]] != "" } {
            pack [label $top.l -image $img -padx 0 -pady 0]
        }
        return [list $type {copy move link} $node]
    }
    return {}
}


# ----------------------------------------------------------------------------
#  Command Tree::_drop_cmd
# ----------------------------------------------------------------------------
proc Tree::_drop_cmd { path source X Y op type dnddata } {
    set path [winfo parent $path]
    variable $path
    upvar 0  $path data

    $path.c delete drop
    if { [string length $data(dnd,afterid)] } {
        after cancel $data(dnd,afterid)
        set data(dnd,afterid) ""
    }
    set data(dnd,scroll) ""
    if { [llength $data(dnd,node)] } {
        if { [set cmd [Widget::getoption $path -dropcmd]] != "" } {
            return [uplevel \#0 $cmd [list $path $source $data(dnd,node) $op $type $dnddata]]
        }
    }
    return 0
}


# ----------------------------------------------------------------------------
#  Command Tree::_over_cmd
# ----------------------------------------------------------------------------
proc Tree::_over_cmd { path source event X Y op type dnddata } {
    set path [winfo parent $path]
    variable $path
    upvar 0  $path data

    if { [string equal $event "leave"] } {
        # we leave the window tree
        $path.c delete drop
        if { [string length $data(dnd,afterid)] } {
            after cancel $data(dnd,afterid)
            set data(dnd,afterid) ""
        }
        set data(dnd,scroll) ""
        return 0
    }

    if { [string equal $event "enter"] } {
        # we enter the window tree - dnd data initialization
        set mode [Widget::getoption $path -dropovermode]
        set data(dnd,mode) 0
        foreach c {w p n} {
            set data(dnd,mode) [expr {($data(dnd,mode) << 1) | ([string first $c $mode] != -1)}]
        }
        set bbox [$path.c bbox all]
        if { [llength $bbox] } {
            set data(dnd,xs) [lindex $bbox 2]
            set data(dnd,empty) 0
        } else {
            set data(dnd,xs) 0
            set data(dnd,empty) 1
        }
        set data(dnd,node) {}
    }

    set x [expr {$X-[winfo rootx $path]}]
    set y [expr {$Y-[winfo rooty $path]}]
    $path.c delete drop
    set data(dnd,node) {}

    # test for auto-scroll unless mode is widget only
    if { $data(dnd,mode) != 4 && [_auto_scroll $path $x $y] != "" } {
        return 2
    }

    if { $data(dnd,mode) & 4 } {
        # dropovermode includes widget
        set target [list widget]
        set vmode  4
    } else {
        set target [list ""]
        set vmode  0
    }
    if { ($data(dnd,mode) & 2) && $data(dnd,empty) } {
        # dropovermode includes position and tree is empty
        lappend target [list root 0]
        set vmode  [expr {$vmode | 2}]
    }

    set xc [$path.c canvasx $x]
    set xs $data(dnd,xs)
    if { $xc <= $xs } {
        set yc   [$path.c canvasy $y]
        set dy   [$path.c cget -yscrollincrement]
        set line [expr {int($yc/$dy)}]
        set xi   0
        set yi   [expr {$line*$dy}]
        set ys   [expr {$yi+$dy}]
        set found 0
        foreach id [$path.c find overlapping $xi $yi $xs $ys] {
            set ltags [$path.c gettags $id]
            set item  [lindex $ltags 1]
            if { [string equal $item "node"] ||
                 [string equal $item "img"]  ||
                 [string equal $item "win"] } {
                # item is the label or image/window of the node
                set node [Tree::_get_node_name $path $id 2]
		set found 1
		break
	    }
	}
	if {$found} {
	    set padx   [_get_node_padx $path $node]
	    set deltax [_get_node_deltax $path $node]
            set xi [expr {[lindex [$path.c coords n:$node] 0] - $padx - 1}]
                if { $data(dnd,mode) & 1 } {
                    # dropovermode includes node
                    lappend target $node
                    set vmode [expr {$vmode | 1}]
                } else {
                    lappend target ""
                }

                if { $data(dnd,mode) & 2 } {
                    # dropovermode includes position
                    if { $yc >= $yi+$dy/2 } {
                        # position is after $node
                        if { [Widget::getoption $path.$node -open] &&
                             [llength $data($node)] > 1 } {
                            # $node is open and have subnodes
                            # drop position is 0 in children of $node
                            set parent $node
                            set index  0
                            set xli    [expr {$xi-5}]
                        } else {
                            # $node is not open and doesn't have subnodes
                            # drop position is after $node in children of parent of $node
                            set parent [lindex $data($node) 0]
                            set index  [lsearch -exact $data($parent) $node]
                            set xli    [expr {$xi - $deltax - 5}]
                        }
                        set yl $ys
                    } else {
                        # position is before $node
                        # drop position is before $node in children of parent of $node
                        set parent [lindex $data($node) 0]
                        set index  [expr {[lsearch -exact $data($parent) $node] - 1}]
                        set xli    [expr {$xi - $deltax - 5}]
                        set yl     $yi
                    }
                    lappend target [list $parent $index]
                    set vmode  [expr {$vmode | 2}]
                } else {
                    lappend target {}
                }

                if { ($vmode & 3) == 3 } {
                    # result have both node and position
                    # we compute what is the preferred method
                    if { $yc-$yi <= 3 || $ys-$yc <= 3 } {
                        lappend target "position"
                    } else {
                        lappend target "node"
                    }
                }
            }
        }

    if { $vmode && [set cmd [Widget::getoption $path -dropovercmd]] != "" } {
        # user-defined dropover command
        set res     [uplevel \#0 $cmd [list $path $source $target $op $type $dnddata]]
        set code    [lindex $res 0]
        set newmode 0
        if { $code & 1 } {
            # update vmode
            set mode [lindex $res 1]
            if { ($vmode & 1) && [string equal $mode "node"] } {
                set newmode 1
            } elseif { ($vmode & 2) && [string equal $mode "position"] } {
                set newmode 2
            } elseif { ($vmode & 4) && [string equal $mode "widget"] } {
                set newmode 4
            }
        }
        set vmode $newmode
    } else {
        if { ($vmode & 3) == 3 } {
            # result have both item and position
            # we choose the preferred method
            if { [string equal [lindex $target 3] "position"] } {
                set vmode [expr {$vmode & ~1}]
            } else {
                set vmode [expr {$vmode & ~2}]
            }
        }

        if { $data(dnd,mode) == 4 || $data(dnd,mode) == 0 } {
            # dropovermode is widget or empty - recall is not necessary
            set code 1
        } else {
            set code 3
        }
    }

    if {!$data(dnd,empty)} {
	# draw dnd visual following vmode
	if { $vmode & 1 } {
	    set data(dnd,node) [list "node" [lindex $target 1]]
	    $path.c create rectangle $xi $yi $xs $ys -tags drop
	} elseif { $vmode & 2 } {
	    set data(dnd,node) [concat "position" [lindex $target 2]]
	    $path.c create line $xli [expr {$yl-$dy/2}] $xli $yl $xs $yl -tags drop
	} elseif { $vmode & 4 } {
	    set data(dnd,node) [list "widget"]
	} else {
	    set code [expr {$code & 2}]
	}
    }

    if { $code & 1 } {
        DropSite::setcursor based_arrow_down
    } else {
        DropSite::setcursor dot
    }
    return $code
}


# ----------------------------------------------------------------------------
#  Command Tree::_auto_scroll
# ----------------------------------------------------------------------------
proc Tree::_auto_scroll { path x y } {
    variable $path
    upvar 0  $path data

    set xmax   [winfo width  $path]
    set ymax   [winfo height $path]
    set scroll {}
    if { $y <= 6 } {
        if { [lindex [$path.c yview] 0] > 0 } {
            set scroll [list yview -1]
            DropSite::setcursor sb_up_arrow
        }
    } elseif { $y >= $ymax-6 } {
        if { [lindex [$path.c yview] 1] < 1 } {
            set scroll [list yview 1]
            DropSite::setcursor sb_down_arrow
        }
    } elseif { $x <= 6 } {
        if { [lindex [$path.c xview] 0] > 0 } {
            set scroll [list xview -1]
            DropSite::setcursor sb_left_arrow
        }
    } elseif { $x >= $xmax-6 } {
        if { [lindex [$path.c xview] 1] < 1 } {
            set scroll [list xview 1]
            DropSite::setcursor sb_right_arrow
        }
    }

    if { [string length $data(dnd,afterid)] && ![string equal $data(dnd,scroll) $scroll] } {
        after cancel $data(dnd,afterid)
        set data(dnd,afterid) ""
    }

    set data(dnd,scroll) $scroll
    if { [string length $scroll] && ![string length $data(dnd,afterid)] } {
        set data(dnd,afterid) [after 200 Tree::_scroll $path $scroll]
    }
    return $data(dnd,afterid)
}


# ----------------------------------------------------------------------------
#  Command Tree::_scroll
# ----------------------------------------------------------------------------
proc Tree::_scroll { path cmd dir } {
    variable $path
    upvar 0  $path data

    if { ($dir == -1 && [lindex [$path.c $cmd] 0] > 0) ||
         ($dir == 1  && [lindex [$path.c $cmd] 1] < 1) } {
        $path.c $cmd scroll $dir units
        set data(dnd,afterid) [after 100 Tree::_scroll $path $cmd $dir]
    } else {
        set data(dnd,afterid) ""
        DropSite::setcursor dot
    }
}

# Tree::_keynav --
#
#	Handle navigational keypresses on the tree.
#
# Arguments:
#	which      tag indicating the direction of motion:
#                  up         move to the node graphically above current
#                  down       move to the node graphically below current
#                  left       close current if open, else move to parent
#                  right      open current if closed, else move to child
#                  open       open current if closed, close current if open
#       win        name of the tree widget
#
# Results:
#	None.

proc Tree::_keynav {which win} {
    # Keyboard navigation is riddled with special cases.  In order to avoid
    # the complex logic, we will instead make a list of all the visible,
    # selectable nodes, then do a simple next or previous operation.

    # One easy way to get all of the visible nodes is to query the canvas
    # object for all the items with the "node" tag; since the tree is always
    # completely redrawn, this list will be in vertical order.
    set nodes {}
    foreach nodeItem [$win.c find withtag node] {
	set node [Tree::_get_node_name $win $nodeItem 2]
	if { [Widget::cget $win.$node -selectable] } {
	    lappend nodes $node
	}
    }

    # Keyboard navigation is all relative to the current node
    # surles: Get the current node for single or multiple selection schemas.
    set node [_get_current_node $win]

    switch -exact -- $which {
	"up" {
	    # Up goes to the node that is vertically above the current node
	    # (NOT necessarily the current node's parent)
	    if { [string equal $node ""] } {
		return
	    }
	    set index [lsearch -exact $nodes $node]
	    incr index -1
	    if { $index >= 0 } {
		$win selection set [lindex $nodes $index]
		_set_current_node $win [lindex $nodes $index]
		$win see [lindex $nodes $index]
		return
	    }
	}
	"down" {
	    # Down goes to the node that is vertically below the current node
	    if { [string equal $node ""] } {
		$win selection set [lindex $nodes 0]
		_set_current_node $win [lindex $nodes 0]
		$win see [lindex $nodes 0]
		return
	    }

	    set index [lsearch -exact $nodes $node]
	    incr index
	    if { $index < [llength $nodes] } {
		$win selection set [lindex $nodes $index]
		_set_current_node $win [lindex $nodes $index]
		$win see [lindex $nodes $index]
		return
	    }
	}
	"right" {
	    # On a right arrow, if the current node is closed, open it.
	    # If the current node is open, go to its first child
	    if { [string equal $node ""] } {
		return
	    }
	    set open [$win itemcget $node -open]
            if { $open } {
                if { [llength [$win nodes $node]] } {
		    set index [lsearch -exact $nodes $node]
		    incr index
		    if { $index < [llength $nodes] } {
			$win selection set [lindex $nodes $index]
			_set_current_node $win [lindex $nodes $index]
			$win see [lindex $nodes $index]
			return
		    }
                }
            } else {
                $win itemconfigure $node -open 1
                if { [set cmd [Widget::getoption $win -opencmd]] != "" } {
                    uplevel \#0 $cmd [list $node]
                }
                return
            }
	}
	"left" {
	    # On a left arrow, if the current node is open, close it.
	    # If the current node is closed, go to its parent.
	    if { [string equal $node ""] } {
		return
	    }
	    set open [$win itemcget $node -open]
	    if { $open } {
		$win itemconfigure $node -open 0
                if { [set cmd [Widget::getoption $win -closecmd]] != "" } {
                    uplevel \#0 $cmd [list $node]
                }
		return
	    } else {
		set parent [$win parent $node]
	        if { [string equal $parent "root"] } {
		    set parent $node
                } else {
                    while { ![$win itemcget $parent -selectable] } {
		        set parent [$win parent $parent]
		        if { [string equal $parent "root"] } {
			    set parent $node
			    break
		        }
                    }
		}
		$win selection set $parent
		_set_current_node $win $parent
		$win see $parent
		return
	    }
	}
	"space" {
	    if { [string equal $node ""] } {
		return
	    }
	    set open [$win itemcget $node -open]
	    if { [llength [$win nodes $node]] } {

		# Toggle the open status of the chosen node.

		$win itemconfigure $node -open [expr {$open?0:1}]

		if {$open} {
		    # Node was open, is now closed. Call the close-cmd

		    if { [set cmd [Widget::getoption $win -closecmd]] != "" } {
			uplevel \#0 $cmd [list $node]
		    }
		} else {
		    # Node was closed, is now open. Call the open-cmd

		    if { [set cmd [Widget::getoption $win -opencmd]] != "" } {
			uplevel \#0 $cmd [list $node]
		    }
                }
	    }
	}
    }
    return
}

# Tree::_get_current_node --
#
#	Get the current node for either single or multiple
#	node selection trees.  If the tree allows for 
#	multiple selection, return the cursor node.  Otherwise,
#	if there is a selection, return the first node in the
#	list.  If there is no selection, return the root node.
#
# arguments:
#       win        name of the tree widget
#
# Results:
#	The current node.

proc Tree::_get_current_node {win} {
    if {[info exists selectTree::selectCursor($win)]} {
	set result $selectTree::selectCursor($win)
    } elseif {[set selList [$win selection get]] != {}} {
	set result [lindex $selList 0]
    } else {
	set result ""
    }
    return $result
}

# Tree::_set_current_node --
#
#	Set the current node for either single or multiple
#	node selection trees.
#
# arguments:
#       win        Name of the tree widget
#	node	   The current node.
#
# Results:
#	None.

proc Tree::_set_current_node {win node} {
    if {[info exists selectTree::selectCursor($win)]} {
	set selectTree::selectCursor($win) $node
    }
    return
}

# Tree::_get_node_name --
#
#	Given a canvas item, get the name of the tree node represented by that
#	item.
#
# Arguments:
#	path		tree to query
#	item		Optional canvas item to examine; if omitted, 
#			defaults to "current"
#	tagindex	Optional tag index, since the n:nodename tag is not
#			in the same spot for all canvas items.  If omitted,
#			defaults to "end-1", so it works with "current" item.
#
# Results:
#	node	name of the tree node.

proc Tree::_get_node_name {path {item current} {tagindex end-1}} {
    return [string range [lindex [$path.c gettags $item] $tagindex] 2 end]
}

# Tree::_get_node_padx --
#
#	Given a node in the tree, return it's padx value.  If the value is
#	less than 0, default to the padx of the entire tree.
#
# Arguments:
#	path		Tree to query
#	node		Node in the tree
#
# Results:
#	padx		The numeric padx value
proc Tree::_get_node_padx {path node} {
    set padx [Widget::getoption $path.$node -padx]
    if {$padx < 0} { set padx [Widget::getoption $path -padx] }
    return $padx
}

# Tree::_get_node_deltax --
#
#	Given a node in the tree, return it's deltax value.  If the value is
#	less than 0, default to the deltax of the entire tree.
#
# Arguments:
#	path		Tree to query
#	node		Node in the tree
#
# Results:
#	deltax		The numeric deltax value
proc Tree::_get_node_deltax {path node} {
    set deltax [Widget::getoption $path.$node -deltax]
    if {$deltax < 0} { set deltax [Widget::getoption $path -deltax] }
    return $deltax
}


# Tree::_get_node_tags --
#
#	Given a node in the tree, return a list of tags to apply to its
#       canvas item.
#
# Arguments:
#	path		Tree to query
#	node		Node in the tree
#	tags		A list of tags to add to the final list
#
# Results:
#	list		The list of tags to apply to the canvas item
proc Tree::_get_node_tags {path node {tags ""}} {
    eval [list lappend list TreeItemSentinal] $tags
    if {[Widget::getoption $path.$node -helptext] == ""} { return $list }

    switch -- [Widget::getoption $path.$node -helptype] {
	balloon {
	    lappend list BwHelpBalloon
	}
	variable {
	    lappend list BwHelpVariable
	}
    }
    return $list
}

# Tree::_set_help --
#
#	Register dynamic help for a node in the tree.
#
# Arguments:
#	path		Tree to query
#	node		Node in the tree
#       force		Optional argument to force a reset of the help
#
# Results:
#	none
proc Tree::_set_help { path node } {
    Widget::getVariable $path help

    set item $path.$node
    set opts [list -helptype -helptext -helpvar]
    foreach {cty ctx cv} [eval [list Widget::hasChangedX $item] $opts] break
    set text [Widget::getoption $item -helptext]

    ## If we've never set help for this item before, and text is not blank,
    ## we need to setup help.  We also need to reset help if any of the
    ## options have changed.
    if { (![info exists help($node)] && $text != "") || $cty || $ctx || $cv } {
	set help($node) 1
	set type [Widget::getoption $item -helptype]
        switch $type {
            balloon {
		DynamicHelp::register $path.c balloon n:$node $text
		DynamicHelp::register $path.c balloon i:$node $text
		DynamicHelp::register $path.c balloon b:$node $text
            }
            variable {
		set var [Widget::getoption $item -helpvar]
		DynamicHelp::register $path.c variable n:$node $var $text
		DynamicHelp::register $path.c variable i:$node $var $text
		DynamicHelp::register $path.c variable b:$node $var $text
            }
        }
    }
}

proc Tree::_mouse_select { path cmd args } {
    eval selection [list $path] [list $cmd] $args
    switch -- $cmd {
        "add" - "clear" - "remove" - "set" - "toggle" {
            event generate $path <<TreeSelect>>
        }
    }
}


proc Tree::_node_name { path node } {
    set map [list & _ | _ ^ _ ! _]
    return  [string map $map $node]
}


# ----------------------------------------------------------------------------
#  Command Tree::_destroy
# ----------------------------------------------------------------------------
proc Tree::_destroy { path } {
    variable $path
    upvar 0  $path data

    if { $data(upd,afterid) != "" } {
        after cancel $data(upd,afterid)
    }
    if { $data(dnd,afterid) != "" } {
        after cancel $data(dnd,afterid)
    }
    _subdelete $path [lrange $data(root) 1 end]
    Widget::destroy $path
    unset data
}
}
class tree {
    proc tree {this parentPath args} widget {[eval ::Tree $parentPath.$this $args]} {}
    proc ~tree {this} {destroy $widget::($this,path)}
}




class thresholdsManager {

    set (number) 0

    proc thresholdsManager {this} {}

    proc ~thresholdsManager {this} {
        variable ${this}number
        variable ${this}text

        catch {unset ${this}number ${this}text}
    }

    proc condition {this cell color level text} {
        variable ${this}number
        variable ${this}text

        if {[string length $color] == 0} {set color $viewer::(background)}
        foreach {red green blue} [winfo rgb . $color] {}
        set color #[format %04X $red][format %04X $green][format %04X $blue]
        set key [list $cell $color $level]
        if {[string length $text] == 0} {
            catch {unset ${this}number($key) ${this}text($key)}
        } else {
            set ${this}number($key) [incr (number)]
            set ${this}text($key) $text
        }
    }

    proc colorsAndTexts {this} {
        variable ${this}number
        variable ${this}text

        set texts {}
        set list {}
        foreach {key number} [array get ${this}number] {
            foreach {cell color level} $key {}
            lappend list [list $level $key $color $number]
        }
        foreach list [lsort -command thresholds::threshold::compareLevels -index 0 -decreasing $list] {
            foreach {level key color number} $list {}
            if {![info exists minimum]} {set minimum $level}
            if {[thresholds::threshold::compareLevels $level $minimum] < 0} break
            set colorNumber($color) $number
            set textNumber([set ${this}text($key)]) $number
        }
        set list {}
        foreach {color number} [array get colorNumber] {lappend list [list $color $number]}
        set colors {}
        foreach list [lsort -decreasing -integer -index end $list] {lappend colors [lindex $list 0]}
        set list {}
        foreach {text number} [array get textNumber] {lappend list [list $text $number]}
        set texts {}
        foreach list [lsort -decreasing -integer -index end $list] {lappend texts [lindex $list 0]}
        return [list $colors $texts]
    }

}



class repeater {

    proc repeater {this milliSeconds command} {
        set ($this,period) $milliSeconds
        set ($this,command) $command
    }

    proc ~repeater {this} {
        stop $this
    }

    proc start {this} {
        stop $this
        uplevel #0 $($this,command)
        set ($this,event) [after $($this,period) "repeater::start $this"]
    }

    proc stop {this} {
        catch {after cancel $($this,event)}
    }

}



class sequencer {

    proc sequencer {this milliSeconds keyword list script} {
        set ($this,period) $milliSeconds
        set ($this,keyword) $keyword
        set ($this,list) $list
        set ($this,script) $script
        set ($this,length) [llength $list]
    }

    proc ~sequencer {this} {
        stop $this
    }

    proc start {this} {
        set ($this,index) 0
        set ($this,repeater) [new repeater $($this,period) "sequencer::next $this"]
        repeater::start $($this,repeater)
    }

    proc stop {this} {
        if {[info exists ($this,repeater)]} {
            delete $($this,repeater)
            unset ($this,repeater)
        }
    }

    proc next {this} {
        regsub -all $($this,keyword) $($this,script) [lindex $($this,list) $($this,index)] command
        uplevel #0 $command
        if {[incr ($this,index)] >= $($this,length)} {
            set ($this,index) 0
        }
    }

}



class thresholdLabel {

    proc thresholdLabel {this parentPath args} composite {
        [new label $parentPath -background $viewer::(background) -font $font::(mediumBold)] $args
    } viewer {} {
        variable singleton

        if {[info exists singleton]} {
            error {only 1 threshold label object can exist}
        }
        set singleton $this
        set ($this,tip) [new widgetTip -path $widget::($this,path)]
        composite::complete $this
    }

    proc ~thresholdLabel {this} {
        error {not implemented}
    }

    proc options {this} {
        return [list            [list -borderwidth $widget::option(button,borderwidth)]            [list -draggable 0 0]            [list -text {} {}]        ]
    }

    proc set-borderwidth {this value} {$widget::($this,path) configure -borderwidth $value}
    proc set-text {this value} {$widget::($this,path) configure -text $value}
    proc set-draggable {this value} {}

    proc supportedTypes {this} {
        return [thresholds::supportedTypes 0]
    }

    proc monitorCell {this array row column} {
        variable ${this}monitored

        set cell ${array}($row,$column)
        set ${this}monitored($cell) {}
    }

    proc forgetAllMonitoredCells {this} {
        variable ${this}monitored

        catch {unset ${this}monitored}
        if {[info exists ($this,thresholds)]} {delete $($this,thresholds); unset ($this,thresholds)}
        if {[info exists ($this,sequencer)]} {delete $($this,sequencer); unset ($this,sequencer)}
        $widget::($this,path) configure -background $viewer::(background)
        switched::configure $($this,tip) -text {}
    }

    proc update {this array} {}

    proc cells {this} {
        variable ${this}monitored

        return [lsort -dictionary [array names ${this}monitored]]
    }

    proc thresholdCondition {this array row column color level summary} {
        variable ${this}monitored

        set cell ${array}($row,$column)
        if {![info exists ${this}monitored($cell)]} return
        if {![info exists ($this,thresholds)]} {
            set ($this,thresholds) [new thresholdsManager]
        }
        thresholdsManager::condition $($this,thresholds) $cell $color $level $summary
        foreach {colors summaries} [thresholdsManager::colorsAndTexts $($this,thresholds)] {}
        if {[info exists ($this,sequencer)]} {delete $($this,sequencer); unset ($this,sequencer)}
        if {[llength $colors] == 0} {
            $widget::($this,path) configure -background $viewer::(background)
        } elseif {[llength $colors] == 1} {
            $widget::($this,path) configure -background [lindex $colors 0]
        } else {
            set ($this,sequencer) [new sequencer 1000 %c $colors "$widget::($this,path) configure -background %c"]
            sequencer::start $($this,sequencer)
        }
        if {[llength $summaries] == 0} {
            switched::configure $($this,tip) -text {}
        } else {
            set text {}
            set number 0
            foreach summary $summaries {
                if {$number < 3} {
                    if {$number > 0} {append text \n}
                    append text $summary
                }
                incr number
            }
            if {$number > 3} {append text \n...}
            switched::configure $($this,tip) -text $text
        }
    }

    proc manageable {this} {return 0}

    proc monitored {this cell} {
        variable ${this}monitored

        return [info exists ${this}monitored($cell)]
    }

    proc monitorActiveCells {} {
        variable singleton

        forgetAllMonitoredCells $singleton
        viewer::view $singleton [thresholds::activeCells]
    }

    proc reset {this} {
        forgetAllMonitoredCells $this
    }

}





class page {

    proc page {this parentPath args} composite {[new frame $parentPath] $args} viewer {} {
        set book [pages::book]
        set first [expr {[llength [$book pages]] == 0}]
        set ($this,page) [$book insert end $this -raisecmd "page::raised $this"]
        set ($this,book) $book
        set ($this,canvas) $pages::(canvas)
        set ($this,drop) [new dropSite            -path $book -regioncommand "page::dropRegion $this" -formats [list HANDLES CANVASVIEWER MINIMIZED]            -command "pages::transfer $this"        ]
        composite::complete $this
        composite::configure $this -deletecommand "pages::deleted $this"
        if {$first} {
            $book raise $this
            pages::monitorActiveCells
        }
    }

    proc ~page {this} {
        variable index
        variable ${this}monitored

        if {[info exists ($this,image)]} {
            images::release $($this,imageFile)
            $global::canvas delete $($this,image)
        }
        unset index($this)
        catch {unset ${this}monitored}
        delete $($this,drop)
        if {[info exists ($this,thresholds)]} {delete $($this,thresholds)}
        if {[info exists ($this,sequencer)]} {delete $($this,sequencer)}
        if {[info exists ($this,tip)]} {delete $($this,tip)}
        $($this,book) delete $this
        if {[string length $composite::($this,-deletecommand)] > 0} {
            uplevel #0 $composite::($this,-deletecommand)
        }
    }

    proc options {this} {
        return [list            [list -background $widget::option(canvas,background) $widget::option(canvas,background)]            [list -deletecommand {} {}]            [list -draggable 0 0]            [list -imagefile {} {}]            [list -imageposition nw]            [list -index {}]            [list -label {}]            [list -raised 0 0]        ]
    }

    proc set-background {this value} {
        if {[string equal [$($this,book) raise] $this]} {
            $global::canvas configure -background $value
        }
    }

    proc set-deletecommand {this value} {}

    proc set-draggable {this value} {}

    proc set-imagefile {this value} {
        set canvas $global::canvas
        if {[info exists ($this,image)]} {
            images::release $($this,imageFile)
        }
        if {[string length $value] == 0} {
            if {[info exists ($this,image)]} {
                $canvas delete $($this,image)
                unset ($this,image) ($this,imageFile)
            }
            return
        }
        if {[package vcompare $::tcl_version 8.4] < 0} {
            if {[string length $value] > 0} {set value [file join [pwd] $value]}
        } else {
            set value [file normalize $value]
        }
        set ($this,imageFile) $value
        images::load $value $value {}
        set image [images::use $value]
        if {[info exists ($this,image)]} {
            $canvas itemconfigure $($this,image) -image $image
        } else {
            set ($this,image) [$canvas create image 0 0 -image $image]
        }
        $canvas lower $($this,image)
        updateImagePosition $this
    }

    proc set-imageposition {this value} {
        updateImagePosition $this
    }

    proc set-index {this value} {
        variable index

        if {$composite::($this,complete)} {
            error {option -index cannot be set dynamically}
        }
        if {[string length $value] == 0} {
            foreach {page value} [array get index] {set taken($value) {}}
            set value 0; while {[info exists taken($value)]} {incr value}
        }
        set index($this) $value
        set ($this,left) [expr {$value * $global::pagesWidth}]
        updateImagePosition $this
    }

    proc set-label {this value} {
        $($this,book) itemconfigure $this -text $value
    }

    proc set-raised {this value} {}

    proc raised {this} {
        if {![info exists global::scroll]} return
        set x [lindex [$global::canvas xview] 0]
        pages::updateScrollRegion $global::canvas $($this,left)
        pack $widget::($global::scroll,path) -in $($this,page) -fill both -expand 1
        ::update idletasks
        $global::canvas xview moveto $x
        $global::canvas configure -background $composite::($this,-background)
    }

    proc editLabel {this} {
        set book $($this,book)
        foreach {x top right bottom} [$($this,canvas) bbox $this:text] {}
        set y [expr {($top + $bottom) / 2}]
        set entry [entry .pageLabel            -borderwidth 0 -highlightthickness 0 -width 0 -font [$book cget -font]            -validate key -validatecommand "$book itemconfigure $this -text %P; list 1"        ]
        lifoLabel::push $global::messenger [mc {enter page tab label (Return to valid, Escape to abort)}]
        foreach key {<KP_Enter> <Return>} {
            bind $entry $key "composite::configure $this -label \[%W get\]; destroy %W; lifoLabel::pop $global::messenger"
        }
        bind $entry <Escape>            "page::set-label $this [list $composite::($this,-label)]; destroy %W; lifoLabel::pop $global::messenger"
        $entry insert 0 $composite::($this,-label)
        $entry selection range 0 end
        place $entry -in $($this,canvas) -anchor w -x $x -y $y
        focus $entry
        ::update idletasks
        grab $entry
    }

    proc dropRegion {this} {
        foreach {left top right bottom} [$($this,canvas) bbox $this:text] {}
        set X [winfo rootx $($this,canvas)]; set Y [winfo rooty $($this,canvas)]
        return [list [incr left $X] [incr top $Y] [incr right $X] [incr bottom $Y]]
    }

    proc supportedTypes {this} {
        return [thresholds::supportedTypes 0]
    }

    proc monitorCell {this array row column} {
        variable ${this}monitored

        set cell ${array}($row,$column)
        set ${this}monitored($cell) {}
    }

    proc forgetAllMonitoredCells {this} {
        variable ${this}monitored

        catch {unset ${this}monitored}
        if {[info exists ($this,thresholds)]} {delete $($this,thresholds); unset ($this,thresholds)}
        if {[info exists ($this,sequencer)]} {delete $($this,sequencer); unset ($this,sequencer)}
        if {[info exists ($this,tip)]} {switched::configure $($this,tip) -text {}}
        $($this,book) itemconfigure $this -background {}
    }

    proc update {this array} {}

    proc cells {this} {
        variable ${this}monitored

        return [lsort -dictionary [array names ${this}monitored]]
    }

    proc initializationConfiguration {this} {
        variable index

        return [list            -background $composite::($this,-background) -index $index($this) -label $composite::($this,-label)            -raised [string equal [$($this,book) raise] $this]            -imagefile $composite::($this,-imagefile) -imageposition $composite::($this,-imageposition)        ]
    }

    proc thresholdCondition {this array row column color level summary} {
        variable ${this}monitored

        set cell ${array}($row,$column)
        if {![info exists ${this}monitored($cell)]} return
        if {![info exists ($this,thresholds)]} {
            set ($this,thresholds) [new thresholdsManager]
        }
        thresholdsManager::condition $($this,thresholds) $cell $color $level $summary
        foreach {colors summaries} [thresholdsManager::colorsAndTexts $($this,thresholds)] {}
        if {[info exists ($this,sequencer)]} {delete $($this,sequencer); unset ($this,sequencer)}
        if {[llength $colors] == 0} {
            $($this,book) itemconfigure $this -background {}
        } elseif {[llength $colors] == 1} {
            $($this,book) itemconfigure $this -background [lindex $colors 0]
        } else {
            set ($this,sequencer) [new sequencer 1000 %c $colors "$($this,book) itemconfigure $this -background %c"]
            sequencer::start $($this,sequencer)
        }
        if {[llength $summaries] == 0} {
            if {[info exists ($this,tip)]} {switched::configure $($this,tip) -text {}}
        } else {
            if {![info exists ($this,tip)]} {
                set ($this,tip) [new widgetTip -path $($this,canvas) -itemortag p:$this]
            }
            set text {}
            set number 0
            foreach summary $summaries {
                if {$number < 3} {
                    if {$number > 0} {append text \n}
                    append text $summary
                }
                incr number
            }
            if {$number > 3} {append text \n...}
            switched::configure $($this,tip) -text $text
        }
    }

    proc manageable {this} {return 0}

    proc monitored {this cell} {
        variable ${this}monitored

        return [info exists ${this}monitored($cell)]
    }

    proc updateImagePosition {this} {
        if {![info exists ($this,image)] || ![info exists ($this,left)]} return
        updateCanvasImagePosition $($this,image) $composite::($this,-imageposition) $($this,left)
    }

}


class pages {

    proc pages {this} error

    proc manageScrolledCanvas {show} {
        if {$show} {
            if {[llength [grid info $(book)]] == 0} {
                grid $(book) -row 2 -column 0 -sticky nsew
                raise $widget::($global::scroll,path) $(book)
            }
            foreach page [$(book) pages] {
                if {[composite::cget $page -raised]} {
                    $(book) raise $page
                    break
                }
            }
        } else {
            grid forget $(book)
        }
    }

    proc deleted {page} {
        if {[llength [$(book) pages]] == 0} {
            ::delete $(drag)
            manageScrolledCanvas 0
            destroy $(book)
            unset (book) (canvas) (drag)
            canvasWindowManager::moveAll $global::windowManager $global::pagesWidth
            canvas::viewer::moveAll $global::pagesWidth
            updateScrollRegion $global::canvas 0
            $global::canvas configure -background $global::canvasBackground
            ::manageScrolledCanvas 1
        } else {
            $(book) raise [$(book) pages 0]
        }
    }

    proc closestPageTopLeftCorner {x} {
        return [list [expr {round(double($x) / $global::pagesWidth) * $global::pagesWidth}] 0]
    }

    proc dragData {format} {
        set page [$(book) raise]
        if {[string length $page] == 0} {return {}}
        if {([llength [$(book) pages]] <= 1) || [currentPageEmpty $global::canvas $page]} {
            return $page
        } else {
            lifoLabel::flash $global::messenger [mc {a page must be empty to be deleted}]
            bell
            return {}
        }
    }

    proc validateDrag {x y} {
        foreach page [$(book) pages] {
            if {![composite::cget $page -draggable]} continue
            foreach {left top right bottom} [$(canvas) bbox p:$page] {}
            if {($x > $left) && ($x < $right) && ($y > $top) && ($y < $bottom)} {return 1}
        }
        return 0
    }

    proc labelsSide {value} {
        if {![info exists (book)]} return
        $(book) configure -side $value
    }

    proc transfer {targetPage} {
        if {[info exists dragSite::data(CANVASVIEWER)]} {
            composite::configure $dragSite::data(CANVASVIEWER) -x $page::($targetPage,left) -y 0
        } elseif {[info exists dragSite::data(MINIMIZED)]} {
            canvasWindowManager::moveIconToPage $dragSite::data(MINIMIZED) $page::($targetPage,left) 0
        } else {
            canvasWindowManager::moveHandlesToPage $dragSite::data(HANDLES) $page::($targetPage,left) 0
        }
        monitorActiveCells
    }

    proc book {} {
        if {![info exists (book)]} {
            set (book) [NoteBook .book                -background $viewer::(background) -borderwidth 1 -internalborderwidth 0 -font $font::(mediumNormal)                -side $global::pagesTabPosition            ]
            $(book) bindtabs <Double-ButtonPress-1> page::editLabel
            $(book) bindtabs <ButtonPress-3> page::editLabel
            set (canvas) $(book).c
            set (drag) [::new dragSite -path $(canvas) -validcommand pages::validateDrag]
            dragSite::provide $(drag) OBJECTS pages::dragData
        }
        return $(book)
    }

    proc edit {page} {
        $(book) see $page
        ::update idletasks
        after idle "page::editLabel $page"
    }

    proc tagOrItemPage {value} {
        if {![info exists (book)]} {return {}}
        foreach {left top right bottom} [$global::canvas bbox $value] {}
        foreach page [$(book) pages] {
            set x [expr {$right - $page::($page,left)}]
            if {($x >= 0) && ($x < $global::pagesWidth)} {
                return $page
            }
        }
        return {}
    }

    proc cellsWithActiveThreshold {pageCellsName} {
        upvar 1 $pageCellsName pageCells

        foreach cell [thresholds::activeCells] {
            foreach viewer [viewer::monitoring $cell] {
                set page [canvasWindowManager::viewerPage $::global::windowManager $viewer]
                if {[string length $page] == 0} {
                    set page [canvas::viewer::page $viewer]
                }
                if {[string length $page] == 0} continue
                set ${page}($cell) {}
            }
            foreach table [dataTable::monitoring $cell] {
                set page [canvasWindowManager::viewerPage $::global::windowManager $table]
                if {[string length $page] == 0} continue
                set ${page}($cell) {}
            }
        }
        foreach page [info locals] {
            if {![string is integer -strict $page]} continue
            set pageCells($page) [array names $page]
        }
    }

    proc monitorActiveCells {} {
        if {![info exists (book)]} return
        foreach page [$(book) pages] {
            page::forgetAllMonitoredCells $page
        }
        cellsWithActiveThreshold data
        foreach {page cells} [array get data] {
            viewer::view $page $cells
        }
    }

    proc updateScrollRegion {canvas {pageLeft {}}} {
        if {[string length $pageLeft] == 0} {
            set pageLeft [lindex [$canvas cget -scrollregion] 0]
        }
        if {[info exists (book)]} {
            foreach page [$(book) pages] {
                lappend lefts $page::($page,left)
            }
        } else {
            set lefts 0
        }
        set width 0; set height 0
        foreach from $lefts {
            set to [expr {$from + ($global::pagesWidth / 2)}]
            set items [list]
            foreach item [$canvas find all] {
                if {[llength [set list [$canvas bbox $item]]] == 0} continue
                foreach {left top right bottom} $list {}
                if {($right >= $from) && ($left <= $to)} {
                    lappend items $item
                }
            }
            if {[llength $items] == 0} continue
            foreach {left top right bottom} [eval $canvas bbox $items] {}
            set width [maximum $width [expr {$right - $from}]]
            set height [maximum $height $bottom]
        }
        if {($global::canvasWidth > 0) && ($global::canvasHeight > 0)} {
            set width [maximum $width $global::canvasWidth]
            set height [maximum $height $global::canvasHeight]
        }
        $canvas configure -scrollregion [list $pageLeft 0 [expr {$pageLeft + $width}] $height]
    }

    proc currentPageEmpty {canvas page} {
        set from [lindex [$canvas cget -scrollregion] 0]
        set to [expr {$from + ($global::pagesWidth / 2)}]
        foreach item [$canvas find all] {
            if {[llength [set list [$canvas bbox $item]]] == 0} continue
            foreach {left top right bottom} $list {}
            if {[info exists page::($page,image)] && ($item == $page::($page,image))} continue
            if {($right >= $from) && ($left <= $to)} {
                return 0
            }
        }
        return 1
    }

    proc data {} {
        set list {}
        if {[info exists (book)]} {
            foreach page [$(book) pages] {
                lappend list $page [composite::cget $page -label] [string equal [$(book) raise] $page]
            }
        }
        return $list
    }

    proc updateImagesPositions {} {
        if {![info exists (book)]} return
        foreach page [$(book) pages] {page::updateImagePosition $page}
    }

    proc current {} {
        if {[info exists (book)]} {
            return [$(book) raise]
        } else {
            return 0
        }
    }

}




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 database {


    proc displayAndSelectInstances {} {
        if {[info exists (dialog)]} {
            raise $widget::($dialog::($(dialog),dialog),path)
        } else {
            set (dialog) [new dialog .]
            dialog::deleteCommand $(dialog) {unset database::(dialog)}
        }
    }

    proc removeInstances {} {
        if {![info exists (dialog)]} return
        delete $dialog::($(dialog),dialog)
    }

    proc displayAndSelectRange {} {
        if {[info exists (range)]} {
            raise $widget::($rangeDialog::($(range),dialog),path)
        } else {
            set (range) [new rangeDialog . {unset database::(range)}]
        }
    }

    proc setRange {from to} {
        if {[info exists (range)]} {
            rangeDialog::update $(range) $from $to
        }
    }

    class dialog {

        proc dialog {this parentPath args} switched {$args} {
            set dialog [new dialogBox .                -buttons hoc -default o -title [mc {moodss: Database instances}] -otherbuttons SQL                -helpcommand {generalHelpWindow #menus.file.database.load} -x [winfo pointerx .] -y [winfo pointery .]                -grab release -command "database::dialog::validated $this" -deletecommand "delete $this"            ]
            wm geometry $widget::($dialog,path) 500x400
            composite::configure $dialog ok -state disabled
            lappend ($this,tips) [linkedHelpWidgetTip $composite::($dialog,help,path)]                [new widgetTip -path $composite::($dialog,SQL,path)                     -text [mc {toggles the display of the SQL query that can be used to retrieve the data cell history}]                ]
            set frame [frame $widget::($dialog,path).frame]
            set scroll [new scroll tree $frame]
            set tree $composite::($scroll,scrolled,path)
            $tree bindText <Control-Button-1> {}; $tree bindImage <Control-Button-1> {}
            $tree configure                -dragenabled 0 -dropenabled 0 -deltay [expr {[font metrics $font::(mediumNormal) -linespace] + 4}]                -background $widget::option(listbox,background) -selectbackground $widget::option(listbox,selectbackground)                -closecmd "database::dialog::stateChange $this 0" -opencmd "database::dialog::stateChange $this 1"                -linestipple gray50 -crossopenimage $configuration::minusIcon -crosscloseimage $configuration::plusIcon                -selectcommand "database::dialog::processEvent $this"
            set treeScrollPath $widget::($scroll,path)
            grid $treeScrollPath -row 0 -sticky nsew
            grid rowconfigure $frame 0 -weight 1
            lappend ($this,objects) $scroll

            set range [frame $frame.range]
            set label [label $range.fromLabel -font $font::(mediumBold) -text [mc from:]]
            grid $label -row 0 -column 0 -sticky w
            set ($this,from) [label $range.from -font $font::(mediumNormal)]
            grid $($this,from) -row 0 -column 1 -sticky w -padx 2
            set label [label $range.toLabel -font $font::(mediumBold) -text [mc to:]]
            grid $label -row 1 -column 0 -sticky w
            set ($this,to) [label $range.to -font $font::(mediumNormal)]
            grid $($this,to) -row 1 -column 1 -sticky w -padx 2
            lappend ($this,tips) [new widgetTip -path $range -text [mc {selected item database time range}]]
            grid columnconfigure $range 1 -weight 1
            grid $range -row 1 -sticky ew

            grid columnconfigure $frame 0 -weight 1

            set scroll [new scroll text $frame -vertical 0]
            set query $composite::($scroll,scrolled,path)
            $query configure -background white -height 4 -state disabled -wrap none -font $font::(mediumNormal)
            $query tag configure italic -font $font::(mediumItalic)
            composite::configure $scroll                -height [expr {[winfo reqheight $query] + [winfo reqheight $composite::($scroll,horizontal,path)]}]
            lappend ($this,objects) $scroll
            composite::configure $dialog SQL                -command "database::dialog::toggleSQLDisplay $this $widget::($scroll,path) $treeScrollPath"
            set ($this,scrollPath) $widget::($scroll,path)

            set canvas [$tree getcanvas]
            set ($this,drag) [new dragSite -path $canvas -validcommand "database::dialog::validateDrag $this"]
            dragSite::provide $($this,drag) INSTANCES "database::dialog::dragData $this"

            dialogBox::display $dialog $frame
            set ($this,tree) $tree
            set ($this,query) $query
            set ($this,dialog) $dialog
            set ($this,deleteCommand) {}
            set ($this,nodeTips) {}
            switched::complete $this
            refresh $this
        }

        proc ~dialog {this} {
            eval delete $($this,nodeTips) $($this,objects) $($this,tips) $($this,drag)
            if {[string length $($this,deleteCommand)] > 0} {
                uplevel #0 $($this,deleteCommand)
            }
            if {[string length $switched::($this,-deletecommand)] > 0} {
                uplevel #0 $switched::($this,-deletecommand)
            }
        }

        proc options {this} {
            return [list                [list -command {} {}]                [list -deletecommand {} {}]            ]
        }

        proc set-command {this value} {}
        proc set-deletecommand {this value} {}

        proc deleteCommand {this command} {
            set ($this,deleteCommand) $command
        }

        proc refresh {this} {
            lifoLabel::push $global::messenger [mc {retrieving module instances from database...}]
            busy 1 [list . $widget::($($this,dialog),path)]
            set database $global::database
            set tree $($this,tree)
            set canvas [$tree getcanvas]
            $tree delete [$tree nodes root]
            array unset {} $this,*Data,*
            eval delete $($this,nodeTips)
            set data(modules) {}
            foreach module [database::modules $database] {
                set data(instances,$module) {}
                foreach instance [database::instances $database $module] {
                    set data(identifier,$instance) [database::identifier $database $instance]
                    if {[string length $database::($database,error)] > 0} break
                    set data(arguments,$instance) [database::arguments $database $instance]
                    if {[string length $database::($database,error)] > 0} break
                    set data(version,$instance) [database::version $database $instance]
                    if {[string length $database::($database,error)] > 0} break
                    set data(cellsData,$instance) [database::cellsData $database $instance]
                    if {[string length $database::($database,error)] > 0} break
                    lappend data(instances,$module) $instance
                }
                if {[string length $database::($database,error)] > 0} break
                lappend data(modules) $module
            }
            if {[string length $database::($database,error)] > 0} {
                set data(modules) {}
            }
            foreach module $data(modules) {
                set node [$tree insert end root #auto -font $font::(mediumBold) -text $module -image $configuration::closedIcon]
                set ($this,moduleData,$node) $module
            }
            foreach node [$tree nodes root] {
                set module [$tree itemcget $node -text]
                foreach instance $data(instances,$module) {
                    set arguments $data(arguments,$instance)
                    set noOption [expr {[string length $arguments] == 0}]
                    if {$noOption} {
                        set arguments {without options}
                    } else {
                        set string {}
                        foreach {option value} $arguments {
                            if {[string length $string] > 0} {append string { }}
                            append string $option
                            if {[string length $value] > 0} {
                                append string { } $value
                            }
                        }
                        set arguments $string
                    }
                    set new [$tree insert end $node #auto -data $instance -text $arguments -image $configuration::closedIcon]
                    if {$noOption} {
                        $tree itemconfigure $new -font $font::(mediumItalic)
                    } else {
                        $tree itemconfigure $new -font $font::(mediumNormal)
                    }
                    set ($this,instanceData,$new) [list $instance $module $data(identifier,$instance) $arguments]
                    lappend ($this,nodeTips) [new widgetTip -path $canvas -itemortag n:$new                        -text [format [mc {instance of module %1$s version %2$s}] $module $data(version,$instance)]                    ]
                }
            }
            foreach node [$tree nodes root] {
                foreach node [$tree nodes $node] {
                    set instance [$tree itemcget $node -data]
                    foreach {row entry label comment} $data(cellsData,$instance) {
                        if {[string length $comment] > 0} {
                            append label " ($comment)"
                        }
                        regsub -all {\n} $label { } label
                        set new [$tree insert end $node #auto                            -data $row,$entry -text $label -font $font::(mediumNormal) -image $configuration::leafIcon                        ]
                        set ($this,cellData,$new) [list $instance $row $entry]
                    }
                }
            }
            busy 0 [list . $widget::($($this,dialog),path)]
            lifoLabel::pop $global::messenger
        }

        proc updateQuery {this instance row entry start end} {
            set query $($this,query)
            $query configure -state normal
            $query delete 1.0 end
            foreach {start optional end} [database::historyQuery $global::database $instance $row $entry $start $end] {}
            $query insert end $start
            if {[string length $optional] > 0} {
                $query insert end \n$optional
                $query tag add italic 3.0 3.end
            }
            $query insert end \n$end
            $query configure -state disabled
        }

        proc clearQuery {this} {
            set query $($this,query)
            $query configure -state normal
            $query delete 1.0 end
            $query configure -state disabled
        }

        proc toggleSQLDisplay {this queryScrollPath treeScrollPath} {
            if {[llength [grid info $queryScrollPath]] == 0} {
                grid $queryScrollPath -row 2 -sticky ew
                set node [$($this,tree) selection get]
                if {[info exists ($this,cellData,$node)]} {
                    foreach {instance row entry} $($this,cellData,$node) {}
                    set start {}; set end {}
                    foreach {start end} [cellRange $this $instance $row $entry] {}
                    updateQuery $this $instance $row $entry $start $end
                }
            } else {
                grid forget $queryScrollPath
                clearQuery $this
            }
        }

        proc validateDrag {this x y} {
            return [info exists ($this,instanceData)]
        }

        proc dragData {this format} {
            return [list $($this,instanceData)]
        }

        proc validated {this} {
            if {[string length $switched::($this,-command)] == 0} return
            wm withdraw $widget::($($this,dialog),path)
            update
            uplevel #0 $switched::($this,-command) [list $($this,instanceData)]
        }

        proc processEvent {this tree node} {
            set start {}; set end {}
            composite::configure $($this,dialog) ok -state disabled
            catch {unset ($this,instanceData)}
            if {![catch {set data $($this,moduleData,$node)}]} {
                foreach {start end} [moduleRange $this $data] {}
            }
            if {![catch {set data $($this,cellData,$node)}]} {
                foreach {instance row entry} $data {}
                foreach {start end} [cellRange $this $instance $row $entry] {}
                if {[llength [grid info $($this,scrollPath)]] > 0} {
                    updateQuery $this $instance $row $entry $start $end
                }
            } else {
                clearQuery $this
            }
            if {![catch {set data $($this,instanceData,$node)}] && ([llength [$tree nodes $node]] > 0)} {
                foreach {start end} [instanceRange $this [lindex $data 0]] {}
                set ($this,instanceData) $data
                composite::configure $($this,dialog) ok -state normal
            }
            $($this,from) configure -text $start; $($this,to) configure -text $end
        }

        proc moduleRange {this module} {
            if {[info exists ($this,moduleRange,$module)]} {
                return $($this,moduleRange,$module)
            } else {
                return [set ($this,moduleRange,$module)                    [database::moduleRange $global::database $module [list . $widget::($($this,dialog),path)]]                ]
            }
        }

        proc instanceRange {this instance} {
            if {[info exists ($this,instanceRange,$instance)]} {
                return $($this,instanceRange,$instance)
            } else {
                return [set ($this,instanceRange,$instance)                    [database::instanceRange $global::database $instance [list . $widget::($($this,dialog),path)]]                ]
            }
        }

        proc cellRange {this instance row entry} {
            if {[info exists ($this,cellRange,$instance,$row,$entry)]} {
                return $($this,cellRange,$instance,$row,$entry)
            } else {
                return [set ($this,cellRange,$instance,$row,$entry)                    [database::cellRange $global::database $instance $row $entry {} {} [list . $widget::($($this,dialog),path)]]                ]
            }
        }

        proc stateChange {this opened node} {
            if {$opened} {
                $($this,tree) itemconfigure $node -image $configuration::openedIcon
            } else {
                $($this,tree) itemconfigure $node -image $configuration::closedIcon
            }
        }

    }

    class rangeDialog {

        proc rangeDialog {this parentPath {deleteCommand {}}} {
            variable singleton

            if {[info exists singleton]} {
                error {only 1 database range dialog object can exist}
            }
            set singleton $this
            set dialog [new dialogBox $parentPath                -buttons hoc -default o -title [mc {moodss: Database history range}] -x [winfo pointerx .] -y [winfo pointery .]                -helpcommand {generalHelpWindow #menus.view.database.range} -deletecommand "delete $this" -grab release                -command "database::rangeDialog::apply $this 1" -die 0 -otherbuttons apply            ]
            composite::configure $dialog apply -text [mc Apply] -command "database::rangeDialog::apply $this 0"
            set ($this,tip) [linkedHelpWidgetTip $composite::($dialog,help,path)]
            set frame [frame $widget::($dialog,path).frame]
            set message [message $frame.message                -width [winfo screenwidth .] -font $font::(mediumNormal) -justify center                -text [mc {Select history range for database views:}]
            ]
            pack $message -pady 5

            set from [frame $frame.from]
            pack $from -fill x -expand 1 -pady 2
            pack [label $from.label -text [mc from:]] -side left -padx 2
            set input [new input $from]
            set ($this,from) $input
            pack $widget::($input,path) -side right
            set to [frame $frame.to]
            pack $to -fill x -expand 1 -pady 2
            pack [label $to.label -text [mc to:]] -side left -padx 2
            set input [new input $to]
            set ($this,to) $input
            pack $widget::($input,path) -side right
            composite::configure $($this,from) -command "database::rangeDialog::updated $this from"
            composite::configure $($this,to) -command "database::rangeDialog::updated $this to"

            if {[info exists databaseInstances::singleton]} {
                foreach {minimum maximum} [databaseInstances::limits $databaseInstances::singleton] {}
                composite::configure $($this,from) -minimum $minimum -maximum $maximum
                composite::configure $($this,to) -minimum $minimum -maximum $maximum
                foreach {minimum maximum} [databaseInstances::cursorsRange] {}
                input::set $($this,from) $minimum
                input::set $($this,to) $maximum
            }

            set ($this,deleteCommand) $deleteCommand
            set ($this,dialog) $dialog
            dialogBox::display $dialog $frame
        }

        proc ~rangeDialog {this} {
            variable singleton

            delete $($this,tip) $($this,from) $($this,to)
            if {[string length $($this,deleteCommand)] > 0} {
                uplevel #0 $($this,deleteCommand)
            }
            unset singleton
        }

        proc apply {this close} {
            if {![info exists databaseInstances::singleton]} return
            set from [input::get $($this,from)]
            set to [input::get $($this,to)]
            if {($from < 0) || ($to < 0)} {
                bell
                return
            }
            databaseInstances::setCursors $databaseInstances::singleton $from $to
            if {$close} {
                delete $($this,dialog)
            }
            after idle ::refresh
        }

        proc updated {this side seconds} {
            if {[string equal $side from]} {
                set value [input::get $($this,to)]
                if {($value >= 0) && ($seconds > $value)} {
                    input::set $($this,to) $seconds
                }
            } else {
                set value [input::get $($this,from)]
                if {($value >= 0) && ($seconds < $value)} {
                    input::set $($this,from) $seconds
                }
            }
            databaseInstances::setCursors $databaseInstances::singleton [input::get $($this,from)] [input::get $($this,to)]
        }

        proc update {this from to} {
            input::set $($this,from) $from
            input::set $($this,to) $to
        }

        class input {

            variable hours
            for {::set value 0} {$value < 24} {incr value} {
                lappend hours [format %02u $value]
            }
            variable sixties
            for {::set value 0} {$value < 60} {incr value} {
                lappend sixties [format %02u $value]
            }
            unset value
            variable minimum 0
            variable maximum [clock scan 2029-12-31]

            proc input {this parentPath args} composite {[new frame $parentPath] $args} {
                variable days
                variable daysWidth
                variable months
                variable monthsWidth
                variable hours
                variable sixties
                variable maximumYear
                variable minimum
                variable maximum

                if {![info exists days]} {
                    ::set days [mc {Sunday Monday Tuesday Wednesday Thursday Friday Saturday}]
                    ::set daysWidth 0
                    foreach value $days {
                        ::set value [string length $value]
                        if {$value > $daysWidth} {::set daysWidth $value}
                    }
                }
                if {![info exists months]} {
                    ::set months [mc {January February March April May June July August September October November December}]
                    ::set monthsWidth 0
                    foreach value $months {
                        ::set value [string length $value]
                        if {$value > $monthsWidth} {::set monthsWidth $value}
                    }
                }
                ::set path $widget::($this,path)
                ::set delay 200
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    composite::manage $this                        [new spinEntry $path                            -font $font::(mediumBold) -width $daysWidth -list $days -justify right -editable 0 -wrap 1                            -repeatdelay $delay -command "database::rangeDialog::input::increment $this %d 86400"                        ] dayOfWeek                        [new spinEntry $path                            -font $font::(mediumBold) -width 2 -range {1 31 1} -justify right -editable 0 -wrap 1                            -repeatdelay $delay -command "database::rangeDialog::input::increment $this %d 86400"                        ] day                        [new spinEntry $path                            -font $font::(mediumBold) -width $monthsWidth -list $months -justify right -editable 0 -wrap 1                            -repeatdelay $delay -command "database::rangeDialog::input::setMonth $this %d"                        ] month                        [new spinEntry $path                            -font $font::(mediumBold) -width 4 -justify right -editable 0                            -range [list [clock format $minimum -format %Y] [clock format $maximum -format %Y] 1]                            -repeatdelay $delay -command "database::rangeDialog::input::setYear $this %d"                        ] year                        [new frame $path -width 10] separator1                        [new spinEntry $path                            -font $font::(mediumBold) -width 2 -list $hours -justify right -wrap 1                            -repeatdelay $delay -command "database::rangeDialog::input::increment $this %d 3600"                        ] hours                        [new label $path -font $font::(mediumBold) -text :] separator2                        [new spinEntry $path                            -font $font::(mediumBold) -width 2 -list $sixties -justify right -wrap 1                            -repeatdelay $delay -command "database::rangeDialog::input::increment $this %d 60"                        ] minutes                        [new label $path -font $font::(mediumBold) -text :] separator3                        [new spinEntry $path                            -font $font::(mediumBold) -width 2 -list $sixties -justify right -wrap 1                            -repeatdelay $delay -command "database::rangeDialog::input::increment $this %d 1"                        ] seconds
                    foreach entry {hours minutes seconds} {
                        setupEntryValidation $composite::($composite::($this,$entry),entry,path) {{check31BitUnsignedInteger %P}}
                    }
                } else {
                    composite::manage $this                        [new spinbox $path                            -font $font::(mediumBold) -width $daysWidth -values $days -justify right -state readonly -wrap 1                            -repeatinterval $delay -command "database::rangeDialog::input::increment $this %d 86400 %s"                        ] dayOfWeek                        [new spinbox $path                            -font $font::(mediumBold) -width 2 -from 1 -to 31 -increment 1 -justify right -state readonly -wrap 1                            -repeatinterval $delay -command "database::rangeDialog::input::increment $this %d 86400 %s"                        ] day                        [new spinbox $path                            -font $font::(mediumBold) -width $monthsWidth -values $months -justify right -state readonly -wrap 1                            -repeatinterval $delay -command "database::rangeDialog::input::setMonth $this %d %s"                        ] month                        [new spinbox $path                            -font $font::(mediumBold) -width 4 -justify right -state readonly                            -from [clock format $minimum -format %Y] -to [clock format $maximum -format %Y] -increment 1                            -repeatinterval $delay -command "database::rangeDialog::input::setYear $this %d %s"                        ] year                        [new frame $path -width 10] separator1                        [new spinbox $path                            -font $font::(mediumBold) -width 2 -values $hours -justify right -wrap 1                            -repeatinterval $delay -command "database::rangeDialog::input::increment $this %d 3600 %s"                        ] hours                        [new label $path -font $font::(mediumBold) -text :] separator2                        [new spinbox $path                            -font $font::(mediumBold) -width 2 -values $sixties -justify right -wrap 1                            -repeatinterval $delay -command "database::rangeDialog::input::increment $this %d 60 %s"                        ] minutes                        [new label $path -font $font::(mediumBold) -text :] separator3                        [new spinbox $path                            -font $font::(mediumBold) -width 2 -values $sixties -justify right -wrap 1                            -repeatinterval $delay -command "database::rangeDialog::input::increment $this %d 1 %s"                        ] seconds
                    foreach entry {hours minutes seconds} {
                        setupEntryValidation $composite::($this,$entry,path) {{check31BitUnsignedInteger %P}}
                    }
                }
                pack $composite::($this,dayOfWeek,path) $composite::($this,day,path) $composite::($this,month,path)                    $composite::($this,year,path) $composite::($this,separator1,path) $composite::($this,hours,path)                    $composite::($this,separator2,path) $composite::($this,minutes,path) $composite::($this,separator3,path)                    $composite::($this,seconds,path) -side left
                composite::complete $this
                set $this $minimum
            }

            proc ~input {this} {}

            proc options {this} {
                variable minimum
                variable maximum

                return [list                    [list -command {} {}]                    [list -maximum $maximum $maximum]                    [list -minimum $minimum $minimum]                ]
            }

            proc set-command {this value} {}

            proc set-maximum {this value} {}
            proc set-minimum {this value} {}

            proc get {this} {
                variable months

                if {[package vcompare $::tcl_version 8.4] < 0} {
                    ::set day [spinEntry::get $composite::($this,day)]
                    ::set month [expr {[lsearch -exact $months [spinEntry::get $composite::($this,month)]] + 1}]
                    ::set year [spinEntry::get $composite::($this,year)]
                    ::set hours [spinEntry::get $composite::($this,hours)]
                    ::set minutes [spinEntry::get $composite::($this,minutes)]
                    ::set seconds [spinEntry::get $composite::($this,seconds)]
                } else {
                    ::set day [$composite::($this,day,path) get]
                    ::set month [expr {[lsearch -exact $months [$composite::($this,month,path) get]] + 1}]
                    ::set year [$composite::($this,year,path) get]
                    ::set hours [$composite::($this,hours,path) get]
                    ::set minutes [$composite::($this,minutes,path) get]
                    ::set seconds [$composite::($this,seconds,path) get]
                }
                if {[catch {::set value [clock scan "$year-$month-$day $hours:$minutes:$seconds"]}]} {
                    if {[catch {clock scan "$hours:00:00"}]} {
                        ::set entry hours
                    } elseif {[catch {clock scan "$hours:$minutes:00"}]} {
                        ::set entry minutes
                    } else {
                        ::set entry seconds
                    }
                    if {[package vcompare $::tcl_version 8.4] < 0} {
                        focus $composite::($composite::($this,$entry),entry,path)
                    } else {
                        focus $composite::($this,$entry,path)
                    }
                    return -1
                }
                return $value
            }

            proc set {this value} {
                variable days
                variable months
                variable minimum
                variable maximum

                if {$value < $minimum} {
                    ::set value $minimum
                } elseif {$value > $maximum} {
                    ::set value $maximum
                }
                foreach {dayOfWeek day month year hours minutes seconds} [clock format $value -format {%w %e %m %Y %H %M %S}] {}
                ::set dayOfWeek [lindex $days $dayOfWeek]
                ::set month [string trimleft $month 0]
                ::set month [lindex $months [expr {$month - 1}]]
                if {[package vcompare $::tcl_version 8.4] < 0} {
                    spinEntry::set $composite::($this,dayOfWeek) $dayOfWeek
                    spinEntry::set $composite::($this,day) $day
                    spinEntry::set $composite::($this,month) $month
                    spinEntry::set $composite::($this,year) $year
                    spinEntry::set $composite::($this,hours) $hours
                    spinEntry::set $composite::($this,minutes) $minutes
                    spinEntry::set $composite::($this,seconds) $seconds
                } else {
                    $composite::($this,dayOfWeek,path) set $dayOfWeek
                    $composite::($this,day,path) set $day
                    $composite::($this,month,path) set $month
                    $composite::($this,year,path) set $year
                    $composite::($this,hours,path) set $hours
                    $composite::($this,minutes,path) set $minutes
                    $composite::($this,seconds,path) set $seconds
                }
                ::set ($this,seconds) $value
                if {[string length $composite::($this,-command)] > 0} {
                    uplevel #0 $composite::($this,-command) $value
                }
            }

            proc increment {this direction value ignore} {
                switch $direction {
                    down {set $this [expr {$($this,seconds) - $value}]}
                    up {set $this [expr {$($this,seconds) + $value}]}
                }
            }

            proc setMonth {this direction ignore} {
                foreach {day month year time} [clock format $($this,seconds) -format {%e %m %Y %T}] {}
                ::set month [string trimleft $month 0]
                switch $direction {
                    down {incr month -1}
                    up {incr month}
                    default return
                }
                if {$month <= 0} {
                    incr year -1
                    ::set month 12
                } elseif {$month > 12} {
                    incr year
                    ::set month 1
                }
                while {[catch {::set seconds [clock scan "$year-$month-$day $time"]}]} {
                    incr day -1
                }
                set $this $seconds
            }

            proc setYear {this direction year} {
                foreach {day month current time} [clock format $($this,seconds) -format {%e %m %Y %T}] {}
                if {$year == $current} return
                while {[catch {::set seconds [clock scan "$year-$month-$day $time"]} message]} {
                    incr day -1
                }
                set $this $seconds
            }

        }

    }

}




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

    }

}

}





class databaseInstances {

    proc databaseInstances {this parentPath args} composite {[new frame $parentPath] $args} {
        variable singleton

        if {[info exists singleton]} {
            error {only 1 database instances object can exist}
        }
        set singleton $this
        set path $widget::($this,path)
        set viewer [blt::stripchart $path.graph -title {} -leftmargin 1 -topmargin 1 -bufferelements 0 -plotborderwidth 1            -background $viewer::(background) -cursor {} -highlightthickness 0 -plotpadx 2 -plotpady 0 -width 400 -height 200        ]
        $viewer xaxis configure -hide 1
        $viewer yaxis configure -hide 1 -descending 1
        set graph [new bltGraph $viewer]
        bind $viewer <Configure> "+ databaseInstances::resized $this"
        set ($this,cursors) [list            [new cursor $viewer -command "databaseInstances::cursorMoved $this" -hide 1]            [new cursor $viewer -command "databaseInstances::cursorMoved $this" -hide 1]        ]
        set ($this,labels) [frame $path.labels]
        grid $viewer -row 0 -column 0 -sticky nwes
        grid rowconfigure $path 0 -weight 1
        grid columnconfigure $path 0 -weight 1
        grid $($this,labels) -row 0 -column 1 -sticky nwes            -pady 5
        set ($this,drop)            [new dropSite -path $path -formats {INSTANCES DATETIME KILL} -command "databaseInstances::handleDrop $this"]
        set ($this,graph) $graph
        set ($this,viewer) $viewer
        composite::complete $this
        updateMessage $this
    }

    proc ~databaseInstances {this} {
        variable singleton
        variable ${this}instance

        eval delete [array names ${this}instance]
        if {[info exists ($this,drag)]} {
            delete $($this,drag)
        }
        eval delete $($this,drop) $($this,graph) $($this,cursors)
        eval delete [array names ${this}instance]
        if {[info exists ($this,selector)]} {
            delete $($this,selector)
        }
        if {[string length $composite::($this,-deletecommand)] > 0} {
            uplevel #0 $composite::($this,-deletecommand)
        }
        if {[info exists ($this,selfDelete)] && ([string length $composite::($this,-selfdeletecommand)] > 0)} {
            uplevel #0 $composite::($this,-selfdeletecommand)
        }
        unset singleton
    }

    proc options {this} {
        return [list            [list -deletecommand {} {}]            [list -draggable 0 0]            [list -plotbackground $global::graphPlotBackground]            [list -selfdeletecommand {} {}]            [list -xlabelsrotation $global::graphXAxisLabelsRotation]        ]
    }

    proc set-deletecommand {this value} {}
    proc set-selfdeletecommand {this value} {}

    proc set-plotbackground {this value} {
        variable ${this}instance

        $($this,viewer) configure -plotbackground $value
        set color [visibleForeground $value]
        foreach element [array names ${this}instance] {
            switched::configure $element -color $color
        }
    }

    proc set-draggable {this value} {
        if {$composite::($this,complete)} {
            error {option -draggable cannot be set dynamically}
        }
        if {!$value} return
        set ($this,drag) [new dragSite -path $($this,viewer) -validcommand "databaseInstances::validateDrag $this 0"]
        dragSite::provide $($this,drag) OBJECTS "databaseInstances::dragData $this"
        set ($this,selector) [new objectSelector -selectcommand "databaseInstances::setLabelsState $this"]
    }

    proc set-xlabelsrotation {this value} {
        bltGraph::xRotateLabels $($this,graph) $value
    }

    proc setLabelsState {this elements select} {
        variable ${this}label

        if {$select} {set relief sunken} else {set relief flat}
        foreach element $elements {
            [set ${this}label($element)] configure -relief $relief
        }
    }

    proc validateDrag {this element x y} {
        variable ${this}instance

        if {($element == 0) && ([array size ${this}instance] == 0)} {
            return 1
        } elseif {[lsearch -exact [selector::selected $($this,selector)] $element] >= 0} {
            return 1
        } else {
            return 0
        }
    }

    proc dragData {this format} {
        variable ${this}instance

        set elements [selector::selected $($this,selector)]
        if {[llength $elements] > 0} {
            return $elements
        } elseif {[array size ${this}instance] == 0} {
            set ($this,selfDelete) {}
            return $this
        } else {
            return {}
        }
    }

    proc handleDrop {this} {
        if {[info exists dragSite::data(KILL)]} {
            set ($this,selfDelete) {}
            delete $this
        } elseif {[info exists dragSite::data(INSTANCES)]} {
            foreach instance $dragSite::data(INSTANCES) {
                monitor $this $instance
            }
        } else {
            set value $dragSite::data(DATETIME)
            foreach cursor $($this,cursors) {
                lappend list [list $cursor [expr {abs([switched::cget $cursor -x] - $value)}]]
            }
            switched::configure [lindex [lindex [lsort -real -index end $list] 0] 0] -x $value
        }
    }

    proc monitor {this instanceData {launch 1}} {
        variable ${this}label
        variable ${this}instance
        variable ${this}tip

        foreach {instance module identifier arguments} $instanceData {}
        foreach {element value} [array get ${this}instance] {
            if {$value == $instance} return
        }
        foreach {start end} [database::instanceRange $global::database $instance] {}
        if {[string length $database::($global::database,error)] > 0} return
        set label [label $($this,labels).$instance -font $font::(mediumNormal)]
        if {[string length $identifier] > 0} {set title $identifier} else {set title $module}
        regsub {<0>$} $title {} title
        $label configure -text $title
        pack $label -anchor w
        if {![info exists (labelHeight)]} {
            set (labelHeight) [winfo reqheight $label]
        }
        set element [new element $($this,viewer) -color [visibleForeground $composite::($this,-plotbackground)]]
        if {[string length $end] > 0} {
            switched::configure $element -start [clock scan $start] -end [clock scan $end]
        }
        switched::configure $element -deletecommand "databaseInstances::deleted $this $element"
        set ${this}instance($element) $instance
        set ${this}label($element) $label
        set ${this}tip($element) [new widgetTip -path $label -text "$module: $arguments"]
        if {$composite::($this,-draggable)} {
            set drag [new dragSite -path $label -validcommand "databaseInstances::validateDrag $this $element"]
            dragSite::provide $drag OBJECTS "databaseInstances::dragData $this"
            set ($this,drag,$element) $drag
            set selector $($this,selector)
            selector::add $selector $element
            bind $label <ButtonPress-1> "databaseInstances::buttonPress $selector $element"
            bind $label <Control-ButtonPress-1> "selector::toggle $selector $element"
            bind $label <Shift-ButtonPress-1> "selector::extend $selector $element"
            bind $label <ButtonRelease-1> "databaseInstances::buttonRelease $selector $element 0"
            bind $label <Control-ButtonRelease-1> "databaseInstances::buttonRelease $selector $element 1"
            bind $label <Shift-ButtonRelease-1> "databaseInstances::buttonRelease $selector $element 1"
        }
        resized $this
        updateElements $this
        $($this,viewer) xaxis configure -hide 0
        updateAxis $this
        if {$launch} {
            launchInstanceModule $instance $module $identifier $arguments
        }
        updateMessage $this
    }

    proc deleted {this element} {
        variable ${this}label
        variable ${this}instance
        variable ${this}tip

        if {$composite::($this,-draggable)} {
            delete $($this,drag,$element)
            selector::remove $($this,selector) $element
        }
        destroy [set ${this}label($element)]
        delete [set ${this}tip($element)]
        set namespace instance<[set ${this}instance($element)]>
        if {[modules::loadedNamespace $namespace]} {
            dynamicallyUnloadModule $namespace
        }
        unset ${this}instance($element) ${this}label($element)
        if {[array size ${this}instance] == 0} {
            $($this,viewer) xaxis configure -hide 1
            foreach cursor $($this,cursors) {
                switched::configure $cursor -hide 0 -x 0
            }
            $($this,labels) configure -width 1
        } else {
            updateElements $this
        }
        updateAxis $this
        updateMessage $this
    }

    proc updateElements {this} {
        variable ${this}label

        set index 0
        foreach label [pack slaves $($this,labels)] {
            foreach {element value} [array get ${this}label] {
                if {[string equal $value $label]} break
            }
            switched::configure $element -ordinate [expr {$index * $(labelHeight)}]
            incr index
        }
    }

    proc limits {this} {
        variable ${this}instance

        set minimum $global::32BitIntegerMaximum
        set maximum 0
        foreach {element instance} [array get ${this}instance] {
            foreach {start end} [element::range $element] {}
            if {$start == 0} continue
            if {$start < $minimum} {set minimum $start}
            if {$end > $maximum} {set maximum $end}
        }
        if {$maximum == 0} {
            set minimum 0
        }
        return [list $minimum $maximum]
    }

    proc updateAxis {this} {
        foreach {minimum maximum} [limits $this] {}
        if {($minimum > 0) && ($minimum == $maximum)} {
            set minimum [expr {$maximum - 60}]
        }
        set graph $($this,graph)
        set range [expr {$maximum - $minimum}]
        bltGraph::setRange $graph $range
        bltGraph::xUpdateGraduations $graph
        bltGraph::xAxisUpdateRange $graph $maximum
        set cursors $($this,cursors)
        if {$maximum == 0} {
            foreach cursor $cursors {switched::configure $cursor -hide 1 -x 0}
            return
        }
        foreach cursor $cursors {switched::configure $cursor -hide 0}
        if {([switched::cget [lindex $cursors 0] -x] == 0) && ([switched::cget [lindex $cursors 1] -x] == 0)} {
            switched::configure [lindex $cursors 0] -x [expr {$maximum - [maximum [expr {$range / 10}] 86400]}]
            switched::configure [lindex $cursors 1] -x $maximum
        }
        foreach cursor $cursors {
            set x [switched::cget $cursor -x]
            if {$x < $minimum} {
                switched::configure $cursor -x $minimum
            } elseif {$x > $maximum} {
                switched::configure $cursor -x $maximum
            }
        }

    }

    proc resized {this} {
        variable ${this}instance

        if {[array size ${this}instance] == 0} return
        set half [expr {$(labelHeight) / 2.0}]
        $($this,viewer) yaxis configure -min -$half -max [expr {[$($this,viewer) extents plotheight] - $half}]
    }

    proc launchInstanceModule {instance module identifier arguments} {
        set database $global::database
        foreach list [database::cellsData $database $instance] {
            lappend cellsData $list
        }
        if {[string length $database::($database,error)] > 0} return
        set entries {}; set indexes {}; set labels {}; set types {}; set messages {}; set anchors {}
        foreach list [database::moduleData $database $instance] {
            if {[llength $list] == 0} break
            foreach {entry indexed label type message anchor} $list {}
            lappend entries $entry
            lappend indexes $indexed
            lappend labels $label
            lappend types $type
            lappend messages $message
            lappend anchors $anchor
        }
        if {[llength $entries] == 0} return
        dynamicallyLoadModules [list instance<$instance>            -module $module -identifier $identifier -arguments \{$arguments\} -instance $instance -cellsdata $cellsData            -entries $entries -types $types -messages $messages -anchors $anchors        ]
        if {$global::pollTime != 0} {error {poll time should be 0}}
    }

    proc cellHistory {instance row entry {last 0}} {
        variable singleton

        if {![info exists singleton] || ($global::database == 0)} {
            return {}
        }
        foreach {start end} [cursorsRange] {}
        if {$last} {
            return [database::cellHistory $global::database $instance $row $entry $start $end 1]
        } else {
            return [database::cellHistory $global::database $instance $row $entry $start $end 0]
        }
    }

    proc history {cell} {
        foreach {instance row entry} [cellIndex $cell] {}
        if {[info exists instance]} {
            return [cellHistory $instance $row $entry]
        } else {
            return {}
        }
    }

    proc range {cell} {
        foreach {instance row entry} [cellIndex $cell] {}
        if {![info exists instance] || ($global::database == 0)} {
            return [list {} {}]
        }
        foreach {start end} [cursorsRange] {}
        set list [database::cellRange $global::database $instance $row $entry $start $end]
        if {[string length $database::($global::database,error)] > 0} {
            set list [list {} {}]
        }
        return $list
    }

    proc cellIndex {cell} {
        if {([scan $cell {%[^<]<%u>::data(%u,%u)} module instance row column] != 4) || ![string equal $module instance]} {
            error "invalid database instance cell: $cell"
        }
        if {[modules::loadedNamespace instance<$instance>]} {
            foreach {row entry} [::instance<$instance>::mapping $row $column] {}
            return [list $instance $row $entry]
        } else {
            return {}
        }
    }

    proc fromTo {this} {
        return [lsort -integer [list            [expr {round([switched::cget [lindex $($this,cursors) 0] -x])}]            [expr {round([switched::cget [lindex $($this,cursors) 1] -x])}]        ]]
    }

    proc cursorsRange {} {
        variable singleton

        return [fromTo $singleton]
    }

    proc cursorMoved {this x} {
        eval database::setRange [fromTo $this]
    }

    proc deleteEmpty {} {
        variable singleton

        if {![info exists singleton]} return
        variable ${singleton}instance
        if {[array size ${singleton}instance] == 0} {
            set ($singleton,selfDelete) {}
            delete $singleton
        }
    }

    proc setCursors {this from to} {
        switched::configure [lindex $($this,cursors) 0] -x $from
        switched::configure [lindex $($this,cursors) 1] -x $to
    }

    proc buttonPress {selector element} {
        foreach selected [selector::selected $selector] {
            if {[string equal $selected $element]} return
        }
        selector::select $selector $element
    }

    proc buttonRelease {selector element extended} {
        if {$extended} return
        set list [selector::selected $selector]
        if {[llength $list] <= 1} return
        foreach selected $list {
            if {[string equal $selected $element]} {
                selector::select $selector $element
                return
            }
        }
    }

    proc entryData {cell} {
        foreach {instance row entry} [cellIndex $cell] {}
        if {![info exists instance]} {
            return {}
        }
        foreach list [database::moduleData $global::database $instance] {
            if {[llength $list] == 0} break
            foreach {index indexed label type message anchor} $list {}
            if {$index == $entry} {
                return [list $label $type $message $anchor]
            }
        }
        return {}
    }

    proc updateMessage {this} {
        variable ${this}instance

        if {[array size ${this}instance] == 0} {
            centerMessage $widget::($this,path) "database instances viewer:\ndrop or load instance(s)"                $composite::($this,-plotbackground) $global::viewerMessageColor
        } else {
            centerMessage $widget::($this,path) {}
        }
    }

    class element {

        proc element {this path args} switched {$args} {
            variable x$this
            variable y$this

            blt::vector create x${this}(2)
            blt::vector create y${this}(2)
            $path element create $this -label {} -xdata x$this -ydata y$this -pixels 2 -dashes 3
            set ($this,path) $path
            switched::complete $this
        }

        proc ~element {this} {
            variable x$this
            variable y$this

            blt::vector destroy x$this y$this
            $($this,path) element delete $this
            if {[string length $switched::($this,-deletecommand)]>0} {
                uplevel #0 $switched::($this,-deletecommand)
            }
        }

        proc options {this} {
            return [list                [list -color white]                [list -deletecommand {} {}]                [list -end $global::32BitIntegerMaximum]                [list -start 0]                [list -ordinate 0 0]            ]
        }

        proc set-color {this value} {
            $($this,path) element configure $this -color $value
        }

        proc set-deletecommand {this value} {}

        proc set-ordinate {this value} {
            variable y$this
            y${this} index : $value
        }

        proc set-start {this value} {
            variable x$this

            x${this} index 0 $value
            if {[x${this} index 1] < $global::32BitIntegerMaximum} {
                $($this,path) element configure $this -dash {}
            }
        }

        proc set-end {this value} {
            variable x$this

            x${this} index 1 $value
            if {[x${this} index 0] > 0} {
                $($this,path) element configure $this -dash {}
            }
        }

        proc range {this} {
            variable x$this
            return [x${this} index :]
        }

    }


    class cursor {

        variable downArrow [image create photo -data {R0lGODlhCQAEAIAAAAAA/////yH5BAEAAAEALAAAAAAJAAQAAAIIhH+BGYoNWSgAOw==}]
        variable upArrow [image create photo -data {R0lGODlhCQAEAIAAAP///wAA/yH5BAEAAAAALAAAAAAJAAQAAAIIhIOmyMv9YgEAOw==}]

        proc cursor {this path args} switched {$args} {
            variable downArrow
            variable upArrow

            $path marker create line -name ${this}line -outline blue
            $path marker create image -name ${this}top -image $downArrow -anchor nw -xoffset -4
            $path marker create image -name ${this}bottom -image $upArrow -anchor sw -xoffset -4
            foreach marker [list ${this}line ${this}top ${this}bottom] {
                $path marker bind $marker <Enter> "$path configure -cursor sb_h_double_arrow"
                $path marker bind $marker <Leave> "$path configure -cursor {}"
                $path marker bind $marker <ButtonPress-1> "databaseInstances::cursor::button $this 1 %x"
                $path marker bind $marker <ButtonRelease-1> "databaseInstances::cursor::button $this 0 %x"
                $path marker bind $marker <Button1-Motion> "databaseInstances::cursor::motion $this %x"
            }
            set ($this,path) $path
            switched::complete $this
        }

        proc ~cursor {this} {
            set path $($this,path)
            foreach marker [list ${this}line ${this}top ${this}bottom] {
                $path marker delete $marker
            }
        }

        proc options {this} {
            return [list                [list -command {} {}]                [list -hide 0 0]                [list -x 0]            ]
        }

        proc set-command {this value} {}

        proc set-hide {this value} {
            set path $($this,path)
            foreach marker [list ${this}line ${this}top ${this}bottom] {
                $path marker configure $marker -hide $value
            }
        }

        proc set-x {this value} {
            set path $($this,path)
            foreach {minimum maximum} [$path xaxis limits] {}
            if {$value < $minimum} {set value $minimum} elseif {$value > $maximum} {set value $maximum}
            $path marker configure ${this}line -coords [list $value -Inf $value Inf]
            $path marker configure ${this}top -coords [list $value -Inf]
            $path marker configure ${this}bottom -coords [list $value Inf]
        }

        proc button {this pressed x} {
            set x [$($this,path) xaxis invtransform $x]
            if {$pressed} {
                lifoLabel::push $global::messenger [bltGraph::axisTime $($this,path) $switched::($this,-x)]
            } else {
                lifoLabel::pop $global::messenger
                if {($x != $($this,x)) && ([string length $switched::($this,-command)] > 0)} {
                    uplevel #0 $switched::($this,-command) $x
                }
            }
            set ($this,x) $x
        }

        proc motion {this x} {
            set x [$($this,path) xaxis invtransform $x]
            switched::configure $this -x $x
            lifoLabel::pop $global::messenger
            lifoLabel::push $global::messenger [bltGraph::axisTime $($this,path) $x]
        }

    }


}

wm protocol . WM_DELETE_WINDOW exit
wm command . [concat [info nameofexecutable] $argv]
wm client . [info hostname]
wm group . .

frame .grabber
place .grabber -x -1 -y -1

grid columnconfigure . 0 -weight 1
set path [createMessageWidget .]
grid $path -row 3 -column 0 -sticky we
update

wm title . [mc {moodss: Loading modules...}]






class container {

    proc container {this {name {}}} {
        ::set ($this,name) $name
        ::set ($this,children) {}
    }

    proc ~container {this} {
        variable ${this}data

        eval delete $($this,children)
        catch {unset ${this}data}
    }


    proc bind {this child} {
        lappend ($this,children) $child
    }

    proc set {this name value} {
        variable ${this}data

        ::set ${this}data($name) $value
    }

    proc get {this name} {
        variable ${this}data

        return [::set ${this}data($name)]
    }

    proc equal {container1 container2} {
        variable ${container1}data
        variable ${container2}data

        if {            ![string equal $($container1,name) $($container2,name)] ||            ([array size ${container1}data] != [array size ${container2}data]) ||            ([llength $($container1,children)] != [llength $($container2,children)])        } {return 0}
        foreach            name1 [lsort -dictionary [array names ${container1}data]] name2 [lsort -dictionary [array names ${container2}data]] {
            if {![string equal $name1 $name2]} {return 0}
            if {![string equal [::set ${container1}data($name1)] [::set ${container2}data($name2)]]} {return 0}
        }
        foreach child1 $($container1,children) child2 $($container2,children) {
            if {![equal $child1 $child2]} {return 0}
        }
        return 1
    }

}



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

}

}

set global::readOnly [info exists arguments(-r)]
set global::static [info exists arguments(-S)]
if {[info exists arguments(-f)]} {
    set initializer [loadFromFile $arguments(-f)]
} else {
    set global::saveFile {}
}

modules::loadResidentTraceModule
residentTraceModule 0

if {[catch {modules::parse $argv} message]} {
    puts stderr $message
    exit 1
}

wm title . [mc {moodss: Initializing modules...}]
modules::initialize 0 initializationErrorMessageBox

rename exit _exit
proc exit {{code 0}} {
    if {$code != 0} {
        _exit $code
    }
    if {$global::readOnly || ![needsSaving]} _exit
    switch [inquireSaving] {
        yes {
            save
            if {![needsSaving]} _exit
        }
        no _exit
    }
}

set global::scroll [new scroll canvas . -viewthreshold 0.01]
set global::canvas $composite::($global::scroll,scrolled,path)
$global::canvas configure -highlightthickness 0 -background $global::canvasBackground    -scrollregion [list 0 0 $global::canvasWidth $global::canvasHeight]
updateCanvasImage $global::canvasImageFile 1
bind $global::canvas <Configure> "updateCanvasImagesPosition; pages::updateScrollRegion $global::canvas"
if {!$global::readOnly} createBackgroundMenu

set global::windowManager [new canvasWindowManager $global::canvas]
bind . <Shift-Tab> "canvasWindowManager::raise $global::windowManager 0"
if {[string equal $::tcl_platform(platform) unix]} {
    bind . <ISO_Left_Tab> "canvasWindowManager::raise $global::windowManager 0"
}
bind . <KP_Tab> "canvasWindowManager::raise $global::windowManager 1"
bind . <Tab> "canvasWindowManager::raise $global::windowManager 1"

if {[info exists ::geometry]} {
    wm geometry . $::geometry
} elseif {[info exists initializer]} {
    foreach {width height} [record::sizes $initializer] {}
    composite::configure $global::scroll -width $width -height $height
} else {
    wm geometry . 500x400
}

image create photo applicationIcon -data [dataGraph::iconData]
if {[string equal $tcl_platform(platform) unix]} {
    wm iconwindow . [toplevel .icon]
    pack [label .icon.image -image applicationIcon]
}

if {!$global::readOnly} {
    grid [updateDragAndDropZone] -row 1 -column 0 -sticky we
}
grid rowconfigure . 2 -weight 1

set draggable [expr {!$global::readOnly}]

if {[info exists arguments(-p)]} {
    modules::setPollTimes $arguments(-p)
} elseif {[info exists initializer]} {
    modules::setPollTimes [record::pollTime $initializer]
} else {
    modules::setPollTimes
}

updateTitle
updateMenuWidget

manageToolBar 0
if {!$global::readOnly} {
    updateFileSaveHelp $global::saveFile
}

set modules::(synchronous) {}

foreach instance $modules::(instances) {
    displayModule $instance $draggable
}
if {[info exists initializer]} {
    createSavedImages $initializer
    createSavedViewers $initializer
    updateMenuWidget
    updateToolBar
}

if {[pages::current] == 0} {
    manageScrolledCanvas 1
} else {
    pages::manageScrolledCanvas 1
}
refresh
update
record::snapshot

list

