mainframe.tcl

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

}


# ------------------------------------------------------------------------------
#  Command MainFrame::getindicator
# ------------------------------------------------------------------------------
proc MainFrame::getindicator { path index } {
    return $path.status.indf.f$index
}


# ------------------------------------------------------------------------------
#  Command MainFrame::getmenu
# ------------------------------------------------------------------------------
proc MainFrame::getmenu { path menuid } {
    variable _widget

    if { [info exists _widget($path,menuid,$menuid)] } {
        return $_widget($path,menuid,$menuid)
    }
    return ""
}


# ------------------------------------------------------------------------------
#  Command MainFrame::setmenustate
# ------------------------------------------------------------------------------
proc MainFrame::setmenustate { path tag state } {
    variable _widget

    if { [info exists _widget($path,tags,$tag)] } {
        foreach {menu entry} $_widget($path,tags,$tag) {
            $menu entryconfigure $entry -state $state
        }
    }
}


# ------------------------------------------------------------------------------
#  Command MainFrame::showtoolbar
# ------------------------------------------------------------------------------
proc MainFrame::showtoolbar { path index bool } {
    variable _widget

    set toolframe $path.topf.f$index
    if { [winfo exists $toolframe] } {
        if { !$bool && [llength [grid info $toolframe]] } {
            grid forget $toolframe
            $path.topf configure -height 1
        } elseif { $bool && ![llength [grid info $toolframe]] } {
            grid $toolframe -column 0 -row $index -sticky ew
        }
    }
}


# ------------------------------------------------------------------------------
#  Command MainFrame::showstatusbar
# ------------------------------------------------------------------------------
proc MainFrame::showstatusbar { path name } {
    set status $path.status
    if { ![string compare $name "none"] } {
        pack forget $status
    } else {
        pack $status -fill x
        switch -- $name {
            status {
                catch {pack forget $status.prg}
            }
            progression {
                pack $status.prg -in $status.prgf
            }
        }
    }
}


# ------------------------------------------------------------------------------
#  Command MainFrame::_destroy
# ------------------------------------------------------------------------------
proc MainFrame::_destroy { path } {
    variable _widget

    Widget::destroy $path
    catch {destroy [$_widget($path,top) cget -menu]}
    $_widget($path,top) configure -menu {}
    unset _widget($path,top)
    unset _widget($path,ntoolbar)
    unset _widget($path,nindic)
    rename $path {}
}


# ------------------------------------------------------------------------------
#  Command MainFrame::_create_menubar
# ------------------------------------------------------------------------------
proc MainFrame::_create_menubar { path descmenu } {
    variable _widget
    global    tcl_platform

    set bg      [Widget::getoption $path -background]
    set top     $_widget($path,top)
    if { $tcl_platform(platform) == "unix" } {
        set menubar [menu $top.menubar -tearoff 0 -background $bg -borderwidth 1]
    } else {
        set menubar [menu $top.menubar -tearoff 0 -background $bg]
    }
    $top configure -menu $menubar

    set count 0
    foreach {name tags menuid tearoff entries} $descmenu {
        set opt  [_parse_name $name]
        if { [string length $menuid] && ![info exists _widget($path,menuid,$menuid)] } {
            # menu has identifier
	    # we use it for its pathname, to enable special menu entries
	    # (help, system, ...)
	    set menu $menubar.$menuid
        } else {
	    set menu $menubar.menu$count
	}
        eval $menubar add cascad $opt -menu $menu
        menu $menu -tearoff $tearoff -background $bg
        foreach tag $tags {
            lappend _widget($path,tags,$tag) $menubar $count
        }
        if { [string length $menuid] } {
            # menu has identifier
            set _widget($path,menuid,$menuid) $menu
        }
        _create_entries $path $menu $bg $entries
        incr count
    }
}


# ------------------------------------------------------------------------------
#  Command MainFrame::_create_entries
# ------------------------------------------------------------------------------
proc MainFrame::_create_entries { path menu bg entries } {
    variable _widget

    set count      [$menu cget -tearoff]
    set registered 0
    foreach entry $entries {
        set len  [llength $entry]
        set type [lindex $entry 0]

        if { ![string compare $type "separator"] } {
            $menu add separator
            incr count
            continue
        }

        # entry name and tags
        set opt  [_parse_name [lindex $entry 1]]
        set tags [lindex $entry 2]
        foreach tag $tags {
            lappend _widget($path,tags,$tag) $menu $count
        }

        if { ![string compare $type "cascad"] } {
            set menuid  [lindex $entry 3]
            set tearoff [lindex $entry 4]
            set submenu $menu.menu$count
            eval $menu add cascad $opt -menu $submenu
            menu $submenu -tearoff $tearoff -background $bg
            if { [string length $menuid] } {
                # menu has identifier
                set _widget($path,menuid,$menuid) $submenu
            }
            _create_entries $path $submenu $bg [lindex $entry 5]
            incr count
            continue
        }

        # entry help description
        set desc [lindex $entry 3]
        if { [string length $desc] } {
            if { !$registered } {
                DynamicHelp::register $menu menu [Widget::getoption $path -textvariable]
                set registered 1
            }
            DynamicHelp::register $menu menuentry $count $desc
        }

        # entry accelerator
        set accel [_parse_accelerator [lindex $entry 4]]
        if { [llength $accel] } {
            lappend opt -accelerator [lindex $accel 0]
            bind $_widget($path,top) [lindex $accel 1] "$menu invoke $count"
        }

        # user options
        set useropt [lrange $entry 5 end]
        if { ![string compare $type "command"] || 
             ![string compare $type "radiobutton"] ||
             ![string compare $type "checkbutton"] } {
            eval $menu add $type $opt $useropt
        } else {
            return -code error "invalid menu type \"$type\""
        }
        incr count
    }
}


# ------------------------------------------------------------------------------
#  Command MainFrame::_parse_name
# ------------------------------------------------------------------------------
proc MainFrame::_parse_name { menuname } {
    set idx [string first "&" $menuname]
    if { $idx == -1 } {
        return [list -label $menuname]
    } else {
        set beg [string range $menuname 0 [expr $idx-1]]
        set end [string range $menuname [expr $idx+1] end]
        append beg $end
        return [list -label $beg -underline $idx]
    }
}


# ------------------------------------------------------------------------------
#  Command MainFrame::_parse_accelerator
# ------------------------------------------------------------------------------
proc MainFrame::_parse_accelerator { desc } {
    if { [llength $desc] == 2 } {
        set seq [lindex $desc 0]
        set key [lindex $desc 1]
        switch -- $seq {
            Ctrl {
                set accel "Ctrl+[string toupper $key]"
                set event "<Control-Key-[string tolower $key]>"
            }
            Alt {
                set accel "Atl+[string toupper $key]"
                set event "<Alt-Key-[string tolower $key]>"
            }
            CtrlAlt {
                set accel "Ctrl+Alt+[string toupper $key]"
                set event "<Control-Alt-Key-[string tolower $key]>"
            }
            default {
                return -code error "invalid accelerator code $seq"
            }
        }
        return [list $accel $event]
    }
    return {}
}