# tko_state.tcl --
#
#       State handling support procedures.
#
# Copyright (c) 2021 <r.zaumseil@freenet.de>

namespace eval ::tko {
    variable state
    array set state {};# state(name) {value commandlist}
}

##  State handling command.
#
# mode  - Mode of operation.
# args  - Mode related arguments. See below.
#
# - add name value ?name value? ..
#   Add new state variable with initialization value.
#
# - del pattern ?pattern? ..
#   Delete one or more state variables matching the given pattern.
#
# - set name value ?name value? ..
#   Set new value of state variables and call all commands with appending
#   the given value.
#
# - bind name command
#   Bind a command to changes in a state variable. If the variable is
#   true then add '-state normal' otherwise add '-state disabled' to the
#   command.
#
# - unbind name command
#   Unbind the command from the state variable.
#
# - update namepattern ?namepattern? ..
#   Reset matching state variables and call associated commands.
#
# - getnames
#   Return ordered list of all state variables.
#
# - getvalue name
#   Return current value of given state variable.
#
# - getcommands name
#   Return list of all commands bind to given state variable.
proc ::tko::state {mode args} {
    switch -- $mode {
    add {;# ?name value? ..
        if {$args eq {} || [llength $args]%2} {
return -code error {wrong # args: should be "state add name value ?name value? .."}
        }
        foreach {myName myValue} $args {
            if {[info exists ::::tko::state($myName)]} {
return -code error "state '$myName' already exists"
            }
        }
        foreach {myName myValue} $args {
            set ::tko::state($myName) [list $myValue {}]
        }
    }
    del {;# ?pattern? ..
        if {$args eq {}} {
return -code error {wrong # args: should be "state del namepattern ?namepattern? .."}
        }
        foreach myPattern $args {
            array unset ::tko::state $myPattern
        }
    }
    set {;# ?name value? ..
        if {$args eq {} || [llength $args]%2} {
return -code error {wrong # args: should be "state set name value ?name value? .."}
        }
        foreach {myName myValue} $args {
            if {![info exists ::tko::state($myName)]} {
return -code error "state '$myName' doesn't exist"
            }
            lassign $::tko::state($myName) myVal myCmds
            if {$myValue ne $myVal} {
                set i 0
                foreach myCmd $myCmds {
                    incr i
                    if {[catch {{*}$myCmd $myValue} myMsg]} {
                        lset ::tko::state($myName) 1 [lreplace $myCmds $i $i]
return -code error "state '$myName' call '$myCmd $myValue' failed\n$myMsg"
                    }
                }
                lset ::tko::state($myName) 0 $myValue
            }
        }
    }
    getnames {;#
        return [lsort [array names ::tko::state]]
    }
    getvalue {;# name
        if {[llength $args] != 1} {
return -code error {wrong # args: should be "state getvalue name"}
        }
        if {![info exists ::tko::state($args)]} {
return -code error "state '$args' doesn't exist"
        }
        return [lindex $::tko::state($args) 0]
    }
    getcommands {;# name
        if {[llength $args] != 1} {
return -code error {wrong # args: should be "state getcommands name"}
        }
        if {![info exists ::tko::state($args)]} {
return -code error "state '$args' doesn't exist"
        }
        return [lindex $::tko::state($args) 1]
    }
    bind {;# name command
        if {[llength $args] != 2} {
return -code error {wrong # args: should be "state bind name command"}
        }
        lassign $args myName myCmd
        if {![info exists ::tko::state($myName)]} {
return -code error "state '$myName' doesn't exist"
        }
        lassign $::tko::state($myName) myValue myCmds
        if {[lsearch $myCmds $myCmd]!=-1} continue;# already there
        if {[catch {{*}$myCmd $myValue} myMsg]} {
return -code error "state '$myName' call '$myCmd $myValue' failed\n$myMsg"
        }
        lappend myCmds $myCmd
        lset ::tko::state($myName) 1 $myCmds
    }
    unbind {;# name command
        if {[llength $args] != 2} {
return -code error {wrong # args: should be "state unbind name command"}
        }
        lassign $args myName myCmd
        if {![info exists ::tko::state($myName)]} return;# ignore
        lassign $::tko::state($myName) myValue myCmds
        set myNr [lsearch $myCmds $myCmd]
        if {$myNr == -1} return;#ignore
        lset ::tko::state($myName) 1 [lreplace $myCmds $myNr $myNr]
    }
    update {;# namepattern ?namepattern? ..
        if {$args eq {}} {
return -code error {wrong # args: should be "state update namepattern ?namepatter? .."}
        }
        foreach myPattern $args {
            foreach myName [array names ::tko::state $myPattern] {
                lassign $::tko::state($myName) myValue myCmds
                set i 0
                foreach myCmd $myCmds {
                    incr i
                    if {[catch {{*}$myCmd $myValue} myMsg]} {
                        lset ::tko::state($myName) 1 [lreplace $myCmds $i $i]
return -code error "state '$myName' call '$myCmd $myValue' failed\n$myMsg"
                    }
                }
            }
        }
    }
    default {
return -code error "unknown option '$mode', should be one of add, bind, del, getcommands, getnames, getvalue, set, unbind or update"
    }
    }
}

# vim: set ts=4 sw=4 sts=4 et :
