set rcsId {$Id: switched.tcl,v 1.4 1998/03/30 08:26:05 jfontain Exp $}

# use revision number automatically generated by RCS
package provide switched [lindex {$Revision: 1.4 $} 1]

class switched {

    proc switched {this args} {                                                                ;# arguments are option / value pairs
        if {([llength $args]%2)!=0} {
            error "value for \"[lindex $args end]\" missing"
        }
        set switched::($this,complete) 0
        # delay arguments processing till completion as pure virtual procedure invocations do not work from base class constructor
        set switched::($this,arguments) $args
    }

    proc ~switched {this} {}

    virtual proc options {this}   ;# derived class implementation must return a list of {name "default value" "initial value"} lists

    # must be invoked once only at the end of derived class constructor so that configuration occurs once derived object is
    # completely built
    proc complete {this} {
        foreach description [options $this] {
            set option [lindex $description 0]
            set switched::($this,$option) [set default [lindex $description 1]]     ;# by default always set option to default value
            if {[llength $description]<3} {
                set initialize($option) {}                            ;# no initial value so force initialization with default value
            } elseif {[string compare $default [lindex $description 2]]!=0} {
                set switched::($this,$option) [lindex $description 2]
                set initialize($option) {}                     ;# initial value different from default value so force initialization
            }
        }
        # check validity of constructor options, which always take precedence for initialization
        foreach {option value} $switched::($this,arguments) {
            if {[catch {string compare $switched::($this,$option) $value} different]} {
                error "$switched::($this,_derived): unknown option \"$option\""
            }
            if {$different} {
                set switched::($this,$option) $value
                set initialize($option) {}
            }
        }
        unset switched::($this,arguments)
        foreach option [array names initialize] {   ;# all option values are initialized before any of the set procedures are called
            $switched::($this,_derived)::set$option $this $switched::($this,$option)
        }
        set switched::($this,complete) 1
    }

    proc configure {this args} {                                                          ;# should not be invoked before completion
        if {[llength $args]==0} {
            return [descriptions $this]
        }
        foreach {option value} $args {                                      ;# check all options validity before doing anything else
            if {![info exists switched::($this,$option)]} {
                error "$switched::($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"
        }
        # derived (dynamic virtual) procedure must either accept (or eventually adjust) the value or throw an error
        # option data member is set prior to invoking the procedure in case other procedures are invoked and expect the new value
        foreach {option value} $args {
            if {[string compare $switched::($this,$option) $value]!=0} {
                $switched::($this,_derived)::set$option $this [set switched::($this,$option) $value]
            }
        }
    }

    proc cget {this option} {
        if {[catch {set value $switched::($this,$option)}]} {
            error "$switched::($this,_derived): unknown option \"$option\""
        }
        return $value                                                                       ;# return specified option current value
    }

    proc description {this option} {                                                      ;# build specified option description list
        foreach description [options $this] {
            if {[string compare [lindex $description 0] $option]==0} {
                if {[llength $description]<3} {                                                                  ;# no initial value
                    lappend description $switched::($this,$option)                                           ;# append current value
                    return $description
                } else {
                    return [lreplace $description 2 2 $switched::($this,$option)]                               ;# set current value
                }
            }
        }
    }

    proc descriptions {this} {                                           ;# build option descriptions list for all supported options
        set descriptions {}
        foreach description [options $this] {
            if {[llength $description]<3} {                                                                      ;# no initial value
                lappend description $switched::($this,[lindex $description 0])                               ;# append current value
                lappend descriptions $description
            } else {
                lappend descriptions [lreplace $description 2 2 $switched::($this,[lindex $description 0])]     ;# set current value
            }
        }
        return $descriptions
    }

}
