Revision: 45813
http://brlcad.svn.sourceforge.net/brlcad/?rev=45813&view=rev
Author: brlcad
Date: 2011-08-08 18:22:58 +0000 (Mon, 08 Aug 2011)
Log Message:
-----------
example of why it's useful to see the tclsh warnings.. remove a handful of
::tk:: functions that curiously are living in our sources, yet they don't
appear to have any overridden behavior. menus in mged tested fine without, so
let the tk guys manage their own code. remove our fork.
Modified Paths:
--------------
brlcad/trunk/src/tclscripts/menu_override.tcl
Modified: brlcad/trunk/src/tclscripts/menu_override.tcl
===================================================================
--- brlcad/trunk/src/tclscripts/menu_override.tcl 2011-08-08 17:33:29 UTC
(rev 45812)
+++ brlcad/trunk/src/tclscripts/menu_override.tcl 2011-08-08 18:22:58 UTC
(rev 45813)
@@ -107,200 +107,6 @@
}
}
-proc ::tk::TraverseWithinMenu { w char } {
- if {$char == ""} {
- return
- }
-
- set char [string tolower $char]
- set last [$w index last]
-
- if {$last == "none"} {
- return
- }
-
- for {set i 0} {$i <= $last} {incr i} {
- if [catch {set char2 [string index [$w entrycget $i -label] [$w
entrycget $i -underline]]}] {
- continue
- }
-
- if {[string compare $char [string tolower $char2]] == 0} {
- if {[$w type $i] == "cascade"} {
- $w activate $i
- $w postcascade active
- event generate $w <<MenuSelect>>
- set m2 [$w entrycget $i -menu]
- if {$m2 != ""} {
- cad_MenuFirstEntry $m2
- }
- } else {
- ::tk::MenuUnpost $w
- uplevel #0 [list $w invoke $i]
- }
- return
- }
-
- }
-}
-
-proc ::tk::MenuNextMenu {menu direction} {
- global ::tk::Priv
-
- # First handle traversals into and out of cascaded menus.
-
- if {$direction == "right"} {
- set count 1
- set parent [winfo parent $menu]
- set class [winfo class $parent]
- if {[$menu type active] == "cascade"} {
- $menu postcascade active
- set m2 [$menu entrycget active -menu]
- if {$m2 != ""} {
- cad_MenuFirstEntry $m2
- }
- return
- } else {
- set parent [winfo parent $menu]
- while {($parent != ".")} {
- if {([winfo class $parent] == "Menu")
- && ([$parent cget -type] == "menubar")} {
- tk_menuSetFocus $parent
- ::tk::MenuNextEntry $parent 1
- return
- }
- set parent [winfo parent $parent]
- }
- }
- } else {
- set count -1
- set m2 [winfo parent $menu]
- if {[winfo class $m2] == "Menu"} {
- if {[$m2 cget -type] != "menubar"} {
- $menu activate none
- ::tk::GenerateMenuSelect $menu
- tk_menuSetFocus $m2
-
- # This code unposts any posted submenu in the parent.
-
- set tmp [$m2 index active]
- $m2 activate none
- $m2 activate $tmp
- return
- }
- }
- }
-
- # Can't traverse into or out of a cascaded menu. Go to the next
- # or previous menubutton, if that makes sense.
-
- set m2 [winfo parent $menu]
- if {[winfo class $m2] == "Menu"} {
- if {[$m2 cget -type] == "menubar"} {
- tk_menuSetFocus $m2
- ::tk::MenuNextEntry $m2 -1
- return
- }
- }
-
- set w $::tk::Priv(postedMb)
- if {$w == ""} {
- return
- }
- set buttons [winfo children [winfo parent $w]]
- set length [llength $buttons]
- set i [expr [lsearch -exact $buttons $w] + $count]
- while 1 {
- while {$i < 0} {
- incr i $length
- }
- while {$i >= $length} {
- incr i -$length
- }
- set mb [lindex $buttons $i]
- if {([winfo class $mb] == "Menubutton")
- && ([$mb cget -state] != "disabled")
- && ([$mb cget -menu] != "")
- && ([[$mb cget -menu] index last] != "none")} {
- break
- }
- if {$mb == $w} {
- return
- }
- incr i $count
- }
- ::tk::MbPost $mb
- ::tk::MenuFirstEntry [$mb cget -menu]
-}
-
-proc ::tk::MenuNextEntry {menu count} {
- global ::tk::Priv
-
- if {[$menu index last] == "none"} {
- return
- }
- $menu postcascade none
- set length [expr [$menu index last]+1]
- set quitAfter $length
- set active [$menu index active]
- if {$active == "none"} {
- set i 0
- } else {
- set i [expr $active + $count]
- }
- while 1 {
- if {$quitAfter <= 0} {
- # We've tried every entry in the menu. Either there are
- # none, or they're all disabled. Just give up.
-
- return
- }
- while {$i < 0} {
- incr i $length
- }
- while {$i >= $length} {
- incr i -$length
- }
- if {[catch {$menu entrycget $i -state} state] == 0} {
- if {$state != "disabled"} {
- break
- }
- }
- if {$i == $active} {
- return
- }
- incr i $count
- incr quitAfter -1
- }
- $menu activate $i
- ::tk::GenerateMenuSelect $menu
- if {[$menu type $i] == "cascade"} {
- set cascade [$menu entrycget $i -menu]
- if {[string compare $cascade ""] != 0} {
- $menu postcascade $i
- # ::tk::MenuFirstEntry $cascade
- }
- }
-}
-
-proc ::tk::MenuEscape menu {
- global ::tk::Priv
-
- set parent [winfo parent $menu]
- if {([winfo class $parent] != "Menu")} {
- ::tk::MenuUnpost $menu
- } elseif {([$parent cget -type] == "menubar")} {
- ::tk::MenuUnpost $menu
- ::tk::RestoreOldGrab
- } else {
- set grand_parent [winfo parent $parent]
- if {[winfo class $grand_parent] != "Menu"} {
- ::tk::MenuUnpost $menu
- } else {
- ::tk::MenuNextMenu $menu left
- }
- }
-}
-
# Local Variables:
# mode: Tcl
# tab-width: 8
This was sent by the SourceForge.net collaborative development platform, the
world's largest Open Source development site.
------------------------------------------------------------------------------
BlackBerry® DevCon Americas, Oct. 18-20, San Francisco, CA
The must-attend event for mobile developers. Connect with experts.
Get tools for creating Super Apps. See the latest technologies.
Sessions, hands-on labs, demos & much more. Register early & save!
http://p.sf.net/sfu/rim-blackberry-1
_______________________________________________
BRL-CAD Source Commits mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/brlcad-commits
