#!/usr/bin/tclsh


set rcsId {$Id: moomps.tcl,v 1.28 2002/01/10 22:18:54 jfontain Exp $}


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

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


set rcsId {$Id: misc.tcl,v 1.5 2002/01/01 11:31:02 jfontain Exp $}


package provide miscellaneous [lindex {$Revision: 1.5 $} 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 $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 ::[lindex [info level -1] 0]:$localName
    uplevel 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
}

set rcsId {$Id: global.tcl,v 2.77 2002/01/19 19:51:18 jfontain Exp $}


namespace eval global {
    variable withGUI [expr {![catch {package present Tk}]}]
    variable debug 0
    if {$withGUI} {
        variable applicationName moodss
        variable applicationVersion 15.7
        variable messenger
        variable scroll
        variable canvas
        variable menu
        variable static
        variable windowManager
        variable fileMenuContextHelper
        variable fileMenuContextHelperSaveIndex
        variable saveFile
        variable xWindowManagerInitialOffset 30
        variable yWindowManagerInitialOffset 20
        variable graphNumberOfIntervals 100
        variable viewerHeight 200
        variable viewerWidth 300
        variable canvasHeight [winfo screenheight .]
        variable canvasWidth [winfo screenwidth .]
        variable canvasBackground white
        variable pieLabeler peripheral
        variable viewerColors {#7FFFFF #7FFF7F #FF7F7F #FFFF7F #7F7FFF #FFBF00 #BFBFBF #FF7FFF #FFFFFF}
        variable fileDirectory [pwd]
    } else {
        variable applicationName moomps
        variable applicationVersion 1.2.1
    }
    variable pollTimes
    variable pollTime
    variable documentationDirectory [file dirname $::argv0]/documentation
    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]
    variable login unknown
    catch {set login $::env(USER)}
    catch {set login $::env(LOGNAME)}
    variable fromAddress $login
    variable smtpServers 127.0.0.1
    variable rpm 0
    variable noMail [catch {package require smtp 1.2}]
}

if {$global::withGUI} {

proc updateCanvasSize {args} {
    $global::canvas configure -width $global::canvasWidth -height $global::canvasHeight\
        -scrollregion [list 0 0 $global::canvasWidth $global::canvasHeight]
}

proc updateCanvasBackground {args} {
    $global::canvas configure -background $global::canvasBackground
}

}

set rcsId {$Id: utility.tcl,v 1.33 2002/01/19 16:42:23 jfontain Exp $}


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} {
        foreach name [package names] {
            set package($name) {}
        }
        uplevel _source [list $file]
        foreach name [package names] {
            if {![info exists package($name)]} {
                set ::packageDirectory($name) [file dirname $file]
            }
        }
    }
}

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

if {$global::withGUI} {

proc configureWritableTable {path {tabActivateScript {}}} {
    bindtags $path [list $path [winfo toplevel $path]]
    foreach event {
        ButtonPress-1 B1-Motion ButtonRelease-1 Shift-1 Control-1 B1-Enter B1-Leave <Table_Commit> Shift-Up Shift-Down Shift-Left
        Shift-Right KeyPress BackSpace Delete Escape Alt-KeyPress Meta-KeyPress Control-KeyPress Any-Tab
    } {
        bind $path <$event> [bind Table <$event>]
    }
    bind $path <Return> {catch {%W activate active}}
    bind $path <KP_Enter> {catch {%W activate active}}
    bind $path <Left> [bind Table <Control-Left>]
    bind $path <Right> [bind Table <Control-Right>]
    bind $path <Home> [bind Table <Control-a>]
    bind $path <End> [bind Table <Control-e>]
    bind $path <Shift-Tab> "tkTableNextCell %W 0 {$tabActivateScript}"
    bind $path <KP_Tab> "tkTableNextCell %W 1 {$tabActivateScript}"
    bind $path <Tab> "tkTableNextCell %W 1 {$tabActivateScript}"
    if {[string equal $::tcl_platform(platform) unix]} {
        bind $path <ISO_Left_Tab> "tkTableNextCell %W 0 {$tabActivateScript}"
        bind $path <ButtonRelease-2> {tk_tablePaste %W [%W index @%x,%y]}
    }
}

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

    set label [label .temporary]
    set row [$table cget -roworigin]
    set lastRow [expr {$row+[$table cget -rows]}]
    set column [$table cget -colorigin]
    set lastColumn [expr {$column+[$table cget -cols]}]
    set defaultFont [$table cget -font]
    set titleFont [$table tag cget title -font]
    for {} {$column<$lastColumn} {incr column} {
        set maximum 0
        for {set row [$table cget -roworigin]} {$row<$lastRow} {incr row} {
            if {[string length [$table hidden $row,$column]]>0} continue
            if {[catch {set window [$table window cget $row,$column -window]}]} {
                if {[$table tag includes title $row,$column]} {
                    $label configure -font $titleFont
                } else {
                    $label configure -font $defaultFont
                }
                $label configure -text $data($row,$column)
                set width [winfo reqwidth $label]
            } 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 compareClocks {value1 value2} {
    set value1 [clock scan $value1 -base 0]
    set value2 [clock scan $value2 -base 0]
    if {$value1==$value2} {
        return 0
    } elseif {$value1<$value2} {
        return -1
    } else {
        return 1
    }
}

if {$global::withGUI} {

proc tkTableSkipEmbeddedWindows {path forward} {
    if {$forward} {set parameter 1} else {set parameter -1}
    while {1} {
        set column [$path index active col]
        if {[catch {$path window cget [$path index active] -window}]} break
        ::tk::table::MoveCell $path 0 $parameter
        if {[$path index active col]==$column} break
    }
}

proc tkTableNextCell {path forward {tabActivateScript {}}} {
    set top [$path index origin row]
    set left [$path index origin col]
    set bottom [$path index end row]
    set right [$path index end col]
    catch {
        set row [$path index active row]
        set column [$path index active col]
    }
    if {[info exists row]} {
        if {$forward} {
            ::tk::table::MoveCell $path 0 1
            tkTableSkipEmbeddedWindows $path 1
            if {([$path index active col]==$column)||![catch {$path window cget [$path index active] -window}]} {
                if {$row<$bottom} {
                    $path activate $row,$left
                    ::tk::table::MoveCell $path 1 0
                    tkTableSkipEmbeddedWindows $path 1
                }
            }
        } else {
            ::tk::table::MoveCell $path 0 -1
            tkTableSkipEmbeddedWindows $path 0
            if {([$path index active col]==$column)||![catch {$path window cget [$path index active] -window}]} {
                if {$row>$top} {
                    $path activate $row,$right
                    ::tk::table::MoveCell $path -1 0
                    tkTableSkipEmbeddedWindows $path 0
                }
            }
        }
    } else {
        if {$forward} {
            $path activate $top,$left
            tkTableSkipEmbeddedWindows $path 1
        } else {
            $path activate $bottom,$right
        }
    }
    if {[string length $tabActivateScript]>0} {
        uplevel #0 $tabActivateScript [$path index active row] [$path index active col]
    }
}

}

proc emailAddressError {string} {
    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
}
startGatheringPackageDirectories

set rcsId {$Id: getopt.tcl,v 2.4 2001/12/29 00:32:39 jfontain Exp $}


proc parseCommandLineArguments {switches arguments arrayName} {
    upvar $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 0 --foreground 0 -h 0 -he 0 -hel 0 -help 0 --help 0 -m 1 --mailto 1 --pid-file 1 -p 1 --poll-files-time 1
                -q 0 --quiet 0 --version 0
            } $argv arguments\
        ]\
    } message\
]} {
    puts stderr $message
    printUsage 1
}

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

if {[info exists arguments(-h)]||[info exists arguments(-he)]||[info exists arguments(-hel)]||[info exists arguments(-help)]} {
    printUsage 1
}
set pollFilesTime 60000
if {[info exists arguments(-p)]&&[catch {expr {$arguments(-p)*1000}} pollFilesTime]} {
    printUsage 1
}

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


set global::debug [expr {![info exists arguments(-q)]}]

if {[lsearch -exact $auto_path /usr/lib]<0} {
    lappend auto_path /usr/lib /usr/lib/moodss
}
lappend auto_path $::tcl_pkgPath/moodss
if {[info exists arguments(-f)]&&!$global::rpm} {
    lappend auto_path [pwd]
}
package require msgcat
namespace import msgcat::*
package require internationalization

if {[llength $argv]==0} {
    printUsage 1
}


set rcsId {$Id: preferen.tcl,v 1.17 2001/12/30 15:28:09 jfontain Exp $}


namespace eval preferences {

    variable rcFileName ~/.moodssrc

    proc read "{rcFileName $rcFileName}" {
        if {![file readable $rcFileName]} {
            return {}
        }
        set file [::open $rcFileName]
        set list {}
        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
        }
        close $file
        return $list
    }

    proc save {variables} {
        variable rcFileName

        if {[catch {::open $rcFileName w} file]} {
            tk_messageBox -title moodss -type ok -default ok -icon error -message $file
            return
        }
        set data [record::globalData]
        foreach name $variables {
            append data [list $name [set ::preferences::$name]]\n
        }
        puts -nonewline $file $data
        close $file
    }

}

set rcsId {$Id: config.tcl,v 2.27 2001/12/29 00:32:39 jfontain Exp $}


namespace eval configuration {

if {$global::withGUI} {

    variable container
    variable interface
    variable hierarchy {
        canvas canvas.size canvas.colors canvas.printing viewers viewers.colors viewers.graphs viewers.pies
        thresholds thresholds.email
    }
    variable configure {1 1 1 0 1 1 1 1 0 0}
    variable helpMessage
    set helpMessage(preferences) "Preferences for the user: $global::login"
    set helpMessage(configuration) {Configuration for the current view.}

    variable entryIcons
    lappend entryIcons [image create photo -data {
        R0lGODlhEAANAPIAAAAAAH9/f7+/v///AP///wAAAAAAAAAAACH+JEZpbGUgd3JpdHRlbiBieSBBZG9iZSBQaG90b3Nob3CoIDUuMAAsAAAAABAADQAAAzNI
        Gsz6kAQxqAjxzcpvc1KWBUDYnRQZWmilYi37EmztlrAt43R8mzrO60P8lAiApHK5TAAAOw==
    }]
    lappend entryIcons [image create photo -data {
        R0lGODlhEAANAPIAAAAAAH9/f7+/v///////AAAAAAAAAAAAACH+JEZpbGUgd3JpdHRlbiBieSBBZG9iZSBQaG90b3Nob3CoIDUuMAAsAAAAABAADQAAAzk4
        Gsz6cIQ44xqCZCGbk4MmclAAgNs4ml7rEaxVAkKc3gTAnBO+sbyQT6M7gVQpk9HlAhgHzqhUmgAAOw==
    }]

}

    proc load {arrayList} {
        foreach {name value} $arrayList {
            set ::global::$name $value
        }
    }

if {$global::withGUI} {

    proc edit {preferencesMode} {
        variable hierarchy
        variable configure
        variable container
        variable interface
        variable tree
        variable preferences
        variable helpMessage
        variable dialog
        variable entryIcons

        set preferences $preferencesMode

        set objects {}

        set title {moodss: }
        if {$preferences} {
            append title Preferences
        } else {
            append title 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 [blt::hierbox $frame.tree\
            -font $font::(mediumBold) -separator . -selectmode single -selectbackground lightgray -hideroot 1 -borderwidth 1\
            -highlightthickness 0 -takefocus 0 -width 150\
        ]
        set container [frame $frame.container -borderwidth 1 -relief sunken]

        set message [createMessage $container.message]
        if {$preferences} {
            $message configure -text $helpMessage(preferences)
        } else {
            $message configure -text $helpMessage(configuration)
        }
        pack $message -fill both -expand 1

        bindtags $tree [list $tree [winfo toplevel $tree] all]
        $tree bind all <Double-ButtonPress-1> {}
        $tree bind all <Shift-ButtonPress-1> {}
        $tree bind all <Control-ButtonPress-1> {}
        $tree bind all <B1-Motion> {}
        $tree bind all <ButtonRelease-1> "$tree toggle current; $tree toggle current"

        catch {unset interface(current)}

        foreach entry $hierarchy specific $configure {
            if {!$preferences&&!$specific} continue
            set index [$tree insert end $entry]
            regsub -all {\.} $entry :: interface($index,class)
            $interface($index,class)::initialize
            $tree entry configure $index -opencommand "configuration::open $index" -icons $entryIcons
        }

        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) 500x300

        bind $frame <Destroy> "delete $objects"
    }

    proc open {index} {
        variable container
        variable interface

        if {[info exists interface(current)]&&![$interface($interface(current),class)::check]} return
        eval destroy [winfo children $container]
        set frame [frame $container.frame]
        pack $frame -fill both -expand 1
        $interface($index,class)::edit $frame
        set interface(current) $index
    }

    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 left
        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} {
        variable preferences

        set namespaces ::global
        if {$preferences} {
            lappend namespaces ::preferences
        }
        foreach namespace $namespaces {
            if {![info exists ${namespace}::$name]||($value!=[set ${namespace}::$name])} {
                set ${namespace}::$name $value
            }
        }
    }

    proc variables {preferences} {
        variable variables

        return $variables($preferences)
    }

    namespace eval canvas {

        proc initialize {} {}

        proc edit {parentPath} {
            set message [configuration::createMessage $parentPath.message -text {Canvas configuration}]
            pack $message -fill both -expand 1
        }

        proc check {} {
            return 1
        }

        proc apply {} {}

        proc variables {} {return {}}

        proc help {} {
            generalHelpWindow #configuration.canvas
        }

        namespace eval size {

            proc variables {} {
                return {canvasHeight canvasWidth}
            }

            proc initialize {} {
                variable height [configuration::initialize canvasHeight]
                variable width [configuration::initialize canvasWidth]
            }

            proc edit {parentPath} {
                variable height
                variable width
                variable message

                set message [configuration::createMessage $parentPath.message -text {Enter size (in pixels):}]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1

                grid columnconfigure $parentPath 0 -weight 1

                if {$::tcl_version<8.4} {
                    set widthEntry [new spinEntry $parentPath -font $font::(mediumBold) -width 4 -list {640 800 1024 1280 1600}]
                    spinEntry::set $widthEntry $width
                    grid $widget::($widthEntry,path) -row 1 -column 2
                    set path $composite::($widthEntry,entry,path)
                } else {
                    set path [spinbox $parentPath.widthEntry -font $font::(mediumBold) -width 4 -values {640 800 1024 1280 1600}]
                    $path set $width
                    grid $path -row 1 -column 2
                }
                $path configure -textvariable configuration::canvas::size::width
                setupEntryValidation $path {{checkMaximumLength 4 %P} {checkUnsignedInteger %P}}
                grid [label $parentPath.width -font $font::(mediumBold) -text width:] -row 1 -column 1 -padx 2
                grid columnconfigure $parentPath 3 -weight 1

                if {$::tcl_version<8.4} {
                    set heightEntry [new spinEntry $parentPath -font $font::(mediumBold) -width 4 -list {400 480 600 768 1024 1280}]
                    spinEntry::set $heightEntry $height
                    grid $widget::($heightEntry,path) -row 1 -column 5
                    set path $composite::($heightEntry,entry,path)
                } else {
                    set path\
                        [spinbox $parentPath.heightEntry -font $font::(mediumBold) -width 4 -values {400 480 600 768 1024 1280}]
                    $path set $height
                    grid $path -row 1 -column 5
                }
                $path configure -textvariable configuration::canvas::size::height
                setupEntryValidation $path {{checkMaximumLength 4 %P} {checkUnsignedInteger %P}}
                grid [label $parentPath.height -font $font::(mediumBold) -text height:] -row 1 -column 4 -padx 2
                grid columnconfigure $parentPath 6 -weight 1

                grid [button $parentPath.apply -text Apply -command configuration::canvas::size::apply]\
                    -row 2 -column 0 -columnspan 100
                grid rowconfigure $parentPath 2 -weight 1

                if {$::tcl_version<8.4} {
                    bind $message <Destroy> "delete $widthEntry $heightEntry"
                }
            }

            proc check {} {
                variable height
                variable width
                variable message

                set valid 1
                foreach item {height width} {
                    if {[string length [set $item]]==0} {
                        set text "please set $item."
                        set valid 0
                        break
                    }
                    if {[set $item]==0} {
                        set text "$item cannot be set to 0."
                        set valid 0
                        break
                    }
                }
                if {!$valid} {
                    $message configure -font $::font::(mediumBold) -text $text
                    bell
                }
                return $valid
            }

            proc apply {} {
                variable height
                variable width

                if {![check]} return
                configuration::apply canvasHeight $height
                configuration::apply canvasWidth $width
            }

            proc help {} {
                generalHelpWindow #configuration.canvas.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 {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 Choose... -command "configuration::canvas::colors::choose $parentPath"]
                updateColorViewer
                grid $colorViewer -row 1 -column 1
                grid [button $parentPath.apply -text Apply -command configuration::canvas::colors::apply] -row 1 -column 2

                grid columnconfigure $parentPath 1 -weight 1
                grid columnconfigure $parentPath 2 -weight 1
                grid columnconfigure $parentPath 3 -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

                foreach {red green blue} [winfo rgb $colorViewer $background] {}
                if {($red+$green+$blue)>=(32768*3)} {
                    $colorViewer configure -foreground black
                } else {
                    $colorViewer configure -foreground white
                }
                $colorViewer configure -background $background
            }

            proc choose {parentPath} {
                variable background

                set choice [tk_chooseColor -initialcolor $background -title {Choose color:} -parent $parentPath]
                if {[string length $choice]>0} {
                    set background $choice
                    updateColorViewer
                }
            }

            proc help {} {
                generalHelpWindow #configuration.canvas.colors
            }

        }

        namespace eval printing {

            variable helpText {}

            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 orientation [configuration::initialize printOrientation]
                variable palette [configuration::initialize printPalette]
                variable size [configuration::initialize printPaperSize]
            }

            proc edit {parentPath} {
                variable helpText
                variable toFile
                variable printFile
                variable command
                variable orientation
                variable palette
                variable size

                set objects {}

                set row 0
                set message [configuration::createMessage $parentPath.message -text {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::canvas::printing::toFile -value 0 -text Command:
                grid $parentPath.toCommand -row $row -column 0 -sticky w
                entry $parentPath.command -textvariable configuration::canvas::printing::command
                grid $parentPath.command -row $row -column 1 -columnspan 2 -sticky ew

                incr row
                radiobutton $parentPath.toFile -variable configuration::canvas::printing::toFile -value 1 -text {to File:}
                grid $parentPath.toFile -row $row -column 0 -sticky w
                entry $parentPath.file -textvariable configuration::canvas::printing::printFile
                grid $parentPath.file -row $row -column 1 -sticky ew
                button $parentPath.browse -text Browse... -command "configuration::canvas::printing::inquirePrintFile $parentPath"
                grid $parentPath.browse -row $row -column 2 -sticky ew
                if {$toFile} {
                    $parentPath.toFile invoke
                } else {
                    $parentPath.toCommand invoke
                }

                incr row
                grid [label $parentPath.orientation -text Orientation:] -row $row -column 0 -sticky w
                set entry\
                    [new comboEntry $parentPath -font $widget::option(entry,font) -list $global::printOrientations -editable 0]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::canvas::printing::orientation
                composite::configure $entry button -listheight [llength $global::printOrientations]
                composite::configure $entry button scroll -selectmode single
                grid $widget::($entry,path) -row $row -column 1 -columnspan 2 -sticky ew

                incr row
                grid [label $parentPath.palette -text Palette:] -row $row -column 0 -sticky w
                set entry [new comboEntry $parentPath -font $widget::option(entry,font) -list $global::printPalettes -editable 0]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::canvas::printing::palette
                composite::configure $entry button -listheight [llength $global::printPalettes]
                composite::configure $entry button scroll -selectmode single
                grid $widget::($entry,path) -row $row -column 1 -columnspan 2 -sticky ew

                incr row
                grid [label $parentPath.size -text {Paper size:}] -row $row -column 0 -sticky w
                set entry [new comboEntry $parentPath -font $widget::option(entry,font) -list $global::printPaperSizes -editable 0]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::canvas::printing::size
                composite::configure $entry button -listheight [llength $global::printPaperSizes]
                composite::configure $entry button scroll -selectmode single
                grid $widget::($entry,path) -row $row -column 1 -columnspan 2 -sticky ew

                incr row
                set message [configuration::createMessage $parentPath.help -text $helpText]
                grid $message -sticky nsew -row $row -column 0 -columnspan 3
                grid rowconfigure $parentPath $row -weight 1

                bind $message <Destroy> "delete $objects"
            }

            proc inquirePrintFile {parentPath} {
                variable printFile

                set file [tk_getSaveFile\
                    -title {moodss: File to print to} -parent $parentPath -initialdir [file dirname $printFile]\
                    -defaultextension .ps -filetypes {{Postscript .ps} {{All files} *}} -initialfile $printFile\
                ]
                if {[string length $file]>0} {
                    set printFile $file
                }
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable toFile
                variable printFile
                variable command
                variable orientation
                variable palette
                variable size

                configuration::apply printToFile $toFile
                configuration::apply fileToPrintTo $printFile
                configuration::apply printCommand $command
                configuration::apply printOrientation $orientation
                configuration::apply printPalette $palette
                configuration::apply printPaperSize $size
            }

            proc help {} {
                generalHelpWindow #preferences.canvas.printing
            }

        }

    }


    namespace eval viewers {

        proc initialize {} {}

        proc edit {parentPath} {
            set message [configuration::createMessage $parentPath.message -text {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 {

            variable helpText {}

            proc variables {} {
                return viewerColors
            }

            proc initialize {} {
                variable colors [configuration::initialize viewerColors]
            }

            proc edit {parentPath} {
                variable helpText
                variable colorsFrame

                set message [configuration::createMessage $parentPath.message -text {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

                set message [configuration::createMessage $parentPath.help -text $helpText]
                grid $message -sticky nsew -row 2 -column 0 -columnspan 100
                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 {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 {

            variable helpText {}

            proc variables {} {
                return graphNumberOfIntervals
            }

            proc initialize {} {
                variable numberOfSamples [configuration::initialize graphNumberOfIntervals]
            }

            proc edit {parentPath} {
                variable helpText
                variable numberOfSamples
                variable message

                set message [configuration::createMessage $parentPath.message -text "Enter number of samples\nfor data graphs:"]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1

                grid columnconfigure $parentPath 0 -weight 1

                if {$::tcl_version<8.4} {
                    set entry [new spinEntry $parentPath -font $font::(mediumBold) -width 4 -list {20 50 100 150 200 300 500 1000}]
                    spinEntry::set $entry $numberOfSamples
                    grid $widget::($entry,path) -row 1 -column 2
                    set path $composite::($entry,entry,path)
                } else {
                    set path [spinbox $parentPath.entry -font $font::(mediumBold) -width 4 -values {20 50 100 150 200 300 500 1000}]
                    $path set $numberOfSamples
                    grid $path -row 1 -column 2
                }
                $path configure -textvariable configuration::viewers::graphs::numberOfSamples
                setupEntryValidation $path {{checkMaximumLength 4 %P} {checkUnsignedInteger %P}}

                grid [label $parentPath.width -font $font::(mediumBold) -text samples:] -row 1 -column 1 -padx 2

                grid columnconfigure $parentPath 3 -weight 1

                set message [configuration::createMessage $parentPath.help -text $helpText]
                grid $message -sticky nsew -row 2 -column 0 -columnspan 100
                grid rowconfigure $parentPath 2 -weight 1

                if {$::tcl_version<8.4} {
                    bind $message <Destroy> "delete $entry"
                }
            }

            proc check {} {
                variable numberOfSamples
                variable message

                set valid 1
                if {[string length $numberOfSamples]==0} {
                    set text {please set number of samples.}
                    set valid 0
                } elseif {$numberOfSamples==0} {
                    set text {number of samples cannot be set to 0.}
                    set valid 0
                }
                if {!$valid} {
                    $message configure -font $::font::(mediumBold) -text $text
                    bell
                }
                return $valid
            }

            proc apply {} {
                variable numberOfSamples

                if {![check]} return
                configuration::apply graphNumberOfIntervals $numberOfSamples
            }

            proc help {} {
                generalHelpWindow #configuration.viewers.graphs
            }

        }

        namespace eval pies {

            variable helpText {}

            proc variables {} {
                return pieLabeler
            }

            proc initialize {} {
                variable labeler [configuration::initialize pieLabeler]
            }

            proc edit {parentPath} {
                variable helpText

                set message [configuration::createMessage $parentPath.message -text {Choose labeler type for data pies:}]
                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 box]
                grid $button -row 1 -column 1
                set button [radiobutton $parentPath.peripheral\
                    -variable ::configuration::viewers::pies::labeler -value peripheral -text peripheral\
                ]
                grid $button -row 1 -column 2

                grid columnconfigure $parentPath 3 -weight 1

                set message [configuration::createMessage $parentPath.help -text $helpText]
                grid $message -sticky nsew -row 2 -column 0 -columnspan 100
                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 thresholds {

        proc initialize {} {}

        proc edit {parentPath} {
            set message [configuration::createMessage $parentPath.message -text {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 {

            variable helpText {}

            proc variables {} {
                return {fromAddress smtpServers}
            }

            proc initialize {} {
                variable from [configuration::initialize fromAddress]
                variable servers [configuration::initialize smtpServers]
            }

            proc edit {parentPath} {
                variable servers
                variable list
                variable parent $parentPath

                set row 0
                set message [configuration::createMessage $parentPath.message -text {Mail settings:}]
                grid $message -sticky nsew -row $row -column 0 -columnspan 2
                grid rowconfigure $parentPath $row -weight 1
                incr row
                set label [label $parentPath.from -text {From address:}]
                if {$global::noMail} {
                    $label configure -foreground $widget::option(button,disabledforeground)
                }
                grid $label -row $row -column 0 -sticky w
                set entry [entry $parentPath.address -textvariable configuration::thresholds::email::from]
                if {$global::noMail} {
                    $entry configure -state disabled
                }
                grid $entry -row $row -column 1 -sticky ew
                incr row
                set label [label $parentPath.out -text {Outgoing mail SMTP servers:}]
                if {$global::noMail} {
                    $label configure -foreground $widget::option(button,disabledforeground)
                }
                grid $label -row $row -column 0 -sticky nw
                set list [new listEntry $parentPath -list $servers]
                if {$global::noMail} {
                    composite::configure $list -state disabled
                }
                grid $widget::($list,path) -row $row -column 1 -sticky nsew
                incr row
                grid rowconfigure $parentPath $row -weight 1
                bind $message <Destroy> "delete $list; unset configuration::thresholds::email::list"
            }

            proc check {} {
                variable from
                variable parent

                if {!$global::noMail&&([string length [emailAddressError $from]]>0)} {
                    tk_messageBox -parent $parent -title {moodss: Email error} -type ok -icon error\
                        -message "$from: [emailAddressError $from]"
                    return 0
                }
                return 1
            }

            proc apply {} {
                variable from
                variable servers
                variable list

                configuration::apply fromAddress $from
                if {[info exists list]} {
                    set servers [composite::cget $list -list]
                }
                configuration::apply smtpServers $servers
            }

            proc help {} {
                generalHelpWindow #preferences.thresholds.email
            }

        }
    }

    variable variables
    set variables(0) {}
    set variables(1) {}
    foreach entry $hierarchy specific $configure {
        regsub -all {\.} $entry :: class
        if {$specific} {
            set variables(0) [concat $variables(0) [${class}::variables]]
        }
        set variables(1) [concat $variables(1) [${class}::variables]]
    }

}

}
configuration::load [preferences::read /etc/moomps/rc]

set startMessage "$::argv0 $global::applicationVersion starting..."

if {[info exists arguments(-m)]} {
    if {$global::noMail} {
        puts stderr {no email capability: please install tcllib}
    } else {
        set message [emailAddressError $arguments(-m)]
        if {[string length $message]>0} {
            puts stderr "invalid email address: \"$arguments(-m)\""
            exit 1
        }
        if {[catch {sendTextEmail $global::fromAddress $arguments(-m) {moomps starting} $startMessage} message]} {
            puts stderr "email error: $message"
            exit 1
        }
    }
}

if {[info exists arguments(-f)]} {
    proc writeLog {message {level info}} {
        puts "$level: $message"
    }
} else {
    package require Tclx
    package require Tnm 2

    rename exit _exit
    proc exit {{code 0}} {
        writeLog "$::argv0 exiting..."
        if {[info exists ::arguments(--pid-file)]} {
            file delete -force $::arguments(--pid-file)
        }
        _exit $code
    }

    rename puts _puts
    proc puts {args} {
        if {[string equal [lindex $args 0] -nonewline]} {
            set arguments [lreplace $args 0 0]
        } else {
            set arguments $args
        }
        if {[llength $arguments]==1} {
            writeLog [lindex $arguments 0]
        } elseif {[llength $arguments]==2} {
            switch -- [lindex $arguments 0] {
                stdout {writeLog [lindex $arguments 1]}
                stderr {writeLog [lindex $arguments 1] error}
                default {eval _puts $args}
            }
        } else {
            eval _puts $args
        }
    }

    proc writeLog {message {level info}} {
        ::syslog $level "\[moomps\]: $message"
    }

    proc daemonize {} {
       if {[fork]} _exit
       cd /
       set null [open /dev/null r+]
       dup $null stdin
       dup $null stdout
       dup $null stderr
       close $null
    }

    proc bgerror {message} {
        writeLog $message error
    }

    daemonize
    signal ignore SIGHUP
    signal unblock {QUIT TERM}
    signal trap {QUIT TERM} exit
}


proc initialize {interpreter} {
    interp eval $interpreter "set ::argv0 $::argv0"
    interp eval $interpreter "array set ::packageDirectory [list [array get ::packageDirectory]]"
    $interpreter alias exit exit
    $interpreter alias writeLog writeLog
    interp eval $interpreter {
        if {[lsearch -exact $auto_path /usr/lib]<0} {
            lappend auto_path /usr/lib /usr/lib/moodss
        }
        lappend auto_path $::tcl_pkgPath/moodss
    }
    if {[info exists ::arguments(-f)]&&!$global::rpm} {
        interp eval $interpreter {lappend auto_path [pwd]}
    }
    interp eval $interpreter {
        if 1 {


package require Tcl 8.3

package provide stooop 4.3

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)
        if {![regexp {^(stdout|stderr)$} $trace(procedureChannel)]} {
            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)
        if {![regexp {^(stdout|stderr)$} $trace(dataChannel)]} {
            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 $fullClass($classOrId)::_copy $id $classOrId
        } else {
            set constructor ${classOrId}::[namespace tail $classOrId]
            uplevel $constructor [set id [incr newId]] $args
            set fullClass($id) [namespace qualifiers\
                [uplevel namespace which -command $constructor]\
            ]
        }
        return $id
    }

    _proc delete {args} {
        variable fullClass

        foreach id $args {
            uplevel ::stooop::deleteObject $fullClass($id) $id
            unset fullClass($id)
        }
    }

    _proc deleteObject {fullClass id} {
        uplevel ${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 namespace eval $class {namespace current}]) {}
    uplevel namespace eval $class [list "::variable {}\n[lindex $args end]"]
}

_proc ::stooop::parseProcedureName {\
    namespace name fullClassVariable procedureVariable messageVariable\
} {
    variable declared
    upvar $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 namespace which -command $keyword] ::proc]} {
        error "virtual operator works only on proc, not $keyword"
    }
    if {![parseProcedureName\
        [uplevel 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 ::proc [list $name $arguments [lindex $args 0]]
    unset pureVirtual
}

_proc proc {name arguments args} {
    if {![::stooop::parseProcedureName\
        [uplevel namespace current] $name fullClass procedure message\
    ]} {
        uplevel _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 \$(\$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 \$(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\]\]
}
::uplevel ${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 namespace eval $class\
                [list {::trace variable {} wu ::stooop::checkData}]
        }
        if {[info exists ::env(STOOOPTRACEDATA)]} {
            uplevel namespace eval $class [list\
                "::trace variable {} $trace(dataOperations) ::stooop::traceData"\
            ]
        }
        uplevel ::stooop::_class $args
    }

    if {$::stooop::check(procedures)} {
        catch {rename ::stooop::virtual ::stooop::_virtual}
        _proc ::stooop::virtual {keyword name arguments args} {
            variable interface

            uplevel ::stooop::_virtual [list $keyword $name $arguments] $args
            parseProcedureName [uplevel 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} {
                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 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 ::stooop::_new $classOrId $args]
        }
    }

    if {$::stooop::check(objects)} {
        _proc ::stooop::delete {args} {
            variable fullClass
            variable deleter

            set procedure [invokingProcedure]
            foreach id $args {
                uplevel ::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 $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]
        if {[llength $list]==0} return
        set procedure [lindex $list 0]
        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 [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 [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 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
    }

}
        }

set rcsId {$Id: misc.tcl,v 1.5 2002/01/01 11:31:02 jfontain Exp $}


package provide miscellaneous [lindex {$Revision: 1.5 $} 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 $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 ::[lindex [info level -1] 0]:$localName
    uplevel 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
}

set rcsId {$Id: global.tcl,v 2.77 2002/01/19 19:51:18 jfontain Exp $}


namespace eval global {
    variable withGUI [expr {![catch {package present Tk}]}]
    variable debug 0
    if {$withGUI} {
        variable applicationName moodss
        variable applicationVersion 15.7
        variable messenger
        variable scroll
        variable canvas
        variable menu
        variable static
        variable windowManager
        variable fileMenuContextHelper
        variable fileMenuContextHelperSaveIndex
        variable saveFile
        variable xWindowManagerInitialOffset 30
        variable yWindowManagerInitialOffset 20
        variable graphNumberOfIntervals 100
        variable viewerHeight 200
        variable viewerWidth 300
        variable canvasHeight [winfo screenheight .]
        variable canvasWidth [winfo screenwidth .]
        variable canvasBackground white
        variable pieLabeler peripheral
        variable viewerColors {#7FFFFF #7FFF7F #FF7F7F #FFFF7F #7F7FFF #FFBF00 #BFBFBF #FF7FFF #FFFFFF}
        variable fileDirectory [pwd]
    } else {
        variable applicationName moomps
        variable applicationVersion 1.2.1
    }
    variable pollTimes
    variable pollTime
    variable documentationDirectory [file dirname $::argv0]/documentation
    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]
    variable login unknown
    catch {set login $::env(USER)}
    catch {set login $::env(LOGNAME)}
    variable fromAddress $login
    variable smtpServers 127.0.0.1
    variable rpm 0
    variable noMail [catch {package require smtp 1.2}]
}

if {$global::withGUI} {

proc updateCanvasSize {args} {
    $global::canvas configure -width $global::canvasWidth -height $global::canvasHeight\
        -scrollregion [list 0 0 $global::canvasWidth $global::canvasHeight]
}

proc updateCanvasBackground {args} {
    $global::canvas configure -background $global::canvasBackground
}

}

set rcsId {$Id: utility.tcl,v 1.33 2002/01/19 16:42:23 jfontain Exp $}


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} {
        foreach name [package names] {
            set package($name) {}
        }
        uplevel _source [list $file]
        foreach name [package names] {
            if {![info exists package($name)]} {
                set ::packageDirectory($name) [file dirname $file]
            }
        }
    }
}

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

if {$global::withGUI} {

proc configureWritableTable {path {tabActivateScript {}}} {
    bindtags $path [list $path [winfo toplevel $path]]
    foreach event {
        ButtonPress-1 B1-Motion ButtonRelease-1 Shift-1 Control-1 B1-Enter B1-Leave <Table_Commit> Shift-Up Shift-Down Shift-Left
        Shift-Right KeyPress BackSpace Delete Escape Alt-KeyPress Meta-KeyPress Control-KeyPress Any-Tab
    } {
        bind $path <$event> [bind Table <$event>]
    }
    bind $path <Return> {catch {%W activate active}}
    bind $path <KP_Enter> {catch {%W activate active}}
    bind $path <Left> [bind Table <Control-Left>]
    bind $path <Right> [bind Table <Control-Right>]
    bind $path <Home> [bind Table <Control-a>]
    bind $path <End> [bind Table <Control-e>]
    bind $path <Shift-Tab> "tkTableNextCell %W 0 {$tabActivateScript}"
    bind $path <KP_Tab> "tkTableNextCell %W 1 {$tabActivateScript}"
    bind $path <Tab> "tkTableNextCell %W 1 {$tabActivateScript}"
    if {[string equal $::tcl_platform(platform) unix]} {
        bind $path <ISO_Left_Tab> "tkTableNextCell %W 0 {$tabActivateScript}"
        bind $path <ButtonRelease-2> {tk_tablePaste %W [%W index @%x,%y]}
    }
}

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

    set label [label .temporary]
    set row [$table cget -roworigin]
    set lastRow [expr {$row+[$table cget -rows]}]
    set column [$table cget -colorigin]
    set lastColumn [expr {$column+[$table cget -cols]}]
    set defaultFont [$table cget -font]
    set titleFont [$table tag cget title -font]
    for {} {$column<$lastColumn} {incr column} {
        set maximum 0
        for {set row [$table cget -roworigin]} {$row<$lastRow} {incr row} {
            if {[string length [$table hidden $row,$column]]>0} continue
            if {[catch {set window [$table window cget $row,$column -window]}]} {
                if {[$table tag includes title $row,$column]} {
                    $label configure -font $titleFont
                } else {
                    $label configure -font $defaultFont
                }
                $label configure -text $data($row,$column)
                set width [winfo reqwidth $label]
            } 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 compareClocks {value1 value2} {
    set value1 [clock scan $value1 -base 0]
    set value2 [clock scan $value2 -base 0]
    if {$value1==$value2} {
        return 0
    } elseif {$value1<$value2} {
        return -1
    } else {
        return 1
    }
}

if {$global::withGUI} {

proc tkTableSkipEmbeddedWindows {path forward} {
    if {$forward} {set parameter 1} else {set parameter -1}
    while {1} {
        set column [$path index active col]
        if {[catch {$path window cget [$path index active] -window}]} break
        ::tk::table::MoveCell $path 0 $parameter
        if {[$path index active col]==$column} break
    }
}

proc tkTableNextCell {path forward {tabActivateScript {}}} {
    set top [$path index origin row]
    set left [$path index origin col]
    set bottom [$path index end row]
    set right [$path index end col]
    catch {
        set row [$path index active row]
        set column [$path index active col]
    }
    if {[info exists row]} {
        if {$forward} {
            ::tk::table::MoveCell $path 0 1
            tkTableSkipEmbeddedWindows $path 1
            if {([$path index active col]==$column)||![catch {$path window cget [$path index active] -window}]} {
                if {$row<$bottom} {
                    $path activate $row,$left
                    ::tk::table::MoveCell $path 1 0
                    tkTableSkipEmbeddedWindows $path 1
                }
            }
        } else {
            ::tk::table::MoveCell $path 0 -1
            tkTableSkipEmbeddedWindows $path 0
            if {([$path index active col]==$column)||![catch {$path window cget [$path index active] -window}]} {
                if {$row>$top} {
                    $path activate $row,$right
                    ::tk::table::MoveCell $path -1 0
                    tkTableSkipEmbeddedWindows $path 0
                }
            }
        }
    } else {
        if {$forward} {
            $path activate $top,$left
            tkTableSkipEmbeddedWindows $path 1
        } else {
            $path activate $bottom,$right
        }
    }
    if {[string length $tabActivateScript]>0} {
        uplevel #0 $tabActivateScript [$path index active row] [$path index active col]
    }
}

}

proc emailAddressError {string} {
    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
}

set rcsId {$Id: getopt.tcl,v 2.4 2001/12/29 00:32:39 jfontain Exp $}


proc parseCommandLineArguments {switches arguments arrayName} {
    upvar $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]
}
    }
    interp eval $interpreter "set ::global::debug $::global::debug"
    interp eval $interpreter {

set rcsId {$Id: record.tcl,v 2.14 2002/01/10 09:50:35 jfontain Exp $}


class record {

    proc record {this args} switched {$args} {
        switched::complete $this
    }

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

    proc options {this} {
        return [list\
            [list -file {} {}]\
        ]
    }

    proc set-file {this value} {}

    proc globalData {} {
        append data "version $global::applicationVersion\n"
        set seconds [clock seconds]
        append data "date [clock format $seconds -format %D] time [clock format $seconds -format %T]\n"
        return $data
    }

if {$global::withGUI} {

    proc data {{snapshot 0}} {
        if {!$snapshot} {
            set data [globalData]
        }
        append data "configuration \{\n"
        foreach name [configuration::variables 0] {
            append data "    [list $name [set ::global::$name]]\n"
        }
        append data \}\n
        set path $::widget::($global::scroll,path)
        append data "width [winfo width $path] height [winfo height $path]\n"
        append data "pollTime $global::pollTime\n"
        append data "modules \{\n"
        foreach instance $modules::(instances) {
            set namespace $modules::instance::($instance,namespace)
            append data "    $namespace \{\n"
            append data "        arguments \{$modules::instance::($instance,arguments)\}\n"
            append data "        tables \{\n"
            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)]
                append data "            $table \{\n"
                append data "                x $x y $y width $width height $height level $level\n"
                foreach {switch value} [dataTable::initializationConfiguration $table] {
                    append data "                $switch [list $value]\n"
                }
                append data "            \}\n"
            }
            append data "        \}\n"
            append data "    \}\n"
        }
        append data \}\n
        append data "viewers \{\n"
        foreach viewer $viewer::(list) {
            append data "    $viewer \{\n"
            set class [classof $viewer]
            append data "        class $class\n"
            if {![string equal $class ::thresholds]} {
                foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $widget::($viewer,path)] {}
                set level [canvasWindowManager::getStackLevel $global::windowManager $widget::($viewer,path)]
                append data "        x $x y $y width $width height $height level $level\n"
            }
            append data "        cells {[viewer::cells $viewer]}\n"
            foreach {switch value} [viewer::initializationConfiguration $viewer] {
                append data "        $switch [list $value]\n"
            }
            append data "    \}\n"
        }
        append data \}
        return $data
    }

    proc write {this} {
        if {[string length $switched::($this,-file)]==0} {
            error {-file option undefined}
        }
        set file [open $switched::($this,-file) w+]
        puts $file [data]
        close $file
    }

}

    proc read {this} {
        variable ${this}data

        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
        }
        if {![regexp {^(version [1-9]\d*\.\d+(\.\d+)*)$} [gets $file]]} {
            puts stderr "file $switched::($this,-file) is not a valid moodss save file"
            exit 1
        }
        seek $file 0
        array set ${this}data [::read $file]
        close $file
    }

    proc modules {this} {
        variable ${this}data

        array set data [set ${this}data(modules)]
        return [lsort -dictionary [array names data]]
    }

    proc modulesWithArguments {this} {
        set list {}
        foreach module [modules $this] {
            moduleData $this $module data
            eval lappend list $module $data(arguments)
        }
        return $list
    }

    proc pollTime {this} {
        variable ${this}data

        return [set ${this}data(pollTime)]
    }

    proc sizes {this} {
        variable ${this}data

        return "[set ${this}data(width)] [set ${this}data(height)]"
    }

    proc viewersData {this} {
        variable ${this}data

        array set data [set ${this}data(viewers)]
        set list {}
        foreach id [lsort -integer [array names data]] {
            catch {unset viewer}
            set viewer(level) {}
            array set viewer $data($id)
            set options {}
            foreach {name value} [array get viewer -*] {
                lappend options $name $value
            }
            if {[string equal $viewer(class) ::thresholds]} {
                lappend list $viewer(class) $viewer(cells) {} {} {} {} {} $options
            } else {
                lappend list $viewer(class) $viewer(cells) $viewer(x) $viewer(y) $viewer(width) $viewer(height) $viewer(level)\
                    $options
            }
        }
        return $list
    }

    proc moduleData {this module dataName} {
        variable ${this}data
        upvar $dataName data

        array set all [set ${this}data(modules)]
        array set data $all($module)
    }

    proc tableData {this module creationIndex dataName} {
        variable ${this}data
        upvar $dataName data

        moduleData $this $module moduleData
        array set tablesData $moduleData(tables)
        unset moduleData
        set data(level) {}
        set index [lindex [lsort -integer [array names tablesData]] $creationIndex]
        if {[string length $index]>0} {
            array set data $tablesData([lindex [lsort -integer [array names tablesData]] $creationIndex])
            return 1
        } else {
            return 0
        }
    }

    proc tableWindowManagerData {this module creationIndex} {
        if {![tableData $this $module $creationIndex data]} {
            return {}
        }
        return [list $data(x) $data(y) $data(width) $data(height) $data(level)]
    }

    proc tableOptions {this module creationIndex} {
        if {![tableData $this $module $creationIndex data]} {
            return {}
        }
        set options {}
        foreach {name value} [array get data -*] {
            lappend options $name $value
        }
        return $options
    }

    proc configurationData {this} {
        variable ${this}data

        return [set ${this}data(configuration)]
    }

    proc snapshot {} {
        set (data) [data 1]
    }

    proc changed {} {
        if {[info exists (data)]} {
            return [string compare $(data) [data 1]]
        } else {
            return 0
        }
    }

}

set rcsId {$Id: viewer.tcl,v 2.14 2002/01/16 20:38:54 jfontain Exp $}


class viewer {

    set (list) {}

    proc viewer {this} {
        lappend (list) $this
    }

    proc ~viewer {this} {
        variable ${this}traces

        foreach array [array names ${this}traces] {
            trace vdelete ${array}(updates) w "viewer::update $this $array"
        }
        catch {unset ${this}traces}
        if {[info exists ($this,drop)]} {
            delete $($this,drop)
        }
        ldelete (list) $this
    }

    virtual proc supportedTypes {this}

    proc view {this cells} {
        foreach cell $cells {
            parse $cell array row column type
            if {![info exists $array]} continue
            if {[lsearch -exact [supportedTypes $this] $type]<0} {
                lifoLabel::flash $global::messenger "cannot display data of type $type"
if {$global::withGUI} bell
                return
            }
            lappend data($array) $row $column
        }
        foreach {array list} [array get data] {
            foreach {row column} $list {
                monitorCell $this $array $row $column
if {$global::withGUI} {
                setCellColor $this $array $row $column [thresholds::cellColor $array $row $column]
            }
}
        }
        foreach array [array names data] {
            update $this $array
        }
    }

    virtual proc monitorCell {this array row column}

    proc parse {dataCell arrayName rowName columnName typeName} {
        upvar $arrayName array $rowName row $columnName column $typeName type

        if {([scan $dataCell {%[^(](%u,%u)} array row column]!=3)||($row<0)||($column<0)} {
            error "\"$dataCell\" is not a valid array cell"
        }
        set type [set ${array}($column,type)]
    }

    proc updateInterval {value} {
        foreach viewer $(list) {
            catch {composite::configure $viewer -interval $value}
        }
    }

    proc label {array row column} {
        set label {}
        set identifier [modules::identifier $array]
        if {[string length $identifier]>0} {
            set label "$identifier: "
        }
        if {[catch {set ${array}(indexColumns)} columns]} {
            set columns 0
        }
        foreach index $columns {
            if {[catch {set ${array}($row,$index)} value]} {
                append label {? }
            } else {
                append label "$value "
            }
        }
        append label [set ${array}($column,label)]
        return $label
    }

    virtual proc update {this array args}

    proc registerTrace {this array} {
        variable ${this}traces

        if {![info exists ${this}traces($array)]} {
            trace variable ${array}(updates) w "viewer::update $this $array"
            set ${this}traces($array) 0
        }
        incr ${this}traces($array)
    }

    proc unregisterTrace {this array} {
        variable ${this}traces

        if {[incr ${this}traces($array) -1]<=0} {
            trace vdelete ${array}(updates) w "viewer::update $this $array"
            unset ${this}traces($array)
        }
    }

    virtual proc cells {this}

    virtual proc initializationConfiguration {this} {
        return {}
    }

if {$global::withGUI} {

    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 dragSite::data(DATACELLS)} data]} {
            view $this $data
        } elseif {![catch {set dragSite::data(VIEWER)} data]} {
            mutate $this $data
        } elseif {[info exists dragSite::data(KILL)]} {
            delete $this
        }
    }

    proc mutate {this class} {
        if {[string equal $class [classof $this]]} return
        set viewer [eval new $class $global::canvas -draggable [composite::cget $this -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 {some data cells no longer exist}
        }
        foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $widget::($this,path)] {}
        set level [canvasWindowManager::getStackLevel $global::windowManager $widget::($this,path)]
        delete $this
        manageViewer $viewer 1 -static $global::static -setx $x -sety $y -setwidth $width -setheight $height -level $level
    }

    proc changeAllCellsColor {array row column color} {
       foreach viewer $(list) {
           setCellColor $viewer $array $row $column $color
       }
    }

    virtual proc setCellColor {this array row column color}

}

    proc numericType {type} {
        switch $type {
            integer - real {return 1}
            default {return 0}
        }
    }

}

set rcsId {$Id: threshold.tcl,v 1.89 2002/01/19 16:47:02 jfontain Exp $}


class thresholds {

    variable levelColor
    array set levelColor {debug blue info white notice yellow warning orange error red critical red alert red emergency red}
    set (levels) {debug info notice warning error critical alert emergency}
    set (colors) {red orange yellow white green cyan blue ? {}}

    variable help
    set help(active) "whether the threshold\ncondition is ckeched"
    set help(type) "threshold type\n(click for next type)"
    set help(level) "importance level (used by\nmoomps for system logging\nand included in email alert)"
    set help(color) "color showing threshold\ncondition occured\n(click to edit)"
    set help(value) {threshold value}
    set help(source) "data description\n(can be edited)"

if {$global::withGUI} {

    set (default,button,background) $widget::option(button,background)
    variable screenIcon [image create photo -data {
        R0lGODlhFQARAKUAAPgA+JiYmAAAAOjw8NjY2ODg4NDQ0MjIyMDAwLi4uKioqKiomFhYWOjo6NjY0Ojk4NDQwMjAyFhscPDw8Pj4+ODs8GBgYMjEsGBYYDh4
        gEiQmDBscDhQUBBESMjc4KjM0IjAwHiwuFigqCiEkAhweABYaNDo6ODg2HBscICEaIiIiLCwsAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAVABEAAAbwQIAwEBAYj0hkQAgIDAiFAoFgOCASCcWCaGAsAw2H9BElQA4RrJYg8QYmFAp8
        MhlMGo1KI9qwWLwCcnZ1eFEOBBcHVhIWGEVyGRqSGRsbHB2YHQUIfoB1GhUUFR4fICEiIyQlFREWbUV3Eh4VJh+lIqiqm52wDRukth8hIRqpJQWtr4EOG8Gm
        p8WqDQmMgAMFGyHP0KkkJCetjUVPHCKnuMXdx5x/RQ0EHRIZEpUb3qqayYANFw0PeCcanAgY5cSVNgKKVEikCIFDhwkiPEQgISGAhEQyatwYwAuTAAZQpFAR
        YAWCFQFUpEDBEsUSIUEAADs=
    }]

}

    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 {ascii clock dictionary integer real}
    }

    proc set-configurations {this value} {
        set ($this,initializeIndex) 0                                        
    }

if {$global::withGUI} {

    proc edit {} {
        variable singleton
        variable thresholds
        variable screenIcon

        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 panes [new panner $frame -panes 3]
        set ($this,panes) $panes
        pack $widget::($panes,path) -fill both -expand 1

        pack [createTable $this $panner::($panes,frame1)] -anchor nw -fill both -expand 1

        set details [frame $panner::($panes,frame2).details]
        set ($this,cellLabel) [label $details.cellLabel -font $font::(mediumBold) -text {Original cell:} -state disabled]
        grid $($this,cellLabel) -row 0 -column 0 -sticky nw
        set ($this,cell) [label $details.cell -font $font::(mediumNormal) -relief sunken -width 20]
        grid $($this,cell) -row 0 -column 1 -sticky nwe -padx 5
        set ($this,emailsLabel) [label $details.emailsLabel -font $font::(mediumBold) -text Emails: -state disabled]
        grid $($this,emailsLabel) -row 0 -column 2 -sticky ne
        set ($this,emails) [new listEntry $details -width 20 -height 2 -state disabled]
        if {$global::noMail} {
            $details.emailsLabel configure -state disabled
        }
        grid $widget::($($this,emails),path) -row 0 -column 3 -rowspan 3 -columnspan 100 -sticky nwe
        set ($this,emailShot) 0
        set ($this,shot) [checkbutton $details.shot -image $screenIcon -variable thresholds::($this,emailShot) -state disabled]
        grid $($this,shot) -row 1 -column 2 -sticky nw
        lappend ($this,objects) [new widgetTip -path $($this,shot) -text "attach screen shot\nto email message"]
        set ($this,currentLabel) [label $details.currentLabel -font $font::(mediumBold) -text {Current value:} -state disabled]
        grid $($this,currentLabel) -row 1 -column 0 -sticky nw
        set ($this,current) [label $details.current -font $font::(mediumNormal) -relief sunken -width 20]
        grid $($this,current) -row 1 -column 1 -sticky nwe -padx 5

        grid columnconfigure $details 1 -weight 1
        grid columnconfigure $details 3 -weight 2
        pack $details -fill x -expand 0

        set ($this,scriptLabel) [label $panner::($panes,frame2).scriptLabel -font $font::(mediumBold) -text Script: -state disabled]
        pack $($this,scriptLabel) -anchor nw
        set ($this,script) [new scroll text $panner::($panes,frame2) -height 50]
        pack $widget::($($this,script),path) -fill both -expand 1
        set ($this,scriptText) $composite::($($this,script),scrolled,path)
        $($this,scriptText) configure -state disabled

        set ($this,testLabel) [label $panner::($panes,frame3).testLabel\
            -font $font::(mediumBold) -text {Test trace:} -state disabled\
        ]
        pack $($this,testLabel) -anchor nw
        set ($this,test) [new scroll text $panner::($panes,frame3) -height 50]
        pack $widget::($($this,test),path) -fill both -expand 1
        set ($this,testText) $composite::($($this,test),scrolled,path)
        $($this,testText) configure -state disabled

        pack [frame $frame.separator3 -relief sunken -borderwidth 1 -height 2] -pady 2 -fill x

        set buttons [frame $frame.buttons]
        set ($this,testButton) [button $buttons.test -text Test -command "thresholds::test $this" -state disabled]
        place $($this,testButton) -anchor n -relx 0.3
        set ($this,deleteButton) [button $buttons.delete -text Delete -command "thresholds::delete $this" -state disabled]
        place $($this,deleteButton) -anchor n -relx 0.7
        $buttons configure -height [winfo reqheight $($this,testButton)]
        pack $buttons -fill x -expand 0

        set ($this,selector) [new objectSelector -selectcommand "thresholds::setRowsState $this"]
        set script [bind $($this,tablePath) <ButtonPress-1>]
        bind $($this,tablePath) <ButtonPress-1> "if {\[thresholds::select $this \[%W index @0,%y row\]\]} {$script}"
        dialogBox::display $dialog $frame

        set ($this,dialog) $dialog
        foreach threshold [lsort -command threshold::comparison -decreasing $thresholds] {
            display $this $threshold
        }
        adjustTableColumns $($this,tablePath)
        drawTableLimits $this
    }

}

    proc monitorCell {this array row column} {
        variable thresholds

        viewer::registerTrace $this $array
        set cell ${array}($row,$column)
        set length [llength $switched::($this,-configurations)]
        if {$length>0} {
            set threshold\
                [eval new threshold $cell [lindex $switched::($this,-configurations) $($this,initializeIndex)]]
            if {[incr ($this,initializeIndex)]==$length} {
                switched::configure $this -configurations {}
                unset ($this,initializeIndex)
            }
        } else {
            set threshold [new threshold $cell]
            switched::configure $threshold\
                -label [viewer::label $threshold::($threshold,array) $threshold::($threshold,row) $threshold::($threshold,column)]
        }
        lappend thresholds $threshold
        if {[info exists ($this,dialog)]} {
            set (held,$threshold) {}
            display $this $threshold
        }
    }

if {$global::withGUI} {

    proc display {this threshold} {
        variable data
        variable number

        set path $($this,tablePath)
        set row [expr {[$path cget -rows]-1}]
        $path configure -rows [expr {$row+2}]
        set background [$path cget -background]
        set font [$path cget -font]

        set data($row,$number(threshold)) $threshold
        $path spans $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 \[thresholds::row $this $threshold\]"
        $path window configure $row,$number(active)\
            -window $button -padx 1 -pady 2 -relief sunken -borderwidth {1 0 1 0} -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 \[thresholds::row $this $threshold\]
        "
        $path window configure $row,$number(type) -window $label -relief sunken -pady 2 -borderwidth {1 0 1 0}

        set data($row,$number(level)) [switched::cget $threshold -level]
        set menu [new optionMenu $path -font $font::(tinyNormal) -choices $(levels) -text [switched::cget $threshold -level]]
        composite::configure $menu base -highlightthickness 0
        $path window configure $row,$number(level)\
            -window $widget::($menu,path) -padx 1 -pady 2 -relief sunken -borderwidth {1 0 1 0} -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 \[thresholds::row $this $threshold\]"
        $path window configure $row,$number(color)\
            -window $button -padx 1 -pady 2 -relief sunken -borderwidth {1 0 1 0} -sticky nsew
        composite::configure $menu -command "thresholds::updateLevel $this $threshold $button"

        set data($row,$number(value)) [switched::cget $threshold -value]
        set data($row,$number(source)) [switched::cget $threshold -label]
        $path height $row [linesCount $data($row,$number(source))]
        set data($row,$number(addresses)) [switched::cget $threshold -addresses]
        set data($row,$number(script)) [switched::cget $threshold -script]
        set data($row,$number(label))\
            [viewer::label $threshold::($threshold,array) $threshold::($threshold,row) $threshold::($threshold,column)]
        set data($row,$number(emailShot)) [switched::cget $threshold -emailshot]
        ::update idletasks
        adjustTableColumns $path
        ::update idletasks
        drawTableLimits $this
    }

}

    proc update {this array args} {
        variable thresholds

        if {[info exists ($this,dialog)]} {
            if {[info exists ($this,selected)]} {
                updateCurrentValue $this $($this,selected)
            }
        } else {
            foreach threshold $thresholds {
                threshold::check $threshold $array
            }
        }
    }

    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
    }

if {$global::withGUI} {

    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"\
        ]
        set ($this,helpTip) [linkedHelpWidgetTip $composite::($dialog,help,path)]
        if {[info exists geometry]} {
            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

        set scroll [new scroll table $parentPath -height 110]
        set ($this,scrolledTable) $scroll
        set path $composite::($scroll,scrolled,path)
        $path configure -variable thresholds::data -font $font::(mediumNormal) -colstretchmode last -cursor {} -bordercursor {}\
            -highlightthickness 1 -titlerows 1 -roworigin -1 -rows 1 -sparsearray 0 -exportselection 0
        set column 0
        foreach title {active threshold addresses script label emailShot type level color value source} {
            set data(-1,$column) $title
            set number($title) $column
            incr column
        }
        $path configure -cols [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 $title]
            $path window configure $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}]
        $path spans -1,$number(active) 0,$(hiddenColumns)
        configureWritableTable $path "thresholds::selectionFromTab $this"
        $path tag configure active -background {} -foreground black -relief sunken

        $path configure -borderwidth {1 0 1 0}
        $path tag configure sel -background {} -foreground black -borderwidth {1 0 2 1}
        $path tag configure lastselectedcell -borderwidth {1 1 2 1}
        $path tag raise lastselectedcell sel
        $path tag configure lastcell -borderwidth 1
        $path tag configure lastcolumn -borderwidth {1 1 1 0}
        $path tag configure lastrow -borderwidth {1 0 1 1}
        $path tag col lastcolumn $number(source)
        set ($this,drop) [new dropSite -path $path -formats DATACELLS -command "viewer::view $this \$dragSite::data(DATACELLS)"]
        set ($this,tablePath) $path
        drawTableLimits $this
        return $widget::($scroll,path)
    }

    proc done {this destroy} {
        variable data
        variable thresholds
        variable deleted
        variable number

        if {$destroy} {
            eval ::delete $($this,helpTip) $($this,selector) $($this,objects) $($this,emails) $($this,script) $($this,test)\
                $($this,panes) $($this,scrolledTable) $($this,drop)
            unset ($this,dialog) ($this,tablePath) ($this,helpTip) ($this,selector) ($this,objects) ($this,emails) ($this,cell)\
                 ($this,current) ($this,script) ($this,scriptText) ($this,test) ($this,testText) ($this,panes)\
                 ($this,scrolledTable) ($this,drop)

            catch {unset ($this,selected)}
            unset data
            foreach threshold $thresholds {
                if {[info exists (held,$threshold)]} {
                    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]
        } else {
            if {[info exists ($this,selected)]} {
                set row $($this,selected)
                set data($row,$number(addresses)) [composite::cget $($this,emails) -list]
                if {![checkEmails $this $row]} 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)) [composite::cget $($this,emails) -list]
                    set data($row,$number(script)) [string trim [$($this,scriptText) get 1.0 end]]
                    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)) -value $data($row,$number(value))\
                    -label $data($row,$number(source)) -addresses $data($row,$number(addresses))\
                    -script $data($row,$number(script)) -emailshot $data($row,$number(emailShot))
            }
            if {[info exists deleted]} {
                foreach threshold $deleted {
                    viewer::unregisterTrace $this $threshold::($threshold,array)
                    ::delete $threshold
                }
                unset deleted
            }
            array unset {} held,*
            ::delete $($this,dialog)
        }
    }

}

    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 {}
            foreach configuration [switched::configure $threshold] {
                foreach {option default value} $configuration {}
                lappend list $option $value
            }
            lappend arguments $list
        }
        return [list -configurations $arguments]
    }

if {$global::withGUI} {

    proc test {this} {
        variable data
        variable number

        set row $($this,selected)
        set threshold $data($row,$number(threshold))
        catch {$($this,tablePath) activate active}
        set script [string trim [$($this,scriptText) get 1.0 end]]
        set emails [composite::cget $($this,emails) -list]
        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 -script $script -emailshot $($this,emailShot)\
        ]
        $($this,testText) configure -state normal
        $($this,testText) insert end [threshold::test $temporary]\n
        $($this,testText) see end
        $($this,testText) configure -state disabled
        ::delete $temporary
    }

    proc delete {this} {
        variable thresholds
        variable deleted
        variable data
        variable number

        set path $($this,tablePath)
        set row $($this,selected)
        deselect $this $row
        set threshold $data($row,$number(threshold))
        $path delete rows $row
        ldelete thresholds $threshold
        lappend deleted $threshold
        array unset data [llength $thresholds],\[0-9\]*
        $path activate -1,0
        drawTableLimits $this
    }

    proc setRowsState {this rows select} {
        drawTableLimits $this
        set path $($this,tablePath)
        set right [expr {[$path cget -cols]-1}]
        if {$select} {
            foreach row $rows {
                $path selection set $row,0 $row,$right
                embeddedWindowsBorder $this $row {1 0 2 1}
                $path tag row sel $row
                $path tag cell lastselectedcell $row,$right
            }
        } else {
            foreach row $rows {
                $path selection clear $row,0 $row,$right
                embeddedWindowsBorder $this $row {1 0 1 0}
                $path tag row {} $row
                $path tag cell {} $row,$right
            }
        }
    }

    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 row} {
        variable data
        variable number

        if {$row<0} {
            return 1
        }
        set noChange 0
        if {[info exists ($this,selected)]} {
            set selected $($this,selected)
            set data($selected,$number(addresses)) [composite::cget $($this,emails) -list]
            set data($selected,$number(script)) [string trim [$($this,scriptText) get 1.0 end]]
            set data($selected,$number(emailShot)) $($this,emailShot)
            set noChange [expr {$row==$selected}]
        }
        if {$noChange} {
            return 1
        }
        if {[info exists selected]&&![checkEmails $this $selected]} {
            return 0
        }
        set ($this,selected) $row
        selector::select $($this,selector) $row
        $($this,testButton) configure -state normal
        $($this,deleteButton) configure -state normal
        if {!$global::noMail} {
            $($this,emailsLabel) configure -state normal
            composite::configure $($this,emails) -state normal
            $($this,shot) configure -state normal
        }
        composite::configure $($this,emails) -list $data($row,$number(addresses))
        $($this,cellLabel) configure -state normal
        $($this,cell) configure -text $data($row,$number(label))
        $($this,currentLabel) configure -state normal
        $($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,emailShot) $data($row,$number(emailShot))
        updateCurrentValue $this $row
        return 1
    }

    proc deselect {this row} {
        if {$row<0} return
        unset ($this,selected)
        selector::deselect $($this,selector) $row
        composite::configure $($this,emails) -list {} -state disabled
        $($this,cellLabel) configure -state disabled
        $($this,currentLabel) configure -state disabled
        $($this,emailsLabel) configure -state disabled
        $($this,scriptLabel) configure -state disabled
        $($this,scriptText) configure -state disabled
        $($this,testLabel) configure -state disabled
        $($this,testButton) configure -state disabled
        $($this,deleteButton) configure -state disabled
        $($this,cell) configure -text {}
        $($this,current) configure -text {}
        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 {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::(smallNormal)
        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
        foreach color $(colors) {
            switch $color {
                {} {
                    $menu add command -label ...
                }
                ? {
                    $menu add command -label { ?}
                }
                default {
                    $menu add command -label {   } -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

        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 setCellColor {this array row column color} {}

    proc cellColor {array row column} {
        variable thresholds

        set color {}
        foreach threshold $thresholds {
            if {\
                [info exists threshold::($threshold,cellColor)]&&[switched::cget $threshold -active]&&\
                [string equal $threshold::($threshold,array) $array]&&\
                [string equal $threshold::($threshold,row) $row]&&[string equal $threshold::($threshold,column) $column]\
            } {
                set color $threshold::($threshold,cellColor)
            }
        }
        return $color
    }

if {$global::withGUI} {

    proc selectionFromTab {this row column} {
        select $this $row
    }

    proc drawTableLimits {this} {
        variable number

        set path $($this,tablePath)
        set previous [$path tag row lastrow]
        if {[llength $previous]>0} {
            $path tag row {} $previous
            embeddedWindowsBorder $this $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,$number(source) -borderwidth 1
        } else {
            $path configure -borderwidth {1 0 1 0}
            $path window configure -1,$number(source) -borderwidth {1 1 1 0}
            $path tag row lastrow $row
            $path tag cell lastcell [$path index end]
            embeddedWindowsBorder $this $row {1 0 1 1}
        }
    }

    proc embeddedWindowsBorder {this row widths} {
        variable number

        set path $($this,tablePath)
        $path window configure $row,$number(active) -borderwidth $widths
        $path window configure $row,$number(type) -borderwidth $widths
        $path window configure $row,$number(color) -borderwidth $widths
        $path window configure $row,$number(level) -borderwidth $widths
    }

    proc reset {this} {
        variable thresholds

        if {[info exists ($this,dialog)]} {
            ::delete $($this,dialog)
        }
        foreach threshold $thresholds {
            viewer::unregisterTrace $this $threshold::($threshold,array)
            ::delete $threshold
        }
        set thresholds {}
    }

}

    proc checkEmails {this row} {
        variable data
        variable number

        set errors {}
        foreach email $data($row,$number(addresses)) {
            set message [emailAddressError $email]
            if {[string length $message]==0} continue
            append errors "$email: $message\n"
        }
        if {[string length $errors]>0} {
            tk_messageBox -parent $widget::($($this,dialog),path) -title {moodss: Email error} -type ok -icon error -message $errors
            return 0
        } else {
            return 1
        }
    }

    proc activeEmails {this} {
        variable thresholds

        set number 0
        foreach threshold $thresholds {
            if {![switched::cget $threshold -active]} continue
            incr number [llength [switched::cget $threshold -addresses]]
        }
        return $number
    }


}

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 (mailMessage) \
{"%s" data value is now "%v",
which triggered the "%T" threshold of "%t".}
        set (logMessage) {"%s" = "%v" (triggered "%T" threshold "%t")}
        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,active) 0
            switched::complete $this
        }

        proc ~threshold {this} {
            if {$($this,active)&&$($this,colored)} {
                changeAllCellsColor $($this,array) $($this,row) $($this,column) {}
            }
        }

        proc options {this} {
            return [list\
                [list -active 0 0]\
                [list -addresses {} {}]\
                [list -color white]\
                [list -emailshot 0 0]\
                [list -label {} {}]\
                [list -level info info]\
                [list -script {} {}]\
                [list -type up up]\
                [list -value {} {}]\
            ]
        }

        proc set-active {this value} {
            if {$value} {
                check $this $($this,array)
            } elseif {$($this,active)} {
                if {$($this,colored)} {
                    changeAllCellsColor $($this,array) $($this,row) $($this,column) {}
                    set ($this,cellColor) {}
                }
                set ($this,active) 0
            }
        }

        proc set-addresses {this value} {}

        proc set-color {this value} {
            set ($this,colored) [string length $value]
            if {$($this,active)} {
                changeAllCellsColor $($this,array) $($this,row) $($this,column) $value
                set ($this,cellColor) $value
            }
        }

        proc set-emailshot {this value} {}

        proc set-label {this value} {}

        proc set-level {this value} {
            if {[lsearch -exact $thresholds::(levels) $value]<0} {
                error {invalid level value}
            }
        }

        proc set-script {this value} {}

        proc set-type {this value} {
            check $this $($this,array)
        }

        proc set-value {this value} {
            check $this $($this,array)
        }

        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,-active)} return
            if {![string equal $array $($this,array)]} return
            set threshold [string trim $switched::($this,-value)]
            catch {set value [set $($this,cell)]}
            set condition 0
            if {![info exists value]||([string equal $value ?]&&$($this,numeric))} {
                if {[string equal $switched::($this,-type) unknown]} {
                    act $this {} ?
                    set condition 1
                }
            } else {
                if {![string equal $switched::($this,-type) unknown]&&[compare $this $threshold $value]} {
                    act $this $threshold $value
                    set condition 1
                }
            }
            if {$($this,colored)&&($condition!=$($this,active))} {
                if {$condition} {
                    changeAllCellsColor $($this,array) $($this,row) $($this,column) $switched::($this,-color)
                    set ($this,cellColor) $switched::($this,-color)
                } else {
                    changeAllCellsColor $($this,array) $($this,row) $($this,column) {}
                    set ($this,cellColor) {}
                }
            }
            set ($this,active) $condition
        }

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)]
            if {[string length $threshold]==0} {
                switch $($this,cellType) {
                    clock {set threshold [clock format [clock seconds]]}
                    integer {set threshold 10}
                    real {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
            set label [viewer::label $($this,array) $($this,row) $($this,column)]
            regsub -all %c $text $label 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 {[string length $threshold]==0} {
                return 0
            }
            switch $type {
                differ {return [expr {[compareClocks $value $threshold]!=0}]}
                down {return [expr {[compareClocks $value $threshold]<0}]}
                equal {return [expr {[compareClocks $value $threshold]==0}]}
                up {return [expr {[compareClocks $value $threshold]>0}]}
            }
        }

        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 length $threshold]==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-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,-script)]>0} {
                set script [replacePercents $this $threshold $value $switched::($this,-script)]
                if {[catch {exec 2>@ stdout sh -c $script} ($this,output)]} {
                    modules::trace thresholds thresholds "$switched::($this,-label): $($this,output)"
                }
            }
            if {!$global::withGUI} {
                writeLog\
                    "($switched::($this,-level)) [replacePercents $this $threshold $value $(logMessage)]" $switched::($this,-level)
            }
            if {!$global::noMail&&[llength $switched::($this,-addresses)]>0} {
                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 [replacePercents $this $threshold $value $(mailMessage)]\
                            ]\
                            [mime::initialize -canonical image/gif -file $shot]\
                        ]\
                    ]
                } else {
                    set token\
                        [mime::initialize -canonical text/plain -string [replacePercents $this $threshold $value $(mailMessage)]]
                }
                lappend headers -servers [list $global::smtpServers]
                lappend headers -header [list From $global::fromAddress]
                foreach address $switched::($this,-addresses) {
                    lappend headers -header [list To $address]
                }
                lappend headers -header [list Subject "$global::applicationName threshold $switched::($this,-level) message"]
                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 thresholds 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 thresholds thresholds $message
                            } else {
                                writeLog $message error
                            }
                        }
                    }
                }
                mime::finalize $token -subordinates all
                if {[info exists shot]} {
                    file delete $shot
                }
            }
        }

        proc comparison {threshold1 threshold2} {
            variable level

            if {![info exists level]} {
                set index 0
                foreach name $thresholds::(levels) {
                    set level($name) $index
                    incr index
                }
                unset name index
            }
            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
            }
        }

    }

}

set rcsId {$Id: sumtable.tcl,v 2.22 2001/12/29 00:32:39 jfontain Exp $}


class summaryTable {

    set (nextDataIndex) 0

if {$global::withGUI} {
    proc summaryTable {this parentPath args} composite {[new frame $parentPath] $args} viewer {} {
        composite::complete $this
        constructor $this
    }
} else {
    proc summaryTable {this args} switched {$args} viewer {} {
        switched::complete $this
        constructor $this
    }
}

    proc constructor {this} {
        variable $($this,dataName)

        array set $($this,dataName) {
            updates 0
            0,label data 0,type ascii 0,message {data cell description}
            1,label current 1,type real 1,message {current value}
            2,label average 2,type real 2,message {average value since viewer creation}
            3,label minimum 3,type real 3,message {minimum value since viewer creation}
            4,label maximum 4,type real 4,message {maximum value since viewer creation}
            sort {0 increasing}
            indexColumns 0
        }
        set ($this,nextRow) 0
if {$global::withGUI} {
        set table [new dataTable $widget::($this,path)\
            -data summaryTable::$($this,dataName) -draggable $composite::($this,-draggable)\
            -titlefont $composite::($this,-titlefont) -columnwidths $composite::($this,-columnwidths)\
        ]
        viewer::setupDropSite $this $dataTable::($table,tablePath)
        if {$composite::($this,-draggable)} {
            dragSite::provide $dataTable::($table,drag) OBJECTS "summaryTable::dragData $this"
            dragSite::provide $dataTable::($table,drag) DATACELLS "summaryTable::dragData $this"
        }
        pack $widget::($table,path) -fill both -expand 1
        set ($this,dataTable) $table
}
    }

    proc ~summaryTable {this} {
        variable [set dataName $($this,dataName)]
if {$global::withGUI} {
        variable ${this}cellRow
        foreach {name wish} [array get {} $this,rowLastWish,*] {
            delete $wish
        }
        delete $($this,dataTable)
        catch {unset ${this}cellRow}
}
        incr ${dataName}(updates)
        unset $dataName
        if {[string length $composite::($this,-deletecommand)]>0} {
            uplevel #0 $composite::($this,-deletecommand)
        }

    }

    proc reset {} {
        set (nextDataIndex) 0
    }

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 -columnwidths {} {}]\
            [list -dataindex {}]\
            [list -deletecommand {} {}]\
            [list -draggable 0 0]\
            [list -titlefont $font $font]\
        ]
    }

if {$global::withGUI} {
    proc set-columnwidths {this value} {
        if {![info exists ($this,dataTable)]} return
        composite::configure $($this,dataTable) -columnwidths $value
    }
} else {
    proc set-columnwidths {this value} {}
}

    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
        }
        set ($this,dataName) $(nextDataIndex)data
        incr (nextDataIndex)
    }

    proc set-deletecommand {this value} {}

    foreach option {-draggable -titlefont} {
        proc set$option {this value} "
if {$global::withGUI} {
            set complete \$composite::(\$this,complete)
} else {
            set complete \$switched::(\$this,complete)
}
            if {\$complete} {
                error {option $option cannot be set dynamically}
            }
        "
    }

    proc supportedTypes {this} {
        return {integer real}
    }

    proc monitorCell {this array row column} {
        variable [set dataName $($this,dataName)]
        variable ${this}cellRow

        set cell ${array}($row,$column)
        if {[info exists ${this}cellRow($cell)]} return
        viewer::registerTrace $this $array
        set label [viewer::label $array $row $column]
        set row $($this,nextRow)
        set ${dataName}($row,0) $label
        if {[catch {set $cell} current]} {
            set ${dataName}($row,1) ?
        } else {
            set ${dataName}($row,1) $current
        }
        array set $dataName [list $row,2 ? $row,3 ? $row,4 ?]
        set ${dataName}($row,updates) 0
        set ${dataName}($row,sum) 0.0
        set ${this}cellRow($cell) $row
if {$global::withGUI} {
        set ($this,rowLastWish,$row) [new lastWish "summaryTable::deleteRow $this $cell"]
}
        incr ($this,nextRow)
        if {[string first ? $label]>=0} {
            set ($this,relabel,$row) {}
        }
        set ${dataName}(updates) 0
    }

    proc update {this array args} {
        variable [set dataName $($this,dataName)]
        variable ${this}cellRow

        foreach {cell row} [array get ${this}cellRow] {
            if {[string first $array $cell]<0} continue
            if {[catch {set $cell} current]||[string equal $current ?]} {
                set ${dataName}($row,1) ?
            } else {
                if {[info exists ($this,relabel,$row)]} {
                    viewer::parse $cell array cellRow cellColumn type
                    set label [viewer::label $array $cellRow $cellColumn]
                    set ${dataName}($row,0) $label
                    if {[string first ? $label]<0} {
                        unset ($this,relabel,$row)
                    }
                }
                set ${dataName}($row,1) $current
                set sum [expr {[set ${dataName}($row,sum)]+$current}]
                set ${dataName}($row,2) [format %.2f [expr {$sum/[incr ${dataName}($row,updates)]}]]
                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 ${dataName}($row,sum) $sum
            }
        }
        incr ${dataName}(updates)
    }

    proc cells {this} {
        variable ${this}cellRow

        return [array names ${this}cellRow]
    }

if {$global::withGUI} {
    proc dragData {this format} {
        variable ${this}cellRow

        switch $format {
            OBJECTS {
                foreach cell [dataTable::dragData $($this,dataTable) $format] {
                    regexp {\(([^,]+)} $cell dummy row
                    set selected($row) {}
                }
                set lastWishes {}
                foreach row [array names selected] {
                    lappend lastWishes $($this,rowLastWish,$row)
                }
                if {[llength $lastWishes]==0} {
                    return $this
                } else {
                    return $lastWishes
                }
            }
            DATACELLS {
                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 [set dataName $($this,dataName)]
        variable ${this}cellRow

        set row [set ${this}cellRow($cell)]
        unset ${dataName}($row,0) ${dataName}($row,1) ${dataName}($row,2) ${dataName}($row,3) ${dataName}($row,4)\
            ${dataName}($row,updates) ${dataName}($row,sum) ($this,rowLastWish,$row)
        unset ${this}cellRow($cell)
        dataTable::update $($this,dataTable)
    }

    proc initializationConfiguration {this} {
        scan $($this,dataName) %u index
        set list [list -dataindex $index]
        foreach {option value} [dataTable::initializationConfiguration $($this,dataTable)] {
            if {[string equal $option -columnwidths]} {
                lappend list -columnwidths $value
                break
            }
        }
        return $list
    }

if {$global::withGUI} {
    proc setCellColor {this array row column color} {
        variable [set dataName $($this,dataName)]
        variable ${this}cellRow

        set source ${array}($row,$column)
        foreach {cell row} [array get ${this}cellRow] {
            if {[string equal $cell $source]} {
                dataTable::setCellColor $($this,dataTable) $row 1 $color
                return
            }
        }
    }
} else {
    proc setCellColor {this array row column color} {}
}

}

set rcsId {$Id: module.tcl,v 2.30 2001/12/29 00:32:39 jfontain Exp $}


class module {

    proc module {this name index} {
        if {[string length $index]==0} {
            set index [newIndex $name]
        } else {
            addIndex $name $index
        }
        set ($this,name) $name
        set ($this,index) $index
    }

    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 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 index $($this,index)
        if {$index==0} {
            set namespace $name
        } else {
            set namespace ${name}<$index>
        }

        set directory [pwd]
        cd $::packageDirectory($name)

        set interpreter [interp create]
        $interpreter eval {
            proc bgerror {error} {
                puts stderr $::errorInfo
                exit 1
            }
        }
        $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) -2147483648
        $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)
        namespace eval ::$namespace [subst -nocommands {proc update {args} {$interpreter eval ::${name}::update \$args}}]
        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
    }

    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
        if {$global::withGUI} {
            lifoLabel::push $global::messenger "$namespace data update..."
            update idletasks
        }
        array unset ::${namespace}::data {[0-9]*,[0-9]*}
        synchronize $this {[0-9]*,[0-9]*}
        set ::${namespace}::data(updates) $updates
        if {$global::withGUI} {
            lifoLabel::pop $global::messenger
        }
    }

    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 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::utilityFunctions
        array set ::${namespace}::data [$interpreter eval hash_string(%${name}::data)]
        if {$global::withGUI} {
            proc ::${namespace}::update {} "
                variable data
                lifoLabel::push $global::messenger {$namespace data update...}
                $interpreter eval ${name}::update()
                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
                }
                lifoLabel::pop $global::messenger
            "
        } else {
            proc ::${namespace}::update {} "
                variable data
                $interpreter eval ${name}::update()
                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
                }
            "
        }
        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()"
        }
        set ($this,version) [$interpreter eval \$${name}::VERSION]
    }

    proc loadPython {this file} {
        set name $($this,name)
        set namespace $($this,namespace)
        if {[catch {package require tclpython2 2.0.1} message]&&[catch {package require tclpython 2} message]} {
            error "$message\nis the tclpython2 or tclpython package installed?"
        }
        set interpreter [python::interp new]
        set ($this,interpreter) $interpreter

        $interpreter eval "import sys\nsys.path.insert(0, '.')"
        $interpreter eval {from types import FunctionType}
        $interpreter eval {import re}
        $interpreter eval "import $name"
        $interpreter eval $python::utilityFunctions
        array set ::${namespace}::data [$interpreter eval formstring($name.form)]
        if {$global::withGUI} {
            proc ::${namespace}::update {} "
                variable data
                lifoLabel::push $global::messenger {$namespace data update...}
                $interpreter eval $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 eval $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
                }
            "
        }
        set ($this,initialize) [$interpreter eval "try: type($name.initialize) == FunctionType\nexcept: 0"]
        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 "try: type($name.terminate) == FunctionType\nexcept: 0"]
        if {$($this,terminate)} {
            proc ::${namespace}::terminate {} "$interpreter eval $name.terminate()"
        }
        set ($this,version) [$interpreter eval $name.__version__]
    }

}

set rcsId {$Id: modperl.tcl,v 1.4 2001/12/29 00:32:39 jfontain Exp $}


namespace eval module::perl {

    variable utilityFunctions {

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

}

set rcsId {$Id: modpython.tcl,v 1.4 2001/12/29 00:32:39 jfontain Exp $}


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

}

}

set rcsId {$Id: modules.tcl,v 2.43 2001/12/29 00:32:39 jfontain Exp $}


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
            catch {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)
            if {![catch {set ${namespace}::data(identifier)} identifier]} {
                if {![modules::validName $identifier]} {
                    foreach {name index} [modules::decoded $namespace] {}
                    puts stderr "\"$name\" module identifier: \"$identifier\" contains invalid characters"
                    exit 1
                }
                set ($this,identifier) $identifier
            }
            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 tclpython2 2.0.1}]&&[catch {package require tclpython 2}]} return
                set python [python::interp new]
                $python eval "import sys\nsys.path.insert(0, '.')"
                $python eval "import $package"
                $interpreter eval "namespace eval $package {catch {set data(updates) [$python eval $package.form\['updates'\]]}}"
                catch {
                    set text [$python eval $package.form\['helpText'\]]
                    $interpreter eval [list namespace eval $package [list set data(helpText) $text]]
                }
                $interpreter eval "package provide $package [$python eval $package.__version__]"
                python::interp delete $python
            }
            .pm {
                if {[catch {package require tclperl 2}]} return
                set perl [perl::interp new]
                $perl eval "use $package"
                $interpreter eval "namespace eval $package {catch {set data(updates) [$perl eval \$${package}::data{updates}]}}"
                catch {
                    set text [$perl eval \$${package}::data{helpText}]
                    $interpreter eval [list namespace eval $package [list set data(helpText) $text]]
                }
                $interpreter eval "package provide $package [$perl eval \$${package}::VERSION]"
                perl::interp delete $perl
            }
            default {
                $interpreter eval _source [list $file]
            }
        }
    }

    proc available {{command {}}} {
        set directory [pwd]
        set packages {}
        foreach package [package names] {
            if {[regexp\
{^(BLT|Tk|Tkined|Tktable|Tnm|apacheutilities|http|internationalization|mime|msgcat|opt|scwoop|smtp|stooop|switched|tcllib|tclperl|tclpython|tclpython2|tcltest|tkpiechart)$}\
                $package\
            ]} continue
            if {![info exists ::packageDirectory($package)]} continue
            cd $::packageDirectory($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 {\
                ![catch {$interpreter eval "package require $package"}]&&\
                [$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 ::packageDirectory($name)]} {
            error "error: \"$name\" is not a valid moodss module name"
        }
        if {![validName $name]} {
            error "\"$name\" module name contains invalid characters"
        }
        if {$global::withGUI} {
            lifoLabel::push $global::messenger "loading $name..."
            update idletasks
        } 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
        update idletasks
    }

    proc helpHTMLData {name} {
        set noHelpText {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)
            }
            lappend arguments $instance::($instance,arguments)
        }
        set header "<b>$name </b>"
        append header {module version}
        if {[info exists text]} {
            append header " <i>$version</i>, "
            append header instances:
            append header <ol>
            foreach argument $arguments {
                append header <li>
                if {[llength $argument]==0} {
                    append header {<i>with no options</i>}
                } else {
                    append header <b>$argument</b>
                }
                append header </li>
            }
            append header </ol>
        } else {
            foreach {version text} [versionAndHelpText $name] {}
            if {[string length $text]==0} {
                set text $noHelpText
            }
            append header " <i>$version</i>"
        }
        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 $::packageDirectory($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 {} {
        foreach instance $(instances) {
            if {!$instance::($instance,initialize)} continue
            set namespace $instance::($instance,namespace)
            if {$global::withGUI} {
                lifoLabel::push $global::messenger "initializing $namespace..."
                update idletasks
            } elseif {$global::debug} {
                writeLog "initializing $namespace module..."
            }
            set error 0
            if {[info exists instance::($instance,options)]} {
                if {[catch {::${namespace}::initialize $instance::($instance,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} {
                unload $instance
                if {$global::debug} {
                    error $information
                } else {
                    error "module \"$namespace\" initialize error:\n$message"
                }
            } else {
                instance::synchronize $instance
            }
            set instance::($instance,initialize) 0
        }
        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]
        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} { 
            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} {
        variable nextIndex

        set namespace [namespaceFromArray $array]
        foreach instance $(instances) {
            if {[string equal $namespace $instance::($instance,namespace)]} {
                if {[info exists instance::($instance,identifier)]} {
                    return $instance::($instance,identifier)
                }
                foreach {module index} [decoded $namespace] {}
                if {[string length $index]>0} {
                    return $namespace
                }
                break
            }
        }
        return {}
    }

    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
            set switches {}
            catch {set switches $instance::($instance,switches)}
            if {[llength $switches]==0} {
                lappend return {}
            } else {
                catch {unset argument}
                foreach {switch required} $switches {
                    set argument($switch) $required
                }
                set arguments $instance::($instance,arguments)
                set length [llength $arguments]
                set list {}
                for {set index 0} {$index<$length} {incr index} {
                    set item [lindex $arguments $index]
                    lappend list $item
                    if {$argument($item)} {
                        lappend list 1 [lindex $arguments [incr index]]
                    } else {
                        lappend list 0 1
                    }
                }
                lappend return $list
            }
        }
        return $return
    }

    proc names {} {
        set list {}
        foreach instance $(instances) {
            set module $instance::($instance,module)
            if {[lsearch -exact $list $module]<0} {
                lappend list $module
            }
        }
        return $list
    }

    proc unload {instance} {
        ldelete (instances) $instance
        delete $instance
    }

    proc namespaceFromArray {name} {
        return [string trimleft [namespace qualifiers [namespace which -variable $name]] :]
    }

    proc trace {module namespace message} {
        foreach instance $(instances) {
            if {[string equal $instance::($instance,module) trace]} {
                set traceNamespace $instance::($instance,namespace)
                ::${traceNamespace}::update $module $namespace $message
            }
        }
    }

    proc flashMessage {module namespace message {seconds 1}} {
        if {$global::withGUI} {
            ::lifoLabel::flash $::global::messenger $message $seconds
        } else {
            writeLog "$namespace: $message"
        }
        trace $module $namespace $message
    }

    proc pushMessage {module namespace message} {
        if {$global::withGUI} {
            ::lifoLabel::push $::global::messenger $message
        } else {
            writeLog "$namespace: $message"
        }
        trace $module $namespace $message
    }

    proc popMessage {} {
        if {$global::withGUI} {
            ::lifoLabel::pop $::global::messenger
        }
    }

}

set rcsId {$Id: preferen.tcl,v 1.17 2001/12/30 15:28:09 jfontain Exp $}


namespace eval preferences {

    variable rcFileName ~/.moodssrc

    proc read "{rcFileName $rcFileName}" {
        if {![file readable $rcFileName]} {
            return {}
        }
        set file [::open $rcFileName]
        set list {}
        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
        }
        close $file
        return $list
    }

    proc save {variables} {
        variable rcFileName

        if {[catch {::open $rcFileName w} file]} {
            tk_messageBox -title moodss -type ok -default ok -icon error -message $file
            return
        }
        set data [record::globalData]
        foreach name $variables {
            append data [list $name [set ::preferences::$name]]\n
        }
        puts -nonewline $file $data
        close $file
    }

}

set rcsId {$Id: config.tcl,v 2.27 2001/12/29 00:32:39 jfontain Exp $}


namespace eval configuration {

if {$global::withGUI} {

    variable container
    variable interface
    variable hierarchy {
        canvas canvas.size canvas.colors canvas.printing viewers viewers.colors viewers.graphs viewers.pies
        thresholds thresholds.email
    }
    variable configure {1 1 1 0 1 1 1 1 0 0}
    variable helpMessage
    set helpMessage(preferences) "Preferences for the user: $global::login"
    set helpMessage(configuration) {Configuration for the current view.}

    variable entryIcons
    lappend entryIcons [image create photo -data {
        R0lGODlhEAANAPIAAAAAAH9/f7+/v///AP///wAAAAAAAAAAACH+JEZpbGUgd3JpdHRlbiBieSBBZG9iZSBQaG90b3Nob3CoIDUuMAAsAAAAABAADQAAAzNI
        Gsz6kAQxqAjxzcpvc1KWBUDYnRQZWmilYi37EmztlrAt43R8mzrO60P8lAiApHK5TAAAOw==
    }]
    lappend entryIcons [image create photo -data {
        R0lGODlhEAANAPIAAAAAAH9/f7+/v///////AAAAAAAAAAAAACH+JEZpbGUgd3JpdHRlbiBieSBBZG9iZSBQaG90b3Nob3CoIDUuMAAsAAAAABAADQAAAzk4
        Gsz6cIQ44xqCZCGbk4MmclAAgNs4ml7rEaxVAkKc3gTAnBO+sbyQT6M7gVQpk9HlAhgHzqhUmgAAOw==
    }]

}

    proc load {arrayList} {
        foreach {name value} $arrayList {
            set ::global::$name $value
        }
    }

if {$global::withGUI} {

    proc edit {preferencesMode} {
        variable hierarchy
        variable configure
        variable container
        variable interface
        variable tree
        variable preferences
        variable helpMessage
        variable dialog
        variable entryIcons

        set preferences $preferencesMode

        set objects {}

        set title {moodss: }
        if {$preferences} {
            append title Preferences
        } else {
            append title 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 [blt::hierbox $frame.tree\
            -font $font::(mediumBold) -separator . -selectmode single -selectbackground lightgray -hideroot 1 -borderwidth 1\
            -highlightthickness 0 -takefocus 0 -width 150\
        ]
        set container [frame $frame.container -borderwidth 1 -relief sunken]

        set message [createMessage $container.message]
        if {$preferences} {
            $message configure -text $helpMessage(preferences)
        } else {
            $message configure -text $helpMessage(configuration)
        }
        pack $message -fill both -expand 1

        bindtags $tree [list $tree [winfo toplevel $tree] all]
        $tree bind all <Double-ButtonPress-1> {}
        $tree bind all <Shift-ButtonPress-1> {}
        $tree bind all <Control-ButtonPress-1> {}
        $tree bind all <B1-Motion> {}
        $tree bind all <ButtonRelease-1> "$tree toggle current; $tree toggle current"

        catch {unset interface(current)}

        foreach entry $hierarchy specific $configure {
            if {!$preferences&&!$specific} continue
            set index [$tree insert end $entry]
            regsub -all {\.} $entry :: interface($index,class)
            $interface($index,class)::initialize
            $tree entry configure $index -opencommand "configuration::open $index" -icons $entryIcons
        }

        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) 500x300

        bind $frame <Destroy> "delete $objects"
    }

    proc open {index} {
        variable container
        variable interface

        if {[info exists interface(current)]&&![$interface($interface(current),class)::check]} return
        eval destroy [winfo children $container]
        set frame [frame $container.frame]
        pack $frame -fill both -expand 1
        $interface($index,class)::edit $frame
        set interface(current) $index
    }

    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 left
        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} {
        variable preferences

        set namespaces ::global
        if {$preferences} {
            lappend namespaces ::preferences
        }
        foreach namespace $namespaces {
            if {![info exists ${namespace}::$name]||($value!=[set ${namespace}::$name])} {
                set ${namespace}::$name $value
            }
        }
    }

    proc variables {preferences} {
        variable variables

        return $variables($preferences)
    }

    namespace eval canvas {

        proc initialize {} {}

        proc edit {parentPath} {
            set message [configuration::createMessage $parentPath.message -text {Canvas configuration}]
            pack $message -fill both -expand 1
        }

        proc check {} {
            return 1
        }

        proc apply {} {}

        proc variables {} {return {}}

        proc help {} {
            generalHelpWindow #configuration.canvas
        }

        namespace eval size {

            proc variables {} {
                return {canvasHeight canvasWidth}
            }

            proc initialize {} {
                variable height [configuration::initialize canvasHeight]
                variable width [configuration::initialize canvasWidth]
            }

            proc edit {parentPath} {
                variable height
                variable width
                variable message

                set message [configuration::createMessage $parentPath.message -text {Enter size (in pixels):}]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1

                grid columnconfigure $parentPath 0 -weight 1

                if {$::tcl_version<8.4} {
                    set widthEntry [new spinEntry $parentPath -font $font::(mediumBold) -width 4 -list {640 800 1024 1280 1600}]
                    spinEntry::set $widthEntry $width
                    grid $widget::($widthEntry,path) -row 1 -column 2
                    set path $composite::($widthEntry,entry,path)
                } else {
                    set path [spinbox $parentPath.widthEntry -font $font::(mediumBold) -width 4 -values {640 800 1024 1280 1600}]
                    $path set $width
                    grid $path -row 1 -column 2
                }
                $path configure -textvariable configuration::canvas::size::width
                setupEntryValidation $path {{checkMaximumLength 4 %P} {checkUnsignedInteger %P}}
                grid [label $parentPath.width -font $font::(mediumBold) -text width:] -row 1 -column 1 -padx 2
                grid columnconfigure $parentPath 3 -weight 1

                if {$::tcl_version<8.4} {
                    set heightEntry [new spinEntry $parentPath -font $font::(mediumBold) -width 4 -list {400 480 600 768 1024 1280}]
                    spinEntry::set $heightEntry $height
                    grid $widget::($heightEntry,path) -row 1 -column 5
                    set path $composite::($heightEntry,entry,path)
                } else {
                    set path\
                        [spinbox $parentPath.heightEntry -font $font::(mediumBold) -width 4 -values {400 480 600 768 1024 1280}]
                    $path set $height
                    grid $path -row 1 -column 5
                }
                $path configure -textvariable configuration::canvas::size::height
                setupEntryValidation $path {{checkMaximumLength 4 %P} {checkUnsignedInteger %P}}
                grid [label $parentPath.height -font $font::(mediumBold) -text height:] -row 1 -column 4 -padx 2
                grid columnconfigure $parentPath 6 -weight 1

                grid [button $parentPath.apply -text Apply -command configuration::canvas::size::apply]\
                    -row 2 -column 0 -columnspan 100
                grid rowconfigure $parentPath 2 -weight 1

                if {$::tcl_version<8.4} {
                    bind $message <Destroy> "delete $widthEntry $heightEntry"
                }
            }

            proc check {} {
                variable height
                variable width
                variable message

                set valid 1
                foreach item {height width} {
                    if {[string length [set $item]]==0} {
                        set text "please set $item."
                        set valid 0
                        break
                    }
                    if {[set $item]==0} {
                        set text "$item cannot be set to 0."
                        set valid 0
                        break
                    }
                }
                if {!$valid} {
                    $message configure -font $::font::(mediumBold) -text $text
                    bell
                }
                return $valid
            }

            proc apply {} {
                variable height
                variable width

                if {![check]} return
                configuration::apply canvasHeight $height
                configuration::apply canvasWidth $width
            }

            proc help {} {
                generalHelpWindow #configuration.canvas.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 {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 Choose... -command "configuration::canvas::colors::choose $parentPath"]
                updateColorViewer
                grid $colorViewer -row 1 -column 1
                grid [button $parentPath.apply -text Apply -command configuration::canvas::colors::apply] -row 1 -column 2

                grid columnconfigure $parentPath 1 -weight 1
                grid columnconfigure $parentPath 2 -weight 1
                grid columnconfigure $parentPath 3 -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

                foreach {red green blue} [winfo rgb $colorViewer $background] {}
                if {($red+$green+$blue)>=(32768*3)} {
                    $colorViewer configure -foreground black
                } else {
                    $colorViewer configure -foreground white
                }
                $colorViewer configure -background $background
            }

            proc choose {parentPath} {
                variable background

                set choice [tk_chooseColor -initialcolor $background -title {Choose color:} -parent $parentPath]
                if {[string length $choice]>0} {
                    set background $choice
                    updateColorViewer
                }
            }

            proc help {} {
                generalHelpWindow #configuration.canvas.colors
            }

        }

        namespace eval printing {

            variable helpText {}

            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 orientation [configuration::initialize printOrientation]
                variable palette [configuration::initialize printPalette]
                variable size [configuration::initialize printPaperSize]
            }

            proc edit {parentPath} {
                variable helpText
                variable toFile
                variable printFile
                variable command
                variable orientation
                variable palette
                variable size

                set objects {}

                set row 0
                set message [configuration::createMessage $parentPath.message -text {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::canvas::printing::toFile -value 0 -text Command:
                grid $parentPath.toCommand -row $row -column 0 -sticky w
                entry $parentPath.command -textvariable configuration::canvas::printing::command
                grid $parentPath.command -row $row -column 1 -columnspan 2 -sticky ew

                incr row
                radiobutton $parentPath.toFile -variable configuration::canvas::printing::toFile -value 1 -text {to File:}
                grid $parentPath.toFile -row $row -column 0 -sticky w
                entry $parentPath.file -textvariable configuration::canvas::printing::printFile
                grid $parentPath.file -row $row -column 1 -sticky ew
                button $parentPath.browse -text Browse... -command "configuration::canvas::printing::inquirePrintFile $parentPath"
                grid $parentPath.browse -row $row -column 2 -sticky ew
                if {$toFile} {
                    $parentPath.toFile invoke
                } else {
                    $parentPath.toCommand invoke
                }

                incr row
                grid [label $parentPath.orientation -text Orientation:] -row $row -column 0 -sticky w
                set entry\
                    [new comboEntry $parentPath -font $widget::option(entry,font) -list $global::printOrientations -editable 0]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::canvas::printing::orientation
                composite::configure $entry button -listheight [llength $global::printOrientations]
                composite::configure $entry button scroll -selectmode single
                grid $widget::($entry,path) -row $row -column 1 -columnspan 2 -sticky ew

                incr row
                grid [label $parentPath.palette -text Palette:] -row $row -column 0 -sticky w
                set entry [new comboEntry $parentPath -font $widget::option(entry,font) -list $global::printPalettes -editable 0]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::canvas::printing::palette
                composite::configure $entry button -listheight [llength $global::printPalettes]
                composite::configure $entry button scroll -selectmode single
                grid $widget::($entry,path) -row $row -column 1 -columnspan 2 -sticky ew

                incr row
                grid [label $parentPath.size -text {Paper size:}] -row $row -column 0 -sticky w
                set entry [new comboEntry $parentPath -font $widget::option(entry,font) -list $global::printPaperSizes -editable 0]
                lappend objects $entry
                composite::configure $entry entry -textvariable configuration::canvas::printing::size
                composite::configure $entry button -listheight [llength $global::printPaperSizes]
                composite::configure $entry button scroll -selectmode single
                grid $widget::($entry,path) -row $row -column 1 -columnspan 2 -sticky ew

                incr row
                set message [configuration::createMessage $parentPath.help -text $helpText]
                grid $message -sticky nsew -row $row -column 0 -columnspan 3
                grid rowconfigure $parentPath $row -weight 1

                bind $message <Destroy> "delete $objects"
            }

            proc inquirePrintFile {parentPath} {
                variable printFile

                set file [tk_getSaveFile\
                    -title {moodss: File to print to} -parent $parentPath -initialdir [file dirname $printFile]\
                    -defaultextension .ps -filetypes {{Postscript .ps} {{All files} *}} -initialfile $printFile\
                ]
                if {[string length $file]>0} {
                    set printFile $file
                }
            }

            proc check {} {
                return 1
            }

            proc apply {} {
                variable toFile
                variable printFile
                variable command
                variable orientation
                variable palette
                variable size

                configuration::apply printToFile $toFile
                configuration::apply fileToPrintTo $printFile
                configuration::apply printCommand $command
                configuration::apply printOrientation $orientation
                configuration::apply printPalette $palette
                configuration::apply printPaperSize $size
            }

            proc help {} {
                generalHelpWindow #preferences.canvas.printing
            }

        }

    }


    namespace eval viewers {

        proc initialize {} {}

        proc edit {parentPath} {
            set message [configuration::createMessage $parentPath.message -text {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 {

            variable helpText {}

            proc variables {} {
                return viewerColors
            }

            proc initialize {} {
                variable colors [configuration::initialize viewerColors]
            }

            proc edit {parentPath} {
                variable helpText
                variable colorsFrame

                set message [configuration::createMessage $parentPath.message -text {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

                set message [configuration::createMessage $parentPath.help -text $helpText]
                grid $message -sticky nsew -row 2 -column 0 -columnspan 100
                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 {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 {

            variable helpText {}

            proc variables {} {
                return graphNumberOfIntervals
            }

            proc initialize {} {
                variable numberOfSamples [configuration::initialize graphNumberOfIntervals]
            }

            proc edit {parentPath} {
                variable helpText
                variable numberOfSamples
                variable message

                set message [configuration::createMessage $parentPath.message -text "Enter number of samples\nfor data graphs:"]
                grid $message -sticky nsew -row 0 -column 0 -columnspan 100
                grid rowconfigure $parentPath 0 -weight 1

                grid columnconfigure $parentPath 0 -weight 1

                if {$::tcl_version<8.4} {
                    set entry [new spinEntry $parentPath -font $font::(mediumBold) -width 4 -list {20 50 100 150 200 300 500 1000}]
                    spinEntry::set $entry $numberOfSamples
                    grid $widget::($entry,path) -row 1 -column 2
                    set path $composite::($entry,entry,path)
                } else {
                    set path [spinbox $parentPath.entry -font $font::(mediumBold) -width 4 -values {20 50 100 150 200 300 500 1000}]
                    $path set $numberOfSamples
                    grid $path -row 1 -column 2
                }
                $path configure -textvariable configuration::viewers::graphs::numberOfSamples
                setupEntryValidation $path {{checkMaximumLength 4 %P} {checkUnsignedInteger %P}}

                grid [label $parentPath.width -font $font::(mediumBold) -text samples:] -row 1 -column 1 -padx 2

                grid columnconfigure $parentPath 3 -weight 1

                set message [configuration::createMessage $parentPath.help -text $helpText]
                grid $message -sticky nsew -row 2 -column 0 -columnspan 100
                grid rowconfigure $parentPath 2 -weight 1

                if {$::tcl_version<8.4} {
                    bind $message <Destroy> "delete $entry"
                }
            }

            proc check {} {
                variable numberOfSamples
                variable message

                set valid 1
                if {[string length $numberOfSamples]==0} {
                    set text {please set number of samples.}
                    set valid 0
                } elseif {$numberOfSamples==0} {
                    set text {number of samples cannot be set to 0.}
                    set valid 0
                }
                if {!$valid} {
                    $message configure -font $::font::(mediumBold) -text $text
                    bell
                }
                return $valid
            }

            proc apply {} {
                variable numberOfSamples

                if {![check]} return
                configuration::apply graphNumberOfIntervals $numberOfSamples
            }

            proc help {} {
                generalHelpWindow #configuration.viewers.graphs
            }

        }

        namespace eval pies {

            variable helpText {}

            proc variables {} {
                return pieLabeler
            }

            proc initialize {} {
                variable labeler [configuration::initialize pieLabeler]
            }

            proc edit {parentPath} {
                variable helpText

                set message [configuration::createMessage $parentPath.message -text {Choose labeler type for data pies:}]
                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 box]
                grid $button -row 1 -column 1
                set button [radiobutton $parentPath.peripheral\
                    -variable ::configuration::viewers::pies::labeler -value peripheral -text peripheral\
                ]
                grid $button -row 1 -column 2

                grid columnconfigure $parentPath 3 -weight 1

                set message [configuration::createMessage $parentPath.help -text $helpText]
                grid $message -sticky nsew -row 2 -column 0 -columnspan 100
                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 thresholds {

        proc initialize {} {}

        proc edit {parentPath} {
            set message [configuration::createMessage $parentPath.message -text {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 {

            variable helpText {}

            proc variables {} {
                return {fromAddress smtpServers}
            }

            proc initialize {} {
                variable from [configuration::initialize fromAddress]
                variable servers [configuration::initialize smtpServers]
            }

            proc edit {parentPath} {
                variable servers
                variable list
                variable parent $parentPath

                set row 0
                set message [configuration::createMessage $parentPath.message -text {Mail settings:}]
                grid $message -sticky nsew -row $row -column 0 -columnspan 2
                grid rowconfigure $parentPath $row -weight 1
                incr row
                set label [label $parentPath.from -text {From address:}]
                if {$global::noMail} {
                    $label configure -foreground $widget::option(button,disabledforeground)
                }
                grid $label -row $row -column 0 -sticky w
                set entry [entry $parentPath.address -textvariable configuration::thresholds::email::from]
                if {$global::noMail} {
                    $entry configure -state disabled
                }
                grid $entry -row $row -column 1 -sticky ew
                incr row
                set label [label $parentPath.out -text {Outgoing mail SMTP servers:}]
                if {$global::noMail} {
                    $label configure -foreground $widget::option(button,disabledforeground)
                }
                grid $label -row $row -column 0 -sticky nw
                set list [new listEntry $parentPath -list $servers]
                if {$global::noMail} {
                    composite::configure $list -state disabled
                }
                grid $widget::($list,path) -row $row -column 1 -sticky nsew
                incr row
                grid rowconfigure $parentPath $row -weight 1
                bind $message <Destroy> "delete $list; unset configuration::thresholds::email::list"
            }

            proc check {} {
                variable from
                variable parent

                if {!$global::noMail&&([string length [emailAddressError $from]]>0)} {
                    tk_messageBox -parent $parent -title {moodss: Email error} -type ok -icon error\
                        -message "$from: [emailAddressError $from]"
                    return 0
                }
                return 1
            }

            proc apply {} {
                variable from
                variable servers
                variable list

                configuration::apply fromAddress $from
                if {[info exists list]} {
                    set servers [composite::cget $list -list]
                }
                configuration::apply smtpServers $servers
            }

            proc help {} {
                generalHelpWindow #preferences.thresholds.email
            }

        }
    }

    variable variables
    set variables(0) {}
    set variables(1) {}
    foreach entry $hierarchy specific $configure {
        regsub -all {\.} $entry :: class
        if {$specific} {
            set variables(0) [concat $variables(0) [${class}::variables]]
        }
        set variables(1) [concat $variables(1) [${class}::variables]]
    }

}

}

        configuration::load [preferences::read /etc/moomps/rc]

        proc createSavedViewers {record} {
            set thresholds 0
            foreach {class cells x y width height level switchedOptions} [record::viewersData $record] {
                if {[string equal $class ::thresholds]} {
                    set viewer $thresholds::singleton
                    eval switched::configure $viewer $switchedOptions
                    incr thresholds
                } elseif {[string equal $class ::summaryTable]} {
                    set viewer [eval new $class $switchedOptions]
                } else continue
                set viewerCells($viewer) $cells
            }
            if {$thresholds==0} {
                writeLog {no thresholds entry (obsolete configuration file)} error
                return
            }
            foreach {viewer cells} [array get viewerCells] {
                viewer::view $viewer $cells
            }
            set thresholds [thresholds::activeEmails $thresholds::singleton]
            if {$global::debug&&($thresholds==0)} {
                writeLog {no active thresholds with email recipient} warning
            }
        }

        set modules::(synchronous) {}
        proc processModule {instance} {
            if {[lindex $modules::instance::($instance,times) 0]>0} {
                lappend modules::(synchronous) $instance
            }
            set index 0
            set namespace $modules::instance::($instance,namespace)
        }

        proc refresh {} {
            static updateEvent

            catch {after cancel $updateEvent}
            if {[llength $modules::(synchronous)]==0} return
            foreach instance $modules::(synchronous) {
                set namespace $modules::instance::($instance,namespace)
                ${namespace}::update
            }
            set updateEvent [after [expr {1000*$global::pollTime}] refresh]
        }

        proc changeAllCellsColor {array row column color} {}

        proc processFile {name} {
            if {$global::debug} {
                writeLog "loading configuration from file: $name"
            }
            set initializer [new record -file $name]
            record::read $initializer
            configuration::load [record::configurationData $initializer]
            modules::parse [record::modulesWithArguments $initializer]
            set modules::(initialized) [record::modules $initializer]
            return $initializer
        }

    }

}

proc modificationsPoll {pollTime files} {
    static lastModified

    foreach file $files {
        if {![file readable $file]} continue
        set seconds [file mtime $file]
        if {![info exists lastModified($file)]} {
            set lastModified($file) $seconds
        } elseif {$seconds>$lastModified($file)} {
            file stat $file data
            set node $data(ino)

            $::interpreter($node) eval {
                foreach instance $modules::(instances) {
                    modules::unload $instance
                }
            }
            interp delete $::interpreter($node)

            set interpreter [interp create]
            initialize $interpreter
            interp eval $interpreter "set initializer \[processFile $file\]"
            if {[catch "$interpreter eval modules::initialize" message]} {
                writeLog $message error
                exit 1
            }
            $interpreter eval {
                modules::setPollTimes [record::pollTime $initializer]
                createSavedViewers $initializer
                foreach instance $modules::(instances) {
                    processModule $instance
                }
                refresh
            }
            set ::interpreter($node) $interpreter

            set lastModified($file) $seconds
        }
    }
    after $pollTime modificationsPoll $pollTime $files
}

writeLog $startMessage

if {[catch {
    foreach file $argv {
        if {[catch {file stat $file data} message]} {
            writeLog $message error
            exit 2
        }
        if {[string equal $data(type) directory]} {
            foreach file [glob -nocomplain [file join $file *.moo]] {
                if {[catch {file stat $file data} message]} {
                    writeLog $message error
                    exit 2
                }
                set fileName($data(ino)) $file
            }
        } else {
            set fileName($data(ino)) $file
        }
    }
    if {![info exists fileName]} {
        writeLog {no modules to load (no configuration files?)} critical
        exit 1
    }
    set files {}
    foreach {node file} [array get fileName] {
        set interpreter($node) [interp create]
        initialize $interpreter($node)
        interp eval $interpreter($node) "set initializer \[processFile $file\]"
        lappend files $file
    }
    if {$global::debug} {
        writeLog {initializing modules...}
    }
    foreach node [array names fileName] {
        if {[catch "$interpreter($node) eval modules::initialize" message]} {
            writeLog $message error
            exit 1
        }
        $interpreter($node) eval {
            modules::setPollTimes [record::pollTime $initializer]
            createSavedViewers $initializer
            foreach instance $modules::(instances) {
                processModule $instance
            }
            refresh
        }
    }
    if {$pollFilesTime>0} {
        modificationsPoll $pollFilesTime $files
    }
    if {![info exists arguments(-f)]&&[info exists arguments(--pid-file)]} {
        set file [open $arguments(--pid-file) w]
        puts -nonewline $file [id process]
        close $file
    }
    vwait forever
} message]} {
    writeLog $::errorInfo error
}

