I now have a working solution for this.
I have MSWindows and Cygwin environments available to me. I've tested in both.
Somewhere behind the scenes, MSWindows uses its own native Menu
code and is totally unaffected by configure(), bind(),
optionAdd() or anything else I threw at it.
So, effectively, everything after here refers to Cygwin.
I'm assuming this will also be valid for the majority of UNIX systems
(but happy to be corrected if I'm wrong).
I used a rather lengthy script for testing this.
I've pulled out the relevant parts and will annotate as I go.
Fairly standard start to the script:
...
use Tk;
...
{
my $mw = MainWindow->new();
...
configure_option_database($mw);
...
build_menu_bar($mw);
...
}
I've used zero-length strings to pick up the system cursor.
I wasn't actually aware of that behaviour, so thanks for that one Khariton.
While testing, I changed these to various other values and they behaved
as expected, i.e. they either affected the entire GUI or just the menu.
sub configure_option_database {
my ($mw) = @_;
...
$mw->optionAdd(q{*cursor}, q{}, $priority);
...
$mw->optionAdd(q{*Menu.cursor}, q{}, $priority);
...
}
Here I've overridden the Menu.pm code
( $mw->bind($class,'<ButtonPress>','ButtonDown'); ).
I've used a different name for the callback which gets around the
subroutine redefinition warning noted by zentara;
although a no warnings q{redefine} can easily do that anyway.
(If you take that route, ensure you add use warnings q{redefine}
immediately after the redefined subroutine or put the whole lot inside
{ ... } so it's lexically hidden.)
I've also given the menu cursor a starting value.
As with optionAdd() (above), I tried this with a number of values
and results were as expected.
One point to note here is that $parent->configure(...) must come
before $mb->configure(...); if you have it the other way around, subsequent calls to
$mb->cget() do not return the configured value - it took a bit of head
scratching to work that one out. :-)
sub build_menu_bar {
my ($parent) = @_;
my $mb = $parent->Menu(
-type => q{menubar},
...
);
$mb->bind(ref $mb, q{<ButtonPress>}, \&menu_button_down);
$parent->configure(-menu => $mb);
$mb->configure(-cursor => q{});
...
}
Finally, I've copied the ButtonDown() method from Menu.pm
and made the modification shown.
If your Perl version is less than 5.10, you'll need the defined
function instead of // (note that || won't work as an
empty string to indicate the system cursor will be seen as a false value).
# A modified version of Tk::Menu::ButtonDown()
sub menu_button_down {
...
$Tk::cursor = $menu->cget('-cursor');
# START: Modification of Tk::Menu::ButtonDown()
#$menu->configure(-cursor => 'arrow');
my $menu_cursor = $Tk::cursor
// $menu->optionGet(q{cursor}, ref $menu)
// q{};
$menu->configure(-cursor => $menu_cursor);
# END: Modification of Tk::Menu::ButtonDown()
...
}
I have two caveats with this solution:
-
If Tk::Menu::ButtonDown() ever changes, the menu_button_down()
code may require an equivalent modification.
-
$Tk::cursor is a global variable.
I don't believe I've used it in any way different from the original
but, obviously, I haven't checked every line of Tk code.
I haven't seen any strange behaviour but I also haven't used every
Tk widget in the test GUI.
Global variables just scare me - which I think is probably a good thing. :-)
|