require MenuPopup; #### $winInfoRef->{HLIST}->bind('' => sub{ MenuPopup($winInfoRef->{MENU}, -popover=>"cursor",-popanchor=>'ne') }); #### $winInfoRef->{HLIST}->bind('' => sub{ $winInfoRef->{MENU}->MenuPopup( -popover=>"cursor",-popanchor=>'ne'); }); #### #Note this can be used to in place of the Popup Method found in TK/Wm.pm # #it fixes a problem where if you ever used a popup menu, and then closed the main #window that posted the menu, you would get a TK error saying something like: # Tk::Error: window ".toplevel.frame.hlist.menu" was deleted before its visibility changed at # C:/Perl/site/lib/Tk/Widget.pm line 1000. # Tk callback for tkwait # It doesn't allow you to directly use as a method like $wid->MenuPopup(-opt1=>'opt',-opt2=>'blah'), # instead you call it and pass it the widget like this: MenuPopup($wid,-opt1=>'opt',-opt2=>'blah); # When you use bind to enable the popup, use it like this: # $widget->bind('' => sub{ # MenuPopup($winInfoRef->{MENU},-popover=>"cursor",-popanchor=>'ne'); # } # ); #The fix was commenting out #$w->waitVisibility; ## Bug #28238 for Tk: Tk::Menu->Popup never returns (Win32) #I got this gem from the perlMonks after reaching out on http://www.perlmonks.org/?node_id=1123733 sub MenuPopup { package Tk::Wm; 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 } $w->Post($X,$Y); #$w->waitVisibility; ## Bug #28238 for Tk: Tk::Menu->Popup never returns (Win32) $w->update; } #needed for require return 1;