| Subject: | Tk::Menu->Popup never returns (Win32) |
Posting a Tk::Menu with $menu->Popup() does not return. This is caused
by Tk::WM::Popup calling waitVisibility() which replaces the MainLoop
with its own event loop until $menu is destroyed. waitVisibility()
eventloops will be nested with each call to Popup() so we get a bunch of
error messages when the Tk::Menu instance is 'destroyed'.
I found this bug on AS-perl with Tk-804.027 and reproduced it with
Tk-804.027_500 compiled with Strawberry-perl.
Best regards, Christoph
(In the attached example I Added a few print statements to Tk::MainLoop
and Tk:Wm::Popup for demonstration)
Output:
...
Main_loop 72
Main_loop 73
Main_loop 74
Main_loop 75
Main_loop 76
Main_loop 77 # clicking Button show_menu: MainLoop is gone
in show_menu()
invoking Post
Post invoked
waiting for visibility
item selected: a # clicking Button show_menu 2nd time etc...
in show_menu()
invoking Post
Post invoked
waiting for visibility
item selected: b
in show_menu()
invoking Post
Post invoked
waiting for visibility
item selected: c
in show_menu()
invoking Post
Post invoked
waiting for visibility
item selected: d # clicked Btn destroy menu:
Main_loop 78 # MainLoop back again
# and a bunch of error messages:
Tk::Error: window ".menu" was deleted before its visibility changed at
C:/Perl/l
ib/Tk/Widget.pm line 926.
Tk callback for tkwait
Tk::Widget::waitVisibility at C:/Perl/lib/Tk/Widget.pm line 926
Tk::Wm::Popup at tk_wait_visibility_menu.pl line 64
main::show_menu at tk_wait_visibility_menu.pl line 94
Tk callback for .button
Tk::__ANON__ at C:/Perl/lib/Tk.pm line 252
Tk::Button::butUp at C:/Perl/lib/Tk/Button.pm line 111
<ButtonRelease-1>
(command bound to event)
Tk::Error: window ".menu" was deleted before its visibility changed at
C:/Perl/l
ib/Tk/Widget.pm line 926.
Tk callback for tkwait
Tk::Widget::waitVisibility at C:/Perl/lib/Tk/Widget.pm line 926
Tk::Wm::Popup at tk_wait_visibility_menu.pl line 64
main::show_menu at tk_wait_visibility_menu.pl line 94
Tk callback for .button
Tk::__ANON__ at C:/Perl/lib/Tk.pm line 252
Tk::Button::butUp at C:/Perl/lib/Tk/Button.pm line 111
<ButtonRelease-1>
(command bound to event)
Tk::Error: window ".menu" was deleted before its visibility changed at
C:/Perl/l
ib/Tk/Widget.pm line 926.
Tk callback for tkwait
Tk::Widget::waitVisibility at C:/Perl/lib/Tk/Widget.pm line 926
Tk::Wm::Popup at tk_wait_visibility_menu.pl line 64
main::show_menu at tk_wait_visibility_menu.pl line 94
Tk callback for .button
Tk::__ANON__ at C:/Perl/lib/Tk.pm line 252
Tk::Button::butUp at C:/Perl/lib/Tk/Button.pm line 111
<ButtonRelease-1>
(command bound to event)
Tk::Error: window ".menu" was deleted before its visibility changed at
C:/Perl/l
ib/Tk/Widget.pm line 926.
Tk callback for tkwait
Tk::Widget::waitVisibility at C:/Perl/lib/Tk/Widget.pm line 926
Tk::Wm::Popup at tk_wait_visibility_menu.pl line 64
main::show_menu at tk_wait_visibility_menu.pl line 94
Tk callback for .button
Tk::__ANON__ at C:/Perl/lib/Tk.pm line 252
Tk::Button::butUp at C:/Perl/lib/Tk/Button.pm line 111
<ButtonRelease-1>
(command bound to event)
Main_loop 79 # and some mainLoop calls until mw->destroy
Main_loop 80
Main_loop 81
Main_loop 82
Main_loop 83
Main_loop 84
Main_loop 85
Main_loop 86
Main_loop 87
Main_loop 88
Main_loop 89
Main_loop 90
Main_loop 91
| Subject: | tk_wait_visibility_menu.pl |
use warnings;
use strict;
use Tk;
package Tk;
my $ct = 0;
sub MainLoop
{
unless ($inMainLoop)
{
local $inMainLoop = 1;
while (Tk::MainWindow->Count)
{
DoOneEvent(0);
$ct++;
print "Main_loop $ct\n";
}
}
}
package Tk::Wm;
sub Popup
{
my $w = shift;
$w->configure(@_) if @_;
$w->idletasks;
my ($mw,$mh) = ($w->reqwidth,$w->reqheight);
my ($rx,$ry,$rw,$rh) = (0,0,0,0);
my $base = $w->cget('-popover');
my $outside = 0;
if (defined $base)
{
if ($base eq 'cursor')
{
($rx,$ry) = $w->pointerxy;
}
else
{
$rx = $base->rootx;
$ry = $base->rooty;
$rw = $base->Width;
$rh = $base->Height;
}
}
else
{
my $sc = ($w->parent) ? $w->parent->toplevel : $w;
$rx = -$sc->vrootx;
$ry = -$sc->vrooty;
$rw = $w->screenwidth;
$rh = $w->screenheight;
}
my ($X,$Y) = AnchorAdjust($w->cget('-overanchor'),$rx,$ry,$rw,$rh);
($X,$Y) = AnchorAdjust($w->cget('-popanchor'),$X,$Y,-$mw,-$mh);
# adjust to not cross screen borders
if ($X < 0) { $X = 0 }
if ($Y < 0) { $Y = 0 }
if ($mw > $w->screenwidth) { $X = 0 }
if ($mh > $w->screenheight) { $Y = 0 }
print "invoking Post\n";
$w->Post($X,$Y);
print "Post invoked\nwaiting for visibility\n";
$w->waitVisibility;
print "w is visible now\n";
}
package main;
my $mw = tkinit();
my $menu = $mw->Menu(-tearoff => 0,
);
for my $item (qw/a b c d/){
$menu->add('command',
-label => $item,
-command => sub{$menu->Unpost;
print "item selected: $item\n";
},
);
}
my $btn = $mw->Button(-text => 'show menu',
-command => \&show_menu,)->pack;
my $btn2 = $mw->Button(-text => 'destroy menu',
-command => \&destroy_menu,
)->pack;
Tk::MainLoop();
sub show_menu{
print "in show_menu()\n";
$menu->Popup(-popover => 'cursor');
print "next: returning from show_menu()\n";
}
sub destroy_menu{
$menu->destroy;
$mw->after(100,sub{
$mw->destroy;
}
);
}