summaryrefslogtreecommitdiffstats
path: root/library/menu.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/menu.tcl')
-rw-r--r--library/menu.tcl167
1 files changed, 89 insertions, 78 deletions
diff --git a/library/menu.tcl b/library/menu.tcl
index ed8182e..782a726 100644
--- a/library/menu.tcl
+++ b/library/menu.tcl
@@ -60,7 +60,7 @@
# This file is tricky because there are five different ways that menus
# can be used:
#
-# 1. As a pulldown from a menubutton. In this style, the variable
+# 1. As a pulldown from a menubutton. In this style, the variable
# tk::Priv(postedMb) identifies the posted menubutton.
# 2. As a torn-off menu copied from some other menu. In this style
# tk::Priv(postedMb) is empty, and menu's type is "tearoff".
@@ -280,81 +280,81 @@ proc ::tk::MbPost {w {x {}} {y {}}} {
update idletasks
if {[catch {
switch [$w cget -direction] {
- above {
- set x [winfo rootx $w]
- set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}]
+ above {
+ set x [winfo rootx $w]
+ set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}]
# if we go offscreen to the top, show as 'below'
- if {$y < 0} {
- set y [expr {[winfo rooty $w] + [winfo height $w]}]
+ if {$y < [winfo vrooty $w]} {
+ set y [expr {[winfo vrooty $w] + [winfo rooty $w] + [winfo reqheight $w]}]
}
PostOverPoint $menu $x $y
- }
- below {
- set x [winfo rootx $w]
- set y [expr {[winfo rooty $w] + [winfo height $w]}]
+ }
+ below {
+ set x [winfo rootx $w]
+ set y [expr {[winfo rooty $w] + [winfo height $w]}]
# if we go offscreen to the bottom, show as 'above'
set mh [winfo reqheight $menu]
- if {($y + $mh) > [winfo screenheight $w]} {
- set y [expr {[winfo rooty $w] - $mh}]
+ if {($y + $mh) > ([winfo vrooty $w] + [winfo vrootheight $w])} {
+ set y [expr {[winfo vrooty $w] + [winfo vrootheight $w] + [winfo rooty $w] - $mh}]
}
PostOverPoint $menu $x $y
- }
- left {
- 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]} {
+ }
+ left {
+ 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 {$entry == [$menu index last]} {
- incr y [expr {-([$menu yposition $entry] \
- + [winfo reqheight $menu])/2}]
+ incr y [expr {-([$menu yposition $entry] \
+ + [winfo reqheight $menu])/2}]
} else {
- incr y [expr {-([$menu yposition $entry] \
+ incr y [expr {-([$menu yposition $entry] \
+ [$menu yposition [expr {$entry+1}]])/2}]
}
- }
+ }
PostOverPoint $menu $x $y
if {$entry ne "" \
&& [$menu entrycget $entry -state] ne "disabled"} {
- $menu activate $entry
+ $menu activate $entry
GenerateMenuSelect $menu
- }
- }
- right {
- 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]} {
+ }
+ }
+ right {
+ 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 {$entry == [$menu index last]} {
- incr y [expr {-([$menu yposition $entry] \
- + [winfo reqheight $menu])/2}]
+ incr y [expr {-([$menu yposition $entry] \
+ + [winfo reqheight $menu])/2}]
} else {
- incr y [expr {-([$menu yposition $entry] \
+ incr y [expr {-([$menu yposition $entry] \
+ [$menu yposition [expr {$entry+1}]])/2}]
}
- }
+ }
PostOverPoint $menu $x $y
if {$entry ne "" \
&& [$menu entrycget $entry -state] ne "disabled"} {
- $menu activate $entry
+ $menu activate $entry
GenerateMenuSelect $menu
- }
- }
- default {
- if {[$w cget -indicatoron]} {
+ }
+ }
+ default {
+ if {[$w cget -indicatoron]} {
if {$y eq ""} {
set x [expr {[winfo rootx $w] + [winfo width $w]/2}]
set y [expr {[winfo rooty $w] + [winfo height $w]/2}]
- }
+ }
PostOverPoint $menu $x $y [MenuFindName $menu [$w cget -text]]
} else {
PostOverPoint $menu [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}]
- }
- }
+ }
+ }
}
} msg]} {
# Error posting menu (e.g. bogus -postcommand). Unpost it and
# reflect the error.
-
+
set savedInfo $errorInfo
MenuUnpost {}
error $msg $savedInfo
@@ -363,7 +363,7 @@ proc ::tk::MbPost {w {x {}} {y {}}} {
set Priv(tearoff) $tearoff
if {$tearoff != 0} {
- focus $menu
+ focus $menu
if {[winfo viewable $w]} {
SaveGrabInfo $w
grab -global $w
@@ -443,8 +443,8 @@ proc ::tk::MenuUnpost menu {
}
if {($Priv(tearoff) != 0) || $Priv(menuBar) ne ""} {
- # Release grab, if any, and restore the previous grab, if there
- # was one.
+ # Release grab, if any, and restore the previous grab, if there
+ # was one.
if {$menu ne ""} {
set grab [grab current $menu]
if {$grab ne ""} {
@@ -584,7 +584,7 @@ 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
@@ -625,7 +625,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
@@ -669,7 +670,7 @@ proc ::tk::MenuInvoke {w buttonRelease} {
set isCascade [string equal [$w type $active] "cascade"]
# Only de-activate the active item if it's a cascade; this prevents
- # the annoying "activation flicker" you otherwise get with
+ # the annoying "activation flicker" you otherwise get with
# checkbuttons/commands/etc. on menubars
if { $isCascade } {
@@ -779,7 +780,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 +805,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 +932,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 +958,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]]
@@ -1112,15 +1113,14 @@ 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
@@ -1177,7 +1177,7 @@ proc ::tk::MenuFindName {menu s} {
proc ::tk::PostOverPoint {menu x y {entry {}}} {
global tcl_platform
-
+
if {$entry ne ""} {
if {$entry == [$menu index last]} {
incr y [expr {-([$menu yposition $entry] \
@@ -1188,24 +1188,34 @@ 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 < [winfo vrooty $menu]} {
+ # The bottom of the menu is offscreen, so adjust upwards
+ incr y [expr {$yoffset - [winfo vrooty $menu]}]
+ }
+ # 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 < [winfo vrooty $menu]} {
+ set y [winfo vrooty $menu]
+ }
}
}
$menu post $x $y
@@ -1239,11 +1249,11 @@ proc ::tk::RestoreOldGrab {} {
variable ::tk::Priv
if {$Priv(oldGrab) ne ""} {
- # Be careful restoring the old grab, since it's window may not
+ # Be careful restoring the old grab, since it's window may not
# be visible anymore.
catch {
- if {$Priv(grabStatus) eq "global"} {
+ if {$Priv(grabStatus) eq "global"} {
grab set -global $Priv(oldGrab)
} else {
grab set $Priv(oldGrab)
@@ -1264,7 +1274,8 @@ proc ::tk_menuSetFocus {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
}
generated by cgit v0.12 at 2024-11-09 16:22:57 (GMT)