widget.tcl

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

}


# ------------------------------------------------------------------------------
#  Command Widget::_configure_option
# ------------------------------------------------------------------------------
proc Widget::_configure_option { option altopt } {
    variable _optiondb
    variable _optionclass

    if { [info exists _optiondb($option)] } {
        set optdb $_optiondb($option)
    } else {
        set optdb [string range $option 1 end]
    }
    if { [info exists _optionclass($option)] } {
        set optclass $_optionclass($option)
    } elseif { [string length $altopt] } {
        if { [info exists _optionclass($altopt)] } {
            set optclass $_optionclass($altopt)
        } else {
            set optclass [string range $altopt 1 end]
        }
    } else {
        set optclass [string range $option 1 end]
    }
    return [list $optdb $optclass]
}


# ------------------------------------------------------------------------------
#  Command Widget::_get_tkwidget_options
# ------------------------------------------------------------------------------
proc Widget::_get_tkwidget_options { tkwidget } {
    variable _tk_widget
    variable _optiondb
    variable _optionclass

    if { ![info exists _tk_widget($tkwidget)] } {
        set widget [$tkwidget ".#BWidget#$tkwidget"]
        set config [$widget configure]
        foreach optlist $config {
            set opt [lindex $optlist 0]
            if { [llength $optlist] == 2 } {
                set refsyn [lindex $optlist 1]
                # search for class
                set idx [lsearch $config [list * $refsyn *]]
                if { $idx == -1 } {
                    if { [string index $refsyn 0] == "-" } {
                        # search for option (tk8.1b1 bug)
                        set idx [lsearch $config [list $refsyn * *]]
                    } else {
                        # last resort
                        set idx [lsearch $config [list -[string tolower $refsyn] * *]]
                    }
                    if { $idx == -1 } {
                        # fed up with "can't read classopt()"
                        return -code error "can't find option of synonym $opt"
                    }
                }
                set syn [lindex [lindex $config $idx] 0]
                set def [lindex [lindex $config $idx] 3]
                lappend _tk_widget($tkwidget) [list $opt $syn $def]
            } else {
                set def [lindex $optlist 3]
                lappend _tk_widget($tkwidget) [list $opt $def]
                set _optiondb($opt)    [lindex $optlist 1]
                set _optionclass($opt) [lindex $optlist 2]
            }
        }
    }
    return $_tk_widget($tkwidget)
}


# ------------------------------------------------------------------------------
#  Command Widget::_test_tkresource
# ------------------------------------------------------------------------------
proc Widget::_test_tkresource { option value arg } {
    set tkwidget [lindex $arg 0]
    set realopt  [lindex $arg 1]
    set path     ".#BWidget#$tkwidget"
    set old      [$path cget $realopt]
    $path configure $realopt $value
    set res      [$path cget $realopt]
    $path configure $realopt $old

    return $res
}


# ------------------------------------------------------------------------------
#  Command Widget::_test_bwresource
# ------------------------------------------------------------------------------
proc Widget::_test_bwresource { option value arg } {
    return -code error "bad option type BwResource in widget"
}


# ------------------------------------------------------------------------------
#  Command Widget::_test_synonym
# ------------------------------------------------------------------------------
proc Widget::_test_synonym { option value arg } {
    return -code error "bad option type Synonym in widget"
}


# ------------------------------------------------------------------------------
#  Command Widget::_test_string
# ------------------------------------------------------------------------------
proc Widget::_test_string { option value arg } {
    return $value
}


# ------------------------------------------------------------------------------
#  Command Widget::_test_flag
# ------------------------------------------------------------------------------
proc Widget::_test_flag { option value arg } {
    set len [string length $value]
    set res ""
    for {set i 0} {$i < $len} {incr i} {
        set c [string index $value $i]
        if { [string first $c $arg] == -1 } {
            return -code error "bad [string range $option 1 end] value \"$value\": characters must be in \"$arg\""
        }
        if { [string first $c $res] == -1 } {
            append res $c
        }
    }
    return $res
}


# ------------------------------------------------------------------------------
#  Command Widget::_test_enum
# ------------------------------------------------------------------------------
proc Widget::_test_enum { option value arg } {
    if { [lsearch $arg $value] == -1 } {
        set last [lindex   $arg end]
        set sub  [lreplace $arg end end]
        if { [llength $sub] } {
            set str "[join $sub ", "] or $last"
        } else {
            set str $last
        }
        return -code error "bad [string range $option 1 end] value \"$value\": must be $str"
    }
    return $value
}


# ------------------------------------------------------------------------------
#  Command Widget::_test_int
# ------------------------------------------------------------------------------
proc Widget::_test_int { option value arg } {
    set binf [lindex $arg 0]
    set bsup [lindex $arg 1]
    if { $binf != "" } {set binf ">$binf"}
    if { $bsup != "" } {set bsup "<$bsup"}
    if { [catch {expr $value}] || $value != int($value) ||
         !($binf == "" || [expr $value$binf]) ||
         !($bsup == "" || [expr $value$bsup]) } {
        return -code error "bad [string range $option 1 end] value \"$value\": must be integer $binf $bsup"
    }
    return $value
}


# ------------------------------------------------------------------------------
#  Command Widget::_test_boolean
# ------------------------------------------------------------------------------
proc Widget::_test_boolean { option value arg } {
    if { $value == 1 ||
         ![string compare $value "true"] ||
         ![string compare $value "yes"] } {
        set value 1
    } elseif { $value == 0 ||
               ![string compare $value "false"] ||
               ![string compare $value "no"] } {
        set value 0
    } else {
        return -code error "bad [string range $option 1 end] value \"$value\": must be boolean"
    }
    return $value
}


# ------------------------------------------------------------------------------
#  Command Widget::focusNext
#  Same as tk_focusNext, but call Widget::focusOK
# ------------------------------------------------------------------------------
proc Widget::focusNext { w } {
    set cur $w
    while 1 {

	# Descend to just before the first child of the current widget.

	set parent $cur
	set children [winfo children $cur]
	set i -1

	# Look for the next sibling that isn't a top-level.

	while 1 {
	    incr i
	    if {$i < [llength $children]} {
		set cur [lindex $children $i]
		if {[winfo toplevel $cur] == $cur} {
		    continue
		} else {
		    break
		}
	    }

	    # No more siblings, so go to the current widget's parent.
	    # If it's a top-level, break out of the loop, otherwise
	    # look for its next sibling.

	    set cur $parent
	    if {[winfo toplevel $cur] == $cur} {
		break
	    }
	    set parent [winfo parent $parent]
	    set children [winfo children $parent]
	    set i [lsearch -exact $children $cur]
	}
	if {($cur == $w) || [focusOK $cur]} {
	    return $cur
	}
    }
}


# ------------------------------------------------------------------------------
#  Command Widget::focusPrev
#  Same as tk_focusPrev, but call Widget::focusOK
# ------------------------------------------------------------------------------
proc Widget::focusPrev { w } {
    set cur $w
    while 1 {

	# Collect information about the current window's position
	# among its siblings.  Also, if the window is a top-level,
	# then reposition to just after the last child of the window.
    
	if {[winfo toplevel $cur] == $cur}  {
	    set parent $cur
	    set children [winfo children $cur]
	    set i [llength $children]
	} else {
	    set parent [winfo parent $cur]
	    set children [winfo children $parent]
	    set i [lsearch -exact $children $cur]
	}

	# Go to the previous sibling, then descend to its last descendant
	# (highest in stacking order.  While doing this, ignore top-levels
	# and their descendants.  When we run out of descendants, go up
	# one level to the parent.

	while {$i > 0} {
	    incr i -1
	    set cur [lindex $children $i]
	    if {[winfo toplevel $cur] == $cur} {
		continue
	    }
	    set parent $cur
	    set children [winfo children $parent]
	    set i [llength $children]
	}
	set cur $parent
	if {($cur == $w) || [focusOK $cur]} {
	    return $cur
	}
    }
}


# ------------------------------------------------------------------------------
#  Command Widget::focusOK
#  Same as tk_focusOK, but handles -editable option and whole tags list.
# ------------------------------------------------------------------------------
proc Widget::focusOK { w } {
    set code [catch {$w cget -takefocus} value]
    if { $code == 1 } {
        return 0
    }
    if {($code == 0) && ($value != "")} {
	if {$value == 0} {
	    return 0
	} elseif {$value == 1} {
	    return [winfo viewable $w]
	} else {
	    set value [uplevel \#0 $value $w]
            if {$value != ""} {
		return $value
	    }
        }
    }
    if {![winfo viewable $w]} {
	return 0
    }
    set code [catch {$w cget -state} value]
    if {($code == 0) && ($value == "disabled")} {
	return 0
    }
    set code [catch {$w cget -editable} value]
    if {($code == 0) && !$value} {
        return 0
    }

    set top [winfo toplevel $w]
    foreach tags [bindtags $w] {
        if { [string compare $tags $top]  &&
             [string compare $tags "all"] &&
             [regexp Key [bind $tags]] } {
            return 1
        }
    }
    return 0
}