15.6.1. Tk::waitVariableX

Although waitVariable is nonblocking in the sense that Tk events continue to be processed, the program flow at the wait point is blocked until the variable changes. If the variable never changes, then that thread of execution can never continue. So, we can imagine a waitVariable with a timeout such that, after a certain amount of time, program flow resumes even if the variable never changes. We can go a step further and wait for a list of variables with a timeout. It's actually very easy to implement these features, using the existing waitVariable command and Tie::Watch.

Here is a typical calling sequence, where we wait for $splash_var to change value, or 3000 milliseconds, whichever occurs first. If the timeout is zero, no timer callback is queued.

$mw->waitVariableX(3 * 1000, \$splash_var);

In typical Perl/Tk style, we've decided that the first argument passed to waitVariableX can also be an array reference. In this case, the first element is the millisecond timeout value (or zero) and the second, a standard Perl/Tk callback that is invoked just before waitVariableX returns:

$self->waitVariableX( [$millis, $destroy_splashscreen] );

Here's the code for waitVariableX:

$Tk::waitVariableX::VERSION = '1.0';

package Tk::waitVariableX;

use Carp;
use Exporter;

use base qw/Exporter/;
@EXPORT = qw/waitVariableX/;
use strict;

sub waitVariableX {

    use Tie::Watch;

    my ($parent, $millis) = (shift, shift); # @_ has list of var refs

    croak "waitVariableX:  no milliseconds." unless defined $millis;
    my ($callback, $st, $tid, @watch, $why);

    if (ref $millis eq 'ARRAY') {
        $callback = Tk::Callback->new($millis->[1]);
        $millis = $millis->[0];
    }

    $st = sub {my $argv = $_[0]->Args('-store'); $why = $argv->[0]};
    foreach my $vref (@_) {
        push @watch,
            Tie::Watch->new(-variable => $vref, -store => [$st, $vref]);
    }
    $tid = $parent->after($millis => sub {$why = 0}) unless $millis == 0;

    $parent->waitVariable(\$why); # wait for timer or watchpoint(s)

    $_->Unwatch foreach @watch;
    $parent->afterCancel($tid);
    $callback->Call($why) if defined $callback;

    return $why;						# why we stopped waiting: 0 or $vref

} # end waitVariableX

1;

Once again, we have an Exporter module, not a mega-widget class module. We first save the parent widget reference and the milliseconds arguments, leaving the list of variables in @_. If the milliseconds argument is really an array reference, we create a Tk::Callback object and reset $millis.

Now we create the Store callback used by the list of variable watchpoints. If and when invoked, the callback calls the Tie::Watch method Args to fetch a reference to the list of Store arguments we supply to the Tie::Watch constructor, new. The first argument in the argument vector $argv is a reference to the watched variable, which is then stored in the lexical $why.

The foreach loop creates the actual watchpoint objects, using our callbacks $st and $vref, which, because we have a closure, uniquely point to each watched variable in turn. If and when the $st callback is invoked, it uses Args to fetch the closed $vref. Each variable's Store callback then stores $vref in the same lexical variable, $why.

If a millisecond timeout was specified, we use after to queue a timer event that sets $why to zero, assuming the timer ever expires. This is the same lexical variable set by the Store callbacks.

Finally, with everything in place, we wait for $why to change. When it does, we destroy all the watchpoint objects, cancel any outstanding timer event, execute the optional completion callback (passing it $why for completeness), and return $why; why waitVariableX is returned.

Note that: