# $Id: scwoop.tcl,v 3.12 2003/03/28 10:07:51 jfontain Exp $


package provide scwoop 4.1

class widget {

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

    proc ~widget {this} {}

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

    virtual proc cget {this args} {                                     ;# for native widgets, arguments sole element is option name
        return [$($this,path) cget $args]
    }

    set option() {}                                                           ;### should not be necessary according to trace manual
    # usage; option(widget,option) as in: $widget::option(button,borderwidth)
    trace variable option r ::widget::checkOption

    # option value is retrieved only when needed, dynamically, as opposed to preset default values, which may have been changed
    # in the option database, preferably at the beginning of the program, since options are cached here once set, for efficiency
    proc checkOption {array index operations} {
        variable option

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

}


foreach class {button canvas entry frame label listbox menu menubutton message radiobutton scale scrollbar text toplevel} {
    class $class {                                                        ;# create a widget wrapper class for each native Tk widget
        # use fully qualified widget command so it does not interfere with class constructor procedure in class namespace
        # if parent is ., Tcl widget command automatically strips off extra dot, that is ..path becomes .path
        proc $class {this parentPath args} widget "\[eval ::$class \$parentPath.\$this \$args\]" {}
        proc ~$class {this} {destroy $widget::($this,path)}
    }
}
if {[package vcompare $::tcl_version 8.4] >= 0} {
    class spinbox {
        proc spinbox {this parentPath args} widget {[eval ::spinbox $parentPath.$this $args]} {}
        proc ~spinbox {this} {destroy $widget::($this,path)}
    }
}

# eventually comment out the following lines if you do not use the great tkTable widget:
class table {
    proc table {this parentPath args} widget {[eval ::table $parentPath.$this $args]} {}
    proc ~table {this} {destroy $widget::($this,path)}
}

# use the following wrappers for BLT (eventually comment out if you do not use the great BLT library):
# (which works around the following bug: [blt::graph ..g] returns .g but .g command does not exist, whereas ..g does)
foreach class {barchart graph hierbox htext stripchart tabset treeview} {
    class $class {
        proc $class {this parentPath args} widget "\[eval ::blt::$class .\[string trimleft \$parentPath.\$this .\] \$args\]" {}
        proc ~$class {this} {destroy $widget::($this,path)}
    }
}

class composite {}

# arguments are option / value pairs as are arguments to Tk widgets configure command
proc composite::composite {this base args} widget {$widget::($base,path)} {
    if {([llength $args]%2)!=0} {
        error "value for \"[lindex $args end]\" missing"
    }
    set ($this,base) $base
    # base path is actually identical to widget path (in widget constructor) but is defined here for consistency
    set ($this,base,path) $widget::($base,path)
    set ($this,_children) {}
    set ($this,complete) 0
    # delay arguments processing till completion as pure virtual procedure invocations do not work from base class constructor
    set ($this,initialArguments) $args
}

# delete children in reverse order of creation because Tk native widgets when destroyed destroy their children as well
proc composite::~composite {this} {
    eval delete [lsort -integer -decreasing $($this,_children)] $($this,base)
}

# derived class implementation must return a list of {name dbname dbclass defaultValue currentValue} lists, as Tk widget configure
# options with current value optional
virtual proc composite::options {this}

proc composite::configure {this args} {
    if {[llength $args]==0} {
        return [descriptions $this]
    }
    if {![string match -* $args]} {
        # first argument is a child widget name (no leading -), so configure child with optional option / value pairs
        return [eval widget::configure $($this,[lindex $args 0]) [lrange $args 1 end]]
    }
    foreach {option value} $args {                                          ;# check all options validity before doing anything else
        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"
    }
    # derived (dynamic virtual) procedure must either accept (or eventually adjust) the value or throw an error
    # option data member is set prior to calling the method in case other methods are called and expect the new value
    foreach {option value} $args {
        if {![string equal $($this,$option) $value]} {
            $($this,_derived)::set$option $this [set ($this,$option) $value]
        }
    }
}

proc composite::manage {this args} {
    # arguments are one or more child widgets (widget class is composite base class) associated with a name which can later be
    # used to retrieve the widget object and the widget path, at the composite level
    foreach {child name} $args {
        if {[string length $name]==0} {
            error "widget $child has no name"
        }
        if {[string match -* $name]} {
            error "widget $child name \"$name\" must not start with a dash character"
        }
        if {[info exists ($this,$name)]} {
            error "\"$name\" member name already exists in composite layer"
        }
        set ($this,$name) $child
        set ($this,$name,path) $widget::($child,path)
        lappend ($this,_children) $child
    }
}

# must be invoked at the end of derived class constructor so that components are properly configured
proc composite::complete {this} {
    foreach description [options $this] {
        set option [lindex $description 0]
        set ($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 equal $default [lindex $description 2]]} {
            set ($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} $($this,initialArguments) {
        if {[catch {string compare $($this,$option) $value} different]} {
            error "$($this,_derived): unknown option \"$option\""
        }
        if {$different} {
            set ($this,$option) $value
            set initialize($option) {}
        }
    }
    unset ($this,initialArguments)
    foreach option [array names initialize] {       ;# all option values are initialized before any of the set procedures are called
        $($this,_derived)::set$option $this $($this,$option)
    }
    set ($this,complete) 1
}

proc composite::cget {this args} {
    switch [llength $args] {
        0 {
            error "wrong # args: should be \"cget $this ?child? ?child? ... option\""
        }
        1 {                                                  ;# sole argument is option name, which must start with a dash character
            if {![string match -* $args]||![info exists ($this,$args)]} {
                error "$($this,_derived): unknown option \"$args\""
            }
            return $($this,$args)                                                           ;# return specified option current value
        }
        default {                                                                    ;# leading arguments must be child widget names
            return [eval widget::cget $($this,[lindex $args 0]) [lrange $args 1 end]]
        }
    }
}

# may be used by derived class for options that it does not implement, but no error checking here, not optimal for debugging
proc composite::try {this args} {
    if {([llength $args]%2)!=0} {
        error "value for \"[lindex $args end]\" missing"
    }
    foreach {option value} $args {                                      ;# for best results, try each option / value pair separately
        catch {widget::configure $($this,base) $option $value}
        foreach child $($this,_children) {
            catch {widget::configure $child $option $value}
        }
    }
}

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

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

proc composite::managingOrder {this name1 name2} {    ;# sort command: returns a negative value if first widget is older than second
    return [expr {$($this,$name1)-$($this,$name2)}]
}

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