widget.tcl

一个用TCL/TK写的用于verilog的集成编辑环境.

# ------------------------------------------------------------------------------
#  Command Widget::syncoptions
# ------------------------------------------------------------------------------
proc Widget::syncoptions { class subclass subpath options } {
    upvar 0 ${class}::sync classync

    foreach {option realopt} $options {
        if { ![string length $realopt] } {
            set realopt $option
        }
        set classync($option) [list $subpath $subclass $realopt]
    }
}


# ------------------------------------------------------------------------------
#  Command Widget::init
# ------------------------------------------------------------------------------
proc Widget::init { class path options } {
    variable _class
    variable _optiontype

    upvar 0 ${class}::opt classopt
    upvar 0 ${class}::map classmap
    upvar 0 ${class}::$path:opt  pathopt
    upvar 0 ${class}::$path:mod  pathmod

    catch {unset pathopt}
    catch {unset pathmod}
    set fpath ".#BWidgetClass#$class"
    regsub -all "::" $class "" rdbclass
    if { ![winfo exists $fpath] } {
        frame $fpath -class $rdbclass
    }
    foreach {option optdesc} [array get classopt] {
        set type [lindex $optdesc 0]
        if { ![string compare $type "Synonym"] } {
            set option  [lindex $optdesc 1]
            set optdesc $classopt($option)
            set type    [lindex $optdesc 0]
        }
        if { ![string compare $type "TkResource"] } {
            set alt [lindex [lindex $optdesc 3] 1]
        } else {
            set alt ""
        }
        set optdb [lindex [_configure_option $option $alt] 0]
        set def   [option get $fpath $optdb $rdbclass]
        if { [string length $def] } {
            set pathopt($option) $def
        } else {
            set pathopt($option) [lindex $optdesc 1]
        }
        set pathmod($option) 0
    }

    set _class($path) $class
    foreach {option value} $options {
        if { ![info exists classopt($option)] } {
            unset pathopt
            unset pathmod
            return -code error "unknown option \"$option\""
        }
        set optdesc $classopt($option)
        set type    [lindex $optdesc 0]
        if { ![string compare $type "Synonym"] } {
            set option  [lindex $optdesc 1]
            set optdesc $classopt($option)
            set type    [lindex $optdesc 0]
        }
        set pathopt($option) [$_optiontype($type) $option $value [lindex $optdesc 3]]
    }
}


# ------------------------------------------------------------------------------
#  Command Widget::destroy
# ------------------------------------------------------------------------------
proc Widget::destroy { path } {
    variable _class

    set class $_class($path)
    upvar 0 ${class}::$path:opt pathopt
    upvar 0 ${class}::$path:mod pathmod

    catch {unset pathopt}
    catch {unset pathmod}
}


# ------------------------------------------------------------------------------
#  Command Widget::configure
# ------------------------------------------------------------------------------
proc Widget::configure { path options } {
    set len [llength $options]
    if { $len <= 1 } {
        return [_get_configure $path $options]
    } elseif { $len % 2 == 1 } {
        return -code error "incorrect number of arguments"
    }

    variable _class
    variable _optiontype

    set class $_class($path)
    upvar 0 ${class}::opt  classopt
    upvar 0 ${class}::map  classmap
    upvar 0 ${class}::$path:opt pathopt
    upvar 0 ${class}::$path:mod pathmod

    set window [_get_window $class $path]
    foreach {option value} $options {
        if { ![info exists classopt($option)] } {
            return -code error "unknown option \"$option\""
        }
        set optdesc $classopt($option)
        set type    [lindex $optdesc 0]
        if { ![string compare $type "Synonym"] } {
            set option  [lindex $optdesc 1]
            set optdesc $classopt($option)
            set type    [lindex $optdesc 0]
        }
        if { ![lindex $optdesc 2] } {
            set curval $pathopt($option)
            set newval [$_optiontype($type) $option $value [lindex $optdesc 3]]
            if { [info exists classmap($option)] } {
                foreach {subpath subclass realopt} $classmap($option) {
                    if { [string length $subclass] } {
                        ${subclass}::configure $window$subpath $realopt $newval
                    } else {
                        $window$subpath configure $realopt $newval
                    }
                }
            }
            set pathopt($option) $newval
            set pathmod($option) [expr {[string compare $newval $curval] != 0}]
        }
    }

    return {}
}


# ------------------------------------------------------------------------------
#  Command Widget::cget
# ------------------------------------------------------------------------------
proc Widget::cget { path option } {
    variable _class

    if { ![info exists _class($path)] } {
        return -code error "unknown widget $path"
    }

    set class $_class($path)
    upvar 0 ${class}::opt  classopt
    upvar 0 ${class}::sync classync
    upvar 0 ${class}::$path:opt pathopt

    if { ![info exists classopt($option)] } {
        return -code error "unknown option \"$option\""
    }
    set optdesc $classopt($option)
    set type    [lindex $optdesc 0]
    if { ![string compare $type "Synonym"] } {
        set option [lindex $optdesc 1]
    }

    if { [info exists classync($option)] } {
        set window [_get_window $class $path]
        foreach {subpath subclass realopt} $classync($option) {
            if { [string length $subclass] } {
                set pathopt($option) [${subclass}::cget $window$subpath $realopt]
            } else {
                set pathopt($option) [$window$subpath cget $realopt]
            }
        }
    }

    return $pathopt($option)
}


# ------------------------------------------------------------------------------
#  Command Widget::subcget
# ------------------------------------------------------------------------------
proc Widget::subcget { path subwidget } {
    variable _class

    set class $_class($path)
    upvar 0 ${class}::map classmap
    upvar 0 ${class}::$path:opt pathopt

    set result {}
    foreach {option map} [array get classmap] {
        foreach {subpath subclass realopt} $map {
            if { ![string compare $subpath $subwidget] } {
                lappend result $realopt $pathopt($option)
            }
        }
    }
    return $result
}


# ------------------------------------------------------------------------------
#  Command Widget::hasChanged
# ------------------------------------------------------------------------------
proc Widget::hasChanged { path option pvalue } {
    upvar    $pvalue value
    variable _class

    set class $_class($path)
    upvar 0 ${class}::$path:opt pathopt
    upvar 0 ${class}::$path:mod pathmod

    set value   $pathopt($option)
    set result  $pathmod($option)
    set pathmod($option) 0

    return $result
}


# ------------------------------------------------------------------------------
#  Command Widget::setoption
# ------------------------------------------------------------------------------
proc Widget::setoption { path option value } {
    variable _class

    set class $_class($path)
    upvar 0 ${class}::$path:opt pathopt

    set pathopt($option) $value
}


# ------------------------------------------------------------------------------
#  Command Widget::getoption
# ------------------------------------------------------------------------------
proc Widget::getoption { path option } {
    variable _class

    set class $_class($path)
    upvar 0 ${class}::$path:opt pathopt

    return $pathopt($option)
}


# ------------------------------------------------------------------------------
#  Command Widget::_get_window
#  returns the window corresponding to widget path
# ------------------------------------------------------------------------------
proc Widget::_get_window { class path } {
    set idx [string last "#" $path]
    if { $idx != -1 && ![string compare [string range $path [expr {$idx+1}] end] $class] } {
        return [string range $path 0 [expr {$idx-1}]]
    } else {
        return $path
    }
}


# ------------------------------------------------------------------------------
#  Command Widget::_get_configure
#  returns the configuration list of options
#  (as tk widget do - [$w configure ?option?])
# ------------------------------------------------------------------------------
proc Widget::_get_configure { path options } {
    variable _class

    set class $_class($path)
    upvar 0 ${class}::opt classopt
    upvar 0 ${class}::map classmap
    upvar 0 ${class}::$path:opt pathopt
    upvar 0 ${class}::$path:mod pathmod

    set len [llength $options]
    if { !$len } {
        set result {}
        foreach option [lsort [array names classopt]] {
            set optdesc $classopt($option)
            set type    [lindex $optdesc 0]
            if { ![string compare $type "Synonym"] } {
                set syn     $option
                set option  [lindex $optdesc 1]
                set optdesc $classopt($option)
                set type    [lindex $optdesc 0]
            } else {
                set syn ""
            }
            if { ![string compare $type "TkResource"] } {
                set alt [lindex [lindex $optdesc 3] 1]
            } else {
                set alt ""
            }
            set res [_configure_option $option $alt]
            if { $syn == "" } {
                lappend result [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
            } else {
                lappend result [list $syn [lindex $res 0]]
            }
        }
        return $result
    } elseif { $len == 1 } {
        set option  [lindex $options 0]
        if { ![info exists classopt($option)] } {
            return -code error "unknown option \"$option\""
        }
        set optdesc $classopt($option)
        set type    [lindex $optdesc 0]
        if { ![string compare $type "Synonym"] } {
            set option  [lindex $optdesc 1]
            set optdesc $classopt($option)
            set type    [lindex $optdesc 0]
        }
        if { ![string compare $type "TkResource"] } {
            set alt [lindex [lindex $optdesc 3] 1]
        } else {
            set alt ""
        }
        set res [_configure_option $option $alt]
        return [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
    }