diff options
Diffstat (limited to 'library')
| -rw-r--r-- | library/menu.tcl | 158 |
1 files changed, 85 insertions, 73 deletions
diff --git a/library/menu.tcl b/library/menu.tcl index ff62484..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 < [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 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,23 +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 < [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] + # 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 @@ -1238,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) @@ -1263,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 } |