summaryrefslogtreecommitdiffstats
path: root/library/menu.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/menu.tcl')
-rw-r--r--library/menu.tcl137
1 files changed, 92 insertions, 45 deletions
diff --git a/library/menu.tcl b/library/menu.tcl
index ed8182e..e00dad9 100644
--- a/library/menu.tcl
+++ b/library/menu.tcl
@@ -259,8 +259,10 @@ proc ::tk::MbPost {w {x {}} {y {}}} {
if {$cur ne ""} {
MenuUnpost {}
}
- set Priv(cursor) [$w cget -cursor]
- $w configure -cursor arrow
+ if {$::tk_strictMotif} {
+ set Priv(cursor) [$w cget -cursor]
+ $w configure -cursor arrow
+ }
if {[tk windowingsystem] ne "aqua"} {
set Priv(relief) [$w cget -relief]
$w configure -relief raised
@@ -303,7 +305,7 @@ proc ::tk::MbPost {w {x {}} {y {}}} {
set x [expr {[winfo rootx $w] - [winfo reqwidth $menu]}]
set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
set entry [MenuFindName $menu [$w cget -text]]
- if {[$w cget -indicatoron]} {
+ if {[$w cget -indicatoron] && $entry ne ""} {
if {$entry == [$menu index last]} {
incr y [expr {-([$menu yposition $entry] \
+ [winfo reqheight $menu])/2}]
@@ -323,7 +325,7 @@ proc ::tk::MbPost {w {x {}} {y {}}} {
set x [expr {[winfo rootx $w] + [winfo width $w]}]
set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
set entry [MenuFindName $menu [$w cget -text]]
- if {[$w cget -indicatoron]} {
+ if {[$w cget -indicatoron] && $entry ne ""} {
if {$entry == [$menu index last]} {
incr y [expr {-([$menu yposition $entry] \
+ [winfo reqheight $menu])/2}]
@@ -402,12 +404,19 @@ proc ::tk::MenuUnpost menu {
# Unpost menu(s) and restore some stuff that's dependent on
# what was posted.
+ after cancel [array get Priv menuActivatedTimer]
+ unset -nocomplain Priv(menuActivated)
+ after cancel [array get Priv menuDeactivatedTimer]
+ unset -nocomplain Priv(menuDeactivated)
+
catch {
if {$mb ne ""} {
set menu [$mb cget -menu]
$menu unpost
set Priv(postedMb) {}
- $mb configure -cursor $Priv(cursor)
+ if {$::tk_strictMotif} {
+ $mb configure -cursor $Priv(cursor)
+ }
if {[tk windowingsystem] ne "aqua"} {
$mb configure -relief $Priv(relief)
} else {
@@ -416,7 +425,8 @@ proc ::tk::MenuUnpost menu {
} elseif {$Priv(popup) ne ""} {
$Priv(popup) unpost
set Priv(popup) {}
- } elseif {[$menu cget -type] ne "menubar" && [$menu cget -type] ne "tearoff"} {
+ } elseif {[$menu cget -type] ne "menubar" \
+ && [$menu cget -type] ne "tearoff"} {
# We're in a cascaded sub-menu from a torn-off menu or popup.
# Unpost all the menus up to the toplevel one (but not
# including the top-level torn-off one) and deactivate the
@@ -424,7 +434,8 @@ proc ::tk::MenuUnpost menu {
while {1} {
set parent [winfo parent $menu]
- if {[winfo class $parent] ne "Menu" || ![winfo ismapped $parent]} {
+ if {[winfo class $parent] ne "Menu" \
+ || ![winfo ismapped $parent]} {
break
}
$parent activate none
@@ -453,7 +464,9 @@ proc ::tk::MenuUnpost menu {
}
RestoreOldGrab
if {$Priv(menuBar) ne ""} {
- $Priv(menuBar) configure -cursor $Priv(cursor)
+ if {$::tk_strictMotif} {
+ $Priv(menuBar) configure -cursor $Priv(cursor)
+ }
set Priv(menuBar) {}
}
if {[tk windowingsystem] ne "x11"} {
@@ -537,6 +550,7 @@ proc ::tk::MbButtonUp w {
proc ::tk::MenuMotion {menu x y state} {
variable ::tk::Priv
if {$menu eq $Priv(window)} {
+ set activeindex [$menu index active]
if {[$menu cget -type] eq "menubar"} {
if {[info exists Priv(focus)] && $menu ne $Priv(focus)} {
$menu activate @$x,$y
@@ -546,9 +560,22 @@ proc ::tk::MenuMotion {menu x y state} {
$menu activate @$x,$y
GenerateMenuSelect $menu
}
- }
- if {($state & 0x1f00) != 0} {
- $menu postcascade active
+ set index [$menu index @$x,$y]
+ if {[info exists Priv(menuActivated)] \
+ && $index ne "none" \
+ && $index ne $activeindex} {
+ set mode [option get $menu clickToFocus ClickToFocus]
+ if {[string is false $mode]} {
+ set delay [expr {[$menu cget -type] eq "menubar" ? 0 : 50}]
+ if {[$menu type $index] eq "cascade"} {
+ set Priv(menuActivatedTimer) \
+ [after $delay [list $menu postcascade active]]
+ } else {
+ set Priv(menuDeactivatedTimer) \
+ [after $delay [list $menu postcascade none]]
+ }
+ }
+ }
}
}
@@ -584,10 +611,15 @@ proc ::tk::MenuButtonDown menu {
set menu [winfo parent $menu]
}
- if {$Priv(menuBar) eq ""} {
+ if {$Priv(menuBar) eq {}} {
set Priv(menuBar) $menu
- set Priv(cursor) [$menu cget -cursor]
- $menu configure -cursor arrow
+ if {$::tk_strictMotif} {
+ set Priv(cursor) [$menu cget -cursor]
+ $menu configure -cursor arrow
+ }
+ if {[$menu type active] eq "cascade"} {
+ set Priv(menuActivated) 1
+ }
}
# Don't update grab information if the grab window isn't changing.
@@ -625,7 +657,8 @@ proc ::tk::MenuLeave {menu rootx rooty state} {
return
}
if {[$menu type active] eq "cascade" \
- && [winfo containing $rootx $rooty] eq [$menu entrycget active -menu]} {
+ && [winfo containing $rootx $rooty] eq \
+ [$menu entrycget active -menu]} {
return
}
$menu activate none
@@ -779,7 +812,8 @@ proc ::tk::MenuNextMenu {menu direction} {
} else {
set parent [winfo parent $menu]
while {$parent ne "."} {
- if {[winfo class $parent] eq "Menu" && [$parent cget -type] eq "menubar"} {
+ if {[winfo class $parent] eq "Menu" \
+ && [$parent cget -type] eq "menubar"} {
tk_menuSetFocus $parent
MenuNextEntry $parent 1
return
@@ -803,16 +837,14 @@ proc ::tk::MenuNextMenu {menu direction} {
}
}
- # Can't traverse into or out of a cascaded menu. Go to the next
+ # 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] eq "Menu"} {
- if {[$m2 cget -type] eq "menubar"} {
- tk_menuSetFocus $m2
- MenuNextEntry $m2 -1
- return
- }
+ if {[winfo class $m2] eq "Menu" && [$m2 cget -type] eq "menubar"} {
+ tk_menuSetFocus $m2
+ MenuNextEntry $m2 -1
+ return
}
set w $Priv(postedMb)
@@ -932,7 +964,8 @@ proc ::tk::MenuFind {w char} {
if {[winfo toplevel $w] ne [winfo toplevel $child]} {
continue
}
- if {[winfo class $child] eq "Menu" && [$child cget -type] eq "menubar"} {
+ if {[winfo class $child] eq "Menu" && \
+ [$child cget -type] eq "menubar"} {
if {$char eq ""} {
return $child
}
@@ -957,7 +990,7 @@ proc ::tk::MenuFind {w char} {
if {[winfo toplevel $w] ne [winfo toplevel $child]} {
continue
}
- switch [winfo class $child] {
+ switch -- [winfo class $child] {
Menubutton {
set char2 [string index [$child cget -text] \
[$child cget -underline]]
@@ -997,10 +1030,11 @@ proc ::tk::TraverseToMenu {w char} {
return
}
while {[winfo class $w] eq "Menu"} {
+ if {[$w cget -type] ne "menubar" && $Priv(postedMb) eq ""} {
+ return
+ }
if {[$w cget -type] eq "menubar"} {
break
- } elseif {$Priv(postedMb) eq ""} {
- return
}
set w [winfo parent $w]
}
@@ -1112,15 +1146,15 @@ proc ::tk::MenuFirstEntry menu {
}
for {set i 0} {$i <= $last} {incr i} {
if {([catch {set state [$menu entrycget $i -state]}] == 0) \
- && $state ne "disabled" \
- && [$menu type $i] ne "tearoff"} {
+ && $state ne "disabled" && [$menu type $i] ne "tearoff"} {
$menu activate $i
GenerateMenuSelect $menu
# Only post the cascade if the current menu is a menubar;
# otherwise, if the first entry of the cascade is a cascade,
# we can get an annoying cascading effect resulting in a bunch of
# menus getting posted (bug 676)
- if {[$menu type $i] eq "cascade" && [$menu cget -type] eq "menubar"} {
+ if {[$menu type $i] eq "cascade" \
+ && [$menu cget -type] eq "menubar"} {
set cascade [$menu entrycget $i -menu]
if {$cascade ne ""} {
$menu postcascade $i
@@ -1188,24 +1222,35 @@ proc ::tk::PostOverPoint {menu x y {entry {}}} {
}
incr x [expr {-[winfo reqwidth $menu]/2}]
}
+
if {$tcl_platform(platform) eq "windows"} {
+ # osVersion is not available in safe interps
+ set ver 5
+ if {[info exists tcl_platform(osVersion)]} {
+ scan $tcl_platform(osVersion) %d ver
+ }
+
# We need to fix some problems with menu posting on Windows,
# where, if the menu would overlap top or bottom of screen,
# Windows puts it in the wrong place for us. We must also
# subtract an extra amount for half the height of the current
# entry. To be safe we subtract an extra 10.
- set yoffset [expr {[winfo screenheight $menu] \
- - $y - [winfo reqheight $menu] - 10}]
- if {$yoffset < 0} {
- # The bottom of the menu is offscreen, so adjust upwards
- incr y $yoffset
- if {$y < 0} { set y 0 }
- }
- # If we're off the top of the screen (either because we were
- # originally or because we just adjusted too far upwards),
- # then make the menu popup on the top edge.
- if {$y < 0} {
- set y 0
+ # NOTE: this issue appears to have been resolved in the Window
+ # manager provided with Vista and Windows 7.
+ if {$ver < 6} {
+ set yoffset [expr {[winfo screenheight $menu] \
+ - $y - [winfo reqheight $menu] - 10}]
+ if {$yoffset < 0} {
+ # The bottom of the menu is offscreen, so adjust upwards
+ incr y $yoffset
+ if {$y < 0} { set y 0 }
+ }
+ # If we're off the top of the screen (either because we were
+ # originally or because we just adjusted too far upwards),
+ # then make the menu popup on the top edge.
+ if {$y < 0} {
+ set y 0
+ }
}
}
$menu post $x $y
@@ -1243,7 +1288,7 @@ proc ::tk::RestoreOldGrab {} {
# be visible anymore.
catch {
- if {$Priv(grabStatus) eq "global"} {
+ if {$Priv(grabStatus) eq "global"} {
grab set -global $Priv(oldGrab)
} else {
grab set $Priv(oldGrab)
@@ -1260,11 +1305,12 @@ proc ::tk_menuSetFocus {menu} {
}
focus $menu
}
-
+
proc ::tk::GenerateMenuSelect {menu} {
variable ::tk::Priv
- if {$Priv(activeMenu) eq $menu && $Priv(activeItem) eq [$menu index active]} {
+ if {$Priv(activeMenu) eq $menu \
+ && $Priv(activeItem) eq [$menu index active]} {
return
}
@@ -1296,6 +1342,7 @@ proc ::tk_popup {menu x y {entry {}}} {
tk::SaveGrabInfo $menu
grab -global $menu
set Priv(popup) $menu
+ set Priv(menuActivated) 1
tk_menuSetFocus $menu
}
}
generated by cgit v0.12 at 2024-09-05 00:02:06 (GMT)