mirror of
https://github.com/shlomif/PySolFC.git
synced 2025-04-05 00:02:29 -04:00
358 lines
11 KiB
Tcl
358 lines
11 KiB
Tcl
# this file from tkabber project
|
|
# http://www.jabberstudio.org/projects/tkabber/
|
|
|
|
namespace eval :: {
|
|
|
|
proc myMenuButtonDown {args} {
|
|
global myMenuFlag myMenuMotion
|
|
eval ::tk::MenuButtonDown $args
|
|
set myMenuFlag 1
|
|
}
|
|
proc myMenuInvoke {args} {
|
|
global myMenuFlag myMenuMotion
|
|
if {$myMenuFlag || $myMenuMotion} {
|
|
eval ::tk::MenuInvoke $args
|
|
}
|
|
set myMenuFlag 0
|
|
set myMenuMotion 0
|
|
}
|
|
proc myMenuMotion {args} {
|
|
global myMenuFlag myMenuMotion
|
|
eval ::tk::MenuMotion $args
|
|
set myMenuMotion 1
|
|
}
|
|
proc myMenuLeave {args} {
|
|
global myMenuFlag myMenuMotion
|
|
eval ::tk::MenuLeave $args
|
|
set myMenuMotion 0
|
|
}
|
|
bind Menu <Leave> {myMenuLeave %W %X %Y %s}
|
|
bind Menu <ButtonPress> {myMenuButtonDown %W}
|
|
bind Menu <ButtonRelease> {myMenuInvoke %W 1}
|
|
bind Menu <Motion> {myMenuMotion %W %x %y %s}
|
|
set myMenuFlag 0
|
|
set myMenuMotion 0
|
|
|
|
# ::tk::MenuNextEntry --
|
|
# Activate the next higher or lower entry in the posted menu,
|
|
# wrapping around at the ends. Disabled entries are skipped.
|
|
#
|
|
# Arguments:
|
|
# menu - Menu window that received the keystroke.
|
|
# count - 1 means go to the next lower entry,
|
|
# -1 means go to the next higher entry.
|
|
|
|
proc ::tk::MenuNextEntry {menu count} {
|
|
global ::tk::Priv
|
|
|
|
if {[$menu index last] eq "none"} {
|
|
return
|
|
}
|
|
set length [expr {[$menu index last]+1}]
|
|
set quitAfter $length
|
|
set active [$menu index active]
|
|
if {$active eq "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 ne "disabled"} {
|
|
break
|
|
}
|
|
}
|
|
if {$i == $active} {
|
|
return
|
|
}
|
|
incr i $count
|
|
incr quitAfter -1
|
|
}
|
|
$menu activate $i
|
|
::tk::GenerateMenuSelect $menu
|
|
if {[$menu type $i] eq "cascade"} {
|
|
set cascade [$menu entrycget $i -menu]
|
|
if {[$menu cget -type] eq "menubar" && $cascade ne ""} {
|
|
# Here we auto-post a cascade. This is necessary when
|
|
# we traverse left/right in the menubar, but undesirable when
|
|
# we traverse up/down in a menu.
|
|
$menu postcascade $i
|
|
::tk::MenuFirstEntry $cascade
|
|
}
|
|
}
|
|
}
|
|
|
|
# ::tk::MenuNextMenu --
|
|
# This procedure is invoked to handle "left" and "right" traversal
|
|
# motions in menus. It traverses to the next menu in a menu bar,
|
|
# or into or out of a cascaded menu.
|
|
#
|
|
# Arguments:
|
|
# menu - The menu that received the keyboard
|
|
# event.
|
|
# direction - Direction in which to move: "left" or "right"
|
|
|
|
proc ::tk::MenuNextMenu {menu direction} {
|
|
global ::tk::Priv
|
|
|
|
# First handle traversals into and out of cascaded menus.
|
|
|
|
if {$direction eq "right"} {
|
|
set count 1
|
|
set parent [winfo parent $menu]
|
|
set class [winfo class $parent]
|
|
if {[$menu type active] eq "cascade"} {
|
|
$menu postcascade active
|
|
set m2 [$menu entrycget active -menu]
|
|
if {$m2 ne ""} {
|
|
::tk::MenuFirstEntry $m2
|
|
}
|
|
return
|
|
} else {
|
|
set parent [winfo parent $menu]
|
|
while {$parent ne "."} {
|
|
if {[winfo class $parent] eq "Menu" && \
|
|
[$parent cget -type] eq "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] eq "Menu"} {
|
|
if {[$m2 cget -type] ne "menubar"} {
|
|
$menu activate none
|
|
::tk::GenerateMenuSelect $menu
|
|
tk_menuSetFocus $m2
|
|
|
|
# This code unposts any posted submenu in the parent.
|
|
$m2 postcascade none
|
|
|
|
#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] eq "Menu"} {
|
|
if {[$m2 cget -type] eq "menubar"} {
|
|
tk_menuSetFocus $m2
|
|
::tk::MenuNextEntry $m2 -1
|
|
return
|
|
}
|
|
}
|
|
|
|
set w $::tk::Priv(postedMb)
|
|
if {$w eq ""} {
|
|
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] eq "Menubutton" \
|
|
&& [$mb cget -state] ne "disabled" \
|
|
&& [$mb cget -menu] ne "" \
|
|
&& [[$mb cget -menu] index last] ne "none"} {
|
|
break
|
|
}
|
|
if {$mb eq $w} {
|
|
return
|
|
}
|
|
incr i $count
|
|
}
|
|
::tk::MbPost $mb
|
|
::tk::MenuFirstEntry [$mb cget -menu]
|
|
}
|
|
|
|
# ::tk::MenuFirstEntry --
|
|
# Given a menu, this procedure finds the first entry that isn't
|
|
# disabled or a tear-off or separator, and activates that entry.
|
|
# However, if there is already an active entry in the menu (e.g.,
|
|
# because of a previous call to ::tk::PostOverPoint) then the active
|
|
# entry isn't changed. This procedure also sets the input focus
|
|
# to the menu.
|
|
#
|
|
# Arguments:
|
|
# menu - Name of the menu window (possibly empty).
|
|
|
|
proc ::tk::MenuFirstEntry menu {
|
|
if {$menu eq ""} {
|
|
return
|
|
}
|
|
tk_menuSetFocus $menu
|
|
if {[$menu index active] ne "none"} {
|
|
return
|
|
}
|
|
set last [$menu index last]
|
|
if {$last eq "none"} {
|
|
return
|
|
}
|
|
for {set i 0} {$i <= $last} {incr i} {
|
|
if {([catch {set state [$menu entrycget $i -state]}] == 0) \
|
|
&& $state ne "disabled"} {
|
|
#~$menu activate $i
|
|
#~::tk::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"} {
|
|
set cascade [$menu entrycget $i -menu]
|
|
if {$cascade ne ""} {
|
|
$menu postcascade $i
|
|
::tk::MenuFirstEntry $cascade
|
|
}
|
|
}
|
|
return
|
|
}
|
|
}
|
|
}
|
|
|
|
# ::tk::MenuMotion --
|
|
# This procedure is called to handle mouse motion events for menus.
|
|
# It does two things. First, it resets the active element in the
|
|
# menu, if the mouse is over the menu. Second, if a mouse button
|
|
# is down, it posts and unposts cascade entries to match the mouse
|
|
# position.
|
|
#
|
|
# Arguments:
|
|
# menu - The menu window.
|
|
# x - The x position of the mouse.
|
|
# y - The y position of the mouse.
|
|
# state - Modifier state (tells whether buttons are down).
|
|
|
|
proc ::tk::MenuMotion {menu x y state} {
|
|
global ::tk::Priv
|
|
if {$menu eq $::tk::Priv(window)} {
|
|
if {[$menu cget -type] eq "menubar"} {
|
|
if {[info exists ::tk::Priv(focus)] && $menu ne $::tk::Priv(focus)} {
|
|
$menu activate @$x,$y
|
|
::tk::GenerateMenuSelect $menu
|
|
}
|
|
} else {
|
|
$menu activate @$x,$y
|
|
::tk::GenerateMenuSelect $menu
|
|
}
|
|
}
|
|
#debugmsg plugins "MENU: $menu $::tk::Priv(activeMenu) $::tk::Priv(activeItem) $::tk::Priv(focus)"
|
|
if {([$menu cget -type] ne "menubar") || \
|
|
([info exist ::tk::Priv(focus)] && ($::tk::Priv(focus) ne "") && ($::tk::Priv(activeItem) != "none"))} {
|
|
myMenuPostCascade $menu
|
|
}
|
|
}
|
|
|
|
# ::tk::MenuButtonDown --
|
|
# Handles button presses in menus. There are a couple of tricky things
|
|
# here:
|
|
# 1. Change the posted cascade entry (if any) to match the mouse position.
|
|
# 2. If there is a posted menubutton, must grab to the menubutton; this
|
|
# overrrides the implicit grab on button press, so that the menu
|
|
# button can track mouse motions over other menubuttons and change
|
|
# the posted menu.
|
|
# 3. If there's no posted menubutton (e.g. because we're a torn-off menu
|
|
# or one of its descendants) must grab to the top-level menu so that
|
|
# we can track mouse motions across the entire menu hierarchy.
|
|
#
|
|
# Arguments:
|
|
# menu - The menu window.
|
|
|
|
proc ::tk::MenuButtonDown menu {
|
|
variable ::tk::Priv
|
|
global tcl_platform
|
|
|
|
if {![winfo viewable $menu]} {
|
|
return
|
|
}
|
|
$menu postcascade active
|
|
if {$Priv(postedMb) ne "" && [winfo viewable $Priv(postedMb)]} {
|
|
grab -global $Priv(postedMb)
|
|
} else {
|
|
while {[$menu cget -type] eq "normal" \
|
|
&& [winfo class [winfo parent $menu]] eq "Menu" \
|
|
&& [winfo ismapped [winfo parent $menu]]} {
|
|
set menu [winfo parent $menu]
|
|
}
|
|
|
|
if {$Priv(menuBar) eq {}} {
|
|
set Priv(menuBar) $menu
|
|
set Priv(cursor) [$menu cget -cursor]
|
|
$menu configure -cursor arrow
|
|
} else {
|
|
$menu activate none
|
|
#MenuUnpost $menu
|
|
}
|
|
|
|
# Don't update grab information if the grab window isn't changing.
|
|
# Otherwise, we'll get an error when we unpost the menus and
|
|
# restore the grab, since the old grab window will not be viewable
|
|
# anymore.
|
|
|
|
if {$menu ne [grab current $menu]} {
|
|
SaveGrabInfo $menu
|
|
}
|
|
|
|
# Must re-grab even if the grab window hasn't changed, in order
|
|
# to release the implicit grab from the button press.
|
|
|
|
if {[tk windowingsystem] eq "x11"} {
|
|
grab -global $menu
|
|
}
|
|
}
|
|
}
|
|
|
|
set myPriv(id) ""
|
|
set myPriv(delay) 170
|
|
set myPriv(activeMenu) ""
|
|
set myPriv(activeItem) ""
|
|
|
|
proc myMenuPostCascade {menu} {
|
|
global myPriv
|
|
|
|
if {$myPriv(id) ne ""} {
|
|
if {($myPriv(activeMenu) == $menu) && ($myPriv(activeItem) == [$menu index active])} {
|
|
return
|
|
} else {
|
|
after cancel $myPriv(id)
|
|
}
|
|
}
|
|
if {[$menu cget -type] eq "menubar"} {
|
|
$menu postcascade active
|
|
} else {
|
|
set myPriv(activeMenu) $menu
|
|
set myPriv(activeItem) [$menu index active]
|
|
set myPriv(id) [after $myPriv(delay) "$menu postcascade active"]
|
|
}
|
|
}
|
|
|
|
}
|