Setting options in Tk::Optionmenu without the callback?

[graff]

I need to change the entries in a Tk::Optionmenu widget whenever the user does something in another widget. No problem with that, but every time this happens, it triggers the Optionmenu widget's "-command" (callback) subroutine.

Of course, when the user actually clicks on the Optionmenu widget and selects one of the current menu items, this runs the callback with the menu value chosen by the user, and this is fine.

My problem is, how can the callback function tell the difference between being invoked by an actual menu selection (user has made a choice, so do something with that) vs. being invoked because the options have been changed (user hasn't really picked a specific option, so don't do anything yet).

Here's a little test script demonstrates the behavior: when the window first starts up, the first installation of options invokes the callback. Thereafter, the callback is invoked when the Optionmenu itself is used to make a selection, and each time the "Change Options" button is clicked.

I want the callback to be able to skip its work (or not be called in the first place) when installing a new menu. How do I do that?

#!/usr/bin/perl

use strict;
use Tk;
my $mw = MainWindow->new();

my ($var, $tvar);
my $opt = $mw->Optionmenu(
                          -command => \&show_choice,
                          -variable => \$var,
                          -textvariable => \$tvar
                         )->pack;
change_ops( $opt );

my $f = $mw->Frame(-relief=>'groove', -borderwidth => 2)->pack;
$f->Label(-textvariable=>\$tvar)->pack(-side => 'left');
$f->Label(-text => " -> ")->pack(-side => 'left');
$f->Label(-textvariable=>\$var)->pack(-side => 'left');

$mw->Button(-text=>'Change Options',-command=>[\&change_ops, $opt])->p
+ack;
$mw->Button(-text=>'Exit', -command=>sub{$mw->destroy})->pack;

MainLoop;

sub show_choice
{
    print "got: ", shift, "\n"
}

sub change_ops
{
    my $op = shift;
    my @newoptions = map { ++$. } ( 0 .. 3 );
    $op->configure( -options => \@newoptions );
}

(the script is based loosely on the example provided in the Optionmenu man page, which also demonstrates the issue when it starts up)

I've looked at the source (Optionmenu.pm), and I could create a modified version of this widget, altering its "addOptions" and "setOption" functions so that the latter does not invoke the callback whenever it happens to be called by the former...

But creating a new version of a widget is the sort of thing I'm likely to do wrong the first few times I try, so I'm hoping some monk can guide me (actually, I'm hoping there's an easier work-around that I'm missing).

[BrowserUk]

(actually, I'm hoping there's an easier work-around that I'm missing).

It's crude and nasty, but it's a lot simpler than creating your own widget.

I had a go at that a while ago and it's definitely not for the faint hearted. Or even the bold and brassy if they have any sort of time contstraints.

my $changed = 0;

sub show_choice
{
    $changed = 0, return if $changed;
    print "got: ", shift, "\n"
}

sub change_ops
{
    my $op = shift;
    my @newoptions = map { ++$. } ( 0 .. 3 );
    $changed = 1;
    $op->configure( -options => \@newoptions );
}

[GrandFather]

Don't know if there is a better way, but:

sub change_ops
{
    my @ops = @_;
    my @newoptions = map { ++$. } ( 0 .. 3 );
    my $callback = $ops[0]->cget (-command);
    $ops[0]->configure( -command => undef );
    $ops[0]->configure( -options => \@newoptions );
    $ops[0]->configure( -command => $callback );
}

fixes the problem.

[zentara]

You can determine the current Tk widget being used to initiate the callbacks, and setup logic as needed.

sub show_choice{
    
    my $caller = $Tk::widget;
    
    print 'caller-> ',$caller,"\n";
    
    if( $caller =~ /^Tk::Menu.*/){    
       print "got: ", shift, "\n"
    }else{ return }

}

[graff]

This is clearly The Way It's Supposed To Be Done™. In fact, I can now make a really compact (and fairly coherent) idiom:

sub my_optionmenu_callback
{
    return unless ( $Tk::widget =~ /^Tk::Menu/ );
    # do stuff...
}

Thank you -- knowing how to identify the caller like that is likely to simplify many things.

[Anonymous Monk]

You can prevent the callback from being triggered by setting the variable to the first item of @newoptions before changing the options.

sub change_ops
{
    my $op = shift;
    my $var = $op->cget('-textvariable');
    my @newoptions = map { ++$. } ( 0 .. 3 );
    my ($prev) = (grep {$_ eq $$var} @newoptions) || '';
    $$var = $newoptions[0];
    $op->configure( -options => \@newoptions );
    $$var = $prev;
}