# ----------------------------------------------------------------------------#  widget.tcl#  This file is part of Unifix BWidget Toolkit#  $Id: widget.tcl 5686 2005-12-29 14:11:56Z lephilousophe $# ----------------------------------------------------------------------------#  Index of commands:#     - Widget::tkinclude#     - Widget::bwinclude#     - Widget::declare#     - Widget::addmap#     - Widget::init#     - Widget::destroy#     - Widget::setoption#     - Widget::configure#     - Widget::cget#     - Widget::subcget#     - Widget::hasChanged#     - Widget::options#     - Widget::_get_tkwidget_options#     - Widget::_test_tkresource#     - Widget::_test_bwresource#     - Widget::_test_synonym#     - Widget::_test_string#     - Widget::_test_flag#     - Widget::_test_enum#     - Widget::_test_int#     - Widget::_test_boolean# ----------------------------------------------------------------------------# Each megawidget gets a namespace of the same name inside the Widget namespace# Each of these has an array opt, which contains information about the # megawidget options.  It maps megawidget options to a list with this format:#     {optionType defaultValue isReadonly {additionalOptionalInfo}}# Option types and their additional optional info are:#	TkResource	{genericTkWidget genericTkWidgetOptionName}#	BwResource	{nothing}#	Enum		{list of enumeration values}#	Int		{Boundary information}#	Boolean		{nothing}#	String		{nothing}#	Flag		{string of valid flag characters}#	Synonym		{nothing}#	Color		{nothing}## Next, each namespace has an array map, which maps class options to their# component widget options:#	map(-foreground) => {.e -foreground .f -foreground}## Each has an array ${path}:opt, which contains the value of each megawidget# option for a particular instance $path of the megawidget, and an array# ${path}:mod, which stores the "changed" status of configuration options.# Steps for creating a bwidget megawidget:# 1. parse args to extract subwidget spec# 2. Create frame with appropriate class and command line options# 3. Get initialization options from optionDB, using frame# 4. create subwidgets# Uses newer string operationspackage require Tcl 8.1.1namespace eval Widget {    variable _optiontype    variable _class    variable _tk_widget    array set _optiontype {        TkResource Widget::_test_tkresource        BwResource Widget::_test_bwresource        Enum       Widget::_test_enum        Int        Widget::_test_int        Boolean    Widget::_test_boolean        String     Widget::_test_string        Flag       Widget::_test_flag        Synonym    Widget::_test_synonym        Color      Widget::_test_color        Padding    Widget::_test_padding    }    proc use {} {}}# ----------------------------------------------------------------------------#  Command Widget::tkinclude#     Includes tk widget resources to BWidget widget.#  class      class name of the BWidget#  tkwidget   tk widget to include#  subpath    subpath to configure#  args       additionnal args for included options# ----------------------------------------------------------------------------proc Widget::tkinclude { class tkwidget subpath args } {    foreach {cmd lopt} $args {        # cmd can be        #   include      options to include            lopt = {opt ...}        #   remove       options to remove             lopt = {opt ...}        #   rename       options to rename             lopt = {opt newopt ...}        #   prefix       options to prefix             lopt = {pref opt opt ..}        #   initialize   set default value for options lopt = {opt value ...}        #   readonly     set readonly flag for options lopt = {opt flag ...}        switch -- $cmd {            remove {                foreach option $lopt {                    set remove($option) 1                }            }            include {                foreach option $lopt {                    set include($option) 1                }            }            prefix {                set prefix [lindex $lopt 0]                foreach option [lrange $lopt 1 end] {                    set rename($option) "-$prefix[string range $option 1 end]"                }            }            rename     -            readonly   -            initialize {                array set $cmd $lopt            }            default {                return -code error "invalid argument \"$cmd\""            }        }    }    namespace eval $class {}    upvar 0 ${class}::opt classopt    upvar 0 ${class}::map classmap    upvar 0 ${class}::map$subpath submap    upvar 0 ${class}::optionExports exports    set foo [$tkwidget ".ericFoo###"]    # create resources informations from tk widget resources    foreach optdesc [_get_tkwidget_options $tkwidget] {        set option [lindex $optdesc 0]        if { (![info exists include] || [info exists include($option)]) &&             ![info exists remove($option)] } {            if { [llength $optdesc] == 3 } {                # option is a synonym                set syn [lindex $optdesc 1]                if { ![info exists remove($syn)] } {                    # original option is not removed                    if { [info exists rename($syn)] } {                        set classopt($option) [list Synonym $rename($syn)]                    } else {                        set classopt($option) [list Synonym $syn]                    }                }            } else {                if { [info exists rename($option)] } {                    set realopt $option                    set option  $rename($option)                } else {                    set realopt $option                }                if { [info exists initialize($option)] } {                    set value $initialize($option)                } else {                    set value [lindex $optdesc 1]                }                if { [info exists readonly($option)] } {                    set ro $readonly($option)                } else {                    set ro 0                }                set classopt($option) \			[list TkResource $value $ro [list $tkwidget $realopt]]		# Add an option database entry for this option		set optionDbName ".[lindex [_configure_option $option ""] 0]"		if { ![string equal $subpath ":cmd"] } {		    set optionDbName "$subpath$optionDbName"		}		option add *${class}$optionDbName $value widgetDefault		lappend exports($option) "$optionDbName"		# Store the forward and backward mappings for this		# option <-> realoption pair                lappend classmap($option) $subpath "" $realopt		set submap($realopt) $option            }        }    }    ::destroy $foo}# ----------------------------------------------------------------------------#  Command Widget::bwinclude#     Includes BWidget resources to BWidget widget.#  class    class name of the BWidget#  subclass BWidget class to include#  subpath  subpath to configure#  args     additionnal args for included options# ----------------------------------------------------------------------------proc Widget::bwinclude { class subclass subpath args } {    foreach {cmd lopt} $args {        # cmd can be        #   include      options to include            lopt = {opt ...}        #   remove       options to remove             lopt = {opt ...}        #   rename       options to rename             lopt = {opt newopt ...}        #   prefix       options to prefix             lopt = {prefix opt opt ...}        #   initialize   set default value for options lopt = {opt value ...}        #   readonly     set readonly flag for options lopt = {opt flag ...}        switch -- $cmd {            remove {                foreach option $lopt {                    set remove($option) 1                }            }            include {                foreach option $lopt {                    set include($option) 1                }            }            prefix {                set prefix [lindex $lopt 0]                foreach option [lrange $lopt 1 end] {                    set rename($option) "-$prefix[string range $option 1 end]"                }            }            rename     -            readonly   -            initialize {                array set $cmd $lopt            }            default {                return -code error "invalid argument \"$cmd\""            }        }    }    namespace eval $class {}    upvar 0 ${class}::opt classopt    upvar 0 ${class}::map classmap    upvar 0 ${class}::map$subpath submap    upvar 0 ${class}::optionExports exports    upvar 0 ${subclass}::opt subclassopt    upvar 0 ${subclass}::optionExports subexports    # create resources informations from BWidget resources    foreach {option optdesc} [array get subclassopt] {	set subOption $option        if { (![info exists include] || [info exists include($option)]) &&             ![info exists remove($option)] } {            set type [lindex $optdesc 0]            if { [string equal $type "Synonym"] } {                # option is a synonym                set syn [lindex $optdesc 1]                if { ![info exists remove($syn)] } {                    if { [info exists rename($syn)] } {                        set classopt($option) [list Synonym $rename($syn)]                    } else {                        set classopt($option) [list Synonym $syn]                    }                }            } else {                if { [info exists rename($option)] } {                    set realopt $option                    set option  $rename($option)                } else {                    set realopt $option                }                if { [info exists initialize($option)] } {                    set value $initialize($option)                } else {                    set value [lindex $optdesc 1]                }                if { [info exists readonly($option)] } {                    set ro $readonly($option)                } else {                    set ro [lindex $optdesc 2]                }                set classopt($option) \			[list $type $value $ro [lindex $optdesc 3]]		# Add an option database entry for this option		foreach optionDbName $subexports($subOption) {		    if { ![string equal $subpath ":cmd"] } {			set optionDbName "$subpath$optionDbName"		    }		    # Only add the option db entry if we are overriding the		    # normal widget default		    if { [info exists initialize($option)] } {			option add *${class}$optionDbName $value \				widgetDefault		    }		    lappend exports($option) "$optionDbName"		}		# Store the forward and backward mappings for this		# option <-> realoption pair                lappend classmap($option) $subpath $subclass $realopt		set submap($realopt) $option            }        }    }}# ----------------------------------------------------------------------------#  Command Widget::declare#    Declares new options to BWidget class.# ----------------------------------------------------------------------------proc Widget::declare { class optlist } {    variable _optiontype    namespace eval $class {}    upvar 0 ${class}::opt classopt    upvar 0 ${class}::optionExports exports    upvar 0 ${class}::optionClass optionClass    foreach optdesc $optlist {        set option  [lindex $optdesc 0]        set optdesc [lrange $optdesc 1 end]        set type    [lindex $optdesc 0]        if { ![info exists _optiontype($type)] } {            # invalid resource type            return -code error "invalid option type \"$type\""        }        if { [string equal $type "Synonym"] } {            # test existence of synonym option            set syn [lindex $optdesc 1]            if { ![info exists classopt($syn)] } {                return -code error "unknow option \"$syn\" for Synonym \"$option\""            }            set classopt($option) [list Synonym $syn]            continue        }        # all other resource may have default value, readonly flag and        # optional arg depending on type        set value [lindex $optdesc 1]        set ro    [lindex $optdesc 2]        set arg   [lindex $optdesc 3]        if { [string equal $type "BwResource"] } {            # We don't keep BwResource. We simplify to type of sub BWidget            set subclass    [lindex $arg 0]            set realopt     [lindex $arg 1]            if { ![string length $realopt] } {                set realopt $option            }            upvar 0 ${subclass}::opt subclassopt            if { ![info exists subclassopt($realopt)] } {                return -code error "unknow option \"$realopt\""            }            set suboptdesc $subclassopt($realopt)            if { $value == "" } {                # We initialize default value                set value [lindex $suboptdesc 1]            }            set type [lindex $suboptdesc 0]            set ro   [lindex $suboptdesc 2]            set arg  [lindex $suboptdesc 3]	    set optionDbName ".[lindex [_configure_option $option ""] 0]"	    option add *${class}${optionDbName} $value widgetDefault	    set exports($option) $optionDbName            set classopt($option) [list $type $value $ro $arg]            continue        }        # retreive default value for TkResource        if { [string equal $type "TkResource"] } {            set tkwidget [lindex $arg 0]	    set foo [$tkwidget ".ericFoo##"]            set realopt  [lindex $arg 1]            if { ![string length $realopt] } {                set realopt $option            }            set tkoptions [_get_tkwidget_options $tkwidget]            if { ![string length $value] } {                # We initialize default value		set ind [lsearch $tkoptions [list $realopt *]]                set value [lindex [lindex $tkoptions $ind] end]            }	    set optionDbName ".[lindex [_configure_option $option ""] 0]"	    option add *${class}${optionDbName} $value widgetDefault