mainframe.tcl

mainframe.tcl
This file is part of Unifix BWidget Toolkit
$Id: mainframe.tcl,v 1.13 2002/05/29 22:02:49 andreas_kupries Exp $
Index of commands:
- MainFrame::create
- MainFrame::configure
- MainFrame::cget
- MainFrame::getframe
- MainFrame::addtoolbar
- MainFrame::gettoolbar
- MainFrame::addindicator
- MainFrame::getindicator
- MainFrame::getmenu
- MainFrame::menuonly
- MainFrame::showtoolbar
- MainFrame::showstatusbar
- MainFrame::_create_menubar
- MainFrame::_create_entries
- MainFrame::_parse_name
- MainFrame::_parse_accelerator


MainFrame
Comments  
Arguments  
Used by  
Uses  
namespace eval MainFrame {
    ProgressBar::use

    Widget::bwinclude MainFrame ProgressBar .status.prg \
        remove {
    -fg -bg -bd -troughcolor -background -borderwidth
    -relief -orient -width -height
    } \
        rename {
    -maximum    -progressmax
    -variable   -progressvar
    -type       -progresstype
    -foreground -progressfg
    }

    Widget::declare MainFrame {
    {-width        TkResource 0      0 frame}
    {-height       TkResource 0      0 frame}
    {-background   TkResource ""     0 frame}
    {-textvariable String     ""     0}
    {-menu         String     {}     1}
    {-separator    Enum       both   1 {none top bottom both}}
    {-bg           Synonym    -background}

    {-menubarfont   String     ""  0}
    {-menuentryfont String     ""  0}
    {-statusbarfont String     ""  0}
    }

    Widget::addmap MainFrame "" .frame  {-width {} -height {} -background {}}
    Widget::addmap MainFrame "" .topf   {-background {}}
    Widget::addmap MainFrame "" .botf   {-background {}}
    Widget::addmap MainFrame "" .status {-background {}}
    Widget::addmap MainFrame "" .status.label {-background {}}
    Widget::addmap MainFrame "" .status.indf  {-background {}}
    Widget::addmap MainFrame "" .status.prgf  {-background {}}
    Widget::addmap MainFrame ProgressBar .status.prg {-background {} -background -troughcolor}

    proc ::MainFrame { path args } { return [eval MainFrame::create $path $args] }
    proc use {} {}

    variable _widget
}


MainFrame::_create_entries
Comments Command MainFrame::_create_entries
Arguments path
menu
bg
entries
Used by  
Uses DynamicHelp::register
Widget::getoption
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
        # ericm@scriptics:  Add a tagstate tracker
        if { ![info exists _widget($path,tagstate,$tag)] } {
        set _widget($path,tagstate,$tag) 1
        }
        }
    # ericm@scriptics.com:  Add mapping from menu items to tags
    set _widget($path,menutags,[list $menu $count]) $tags

        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
    }
}


MainFrame::_create_menubar
Comments Command MainFrame::_create_menubar
Arguments path
descmenu
Used by  
Uses Widget::getoption
proc MainFrame::_create_menubar { path descmenu } {
    variable _widget
    global    tcl_platform

    set bg      [Widget::getoption $path -background]
    set top     $_widget($path,top)

    foreach {v x} {mbfnt -menubarfont mefnt -menuentryfont} {
    if {[string length [Widget::getoption $path $x]]} {
        set $v [list -font [Widget::getoption $path $x]]
    } else {
        set $v ""
    }
    }

    if {$tcl_platform(platform) == "unix"} {
    lappend mbfnt -borderwidth 1
    }
    set menubar [eval [list menu $top.menubar -tearoff 0 \
        -background $bg] $mbfnt]
    $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 cascade $opt -menu $menu
        eval [list menu $menu -tearoff $tearoff -background $bg] $mefnt
        foreach tag $tags {
            lappend _widget($path,tags,$tag) $menubar $count
        # ericm@scriptics:  Add a tagstate tracker
        if { ![info exists _widget($path,tagstate,$tag)] } {
        set _widget($path,tagstate,$tag) 1
        }
        }
    # ericm@scriptics.com:  Add mapping from menu items to tags
    set _widget($path,menutags,[list $menubar $count]) $tags
        
        if { [string length $menuid] } {
            # menu has identifier
            set _widget($path,menuid,$menuid) $menu
        }
        _create_entries $path $menu $bg $entries
        incr count
    }
}


MainFrame::_destroy
Comments Command MainFrame::_destroy
Arguments path
Used by MainFrame::create
Uses Widget::destroy
proc MainFrame::_destroy { path } {
    variable _widget

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

    # Unset all of the state vars associated with this main frame.
    foreach index [array names _widget $path,*] {
    unset _widget($index)
    }
    rename $path {}
}


MainFrame::_parse_accelerator
Comments MainFrame::_parse_accelerator --

Given a key combo description, construct an appropriate human readable
string (for display on as a menu accelerator) and the corresponding
bind event.

Arguments:
desc a list with the following format:
?sequence? key
sequence may be None, Ctrl, Alt, or CtrlAlt
key may be any key

Results:
{accel event} a list containing the accelerator string and the event
Arguments desc
Used by  
Uses  
proc MainFrame::_parse_accelerator { desc } {
    if { [llength $desc] == 1 } {
    set seq None
    set key [string tolower [lindex $desc 0]]
    # If the key is an F key (ie, F1, F2, etc), it has to be capitalized
    if {[regexp {f[1]?[0-9]*} $key]} {
        set key [string toupper $key]
    }
    } elseif { [llength $desc] == 2 } {
        set seq [lindex $desc 0]
        set key [string tolower [lindex $desc 1]]
    # If the key is an F key (ie, F1, F2, etc), it has to be capitalized
    if {[regexp {f[1]?[0-9]*} $key]} {
        set key [string toupper $key]
    }
    } else {
    return {}
    }
    switch -- $seq {
    None {
        set accel "[string toupper $key]"
        set event "<Key-$key>"
    }
    Ctrl {
        set accel "Ctrl+[string toupper $key]"
        set event "<Control-Key-$key>"
    }
    Alt {
        set accel "Alt+[string toupper $key]"
        set event "<Alt-Key-$key>"
    }
    CtrlAlt {
        set accel "Ctrl+Alt+[string toupper $key]"
        set event "<Control-Alt-Key-$key>"
    }
    default {
        return -code error "invalid accelerator code $seq"
    }
    }
    return [list $accel $event]
}


MainFrame::_parse_name
Comments Command MainFrame::_parse_name
Arguments menuname
Used by  
Uses  
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]
    }
}


MainFrame::addindicator
Comments Command MainFrame::addindicator
Arguments path
args
Used by  
Uses Widget::getoption
proc MainFrame::addindicator { path args } {
    variable _widget

    if {[string length [Widget::getoption $path -statusbarfont]]} {
    set sbfnt [list -font [Widget::getoption $path -statusbarfont]]
    } else {
    set sbfnt ""
    }

    set index $_widget($path,nindic)
    set indic $path.status.indf.f$index
    eval label $indic $args -relief sunken -borderwidth 1 \
        -takefocus 0 -highlightthickness 0 $sbfnt

    pack $indic -side left -anchor w -padx 2 -fill y -expand 1

    incr _widget($path,nindic)

    return $indic
}


MainFrame::addtoolbar
Comments Command MainFrame::addtoolbar
Arguments path
Used by  
Uses Separator::create
Widget::getoption
proc MainFrame::addtoolbar { path } {
    global   tcl_platform
    variable _widget

    set index     $_widget($path,ntoolbar)
    set toolframe $path.topf.f$index
    set toolbar   $path.topf.tb$index
    set bg        [Widget::getoption $path -background]
    if { $tcl_platform(platform) == "unix" } {
        frame $toolframe -relief raised -borderwidth 1 \
            -takefocus 0 -highlightthickness 0 -background $bg
    } else {
        frame $toolframe -relief flat -borderwidth 0 -takefocus 0 \
            -highlightthickness 0 -background $bg
        set sep [Separator::create $toolframe.sep -orient horizontal -background $bg]
        pack $sep -fill x
    }
    set toolbar [frame $toolbar -relief flat -borderwidth 2 \
                     -takefocus 0 -highlightthickness 0 -background $bg]
    pack $toolbar -in $toolframe -anchor w -expand yes -fill x
    incr _widget($path,ntoolbar)
    grid $toolframe -column 0 -row $index -sticky ew
    return $toolbar
}


MainFrame::cget
Comments Command MainFrame::cget
Arguments path
option
Used by  
Uses Widget::cget
proc MainFrame::cget { path option } {
    return [Widget::cget $path $option]
}


MainFrame::configure
Comments Command MainFrame::configure
Arguments path
args
Used by  
Uses Widget::hasChanged
Widget::configure
Separator::configure
proc MainFrame::configure { path args } {
    variable _widget

    set res [Widget::configure $path $args]

    if { [Widget::hasChanged $path -textvariable newv] } {
        uplevel \#0 $path.status.label configure -textvariable [list $newv]
    }

    if { [Widget::hasChanged $path -background bg] } {
        set listmenu [$_widget($path,top) cget -menu]
        while { [llength $listmenu] } {
            set newlist {}
            foreach menu $listmenu {
                $menu configure -background $bg
                set newlist [concat $newlist [winfo children $menu]]
            }
            set listmenu $newlist
        }
        foreach sep {.sep .botf.sep} {
            if { [winfo exists $path.$sep] } {
                Separator::configure $path.$sep -background $bg
            }
        }
        foreach w [winfo children $path.topf] {
            $w configure -background $bg
        }
    }

    if { [Widget::hasChanged $path -menubarfont newmbfnt] } {
    if {[string length $newmbfnt]} {
        set mbfnt [list -font $newmbfnt]
    } else {
        set mbfnt ""
    }
    set top     $_widget($path,top)
    if {[string compare $top .] == 0} {
        eval .menubar configure $mbfnt
    } else {
        eval $top.menubar configure $mbfnt
    }
    }
    if { [Widget::hasChanged $path -menuentryfont newmefnt] } {
    if {[string length $newmefnt]} {
        set mefnt [list -font $newmefnt]
    } else {
        set mefnt ""
    }
    set top     $_widget($path,top)
    if {[string compare $top .] == 0} {
        set mb .menubar
    } else {
        set mb $top.menubar
    }
    set l [winfo children $mb]
    while {[llength $l]} {
        set e [lindex $l 0]
        set l [lrange $l 1 end]
        if {[string length $e] == 0} {continue}
        lappend l [winfo children $e]
        eval $e configure $mefnt
    }
    }


    if { [Widget::hasChanged $path -statusbarfont newsbfnt] } {
    if {[string length $newsbfnt]} {
        set sbfnt [list -font $newsbfnt]
    } else {
        set sbfnt ""
    }
    for {set index 0} {$index<$_widget($path,nindic)} {incr index} {
        set indic $path.status.indf.f$index
        eval $indic configure $sbfnt
    }
    eval $path.status.label configure $sbfnt
    $path.status configure -height [winfo reqheight $path.status.label]

    $path.status.prg configure \
        -height [expr {[winfo reqheight $path.status.label]-2}]
    }

    return $res
}


MainFrame::create
Comments Command MainFrame::create
Arguments path
args
Used by  
Uses Widget::cget
MainFrame::_destroy
Widget::getoption
ProgressBar::create
Widget::subcget
Widget::init
Separator::create
proc MainFrame::create { path args } {
    global   tcl_platform
    variable _widget

    set path [frame $path -takefocus 0 -highlightthickness 0]
    set top  [winfo parent $path]
    if { [string compare [winfo toplevel $path] $top] } {
        destroy $path
        return -code error "parent must be a toplevel"
    }
    Widget::init MainFrame $path $args

    if { $tcl_platform(platform) == "unix" } {
        set relief raised
        set bd     1
    } else {
        set relief flat
        set bd     0
    }
    set topframe  [eval frame $path.topf -relief flat -borderwidth 0 \
        [Widget::subcget $path .topf]]
    set userframe [eval frame $path.frame [Widget::subcget $path .frame] \
                       -relief $relief -borderwidth $bd]
    set botframe  [eval frame $path.botf -relief $relief -borderwidth $bd \
        [Widget::subcget $path .botf]]

    pack $topframe -fill x
    grid columnconfigure $topframe 0 -weight 1

    set bg [Widget::cget $path -background]
    $path configure -background $bg
    if { $tcl_platform(platform) != "unix" } {
        set sepopt [Widget::getoption $path -separator]
        if { $sepopt == "both" || $sepopt == "top" } {
            set sep [Separator::create $path.sep -orient horizontal -background $bg]
            pack $sep -fill x
        }
        if { $sepopt == "both" || $sepopt == "bottom" } {
            set sep [Separator::create $botframe.sep -orient horizontal -background $bg]
            pack $sep -fill x
        }
    }

    # --- status bar -------------------------------------------------------------------
    if {[string length [Widget::getoption $path -statusbarfont]] >0 } {
    set sbfnt [list -font [Widget::getoption $path -statusbarfont]]
    } else {
    set sbfnt ""
    }

    set status   [frame $path.status -relief flat -borderwidth 0 \
                      -takefocus 0 -highlightthickness 0 -background $bg]
    set label    [eval [list label $status.label \
        -textvariable [Widget::getoption $path -textvariable] \
        -takefocus 0 -highlightthickness 0 -background $bg] $sbfnt]
    set indframe [frame $status.indf -relief flat -borderwidth 0 \
                      -takefocus 0 -highlightthickness 0 -background $bg]
    set prgframe [frame $status.prgf -relief flat -borderwidth 0 \
                      -takefocus 0 -highlightthickness 0 -background $bg]

    place $label    -anchor w -x 0 -rely 0.5
    place $indframe -anchor ne -relx 1 -y 0 -relheight 1
    pack  $prgframe -in $indframe -side left -padx 2
    $status configure -height [winfo reqheight $label]

    set progress [eval ProgressBar::create $status.prg [Widget::subcget $path .status.prg] \
                      -width       50 \
                      -height      [expr {[winfo reqheight $label]-2}] \
                      -borderwidth 1 \
                      -relief      sunken]
    pack $status    -in $botframe -fill x -pady 2
    pack $botframe  -side bottom -fill x
    pack $userframe -fill both -expand yes

    set _widget($path,top)      $top
    set _widget($path,ntoolbar) 0
    set _widget($path,nindic)   0

    set menu [Widget::getoption $path -menu]
    if { [llength $menu] } {
        _create_menubar $path $menu
    }

    bind $path <Destroy> {MainFrame::_destroy %W}

    rename $path ::$path:cmd
    proc ::$path { cmd args } "return \[eval MainFrame::\$cmd $path \$args\]"

    return $path
}


MainFrame::getframe
Comments Command MainFrame::getframe
Arguments path
Used by  
Uses  
proc MainFrame::getframe { path } {
    return $path.frame
}


MainFrame::getindicator
Comments Command MainFrame::getindicator
Arguments path
index
Used by  
Uses  
proc MainFrame::getindicator { path index } {
    return $path.status.indf.f$index
}


MainFrame::getmenu
Comments Command MainFrame::getmenu
Arguments path
menuid
Used by  
Uses  
proc MainFrame::getmenu { path menuid } {
    variable _widget

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


MainFrame::gettoolbar
Comments Command MainFrame::gettoolbar
Arguments path
index
Used by  
Uses  
proc MainFrame::gettoolbar { path index } {
    return $path.topf.tb$index
}


MainFrame::menuonly
Comments Command MainFrame::menuonly
Arguments path
Used by  
Uses  
proc MainFrame::menuonly { path } {
    variable _widget

    catch {pack forget $path.sep}
    catch {pack forget $path.botf.sep}
    catch {pack forget $path.frame}
}


MainFrame::setmenustate
Comments Command MainFrame::setmenustate
Arguments path
tag
state
Used by  
Uses  
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
    #        }
    #    }

    # We need a more sophisticated state system.
    # The original model was this:  each menu item has a list of tags;
    # whenever any one of those tags changed state, the menu item did too.
    # This makes it hard to have items that are enabled only when both tagA and
    # tagB are.  The new model therefore only sets the menustate to enabled
    # when ALL of its tags are enabled.

    # First see if this is a real tag
    if { [info exists _widget($path,tagstate,$tag)] } {
    if { [string compare $state "disabled"] } {
        set _widget($path,tagstate,$tag) 1
    } else {
        set _widget($path,tagstate,$tag) 0
    }
    foreach {menu entry} $_widget($path,tags,$tag) {
        set expression "1"
        foreach menutag $_widget($path,menutags,[list $menu $entry]) {
        append expression " && $_widget($path,tagstate,$menutag)"
        }
        if { [expr $expression] } {
        set state normal
        } else {
        set state disabled
        }
        $menu entryconfigure $entry -state $state
    }
    }
    return
}


MainFrame::showstatusbar
Comments Command MainFrame::showstatusbar
Arguments path
name
Used by  
Uses  
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
            }
        }
    }
}


MainFrame::showtoolbar
Comments Command MainFrame::showtoolbar
Arguments path
index
bool
Used by  
Uses  
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
        }
    }
}
generated by zdoc.tcl on 2003-03-06 00:21:54