arcadia 0.1.1 → 0.1.2

data/tcl/BWidget-1.8.0/mainframe.tcl

@@ -0,0 +1,711 @@
+# ----------------------------------------------------------------------------
+#  mainframe.tcl
+#  This file is part of Unifix BWidget Toolkit
+#  $Id: mainframe.tcl,v 1.23 2006/03/24 22:19:57 dev_null42a 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
+# ----------------------------------------------------------------------------
+
+namespace eval MainFrame {
+    Widget::define MainFrame mainframe ProgressBar
+
+    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}
+
+    variable _widget
+}
+
+
+# ----------------------------------------------------------------------------
+#  Command MainFrame::create
+# ----------------------------------------------------------------------------
+proc MainFrame::create { path args } {
+    global   tcl_platform
+    variable _widget
+
+    if {[Widget::theme]} {
+	set path [ttk::frame $path]
+    } else {
+	set path [frame $path -takefocus 0 -highlightthickness 0]
+    }
+    set top  [winfo parent $path]
+    if { ![string equal [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
+    }
+    if {[Widget::theme]} {
+	set userframe [eval [list ttk::frame $path.frame] \
+			   [Widget::subcget $path .frame]]
+	set topframe  [ttk::frame $path.topf]
+	set botframe  [ttk::frame $path.botf]
+    } else {
+	set userframe [eval [list frame $path.frame] \
+			   [Widget::subcget $path .frame] \
+			   -relief $relief -borderwidth $bd]
+	set topframe  [eval [list frame $path.topf] \
+			   [Widget::subcget $path .topf]]
+	set botframe  [eval [list frame $path.botf] \
+			   -relief $relief -borderwidth $bd \
+			   [Widget::subcget $path .botf]]
+    }
+
+    pack $topframe -fill x
+    grid columnconfigure $topframe 0 -weight 1
+
+    if {![Widget::theme]} {
+	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" } {
+	    if {[Widget::theme]} {
+		set sep [ttk::separator $path.sep -orient horizontal]
+	    } else {
+		set sep [Separator::create $path.sep -orient horizontal -background $bg]
+	    }
+            pack $sep -fill x
+        }
+        if { $sepopt == "both" || $sepopt == "bottom" } {
+	    if {[Widget::theme]} {
+		set sep [ttk::separator $botframe.sep -orient horizontal]
+	    } else {
+		set sep [Separator::create $botframe.sep -orient horizontal -background $bg]
+	    }
+            pack $sep -fill x
+        }
+    }
+
+    # --- status bar ---------------------------------------------------------
+    if {[string length [Widget::getoption $path -statusbarfont]]} {
+	set sbfnt [list -font [Widget::getoption $path -statusbarfont]]
+    } else {
+	set sbfnt ""
+    }
+
+    if {[Widget::theme]} {
+	set status   [ttk::frame $path.status]
+	set label    [eval [list ttk::label $status.label \
+				-textvariable [Widget::getoption $path -textvariable]] $sbfnt]
+	set indframe [ttk::frame $status.indf]
+	set prgframe [ttk::frame $status.prgf]
+    } else {
+	set status   [frame $path.status -background $bg]
+	set label    [eval [list label $status.label \
+				-textvariable [Widget::getoption $path -textvariable] \
+				-background $bg] $sbfnt]
+	set indframe [frame $status.indf -background $bg]
+	set prgframe [frame $status.prgf -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 [list 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> [list MainFrame::_destroy %W]
+
+    return [Widget::create MainFrame $path]
+}
+
+
+# ----------------------------------------------------------------------------
+#  Command MainFrame::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]
+    }
+
+    # The ttk frame has no -background
+    if {![Widget::theme] && [Widget::hasChanged $path -background bg] } {
+	if {$::tcl_platform(platform) == "unix"} {
+	    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 equal $top .]} {
+	    eval [list .menubar configure] $mbfnt
+	} else {
+	    eval [list $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 equal $top .]} {
+	    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 [list $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 [list $indic configure] $sbfnt
+	}
+	eval [list $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
+}
+
+
+# ----------------------------------------------------------------------------
+#  Command MainFrame::cget
+# ----------------------------------------------------------------------------
+proc MainFrame::cget { path option } {
+    return [Widget::cget $path $option]
+}
+
+
+# ----------------------------------------------------------------------------
+#  Command MainFrame::getframe
+# ----------------------------------------------------------------------------
+proc MainFrame::getframe { path } {
+    return $path.frame
+}
+
+
+# ----------------------------------------------------------------------------
+#  Command MainFrame::addtoolbar
+# ----------------------------------------------------------------------------
+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" } {
+	if {[Widget::theme]} {
+	    ttk::frame $toolframe -padding 1
+	} else {
+	    frame $toolframe -relief raised -borderwidth 1 \
+		-takefocus 0 -highlightthickness 0 -background $bg
+	}
+    } else {
+	if {[Widget::theme]} {
+	    ttk::frame $toolframe
+	    set sep [ttk::separator $toolframe.sep -orient horizontal]
+	} 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
+    }
+    if {[Widget::theme]} {
+	set toolbar [ttk::frame $toolbar -padding 2]
+    } else {
+	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
+}
+
+
+# ----------------------------------------------------------------------------
+#  Command MainFrame::gettoolbar
+# ----------------------------------------------------------------------------
+proc MainFrame::gettoolbar { path index } {
+    return $path.topf.tb$index
+}
+
+
+# ----------------------------------------------------------------------------
+#  Command MainFrame::addindicator
+# ----------------------------------------------------------------------------
+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 [list 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
+}
+
+
+# ----------------------------------------------------------------------------
+#  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
+    #        }
+    #    }
+
+    # 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 equal $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
+}
+
+
+# -----------------------------------------------------------------------------
+#  Command MainFrame::menuonly
+# ----------------------d------------------------------------------------------
+proc MainFrame::menuonly { path } {
+    variable _widget
+
+    catch {pack forget $path.sep}
+    catch {pack forget $path.botf.sep}
+    catch {pack forget $path.frame}
+}
+
+# ----------------------------------------------------------------------------
+#  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
+    set botframe $path.botf
+    if { [string equal $name "none"] } {
+        pack forget $status
+    } else {
+        pack $status -fill x -in $botframe -fill x -pady 2
+        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 all of the state vars associated with this main frame.
+    foreach index [array names _widget $path,*] {
+	unset _widget($index)
+    }
+}
+
+
+# ----------------------------------------------------------------------------
+#  Command MainFrame::_create_menubar
+# ----------------------------------------------------------------------------
+proc MainFrame::_create_menubar { path descmenu } {
+    variable _widget
+    global    tcl_platform
+
+    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 {![Widget::theme] && $tcl_platform(platform) == "unix"} {
+	set menuopts [list -background [Widget::getoption $path -background] \
+			  -borderwidth 1]
+    } else {
+	set menuopts [list]
+    }
+    set menubar [eval [list menu $top.menubar -tearoff 0] $menuopts $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 [list $menubar add cascade] $opt [list -menu $menu]
+        eval [list menu $menu -tearoff $tearoff] $menuopts $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:  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 $menuopts $entries
+        incr count
+    }
+}
+
+
+# ----------------------------------------------------------------------------
+#  Command MainFrame::_create_entries
+# ----------------------------------------------------------------------------
+proc MainFrame::_create_entries { path menu menuopts 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 equal $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:  Add mapping from menu items to tags
+	set _widget($path,menutags,[list $menu $count]) $tags
+
+        if {[string equal $type "cascade"] || [string equal $type "cascad"]} {
+            set menuid  [lindex $entry 3]
+            set tearoff [lindex $entry 4]
+            set submenu $menu.menu$count
+            eval [list $menu add cascade] $opt [list -menu $submenu]
+            eval [list menu $submenu -tearoff $tearoff] $menuopts
+            if { [string length $menuid] } {
+                # menu has identifier
+                set _widget($path,menuid,$menuid) $submenu
+            }
+            _create_entries $path $submenu $menuopts [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] [list $menu invoke $count]
+        }
+
+        # user options
+        set useropt [lrange $entry 5 end]
+        if { [string equal $type "command"] ||
+             [string equal $type "radiobutton"] ||
+             [string equal $type "checkbutton"] } {
+            eval [list $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]
+    }
+}
+
+
+# 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
+
+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-9]|([12][0-9]|3[0-5]))$} $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-9]|([12][0-9]|3[0-5]))$} $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]
+}