Import Tk 8.6.10
This commit is contained in:
Steve Dower
239
library/menu.tcl
239
library/menu.tcl
@@ -234,6 +234,7 @@ proc ::tk::MbLeave w {
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# ::tk::MbPost --
|
||||
# Given a menubutton, this procedure does all the work of posting
|
||||
# its associated menu and unposting any other menu that is currently
|
||||
@@ -282,101 +283,17 @@ proc ::tk::MbPost {w {x {}} {y {}}} {
|
||||
set Priv(focus) [focus]
|
||||
$menu activate none
|
||||
GenerateMenuSelect $menu
|
||||
|
||||
# If this looks like an option menubutton then post the menu so
|
||||
# that the current entry is on top of the mouse. Otherwise post
|
||||
# the menu just below the menubutton, as for a pull-down.
|
||||
|
||||
update idletasks
|
||||
if {[catch {
|
||||
switch [$w cget -direction] {
|
||||
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 < [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]}]
|
||||
# if we go offscreen to the bottom, show as 'above'
|
||||
set mh [winfo reqheight $menu]
|
||||
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 {$entry eq ""} {
|
||||
set entry 0
|
||||
}
|
||||
if {[$w cget -indicatoron]} {
|
||||
if {$entry == [$menu index last]} {
|
||||
incr y [expr {-([$menu yposition $entry] \
|
||||
+ [winfo reqheight $menu])/2}]
|
||||
} else {
|
||||
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
|
||||
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 {$entry eq ""} {
|
||||
set entry 0
|
||||
}
|
||||
if {[$w cget -indicatoron]} {
|
||||
if {$entry == [$menu index last]} {
|
||||
incr y [expr {-([$menu yposition $entry] \
|
||||
+ [winfo reqheight $menu])/2}]
|
||||
} else {
|
||||
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
|
||||
GenerateMenuSelect $menu
|
||||
}
|
||||
}
|
||||
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 opt]} {
|
||||
|
||||
if {[catch {PostMenubuttonMenu $w $menu} msg opt]} {
|
||||
# Error posting menu (e.g. bogus -postcommand). Unpost it and
|
||||
# reflect the error.
|
||||
|
||||
MenuUnpost {}
|
||||
return -options $opt $msg
|
||||
}
|
||||
|
||||
set Priv(tearoff) $tearoff
|
||||
if {$tearoff != 0} {
|
||||
if {$tearoff != 0 && [tk windowingsystem] ne "aqua"} {
|
||||
focus $menu
|
||||
if {[winfo viewable $w]} {
|
||||
SaveGrabInfo $w
|
||||
@@ -576,11 +493,13 @@ proc ::tk::MenuMotion {menu x y state} {
|
||||
if {[string is false $mode]} {
|
||||
set delay [expr {[$menu cget -type] eq "menubar" ? 0 : 50}]
|
||||
if {[$menu type $index] eq "cascade"} {
|
||||
# Catch these postcascade commands since the menu could be
|
||||
# destroyed before they run.
|
||||
set Priv(menuActivatedTimer) \
|
||||
[after $delay [list $menu postcascade active]]
|
||||
[after $delay "catch {$menu postcascade active}"]
|
||||
} else {
|
||||
set Priv(menuDeactivatedTimer) \
|
||||
[after $delay [list $menu postcascade none]]
|
||||
[after $delay "catch {$menu postcascade none}"]
|
||||
}
|
||||
}
|
||||
}
|
||||
@@ -1208,10 +1127,109 @@ proc ::tk::MenuFindName {menu s} {
|
||||
return ""
|
||||
}
|
||||
|
||||
# ::tk::PostMenubuttonMenu --
|
||||
#
|
||||
# Given a menubutton and a menu, this procedure posts the menu at the
|
||||
# appropriate location. If the menubutton looks like an option
|
||||
# menubutton, meaning that the indicator is on and the direction is
|
||||
# neither above nor below, then the menu is posted so that the current
|
||||
# entry is vertically aligned with the menubutton. On the Mac this
|
||||
# will expose a small amount of the blue indicator on the right hand
|
||||
# side. On other platforms the entry is centered over the button.
|
||||
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
proc ::tk::PostMenubuttonMenu {button menu} {
|
||||
set entry ""
|
||||
if {[$button cget -indicatoron]} {
|
||||
set entry [MenuFindName $menu [$button cget -text]]
|
||||
if {$entry eq ""} {
|
||||
set entry 0
|
||||
}
|
||||
}
|
||||
set x [winfo rootx $button]
|
||||
set y [expr {2 + [winfo rooty $button]}]
|
||||
switch [$button cget -direction] {
|
||||
above {
|
||||
set entry ""
|
||||
incr y [expr {4 - [winfo reqheight $menu]}]
|
||||
}
|
||||
below {
|
||||
set entry ""
|
||||
incr y [expr {2 + [winfo height $button]}]
|
||||
}
|
||||
left {
|
||||
incr x [expr {-[winfo reqwidth $menu]}]
|
||||
}
|
||||
right {
|
||||
incr x [winfo width $button]
|
||||
}
|
||||
default {
|
||||
incr x [expr {[winfo width $button] - [winfo reqwidth $menu] - 5}]
|
||||
}
|
||||
}
|
||||
PostOverPoint $menu $x $y $entry
|
||||
}
|
||||
} else {
|
||||
proc ::tk::PostMenubuttonMenu {button menu} {
|
||||
set entry ""
|
||||
if {[$button cget -indicatoron]} {
|
||||
set entry [MenuFindName $menu [$button cget -text]]
|
||||
if {$entry eq ""} {
|
||||
set entry 0
|
||||
}
|
||||
}
|
||||
set x [winfo rootx $button]
|
||||
set y [winfo rooty $button]
|
||||
switch [$button cget -direction] {
|
||||
above {
|
||||
incr y [expr {-[winfo reqheight $menu]}]
|
||||
# if we go offscreen to the top, show as 'below'
|
||||
if {$y < [winfo vrooty $button]} {
|
||||
set y [expr {[winfo vrooty $button] + [winfo rooty $button]\
|
||||
+ [winfo reqheight $button]}]
|
||||
}
|
||||
set entry {}
|
||||
}
|
||||
below {
|
||||
incr y [winfo height $button]
|
||||
# if we go offscreen to the bottom, show as 'above'
|
||||
set mh [winfo reqheight $menu]
|
||||
if {($y + $mh) > ([winfo vrooty $button] + [winfo vrootheight $button])} {
|
||||
set y [expr {[winfo vrooty $button] + [winfo vrootheight $button] \
|
||||
+ [winfo rooty $button] - $mh}]
|
||||
}
|
||||
set entry {}
|
||||
}
|
||||
left {
|
||||
# It is not clear why this is needed.
|
||||
if {[tk windowingsystem] eq "win32"} {
|
||||
incr x [expr {-4 - [winfo reqwidth $button] / 2}]
|
||||
}
|
||||
incr x [expr {- [winfo reqwidth $menu]}]
|
||||
}
|
||||
right {
|
||||
incr x [expr {[winfo width $button]}]
|
||||
}
|
||||
default {
|
||||
if {[$button cget -indicatoron]} {
|
||||
incr x [expr {([winfo width $button] - \
|
||||
[winfo reqwidth $menu])/ 2}]
|
||||
} else {
|
||||
incr y [winfo height $button]
|
||||
}
|
||||
}
|
||||
}
|
||||
PostOverPoint $menu $x $y $entry
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::PostOverPoint --
|
||||
# This procedure posts a given menu such that a given entry in the
|
||||
# menu is centered over a given point in the root window. It also
|
||||
# activates the given entry.
|
||||
#
|
||||
# This procedure posts a menu on the screen so that a given entry in
|
||||
# the menu is positioned with its upper left corner at a given point
|
||||
# in the root window. The procedure also activates that entry. If no
|
||||
# entry is specified the upper left corner of the entire menu is
|
||||
# placed at the point.
|
||||
#
|
||||
# Arguments:
|
||||
# menu - Menu to post.
|
||||
@@ -1220,19 +1238,24 @@ proc ::tk::MenuFindName {menu s} {
|
||||
# If omitted or specified as {}, then the menu's
|
||||
# upper-left corner goes at (x,y).
|
||||
|
||||
proc ::tk::PostOverPoint {menu x y {entry {}}} {
|
||||
if {$entry ne ""} {
|
||||
if {$entry == [$menu index last]} {
|
||||
incr y [expr {-([$menu yposition $entry] \
|
||||
+ [winfo reqheight $menu])/2}]
|
||||
if {[tk windowingsystem] ne "win32"} {
|
||||
proc ::tk::PostOverPoint {menu x y {entry {}}} {
|
||||
if {$entry ne ""} {
|
||||
$menu post $x $y $entry
|
||||
if {[$menu entrycget $entry -state] ne "disabled"} {
|
||||
$menu activate $entry
|
||||
GenerateMenuSelect $menu
|
||||
}
|
||||
} else {
|
||||
incr y [expr {-([$menu yposition $entry] \
|
||||
+ [$menu yposition [expr {$entry+1}]])/2}]
|
||||
$menu post $x $y
|
||||
}
|
||||
incr x [expr {-[winfo reqwidth $menu]/2}]
|
||||
return
|
||||
}
|
||||
|
||||
if {[tk windowingsystem] eq "win32"} {
|
||||
} else {
|
||||
proc ::tk::PostOverPoint {menu x y {entry {}}} {
|
||||
if {$entry ne ""} {
|
||||
incr y [expr {-[$menu yposition $entry]}]
|
||||
}
|
||||
# osVersion is not available in safe interps
|
||||
set ver 5
|
||||
if {[info exists ::tcl_platform(osVersion)]} {
|
||||
@@ -1248,7 +1271,7 @@ proc ::tk::PostOverPoint {menu x y {entry {}}} {
|
||||
# manager provided with Vista and Windows 7.
|
||||
if {$ver < 6} {
|
||||
set yoffset [expr {[winfo screenheight $menu] \
|
||||
- $y - [winfo reqheight $menu] - 10}]
|
||||
- $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]}]
|
||||
@@ -1260,11 +1283,11 @@ proc ::tk::PostOverPoint {menu x y {entry {}}} {
|
||||
set y [winfo vrooty $menu]
|
||||
}
|
||||
}
|
||||
}
|
||||
$menu post $x $y
|
||||
if {$entry ne "" && [$menu entrycget $entry -state] ne "disabled"} {
|
||||
$menu activate $entry
|
||||
GenerateMenuSelect $menu
|
||||
$menu post $x $y
|
||||
if {$entry ne "" && [$menu entrycget $entry -state] ne "disabled"} {
|
||||
$menu activate $entry
|
||||
GenerateMenuSelect $menu
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
Reference in New Issue
Block a user