Mastering Perl/Tk Graphical User Interfaces in Perl By Steve Lidie & Nancy Walsh January 2002 1-56592-716-8, Order Number: 7168 766 Pages, $44.95

Chapter 15
Anatomy of the MainLoop

As programmers, we all know what a "main loop" is. It's the heart of our programs, the repeating chunk of code that carries out the task at hand. But Perl/Tk programs are event driven, so even if we write what we believe is our program's main loop, it must coexist with a higher order main loop that's a fundamental part of Tk. The Tk main loop is typically referred to as the event loop, and its job is to invoke callbacks in response to events such as button presses or timer expirations.

Callbacks are Perl subroutines associated with Tk events. In Perl/Tk, we can define callbacks that, from our point of view, are automatically invoked when the appropriate event occurs. The Tk core defines hundreds of other callbacks on our behalf that we're not even aware of. It's the combination of our own callbacks and Tk-defined callbacks that gives behavior to our Perl/Tk applications.

The event loop is activated once the Perl/Tk program's MainLoop statement is reached. From that point on, MainLoop controls our program. As events happen, MainLoop dispatches them to a handler (a callback) for processing and puts the application to sleep for a short amount of time when the event queue is empty. This repeats until there are no more MainWindows, at which time MainLoop returns. Any code after the MainLoop statement is then executed.

Here is the salient portion of the actual MainLoop subroutine from the Perl/Tk source distribution:

use Tk ':eventtypes';
 
while (Tk::MainWindow->Count) {
    DoOneEvent(ALL_EVENTS);
}

As we see, the Tk main loop processes all events, one by one, until the count of MainWindows becomes zero. The use tag :eventtypes imports various symbols used by DoOneEvent, the subroutine that actually dispatches individual events. We'll learn more about DoOneEvent later. For now it's sufficient to know that the subroutine expects one argument, a bit pattern, specifying what types of events to process and whether to return immediately or to wait if there are no such events.

The symbol ALL_EVENTS is the inclusive OR of all the various event types, which we'll examine in detail later. The individual event types that DoOneEvent recognizes are as follows:

WINDOW_EVENTS

These include things such as keyboard entry, button clicks, and window size and visibility changes.

FILE_EVENTS

These deal with reading and writing files and network sockets.

TIMER_EVENTS

These are created by the after and repeat commands.

IDLE_EVENTS

These are low-priority callbacks executed only after all events of the previous types have been processed. The most common idle events are those that redraw widgets and refresh the display. You can queue idle callbacks using DoWhenIdle.

The :eventtypes tag defines one other symbol, DONT_WAIT, that can be inclusively ORed with a DoOneEvent bit pattern to make the subroutine call nonblocking. Notice that MainLoop does not include DONT_WAIT in its DoOneEvent bit pattern, meaning that DoOneEvent sleeps when there is nothing to do, instead of returning to MainLoop. This is actually a good thing, as it allows other programs running on our computer a slice of the CPU pie. Later we'll see when including DONT_WAIT works to our advantage.

MainLoop's job is to dispatch events to callbacks in a timely fashion. As you write callbacks, keep in mind you are in a mutually cooperative environment; all callbacks should be brief and nonblocking so the application remains responsive. A common novice mistake is to execute a long-running system command, then wonder why Buttons don't work and the display won't refresh. The novice fails to realize that MainLoop has been locked out, and the events responsible for Button actions and screen refreshes are being queued by the underlying operating system. We'll examine idioms to avoid blocking situations. The principle of mutual cooperation applies also when sharing events with other GUI packages, such as OpenGL.

And that, in a nutshell, describes the contents of this chapter. In summary, we'll learn:

• How to create callbacks
• About the different events, including virtual events
• How to associate events with callbacks
• About nonblocking programming techniques and how to cooperate with MainLoop
• How to share the event loop with OpenGL

Let us move on and examine the details.

Creating a Callback

Perl/Tk has an expressive and well-defined callback syntax. Anywhere an option expects a callback, you can use this syntax. The most common option name is -command, but you'll also see -validatecommand, -browsecmd, or something similar. For instance, when you create a Button widget, you use -command to specify the callback invoked when the button is pressed. Similarly, when you create an event binding, you specify the event of interest and a callback to invoke when the event occurs.

At its simplest, a callback is a subroutine reference:

-command => \&callback

or:

-command => sub { ... }

The first example is a code reference to a named subroutine. The second is a code reference to an anonymous subroutine. Notice that you cannot pass explicit arguments to the subroutines using this callback format. A common mistake is to assume a statement of this form will work:

-command => \&callback(arguments)

Well, it "works" in the sense that it compiles and produces a result, but the result is probably not what you expect. You aren't creating a code reference to a subroutine that will execute sometime in the future. Instead, the subroutine is executed immediately, and you get a reference to the subroutine's return value. A fast session in the Perl debugger shows us the scary details:

[bug@Pandy Anatomy]$ perl -de 0
Default die handler restored.
 
Loading DB routines from perl5db.pl version 1.07
Editor support available.
 
Enter h or `h h' for help, or `man perldebug' for more help.
 
main::(-e:1):   0
  DB<1> sub frog {print "frog args=@_!\n"; return 456}
 
  DB<2> &frog(1, 2, 3)
frog args=1 2 3!
 
  DB<3> $cref1 = \&frog
 
  DB<4> p $cref1
CODE(0x82c45f8)
  DB<5> $cref2 = \&frog(789)
frog args=789!
 
  DB<6> p $cref2
SCALAR(0x82c6818)
  DB<7> p $$cref2
456
  DB<8> q

Debug line 1 first creates the subroutine frog that prints its arguments and returns the integer 456. Line 2 then calls frog as a test. Line 3 takes a reference to frog, verified in line 4. Notice in line 5 that frog is called immediately and prints its argument 789. Line 6 shows us that we have failed to create a code reference but have a reference to a scalar instead. Line 7 dereferences $cref2 and prints the result, which is 456, frog's return value. You have been warned!

When you want to pass arguments to a callback, specify an array reference, with the callback code reference as first element and the callback arguments as subsequent array elements:

-command => [ \&callback, arg1, arg2 ...]

or:

-command => [ sub { ... }, arg1, arg2, ... ]

Finally, there's a third callback form in which you specify a method name as a string. This form is used more often in binding commands and when writing mega-widgets, because it's very easy for a subclass to override the subroutine by providing it's own method with the same name. We'll see examples later on in this chapter. Table 15-1 shows legal callback syntax.

Table 15-1: Legal callback syntax

Callback formats without arguments	Callback formats with arguments
\&callback	[ \&callback, arg1, arg2, ... ]
sub { ... }	[ sub { ... }, arg1, arg2, ... ]
'methodname'	[ 'methodname', arg1, arg2, ... ]

Regardless of the syntax you use, Perl/Tk ends up creating a Tk::Callback object.

One final note: for callbacks with arguments, Perl/Tk evaluates the contents of the (anonymous) array when the callback is parsed. To defer evaluation of an argument until the callback is executed, use the Ev method, described in the section "Binding to a MouseWheel Event." The Ev method should only be used to construct parameters for event callbacks.

Callbacks and Closures

Creating a number of widgets using a Perl loop construct is a common programming task, which in itself is easy enough:

foreach $b (1 .. 5) {
    $mw->Button(
        -text    => $b, 
    )->pack;
}

This code produces five Buttons aligned vertically, labeled 1 through 5. But the Buttons don't do anything, and trouble usually begins when you try to specify a callback. Since we're creating Buttons in a loop, the assumption is that they do similar things but vary slightly depending upon which one is pressed. So the problem reduces to how to tell the callback which button invoked it.

Here's a first attempt at creating a series of Buttons with unique identifiers (differences are shown in bold type). It's doomed to failure, because the scope of $b is local to the for loop only, and although the Button text is correct, by the time a Button callback is executed, $b has gone out of scope and no longer exists.

foreach $b (1 .. 5) {
    $mw->Button(
        -text    => $b, 
        -command => sub {print "Button $b\n"},
    )->pack;
}

In the previous example, every time you click on any of the Buttons, you see this:

Use of uninitialized value in concatenation (.) at ./close1 line 12.
Button 

Our second attempt at creating a series of Buttons with unique identifiers also fails, because the callback uses the value that $n had at the end of the for statement. This is simply a variation of our first attempt.

$n = 1;
foreach $b (1 .. 5) {
    $mw->Button(
        -text    => $b, 
        -command => sub {print "Button $n\n"},
    )->pack;
    $n++;
}

When you click on any Button, you see this:

Button 6

For our third attempt, we declare $b a my, or lexical, variable, and voilà, it works! Every Button callback correctly prints its Button ID number.

foreach my $b (1 .. 5) {
    $mw->Button(
        -text    => $b, 
        -command => sub {print "Button $b\n"},
    )->pack;
}

What's so magical about lexicals? In simple terms, when an anonymous subroutine is defined, the values of lexical variables it references outside its scope become "closed," or finalized, as the subroutine is defined. Closures are ideal for creating callbacks, because they can enclose current information in their definitions, which are available later in a different scope. For an authoritative essay on closures, please read the perlref manpage.

Here's another version, which also works as expected because Perl/Tk creates the closures for us. It's somewhat verbose, but it does the job.

foreach $b (1 .. 5) {
    $mw->Button(
        -text    => $b, 
        -command => [\&do_button, $b],
    )->pack;
}
 
MainLoop;
 
sub do_button {
    $n = shift;
    print "Button $n\n";
}

Here's our final attempt at creating a series of Buttons with unique identifiers. This is a variation of our previous attempt that avoids the use of an explicit subroutine.

foreach $b (1 .. 5) {
    $mw->Button(
        -text    => $b, 
        -command => [sub {print "Button $_[0]\n"}, $b],
    )->pack;
}

Generally, the preferred solution to this problem is either this most recent attempt or to use the lexical for loop variable (our third attempt).

Binding to Events

When creating a Button instance, the -command option specifies the callback to invoke when the user presses the Button. The button press must be button 1, because that's the Button's documented behavior. As a convenience, the Button constructor automatically creates the link between the button 1 press and our callback using the bind command. If it didn't, we'd have to do it manually for every Button we create, using syntax similar to this:

$button->bind('<ButtonRelease-1>' => callback);

If nothing else, -command => callback is fewer characters to type, but it also provides consistency, because the Button always reacts to the first button, not whatever button the programmer decided to use.

In the previous bind command, the string <ButtonRelease-1> is know as an event descriptor. It's composed of two fields enclosed in angle brackets, the event type and the event detail. In the case of a ButtonRelease event type, the detail portion specifies which button we are interested in. The event descriptor in this example is very specific: it invokes the callback only when button 1 is released over the Button widget (as opposed to when it's pressed). If you watch a Button closely, pressing button 1 only changes the widget's relief from raised to sunken. If you move the cursor away from the Button, the relief changes back, but the widget's callback is never invoked.

Event Descriptor Syntax

An event descriptor can be more complex than our first example; it can actually be one or more event patterns, and each pattern can have zero or more modifiers:

<modifier-modifier-type-detail>

In the previous example, the event descriptor was comprised of one event pattern, which is typically all you'll ever use. Any of the fields may be omitted, as long as at least type or detail is present.

Tk also supports user defined virtual events. They are named entities surrounded by double angle brackets:

<<virtual-event-name>>                                                   

Virtual events may not have modifiers. In previous chapters, we've discussed these virtual events: Tk::Text <<Undo>> and <<Redo>>, Tk::Menu <<MenuSelect>>, and Tk::Listbox <<ListboxSelect>>.

Use the eventGenerate command described later to trigger a virtual event.

Event descriptor modifiers

Table 15-2 lists the valid modifiers. Double and Triple modifiers repeat events. They are most often associated with buttons, so we often see event descriptors like <Double-Button-1>. Common keyboard modifiers include Alt, Control, Meta, Mod, and Shift; thus, <Control-Key-c> would trap a Control-c.

Table 15-2: Event modifiers

Alt	Control	Mod3, M3
Button1, B1	Double	Mod4, M4
Button2, B2	Lock	Mod5, M5
Button3, B3	Meta, M	Shift
Button4, B4	Mod1, M1	Triple
Button5, B5	Mod2, M2

Event descriptor types

An event descriptor can include any of the types described in Table 15-3.

Table 15-3: Legal event types

Event type	Brief description
Activate	Currently unused.
ButtonPress (or Button)	A mouse button was pressed.
ButtonRelease	A mouse button was released.
Circulate	A widget's stacking order has changed.
ColorMap	A widget's colormap has changed.
Configure	A widget has changed size or position and may need to adjust its layout.
Deactivate	Currently unused.
Destroy	A widget was destroyed.
Enter	The cursor has moved into a widget.
Expose	All or part of a widget has been uncovered and may need to be redrawn.
FocusIn	A widget has gained the keyboard focus.
FocusOut	A widget has lost the keyboard focus.
Gravity	A widget has moved because its parent changed size.
KeyPress (or Key)	A key has been pressed.
KeyRelease	A key has been released.
Motion	The cursor is in motion over a widget.
MouseWheel	The mousewheel is scrolling.
Leave	The cursor has moved out of a widget.
Map	A widget has been mapped onto the display and is visible.
Property	A widget property has changed.
Reparent	A widget has been reparented.
Unmap	A widget has been unmapped from the display and is no longer visible.
Visibility	A widget's visibility has changed.

Of all these event types, most of the time you'll only deal with ButtonPress, ButtonRelease, Destroy, Enter, KeyPress, KeyRelease, Leave, and Motion.

We know that for Button events, the detail field of the event descriptor is a button number. Valid numbers are one through five. If the Button detail is omitted, any button triggers the callback. For Key events (KeyPress and KeyRelease), the detail field is a keysym, an identifier for the desired keyboard character. For alphabetic characters, the keysym is simply the character itself. For example:

$mw->bind('<KeyRelease-a>' => callback);

invokes the callback when the lowercase character "a" is typed in the MainWindow. If you want to bind to an uppercase character, use the uppercase keysym:

$mw->bind('<KeyRelease-A>' => callback);

Other keysyms are not so easy to figure out; for instance, what's the keysym for the page-down key? Well, let's find out....

The Event Structure

When Tk invokes a callback, it provides detailed information about the event that triggered the callback. In C, this data is stored in a structure and has been historically called the event structure. The internal Tk event structure is still a real C structure, but we don't fiddle with it directly. Instead, Perl/Tk gives us an event object, which we use to call methods that return the pieces of data of interest to us.

To see how this works, let's examine a program that prints the keysym for any keyboard character:

$mw->bind('<KeyPress>' => \&print_keysym);
 
sub print_keysym {
    my($widget) = @_;
    my $e = $widget->XEvent;    # get event object
    my($keysym_text, $keysym_decimal) = ($e->K, $e->N);
    print "keysym=$keysym_text, numeric=$keysym_decimal\n";
}

Notice the KeyPress binding is for the MainWindow, which lets us type anywhere in the window, even if it's filled with other widgets. The KeyPress event descriptor is missing its detail field, which means the callback is invoked when any key is pressed. Also notice that we've used a callback syntax that doesn't allow us to pass explicit arguments to print_keysym.

But print_keysym is expecting an argument; in fact, Tk implicitly passes the bound widget reference as the first argument to the callback, adding any of our explicit arguments afterwards. This is usually what we want, but sometimes the implicit argument gets in our way. To prevent bind from supplying the widget reference, specify your own object:

$a->bind(event_desciptor => [$b => callback]);

bind invokes the callback with widget $b rather than $a.

Using the widget reference, we call XEvent, which returns the event object for the KeyPress. The K method returns the key symbol, and the N method returns its decimal value.

In case you're wondering, the keysym for page down is Next.

The exporter tag :variables

The two most important pieces of information a callback needs are the event object and the widget the event object applies to. In newer Tks, Nick introduced two localized variables that represent this information: $Tk::event and $Tk::widget. These fully qualified variables are available to any callback. If you're particularly lazy, import them like so:

use Tk ':variables';

Then you can use the unqualified names $event and $widget in your callbacks. With this new information, we can write our keysym program more succinctly:

$mw->bind('<KeyPress>' => sub {
    print 'Keysym=', $Tk::event->K, ', numeric=', $Tk::event->N, "\n";
});
 

In the following example, we see the three different ways to get the event's widget reference:

my $b = $mw->Button(-text => 'Click B1 Then B2', -command => \&callback);
$b->bind('<ButtonRelease-2>' => \&callback);
 
sub callback {
    print "\n";
    print "callback args  = @_\n";
    print "\$Tk::event     = $Tk::event\n";
    print "\$Tk::widget    = $Tk::widget\n";
    print "\$Tk::event->W  = ", $Tk::event->W, "\n";
}

Clicking button 1 invokes callback with no arguments, and we see that $Tk::widget and the W event information method both return the same widget reference (that of the Button). Clicking button 2 invokes callback again, but this time, Tk supplies the bind widget reference as an argument: the Button reference.

callback args  = 
$Tk::event     = XEvent=SCALAR(0x82920f0)
$Tk::widget    = Tk::Button=HASH(0x817fa00)
$Tk::event->W  = Tk::Button=HASH(0x817fa00)
 
callback args  = Tk::Button=HASH(0x817fa00)
$Tk::event     = XEvent=SCALAR(0x817ff70)
$Tk::widget    = Tk::Button=HASH(0x817fa00)
$Tk::event->W  = Tk::Button=HASH(0x817fa00)

Event information methods

Table 15-4 lists all the event information methods. Keep in mind that not all information is applicable to all events. For conciseness, we also list the corresponding eventGenerate options. The Tk::event documentation has more complete information.

Table 15-4: Event information methods

Method/option	Valid events	Comments
#[1] / -serial	All events	Integer
@	Events with x/y fields	"@x,y" used by Tk::Text
A	KeyPress, KeyRelease	ASCII character
a / -above	Configure	Window object or ID
B / -borderwidth	Configure	Screen distance
b / -button	ButtonPress, ButtonRelease	Button number
c / -count	Expose, Map	Integer
D / -delta	MouseWheel	Integer
d / -detail	Enter, Leave, FocusIn, FocusOut	See Tk::event POD
E / -sendevent	All events	Boolean
f / -focus	Enter, Leave	All events
h / -height	Configure	Screen distance
K / -keysym	KeyPress, KeyRelease	Symbolic keysym
k / -keycode	KeyPress, KeyRelease	Integer
m / -mode	Enter, Leave, FocusIn, FocusOut	See Tk::events POD
N	KeyPress, KeyRelease	Decimal keysym
o / -override	Map, Reparent, Configure	Boolean (overrideredirect)
p / -place	Circulate	See Tk::event POD
R / -root	KeyPress, KeyRelease, ButtonPress, ButtonRelease, Enter, Leave, Motion	Window object or ID
S / -subwindow	KeyPress, KeyRelease, ButtonPress, ButtonRelease, Enter, Leave, Motion	Window object or ID
s / -state	All events	See Tk::event POD
T	All events	The event type
t / -time	KeyPress, KeyRelease, ButtonPress, ButtonRelease, Enter, Leave, Motion, Property	Integer
W	All events	Widget reference
/ -when	All events	now | tail | head | mark See Tk::event POD
w / -width	Configure	Screen distance
X / -rootx	KeyPress, KeyRelease, ButtonPress, ButtonRelease, Enter, Leave, Motion	Screen distance (the event's x coordinate relative to the root window)
x / -x	KeyPress, KeyRelease, ButtonPress, ButtonRelease, Motion, Enter, Leave, Expose, Configure, Gravity, Reparent	Screen distance (the event's x coordinate relative to the widget)
Y/ -rooty	KeyPress, KeyRelease, ButtonPress, ButtonRelease, Enter, Leave, Motion	Screen distance (the event's y coordinate relative to the root window)
y / -y	KeyPress, KeyRelease, ButtonPress, ButtonRelease, Motion, Enter, Leave, Expose, Configure, Gravity, Reparent	Screen distance (the event's y coordinate relative to the widget)

Widget Class Bindings

Like most widgets, Buttons have a default behavior defined by bindings automatically created by Perl/Tk. That's why when we make a Button, we don't have to create its <ButtonRelease-1> binding. These default widget bindings are known as class bindings. We can see these bindings by using a second form of the bind command, where we pass it just a class name. bind then reports all the event descriptors for that class. We use the Perl built-in function ref to determine the widget's class:

my $b = $mw->Button(qw/-text Beep -command/ => sub {$mw->bell});
$b->pack;
my $class = ref $b;
print "Button \$b is an instance of class '$class'.\n" .
      "This class has bindings for these events:\n\n";
print join("\n", $b->bind($class) ), "\n";

This produces:

Button $b is an instance of class 'Tk::Button'.
This class has bindings for these events:
 
<Key-Return>
<Key-space>
<ButtonRelease-1>
<ButtonPress-1>
<Leave>
<Enter>

Without even referring to the Tk::Button documentation, we can guess what most of these bindings do. The <Enter> event is triggered when the cursor moves over the Button, and the Button's background color changes, indicating it's activated. The <Leave> event restores the Button's background color. The <ButtonPress-1> event changes the Button's relief to sunken, and the <ButtonRelease-1> event changes the relief back to raised and invokes the -command callback. The Key events also invoke the callback if the Button has the input focus.

You can add additional widget bindings to the class if you desire, so that all Buttons inherit this new behavior. Suppose you want button 2 to execute a Button callback twice. Here's how to do it:

my $b = $mw->Button(qw/-text Beep -command/ => sub {$mw->bell});
$b->pack;
my $class = ref $b;
$b->bind($class, '<ButtonRelease-2>' => \&twice);
 
print "Button \$b is an instance of class '$class'.\n" .
      "This class has bindings for these events:\n\n";
print join("\n", $b->bind($class) ), "\n";
 
sub twice {
    my $button = shift;
    $button->Callback(-command);
    $button->Callback(-command);
}

This produces:

Button $b is an instance of class 'Tk::Button'.
This class has bindings for these events:
 
<ButtonRelease-2>
<Key-Return>
<Key-space>
<ButtonRelease-1>
<Button-1>
<Leave>
<Enter>

Here we used a third variant of bind that ties an event to a class as a whole. There are three important facts to note:

• We've used a named subroutine rather than an anonymous subroutine for the callback. While not strictly required, it's still good style, because it lets others override the callback by providing their own subroutine of the same name. This is particularly relevant when writing mega-widgets.
• The new binding is retroactive. Widget instances of the class created prior to the new binding definition automatically inherit the new binding.
• The Callback method is the proper way to invoke a Perl/Tk callback. It works like this: Callback takes its object (here, the Button widget), looks up the value of the option passed as its argument (here, -command), then invokes the callback. Callback takes care of the argument handling on our behalf; all the information it needs is contained in the Tk::Callback object.

Widget Instance Bindings

Sometimes you want a binding placed on a particular widget instance instead of the entire class. If you want one particular Button to invoke its callback twice, use this familiar bind format:

$b->bind('<ButtonRelease-2>' => \&twice);

To query instance bindings, use this fourth flavor of the bind command:

print $b->bind, "\n";

Which yields:

<ButtonRelease-2>

This is as expected. Remember, all other Button bindings are class bindings.

Table 15-5 shows bind syntax. tag represents a Tk class name, a widget reference, or a symbolic bindtags tag. We examine bindtags in the next section.

Table 15-5: Legal bind syntax

bind format	Comments
$w->bind;	Query $w for its event descriptors (same as $w->bind($w);).
$w->bind(tag);	Query tag for its event descriptors.
$w->bind(event_descriptor);	Query $w's event_descriptor for its callback.
$w->bind(tag, event_descriptor);	Query tag's event_descriptor for its callback.
$w->bind(event_descriptor => callback);	Set callback for $w.
$w->bind(tag, event_descriptor => callback);	Set callback for tag.

There are two callback formats we haven't yet talked about. They both query for the actual callback associated with an event descriptor, and you might wonder how they can be useful in the Perl/Tk world, where callbacks are code references. Well, the callbacks may be method names as well, and if we query for a callback, we might get a method name (as a string) instead of a code reference. One thing we can do with this information is write a drop-in replacement for the named subroutine in a widget subclass. Tk will invoke our new subroutine in deference to the superclass method. We can simulate this in non-mega-widget code using the _ _PACKAGE_ _ construct. Here's a way of rewriting the previous instance binding as a fake method name:

$b->bind('<ButtonRelease-2>' => _  _PACKAGE_  _ . '::twice');

Now Tk invokes the named subroutine in the named package (usually package main). You do not want to qualify the subroutine with an explicit package name in a mega-widget, though; Perl will find the method via its normal lookup mechanism.

Here is example code for a hypothetical calculator that binds the digits and arithmetic operators that drive the calculator, including those on the numeric keypad:

foreach my $key ( qw/0 1 2 3 4 5 6 7 8 9/ ) {
    $mw->bind( "<Key-$key>" => [\&key, $key] );
    $mw->bind( "<KP_$key>"  => [\&key, $key] );
}
 
foreach my $key ( qw/period KP_Decimal/ ) {
    $mw->bind( "<$key>"     => [\&key, '.'] );
}
 
foreach my $key ( qw/Return KP_Enter/ ) {
    $mw->bind( "<$key>"     =>  \&enter );
}
 
foreach my $key ( qw/plus KP_Add/ ) {
    $mw->bind( "<$key>"     => [\&math3, $ad, $io,   undef] );
}
 
foreach my $key ( qw/minus KP_Subtract/ ) {
    $mw->bind( "<$key>"     => [\&math3, $sb, undef, undef] );
}
 
foreach my $key ( qw/asterisk KP_Multiply/ ) {
    $mw->bind( "<$key>"     => [\&math3, $ml, $an,     $dm] );
}
 
foreach my $key ( qw/slash KP_Divide/ ) {
    $mw->bind( "<$key>"     => [\&math3, $dv, $xr,     $dd] );
}
 
$mw->bind( '<Delete>'       => \&bspclrx );

Binding to a MouseWheel Event

Many machines of an Intel architecture include an IntelliMouse, a mouse with a wheel sandwiched between its two buttons. In a Unix environment, Linux in particular, the wheel acts as the middle button. Thus, one has full three-button capabilities. In a Win32 environment, however, the wheel serves as a scrolling device. As it happens, Tk can also use the wheel to scroll.

The following code is taken from Slaven Rezic's post on comp.lang.perl.tk. At last, we Unix Perl/Tk-ers can use the MouseWheel event. Slaven tested the code under NT, and we have tested it under Linux.

Until BindMouseWheel becomes part of core Perl/Tk, you can use code similar to this:

#!/usr/local/bin/perl -w
use Tk;
use strict;
 
my $mw = MainWindow->new;
my $t = $mw->Text->pack;
$t->insert('end', "line $_\n") for (1 .. 200);
$t->focus;
 
&BindMouseWheel($t);
 
MainLoop;
 
sub BindMouseWheel {
 
    my($w) = @_;
 
    if ($^O eq 'MSWin32') {
        $w->bind('<MouseWheel>' =>
            [ sub { $_[0]->yview('scroll', -($_[1] / 120) * 3, 'units') },
                Ev('D') ]
        );
    } else {
 
       # Support for mousewheels on Linux commonly comes through
       # mapping the wheel to buttons 4 and 5.  If you have a
       # mousewheel ensure that the mouse protocol is set to
       # "IMPS/2" in your /etc/X11/XF86Config (or XF86Config-4)
       # file:
       #
       # Section "InputDevice"
       #     Identifier  "Mouse0"
       #     Driver      "mouse"
       #     Option      "Device" "/dev/mouse"
       #     Option      "Protocol" "IMPS/2"
       #     Option      "Emulate3Buttons" "off"
       #     Option      "ZAxisMapping" "4 5"
       # EndSection
 
        $w->bind('<4>' => sub {
            $_[0]->yview('scroll', -3, 'units') unless $Tk::strictMotif;
        });
 
        $w->bind('<5>' => sub {
            $_[0]->yview('scroll', +3, 'units') unless $Tk::strictMotif;
        });
    }
 
} # end BindMouseWheel

There's an interesting item here. Notice the funny Ev('D') construct in the Win32 callback. This is the Perl/Tk way of postponing argument evaluation until the callback is executed. Here, it's the D field (MouseWheel delta) from the event structure. Equivalently, we could omit the Ev call and use the Tk::event object to manually fetch the mousewheel delta within the callback:

my $delta = $Tk::event->D;

where $delta corresponds to $_[1] in the callback.

Ev is even more sophisticated. You can pass it yet another Perl/Tk callback that doesn't get evaluated until the main event callback is executed. And Ev is recursive, so an Ev call can contain other Ev calls.

Canvas Bindings

Some final notes. A Canvas widget has its own bind method that binds callbacks to individual Canvas items rather than the Canvas as a whole. Unsurprisingly, the syntax parallels the normal bind:

$canvas->bind(tagorid, event_descriptor => callback);

where tagorid identifies the particular Canvas item. To create a binding for the Canvas instance, we use this special method:

$canvas->CanvasBind(event_descriptor => callback);

If CanvasBind isn't available with your version of Perl/Tk, you can always fall back to the old syntax:

$canvas->Tk::bind(event_descriptor => callback);

The bindtags Command

So, we know that a Button has a predefined binding for a <ButtonRelease-1> event. What do you suppose will happen if we make an instance binding to <ButtonRelease-1> as well? Which callback gets invoked, the class or the instance? Or are both invoked? If both callbacks are invoked, in what order do they occur?

Both callbacks are invoked: first the class, then the instance. To understand why, we need to study the bindtags command. Whenever a binding is created, it is always associated with an identifying tag. Thus far, each of our Button binding examples has used two tags, a class name and a widget instance, which represent the Button's class tag and the instance tag, respectively. Except for Toplevels, every widget has two additional binding tags: the widget's Toplevel window and the global string all. Toplevels are their own instances, so they have only three binding tags.

When an event occurs, it's compared against all the event descriptors for every tag that a widget owns, and if the event matches one of the tag's list of event descriptors, the associated callback is executed. The search continues through the bindtags list until all the tags have been examined and every possible callback executed.

A widget's bindtags list is ordered. It is always searched from left to right (starting at array index 0). The bindtags command queries, adds, deletes, or rearranges a widget's binding tags list.

Let's do a bindtags query command on our $twice button from the previous section:

my $twice = $mw->Button(qw/-text Beep -command/ =>  sub {$mw->bell});
$twice->pack;
$twice->bind('<ButtonRelease-1>' => \&twice);
 
my (@bindtags) = $twice->bindtags;
print "\$twice's bindtags:\n\n", join("\n", @bindtags), "\n";
Which yields:
$twice's bindtags:
 
Tk::Button
.button
.
all

Ignoring the fact that the $twice instance tag is represented by the string ".button", and the Toplevel tag by the string ".", a vestige of Perl/Tk's Tcl origins, the tag list order is class, instance, Toplevel, all.

As an aside, these string names are internal widget identifiers that you should never intentionally use; always use the real Perl/Tk reference. They are actually Tcl/Tk pathnames and are created by Perl/Tk when a widget is instantiated. "." Is the Tcl/Tk name for the MainWindow and .frame2.text.radiobutton10 is the name of a Radiobutton deep inside the widget hierarchy. The PathName method shows a widget's internal pathname.

Now let's iterate through the binding tags and print the event descriptors for each tag:

print "\nHere are \$twice's binding tags, and each tag's bindings:\n\n";
foreach my $tag ($twice->bindtags) {
    print "  bindtag tag '$tag' has these bindings:\n";
    print "    ", $twice->bind($tag), "\n";
}
print "\n";

Here's the output:

Here are $twice's binding tags, and each tag's bindings:
 
  bindtag tag 'Tk::Button' has these bindings:
    <Key-Return><Key-space><ButtonRelease-1><Button-1><Leave><Enter>
  bindtag tag '.button' has these bindings:
    <ButtonRelease-1>
  bindtag tag '.' has these bindings:
    
  bindtag tag 'all' has these bindings:
    <Key-F10><Alt-Key><<LeftTab>><Key-Tab>
  

Now we can see exactly what happens when a button 1 release event occurs. First the class binding is executed, and we hear a beep. Perl/Tk then looks at the next tag in the binding tag list, finds a matching event descriptor, and executes its callback, which beeps the bell twice. The search continues through the Toplevel and all bindings, but no other matching event descriptor is found.

How Might We Use bindtags?

One way to use bindtags is to completely remove every binding tag belonging to a widget. If you want a "view only" Text widget that displays some fancy instructions but can't be modified by the user, remove all binding tags and render the widget inert.

my $mw = MainWindow->new;
my $b = $mw->Button(qw/-text Quit -command/ => \&exit)->grid;
my $t = $mw->Text->grid;
$t->insert(qw/end HelloWorld/);
$t->bindtags(undef);

A second use allows us to override a class binding for a widget instance. The idiom is to create the instance binding, reorder the widget's bindtags list, placing the instance tag before the class tag, then use break in the instance callback to short-circuit the bindtags search so the class callback can never be invoked.

In the following example, pretend we want to override the <Enter> binding for one Button instance only. When the cursor moves over that oddball Button, the bell sounds rather than the background color changing.

We also show how to override a binding for an entire class. The idiom is to derive a subclass that establishes the new bindings in ClassInit. Refer to Chapter 14 for mega-widget details.

This is how it's done:

package MyButton;

MyButton is a subclass of the standard Button widget. A MyButton behaves just like a normal Button except that it prints a message when the cursor moves over it instead of changing color. ClassInit first establishes normal Button bindings and then overrides the <Enter> event descriptor.

If there is no SUPER::ClassInit call, MyButton widgets would have no default behavior at all.

use base qw/Tk::Button/;
Construct Tk::Widget 'MyButton';
 
sub ClassInit {
    my ($class, $mw) = @_;
    $class->SUPER::ClassInit($mw);
    $mw->bind($class, '<Enter>', sub{print "Entered a MyButton\n"});
}

Make a Button and a MyButton:

package main;
 
my $mw = MainWindow->new;
$mw->Button(-text => 'NormalButton')->pack;
$mw->MyButton(-text => 'MyButton')->pack;

Although MyButton has overridden <Enter> on a class-wide basis, both Button and MyButton widgets have the same bindtags order: class, instance, Toplevel, all.

Now create a Button, $swap, and print its bindtags list to prove that, by default, the order remains class, instance, Toplevel, all.

my $swap = $mw->Button(-text => 'SwapButton')->pack;
my (@swap_bindtags) = $swap->bindtags;
print "\$swap's original bindtags list is : @swap_bindtags\n";

Reorder $swap's bindtags by swapping the class and instance order, yielding instance, class, Toplevel, all. bindtags expects a reference to an array of tags, which we provide after slicing the original array.

$swap->bindtags( [ @swap_bindtags[1, 0, 2, 3] ] );
@swap_bindtags = $swap->bindtags;
print "\$swap's new      bindtags list is : @swap_bindtags\n";

Override <Enter> for the instance $swap only. Now, when the cursor enters $swap, first the instance callback is executed, then break halts further searching of the bindtags list. $_[0] is $swap, the implicit callback argument provided by Perl/Tk.

$swap->bind('<Enter>' => sub {
    $_[0]->bell;
    $_[0]->break;
});
 
MainLoop;

In summary, to alter class bindings for many widgets, it's best to subclass them. For a single instance, break with a reordered bindtags list might be easiest.

This is why the bindtags order differs from Tcl/Tk's order of instance, class, Toplevel, all. Under object-oriented Perl/Tk, we are expected to use subclassing.

bindDump--Dump Lots of Binding Information

bindtags, in conjunction with bind, is a powerful debugging tool, since it can display tons of useful widget binding data. We've encapsulated it into a module that exports one symbol: the subroutine bindDump. Here's what it has to say about our $twice Button widget. For this example, we're using the "fake method" binding syntax:

my $twice = $mw->Button(qw/-text Beep -command/ =>  sub {$mw->bell});
$twice->bind('<ButtonRelease-2>' => __PACKAGE_  _ . '::twice');
&bindDump($twice);

The bindDump output follows. For each binding tag, it lists the event descriptor, the event descriptor's callback, plus all the callback arguments. Notice that without exception, the callback is a method name and not a code reference.

bindDump also lists the arguments passed to the callback, expanding Ev calls. Notice that the all tag's <Alt-Key> event uses Ev('K'), the event's keysym. The all binding tag affects menu and focus traversal.

## Binding information for '.button', Tk::Button=HASH(0x81803f0) ##
 
1. Binding tag 'Tk::Button' has these bindings:
                  <Key-Return> : Tk::Callback=SCALAR(0x818024c)
                                   'Invoke'
                   <Key-space> : Tk::Callback=SCALAR(0x8180234)
                                   'Invoke'
             <ButtonRelease-1> : Tk::Callback=SCALAR(0x818021c)
                                   'butUp'
                    <Button-1> : Tk::Callback=SCALAR(0x8180204)
                                   'butDown'
                       <Leave> : Tk::Callback=SCALAR(0x81801d4)
                                   'Leave'
                       <Enter> : Tk::Callback=SCALAR(0x81801e0)
                                   'Enter'
 
2. Binding tag '.button' has these bindings:
             <ButtonRelease-2> : Tk::Callback=ARRAY(0x81808d0)
                                   'main::twice'
 
3. Binding tag '.' has no bindings.
 
4. Binding tag 'all' has these bindings:
                     <Key-F10> : Tk::Callback=SCALAR(0x82910a8)
                                   'FirstMenu'
                     <Alt-Key> : Tk::Callback=ARRAY(0x829103c)
                                   'TraverseToMenu'
                                     Tk::Ev=SCALAR(0x8164f3c)      : 'K'
                   <<LeftTab>> : Tk::Callback=SCALAR(0x829100c)
                                   'focusPrev'
                     <Key-Tab> : Tk::Callback=SCALAR(0x8290f10)
                                   'focusNext'

You should try bindDump on a Text widget; there's information there that will be quite surprising.

The actual bindDump.pm file isn't particularly pretty, but it illustrates an Exporter module with POD documentation. In any case, with reservations, here it is:

$Tk::bindDump::VERSION = '1.0';
 
package Tk::bindDump;
 
use Exporter;
 
use base qw/Exporter/;
@EXPORT = qw/bindDump/;
use strict;
 
sub bindDump {
 
     # Dump lots of good binding information.  This pretty-print
     #  subroutine is, essentially, the following code in disguise:
     #
     # print "Binding information for $w\n";
     # foreach my $tag ($w->bindtags) {
     #     printf "\n Binding tag '$tag' has these bindings:\n";
     #     foreach my $binding ($w->bind($tag)) {
     #         printf "  $binding\n";
     #     }
     # }
 
     my ($w) = @_;
 
     my (@bindtags) = $w->bindtags;
     my $digits = length( scalar @bindtags );
     my ($spc1, $spc2) = ($digits + 33, $digits + 35);
     my $format1 = "%${digits}d.";
     my $format2 = ' ' x ($digits + 2);
     my $n = 0;
 
     print "\n## Binding information for '", $w->PathName, "', $w ##\n";
 
     foreach my $tag (@bindtags) {
         my (@bindings) = $w->bind($tag);
         $n++;                   # count this bindtag
 
         if ($#bindings == -1) {
             printf "\n$format1 Binding tag '$tag' has no bindings.\n", $n;
         } else {
             printf "\n$format1 Binding tag '$tag' has these bindings:\n", $n;
 
             foreach my $binding ( @bindings ) {
                 my $callback = $w->bind($tag, $binding);
                 printf "$format2%27s : %-40s\n", $binding, $callback;
 
                 if ($callback =~ /SCALAR/) {
                     if (ref $$callback) {
                         printf "%s %s\n", ' ' x $spc1, $$callback;
                     } else {
                         printf "%s '%s'\n", ' ' x $spc1, $$callback;
                     }
                 } elsif ($callback =~ /ARRAY/) {
                     if (ref $callback->[0]) {
                         printf "%s %s\n", ' ' x $spc1, $callback->[0], "\n";
                     } else {
                         printf "%s '%s'\n", ' ' x $spc1, $callback->[0], "\n";
                     }
                     foreach my $arg (@$callback[1 .. $#{@$callback}]) {
                         if (ref $arg) {
                             printf "%s %-40s", ' ' x $spc2, $arg;
                         } else {
                             printf "%s '%s'", ' ' x $spc2, $arg;
                         }
 
                         if (ref $arg eq 'Tk::Ev') {
                             if ($arg =~ /SCALAR/) {
                                 print ": '$$arg'";
                             } else {
                                 print ": '", join("' '", @$arg), "'";
                             }
                         }
 
                         print "\n";
                     } # forend callback arguments
                 } # ifend callback
 
             } # forend all bindings for one tag
 
         } # ifend have bindings
 
     } # forend all tags
     print "\n";
 
} # end bindDump
 
1;
__END__
 
=head1 NAME
 
Tk::bindDump - dump detailed binding information for a widget.
 
=head1 SYNOPSIS
 
  use Tk::bindDump;
 
  $splash->bindDump;
 
=head1 DESCRIPTION
 
This subroutine prints a widget's bindtags.  For each binding tag it
prints all the bindings, comprised of the event descriptor and the
callback.  Callback arguments are printed, and Tk::Ev objects are
expanded.
 
=head1 COPYRIGHT
 
Copyright (C) 2000 - 2001 Stephen O. Lidie. All rights reserved.
 
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

Executing Nonblocking System Commands

One of the most common requests seen on the comp.lang.perl.tk newsgroup is how to execute a system command and display its output in a Text widget. The typical response is some variation of tktail, which uses fileevent to signal that output data is available without blocking the application.

Here's the program:

open(H, "tail -f -n 25 $ARGV[0]|") or die "Nope: $!";
 
my $t = $mw->Text(-width => 80, -height => 25, -wrap => 'none');
$t->pack(-expand => 1);
$mw->fileevent(\*H, 'readable', [\&fill_text_widget, $t]);
MainLoop;
 
sub fill_text_widget {
 
    my($widget) = @_;
 
    $_ = <H>;
    $widget->insert('end', $_);
    $widget->yview('end');
 
}

The standard way to keep Perl/Tk programs from blocking is to use multiple processes. Here we use Perl's open function to create a separate process that sends its output to a pipe. fileevent then defines a callback that gets invoked whenever the file handle H has data available to read. The callback appends one line to the Text widget and uses yview to ensure that we always see the end of the file.

There's a problem here. The statement $_ = <H> expects to read an entire line, one that's newline terminated. If only a partial line were available, the read would block, and so would tktail. To be rigorous, we should use sysread for our I/O, which handles partial lines:

sub fill_text_widget {
 
    my($widget) = @_;
 
    my($stat, $data);
    $stat = sysread H, $data, 4096;
    die "sysread error:  $!" unless defined $stat;
    $widget->insert('end', $data);
    $widget->yview('end');
 
}

Later we take this simple example and turn it into a first-class mega-widget that's more powerful and flexible.

fileevent Syntax

The syntax for fileevent is as follows:

$mw->fileevent(handle, operation => callback);

handle is a Perl file handle, which may be a reference to a glob (\*STDIN), the return value from IO::Handle, etc.

operation may be readable or writable.

callback is a standard callback or the empty string "". The callback is invoked when the file is readable/writable. If callback is the empty string, the callback is canceled.

Please refer to Chapter 19 for more information on fileevent.

Tk::ExecuteCommand

Tk::ExecuteCommand runs a command yet still allows Tk events to flow. All command output and errors are displayed in a window. This ExecuteCommand mega-widget is composed of a LabEntry widget for command entry, a "Do It" Button that initiates command execution, and a ROText widget that collects command execution output. While the command is executing, the "Do It" Button changes to a "Cancel" Button that can prematurely kill the executing command.

We start with a typical Frame-based mega-widget prologue, fully detailed in Chapter 14. As with the previous example, it depends on fileevent to keep the application from blocking.

$Tk::ExecuteCommand::VERSION = '1.1';
 
package Tk::ExecuteCommand;
 
use IO::Handle;
use Proc::Killfam;
use Tk::widgets qw/ROText/;
use base qw/Tk::Frame/;
use strict;
 
Construct Tk::Widget 'ExecuteCommand';

The Populate subroutine in the next example defines the widget pictured in Figure 15-1. Type the command (or commands) to execute in the Entry widget and start it running by clicking the "Do It" Button. Once pressed, "Do It" changes to "Cancel." The subroutine _reset_doit_button ensures that the Button is properly configured to begin command execution. The leading underscore in the method name indicates a private method, one that the widget's users should not call. The OnDestroy call ensures that any running command is terminated when the widget goes away.

Figure 15-1. Tk::ExecuteCommand in action

The instance variable $self->{-finish} is true when it's time to kill the command. It can be set either by clicking the "Cancel" button or when the fileevent handler has sensed end-of-file. The widget's -command option is stored in another instance variable, $self->{-command}.

sub Populate {
 
    my($self, $args) = @_;
 
    $self->SUPER::Populate($args);
 
    my $f1 = $self->Frame->pack;
    $f1->LabEntry(
        -label => 'Command to Execute',
        -labelPack => [qw/-side left/],
        -textvariable => \$self->{-command},
    )->pack(qw/-side left/);
 
    my $doit = $f1->Button(-text => 'Do It!')->pack(qw/-side left/);
    $self->Advertise('doit' => $doit);
    $self->_reset_doit_button;
 
    $self->Frame->pack(qw/pady 10/);
    $self->Label(-text => 'Command\'s stdout and stderr')->pack;
 
    my $text = $self->Scrolled('ROText', -wrap => 'none');
    $text->pack(qw/-expand 1 -fill both/); 
    $self->Advertise('text' => $text);
    $self->OnDestroy([$self => 'kill_command']);
 
    $self->{-finish} = 0;
 
    $self->ConfigSpecs(
        -command => [qw/METHOD command Command/, 'sleep 5; pwd'],
    );
 
} # end Populate
 
sub command {
 
    my($self, $command) = @_;
    $self->{-command} = $command;
 
} # end command

When the "Do It" Button is pressed, it begins flashing and continues to do so until the command has completed or is canceled. We use a Tcl/Tk idiom of rescheduling a timer callback that alternates the Button's background color. The first time through, the Button's background color is $val1, but the subsequent after callback reverses the colors so that $interval milliseconds later, the background changes to $val2. When the command finishes, no further timer callbacks are queued, and the flashing ceases.

sub _flash_doit {
 
    # Flash "Do It" by alternating its background color.
 
    my($self, $option, $val1, $val2, $interval) = @_;
 
    if ($self->{-finish} == 0) {
         $self->Subwidget('doit')->configure($option => $val1);
         $self->idletasks;
         $self->after($interval, [\&_flash_doit, $self, $option, $val2,
         $val1, $interval]);
    }
 
} # end _flash_doit

Here's a private method that reads command output and inserts it into the Text widget. It calls kill_command to perform cleanup operations when the command completes or the user clicks on the "Cancel" Button.

sub _read_stdout {
 
    # Called when input is available for the output window.
    # Also checks to see if the user has clicked Cancel.
 
    my($self) = @_;
 
    if ($self->{-finish}) {
			$self->kill_command;
    } else {
			my $h = $self->{-handle};
			if ( sysread $h, $_, 4096 ) {
			    my $t = $self->Subwidget('text');
			    $t->insert('end', $_);
			    $t->yview('end');
			} else {
			    $self->{-finish} = 1;
			}
    }
			
} # end _read_stdout

The private method _reset_doit_button ensures that the "Do It" button is properly configured to start a new command. Besides setting the Button's text and appearance, it also configures the callback so that, once pressed, the Button is disabled (preventing a possible race condition), and command execution begins.

Notice it's not sufficient to use cget to fetch the background color, because the Button may have been flashing by alternating its background color. The only sure-fire way is to use configure and fetch the original default color from the configuration specifications. All Tk options are described by a five element array containing the option name, resource database name, class name, default value, and current value. The "Do It" Button's specifications might look like this:

-background background Background #d9d9d9 cyan
 
sub _reset_doit_button {
 
    # Establish normal "Do It" button parameters.
 
    my($self) = @_;
 
    my $doit = $self->Subwidget('doit');
    my $doit_bg = ($doit->configure(-background))[3];
 
    $doit->configure(
        -text       => 'Do It',
        -relief     => 'raised',
        -background => $doit_bg,
        -state      => 'normal',
        -command    => [sub {
            my($self) = @_;
            $self->{-finish} = 0;
            $self->Subwidget('doit')->configure(
                -text   => 'Working ...',
                -relief => 'sunken',
                -state  => 'disabled'
            );
            $self->execute_command;
        }, $self],
    );
 
} # end _reset_doit_button

Here are all the public methods. execute_command creates a new file handle and stores it in an instance variable. Then it uses a pipe-open to execute the command, redirecting STDERR to STDOUT. If the open fails, the error is posted in the Text widget. The file handle is unbuffered, so data can be read as quickly as possible, and the readable fileevent is created. The "Do It" button is reconfigured into the "Cancel" button, and we start it flashing.

sub execute_command {
 
    # Execute the command and capture stdout/stderr.
 
    my($self) = @_;
    
    my $h = IO::Handle->new;
    die "IO::Handle->new failed." unless defined $h;
    $self->{-handle} = $h;
 
    $self->{-pid} = open $h, $self->{-command} . ' 2>&1 |';
    if (not defined $self->{-pid}) {
			$self->Subwidget('text')->insert('end',
                 "'" . $self->{-command} . "' : $!\n");
			$self->kill_command;
			return;
    }
    $h->autoflush(1);
    $self->fileevent($h, 'readable' => [\&_read_stdout, $self]);
 
    my $doit = $self->Subwidget('doit');
    $doit->configure(
        -text    => 'Cancel',
        -relief  => 'raised',
        -state   => 'normal',
        -command => [\&kill_command, $self],
    );
 
    my $doit_bg = ($doit->configure(-background))[3];
    $self->_flash_doit(-background => $doit_bg, qw/cyan 500/);
    
} # end execute_command

kill_command sets the finish flag so that the flash and fileevent handlers know to quit. It releases resources by clearing the fileevent handler, killing the command and all its children, and closing the file handle. Then it resets "Do It."

The killfam command is an extension to the CPAN module Proc::ProcessTable. It accepts the same arguments as the Perl built-in kill command, but recursively kills subchildren. For the code, as well as the POD for this module, see Appendix C.

sub kill_command {
    
    # A click on the blinking Cancel button resumes normal operations.
 
    my($self) = @_;
 
    $self->{-finish} = 1;
    my $h = $self->{-handle};
    return unless defined $h;
    $self->fileevent($h, 'readable' => ''); # clear handler
    killfam 'TERM', $self->{-pid} if defined $self->{-pid};
    close $h;
    $self->_reset_doit_button;
 
} # end kill_command
 
1;

An MPG Player--tkmpg123

Using fileevent, the mpg123 library, and its Perl interface, Audio::Play::MPG123, we can write a Tk program to play our favorite tunes. Audio::Play::MPG123 sports an object-oriented syntax and methods that load, play, and pause a song.

Besides playing the music, our program needs a user interface. In this case, we've become extremely lazy and taken the skin from Apple's iTunes application and used it as a basis for our own. Briefly, we took a screenshot of the original application, shown in Figure 15-2, and placed that over the entire area of a Canvas. Then widgets and images were overlaid at key hot spots, which we bound to actions. For instance, the play and pause buttons are actually tiny images, which are selectively placed over the original play/pause button (see Figure 15-3).

The images, of course, we excised from iTunes while it was running.

Figure 15-2. Apple's iTunes Player

As for the remainder of the interface, we've essentially ignored it, preferring to concentrate on listening to tunes instead. For instance, instead of an oval display and status window, we use a simple Frame. Instead of a multicolumn play list, we use a Scrolled Listbox. The complete program listing appears in Appendix C.

Figure 15-3. Play and pause images

We start by creating an Audio::Play::MPG123 instance, $player, and retrieving the player's input file handle, $phand, which we'll tie to a fileevent handler. The mpg123 library has its own event loop, and when $phand is readable, we must empty the mpg123 event queue in order to keep the music playing.

$player = Audio::Play::MPG123->new;
$phand = $player->IN;

Here we create the Canvas, overlay the iTunes skin, and configure the Canvas' width and height to match the dimensions of the skin. See Chapter 17 for details on images.

    $c = $mw->Canvas(
        -width  => 1,
        -height => 1,
        -background => 'dark slate gray',
    )->pack;
    my $itunes = $c->Photo(-file => 'images/itunes.gif');
    $c->createImage(0, 0,
        -image => $itunes,
        -tag   => 'itunes',
        -anchor => 'nw',
    );
    $c->configure(-width => $itunes->width, -height => $itunes->height);

Overlay the play button image on top of the static background button and tag it with the string 'play-image'. Create a Canvas item button-1 binding that invokes the pause subroutine. Subroutine pause toggles the player's pause state, as well as the play/pause image.

    $paus = $c->Photo(-file => 'images/paus.gif');
    $play = $c->Photo(-file => 'images/play.gif');
 
    $c->createImage(80, 40, -image => $play, -tag => 'play-image');
    $c->bind('play-image', '<1>' => \&pause);

Every song has optional data associated with it, such as the title, artist, and album. We can display this data in a simple Label widget, using a timer event to rotate through the information list and update the Label's -textvariable, $infov.

Similarly, we use another Label to display the song's elapsed and total playing time, in minutes and seconds.

    $infov = '';
    my $info = $f->Label(
        -textvariable => \$infov,
        -font         => $font,
        -background   => $green,
    );
    $info->pack(-side => 'top');
 
    $timev = 'Elapsed Time: 0:00';
    my $time = $f->Label(
        -textvariable => \$timev,
        -font         => $font,
        -background   => $green,
    );
    $time->pack(-side => 'top');

Create the Listbox and populate it with songs from the current directory. The button bindings says call subroutine play with the name of the song under the cursor as its one argument.

my $mpgs = $f2->Scrolled('Listbox')->pack(-fill => 'y', -expand => 1);
foreach my $mpg (<*.mpg>, <*.mp3>) {
    $mpgs->insert('end', $mpg);
}
$mpgs->bind('<1>' => sub {play $mpgs->get( $mpgs->nearest($Tk::event->y) )});

When the play/pause button image is clicked, subroutine pause is called. It first toggles the player's state, pausing it if it was playing or resuming play if it was paused. Then the play/pause image is updated appropriately.

sub pause {
    $player->pause;
    $c->itemconfigure('play-image',
        -image => ($player->state == 1) ? $paus : $play
    );
}

We get here after a button click on a song name, where we load the song and start it playing. @info holds the title, artist, and album data (any of which may be undef).

sub play {
    my $song = shift;
    if (defined $song) {
        $player->load($song);
        @info = map {$player->$_} qw/title artist album/;
        start_play;
    }
}

Subroutine start_play does three things:

• Creates a timer event to display each song's title, artist, and album over and over again
• Creates another timer event that updates the song's elapsed playing time
• Creates a fileevent read handler to empty mpg123's event queue

The code for start_play is:

sub start_play {
 
    my $info_tid = $mw->repeat(5000 => sub {
	$infov = $info[0];
	 unshift @info, pop @info;
    });
 
    my $time_tid = $mw->repeat(1000 => sub {
        my(@toks) = split ' ', $player->stat;
        $timev = sprintf( "Elapsed Time: %s of %s\n",
            &ctm($toks[3]), &ctm($toks[3] + $toks[4]) );
    });

At last, the heart of Tkmpg123, a single fileevent call pointing to an anonymous, readable subroutine. The subroutine calls poll in nonblocking mode (with 0 as its argument) to empty the mpg123 event queue, then update to empty Tk's event queue. This sequence repeats until the state method reports zero, meaning the song has ended. The stop method unloads the song, the fileevent is cleared, and the two timers are canceled.

    my $in_hand = sub {
	$player->poll(0);
	$mw->update;
	if ($player->state == 0) {
	    $player->stop;
	    $mw->fileevent(\$phand, 'readable' => '');
	    $mw->afterCancel($info_tid);
	    $mw->afterCancel($time_tid);
	}
    };
    $mw->fileevent(\$phand, 'readable' => $in_hand);
 
}

Figure 15-4 shows the tkmpg123 program in action.

Figure 15-4. tkmpg123 playing a tune

Tracing Perl/Tk Variables

This is something of an oddball topic for this Anatomy lesson, but it introduces background information we'll use later. Plus, it lets us do some neat things.

The Perl way to trace (or set watchpoints upon) a variable is by using the built-in tie function or the CPAN module Tie::Watch. Tcl has three commands associated with variable tracing: trace variable, trace vdelete, and trace vinfo. We'll examine sample code that uses three similar Perl subroutines, then briefly illustrate how our new Trace module is implemented.

First we need to define three new commands, the analogs of the Tcl/Tk Trace commands. They are traceVariable (start tracing a variable), traceVinfo (show trace information), and traceVdelete (stop tracing a variable). Using these commands, we can write a program that animates an analog dial via a Scale widget (see Figure 15-5).

Figure 15-5. Animating a meter

The dial is actually a fat Canvas line item with an arrow on one end. The Scale goes from 0 to 100, with the dial pointing straight up when it reads 50. The Scale's value is updated in the variable $v.

my $c = $mw->Canvas(qw/-width 200 -height 110 -bd 2 -relief sunken/)->grid;
$c->createLine(qw/ 100 100 10 100  -tag meter -arrow last -width 5/);
my $s = $mw->Scale(qw/-orient h -from 0 -to 100 -variable/ => \my $v)->grid;
$mw->Label(-text => 'Slide Me for > 5 Seconds')->grid;

The idea is to define a callback that's invoked whenever the Scale's variable $v changes value. The callback then redraws the dial appropriately. traceVariable expects three arguments: a reference to the traced variable; a letter from the set rwu that selects read, write, or undef (destroy) operations; and a standard Perl/Tk callback.

Here we call update_meter whenever $v is written.

$mw->traceVariable(\$v, 'w' => [\&update_meter, $c, $s]);

This code demonstrates the other Trace commands. After five seconds, we display trace information, then delete the trace. Once the trace is cleared, the dial stops moving. (This explains why the Scale's value does not correspond to the dial position in Figure 15-5.)

$mw->after(5000 => sub {
    print "Untrace time ...\n";
    my %vinfo = $s->traceVinfo(\$v);
    print "Watch info  :\n  ", join("\n  ", @{$vinfo{-legible}}), "\n";
    $c->traceVdelete(\$v);
});
 
MainLoop;

Here's the output from traceVinfo. It shows the variable being traced, two internal flags, the variable's value, and the three callbacks associated with the u (undef), r (read), and w (write) operations. Trace supplies default callbacks for any that we don't provide.

Untrace time ...
Watch info  :
  variable  : SCALAR(0x82a5178)
  debug     : '0'
  shadow    : '1'
  value     : '56'
  destroy   : ARRAY(0x82fd14c)
  fetch     : ARRAY(0x82fd224)
  store     : ARRAY(0x82fd110)

update_meter, as with any Trace callback, is invoked with three automatically provided arguments:

$_[0]        = undef for a scalar, index/key for array/hash
$_[1]        = variable's current (read), new (write), final (undef) value
$_[2]        = operation (r, w, or u)
$_[3 .. $#_] = optional user callback arguments

In our case, the fourth and fifth arguments are the Canvas and Scale widget references, respectively.

A Trace callback is responsible for returning the traced variable's new value, so you can choose to keep the proper value or change it. Our callback just needs to peek at the value to adjust the dial, so it keeps the value unchanged. The callback first checks the operation code and returns if the variable is being destroyed. Otherwise, it computes the dial's new position and redraws it.

sub update_meter {
    my($index, $value, $op, @args) = @_;
    return if $op eq 'u';
    my($c, $s) = @args[0,1];    # Canvas and Scale widgets
    my($min, $max) = ($s->cget(-from), $s->cget(-to));
    my $pos = $value / abs($max - $min);
    my $x = 100.0 - 90.0 * (cos( $pos * PI ));
    my $y = 100.0 - 90.0 * (sin( $pos * PI ));
    $c->coords(qw/meter 100 100/, $x, $y);
    return $value;
}

The Trace module is not a mega-widget. It's a plain old Exporter module, and a tad complicated at that. For the complete listing, see Appendix C. Trace is a wrapper around Tie::Watch, giving us a super-simple interface, at the expense of some loss of functionality. Let's see what Tie::Watch gives us, since we'll be using it in the future.

Tie::Watch

Tie::Watch is an object-oriented interface to Perl's built-in tie function, which lets us define a variable's implementation. The implementation is carried out using subroutines of our own devising that are invoked as the variable is operated upon. For a Perl scalar, there are only three operations: fetch, store, and destroy. Here's how to watch a scalar:

$watch = Tie::Watch->new(
    -variable => \$v,
    -fetch    => [\&fetch, 'arg1', 'arg2', ..., 'argn'],
    -store    => \&store,
    -destroy  => sub {print "Final value=$v.\n"},
}

The only required argument is -variable. We can provide behavior for any or all of the operations, or none at all. fetch and store callbacks look like this:

sub fetch{
    my($self) = @_;
    $self->Fetch;
};
 
sub store {
    my($self, $new_val) = @_;
    $self->Store($new_val);
};

These callbacks return the variable's new value by calling the underlying tie method. If you really want to confuse someone, make the traced variable read-only with this store callback:

sub store {
    my($self, $new_val) = @_;
    $self->Store($self->Fetch);
};

Tie::Watch can also watch arrays and hashes, but watching scalars is sufficient for our current needs.

Nonblocking Wait Activities

Perl/Tk provides three commands that wait for particular events to occur. Although the wait is nonblocking (Tk events continue to be processed), program flow is logically suspended at the wait point only until the appropriate event occurs. The commands are:

$widget->waitVariable(varRef)

Waits until the variable referenced by varRef changes (i.e., it is written or undef).

$widget->waitVisibility

Waits until $widget's visibility state changes. The most common use for this command is to wait for a window to appear on the display. (Event type = Visibility.)

$widget->waitWindow

Waits until $widget is destroyed. (Event type = Destroy.)

waitVariable can be employed in a number of ingenious situations. In Chapter 23, we use it as a means of effecting interprocess communications. But perhaps the most common is waiting for a user response to, say, a Dialog widget. A Dialog posts a message and one or more Buttons, then waits for the user to make a selection by clicking a Button. The specified Button label text is then stored in the variable that waitVariable is watching, and logical program flow continues.

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.

We'll call this new command waitVariableX. The scheme is sublimely simple and clever. Our new command employs waitVariable to wait for a single scalar to change value. That scalar is set either by a timer callback or a Store callback invoked by watchpoints placed on the list of variables. Furthermore, waitVariableX tells us why it completed, by returning zero if the timer expired or a reference to the variable that changed.

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:

• The list of variables is optional. If omitted and milliseconds is greater than 0, the command behaves much like after.
• If a variable list is specified but the millisecond timer is zero, the command behaves much like waitVariable.
• If the variable list is omitted and the millisecond timer is zero, the command waits forever. Hmm, perhaps we should disallow this possibility!

Splash Screens

Splash screens are those windows that pop up for the amusement of the user while a long-loading program gets underway. Some folks display their splash screens during program initialization sequentially, so that if a splash screen stays on the display for three seconds, the program takes three seconds longer to load. We, however, prefer that our splash screens run in parallel with program initialization. One approach might be:

1. Create a Toplevel splash screen.
2. Queue a timer event to set a variable after X seconds.
3. Initialize program.
4. Wait for splash timer to expire with waitVariable.
5. Destroy splash screen and enter MainLoop.

There's a problem with this scheme: if initialization takes too long and the splash timer expires, the waitVariable will hang. This can also happen if the splash delay is set too small. We could use waitVariableX with a timeout, resulting in code that might look like this:

    my $mw = MainWindow->new;
    $mw->withdraw;
 
    my ($splash_scr, $splash_tid, $splash_var) = splash 3000;
 
    # - program initialization.
 
    my $why = $mw->&waitVariableX(3000, $splash_var);
    $splash_scr->afterCancel($splash_tid);
    $splash_scr->destroy;
 
    $mw->deiconify;

But this just doesn't feel right. First, having the splash screen remain on the screen for X seconds one time, and X+3 seconds at others, is an unsatisfactory hack. Second, too much of the work is left to the application. We need to encapsulate things in a mega-widget. Besides, there are some subtle details, as we are about to see.

Tk::Splashscreen

We've just written tkhp16c, our version of the venerable RPN programming calculator, shown in Figure 15-6. As Tk programs go, this application loads slowly, because it's composed of so many widgets. So we'll incorporate a splash screen.

Figure 15-6. An HP-16C RPN calculator

Tk::Splashscreen is a Toplevel mega-widget providing all the display, destroy, and timing events. All we do is create the Splashscreen widget, populate it, then invoke Splash to display it and Destroy to tear it down. The plan for our splash screen is that it contain a progress bar; we'll be sure to sprinkle update calls throughout our initialization code so that any Splashscreen events are handled.

Here's the mega-widget preamble. If it's unfamiliar, please read Chapter 14 for complete details. Note that for this mega-widget, we import the DoOneEvent bit patterns.

$Tk::Splashscreen::VERSION = '1.0';
 
package Tk::Splashscreen;
 
use Tk qw/Ev/;
use Tk qw/:eventtypes/;
use Tk::waitVariableX;
use Tk::widgets qw/Toplevel/;
use base qw/Tk::Toplevel/;
 
Construct Tk::Widget 'Splashscreen';

Subroutine Populate immediately removes the empty Toplevel from the display so tkhp16c can fill it at its leisure. Then overrideredirect removes the window manager decorations. Of course, with the decorations gone, the Toplevel can't be moved around by normal means, so we'll have to create our own movement bindings. The widget uses mouse button 3 for this purpose and keeps state information in the instance variables $self->{ofx} and $self->{ofy}, the x and y pixel offsets from the Splashscreen's top-left corner to the cursor at the time the button is pressed.

The two button bindings use the special format where we explicitly state the object to use, $self rather than letting Tk supply us one indirectly. This forces Tk to look up the methods b3prs and b3rls in the package Tk::Splashscreen, which is where they are located. Otherwise, if for instance the Splashscreen contained a Label and we clicked on it, Tk would try to invoke Tk::Label::b3prs, and that would fail. We also use the Ev subroutine to pass event data to the callback.

Lastly, instance variable $self->{tm0} stores the time the Splashscreen is first shown.

sub Populate {
    my ($self, $args) = @_;
 
    $self->withdraw;
    $self->overrideredirect(1);
 
    $self->SUPER::Populate($args);
 
    $self->{ofx} = 0;   # X offset from top-left corner to cursor
    $self->{ofy} = 0;   # Y offset from top-left corner to cursor
    $self->{tm0} = 0;   # microseconds time widget was Shown
 
    $self->ConfigSpecs(
        -milliseconds => [qw/PASSIVE milliseconds Milliseconds 0/],
    );
 
    $self->bind('<ButtonPress-3>'   => [$self => 'b3prs', Ev('x'), Ev('y')]);
    $self->bind('<ButtonRelease-3>' => [$self => 'b3rls', Ev('X'), Ev('Y')]);
 
} # end Populate

At this point, we have an empty Splashscreen widget. Before we show it, let's put something inside. We'll keep it simple, with a MacProgressBar and a picture of an actual HP-16C calculator, as shown in Figure 15-7.

A MacProgressBar widget has a 3D look, exactly like the classic Macintosh progress bar. We won't examine the code here, but it's listed in Appendix C. It's a versatile widget. Here's a pseudo-volume meter:

$pb = $mw->MacProgressBar(-width => 150, -bg => 'cyan')->pack;
 
while (1) {
    my $w = rand(100);
    $pb->set($w);
    $mw->update;
    $mw->after(250);
} 

Figure 15-7. tkhp16c initialization is 90% complete

Anyway, we keep the MacProgressBar widget reference in the global variable $MAC_PB, so we can access it throughout the various initialization subroutines. For our Splashscreen, we've use the -milliseconds option to specify that the Splashscreen remain posted for a minimum of three seconds.

$splash = $mw->Splashscreen(-milliseconds => 3000);
$splash->Label(-text => 'Building your HP 16C ...', -bg => $BLUE)->
    pack(qw/-fill both -expand 1/);
$MAC_PB = $splash->MacProgressBar(-width => 300);
$MAC_PB->pack(qw/-fill both -expand 1/);
$splash->Label(-image => $mw->Photo(-file => 'hp16c-splash.gif'))->pack;

Here's how we use the Splashscreen. First, withdraw the MainWindow and show the Splashscreen. Now perform program initialization. Note how we use the set method to update the MacProgressBar to 100% before destroying the Splashscreen. With the Splashscreen gone, redisplay the MainWindow containing the completed calculator.

my $mw = MainWindow->new;
$mw->withdraw;
$splash->Splash;            # show Splashscreen
 
build_help_window;
build_calculator;
 
$MAC_PB->set($MAC_PB_P = 100);
$splash->Destroy;           # tear down Splashscreen
 
$mw->deiconify;             # show calculator

The Splash method serves to record the second of the epoch that the Splashscreen is first displayed. This datum is used to ensure that the Splashscreen remains visible for the specified minimum amount of time. Then Splash maps the widget in the center of the screen.

sub Splash {
 
    my ($self, $millis) = @_;
 
    $millis = $self->cget(-milliseconds) unless defined $millis;
    $self->{tm0} = Tk::timeofday;
    $self->configure(-milliseconds => $millis);
    $self->Popup;
 
} # end_splash

Destroy's first duty is to ensure that the Splashcreen remains visible for its allotted minimum time. It does this with a simple computation, which, if positive, gives the time to delay. If the result is negative, we set it to zero so there is no wait.

We then create a generic completion callback that does one final update call (to ensure all pending events are completed) and destroys the Splashscreen.

Now, if the program initialization has taken longer than the minimum Splashscreen time, we call the completion callback and return. Otherwise, we process all timer events, wait the requisite amount of time, and destroy the Splashscreen.

sub Destroy {
 
    my ($self, $millis) = @_;
 
    $millis = $self->cget(-milliseconds) unless defined $millis;
    my $t = Tk::timeofday;
    $millis = $millis - ( ($t - $self->{tm0}) * 1000 );
    $millis = 0 if $millis < 0;
 
    my $destroy_splashscreen = sub {
			$self->update;
			$self->after(100);   # ensure 100% of PB seen
			$self->destroy;
    };
 
    do { &$destroy_splashscreen; return } if $millis == 0;
 
    while ( $self->DoOneEvent (DONT_WAIT | TIMER_EVENTS)) {}
 
    $self->waitVariableX( [$millis, $destroy_splashscreen] );
 
} # end Destroy

These are the private methods responsible for moving a Splashscreen widget. On a button press, we record the cursor's x and y coordinates relative to the Splashscreen's top-left corner. When the button is released, we compute new x and y coordinates relative to the display's top-left corner and use geometry to move the Toplevel.

sub b3prs {
    my ($self, $x, $y) = @_;
    $self->{ofx} = $x;
    $self->{ofy} = $y;
} # end b3prs
 
sub b3rls {
    my($self, $X, $Y) = @_;
    $X -= $self->{ofx};
    $Y -= $self->{ofy};
    $self->geometry("+${X}+${Y}");
} # end b3rls

To complete our discussion on Tk::Splashscreen, here is a bindDump output:

## Binding information for '.splashscreen',
Tk::Splashscreen=HASH(0x83a6874) ##
 
1. Binding tag 'Tk::Splashscreen' has no bindings.
 
2. Binding tag '.splashscreen' has these bindings:
             <ButtonRelease-3> : Tk::Callback=ARRAY(0x83aaaf8)
                                   Tk::Splashscreen=HASH(0x83a6874)
                                     'b3rls'
                                     Tk::Ev=SCALAR(0x83aab1c)     : 'X'
                                     Tk::Ev=SCALAR(0x83aab58)     : 'Y'
                    <Button-3> : Tk::Callback=ARRAY(0x83aaae0)
                                   Tk::Splashscreen=HASH(0x83a6874)
                                     'b3prs'
                                     Tk::Ev=SCALAR(0x839a348)     : 'x'
                                     Tk::Ev=SCALAR(0x83aab04)     : 'y'
 
3. Binding tag 'all' has these bindings:
                     <Key-F10> : Tk::Callback=SCALAR(0x839a3fc)
                                   'FirstMenu'
                     <Alt-Key> : Tk::Callback=ARRAY(0x839a390)
                                   'TraverseToMenu'
                                     Tk::Ev=SCALAR(0x816e198)     : 'K'
                   <<LeftTab>> : Tk::Callback=SCALAR(0x839a360)
                                   'focusPrev'
                     <Key-Tab> : Tk::Callback=SCALAR(0x839a264)
                                   'focusNext'

Synthesizing Virtual Events

Tk supports a generic event command to define, generate, query, and delete virtual events. These are events that we make (or are made on our behalf) above and beyond those in Tk. We've mentioned the eventGenerate method previously, which generates events just as if they'd come from the window system. Using eventGenerate, we can simulate a person typing characters and clicking buttons, as well as invoking other real and virtual events.

The following code "types" the characters "Hello Perl/Tk" in the Entry widget $e. It's important to note that the Entry widget must have the keyboard focus, otherwise the data falls into the bit bucket. The update command is also important, as it ensures that all events have been processed. $evar is the Entry's -textvariable and, if all goes well, it will contain the "typed" characters.

my %keysyms = (' ' => 'space', '/' => 'slash');
my $evar;
my $e = $mw->Entry(-textvariable => \$evar)->pack;
 
$b = $mw->Button(
    -text    => 'Show $evar',
    -command => sub {print "$evar\n"},
)->pack;
 
$e->focus;
$mw->update;			# prevents lost characters

Figure 15-8 shows the outcome.

Figure 15-8. Data synthesized by eventGenerate

Here's the input loop. Most of the characters in the string "Hello Perl/Tk" are their own keysyms, but for those that aren't, we provide a mapping through the hash %keysysms.

foreach (split '', 'Hello Perl/Tk') {
    $_ = $keysyms{$_} if exists $keysyms{$_};
    $e->eventGenerate('<KeyPress>', -keysym => $_);
    $mw->idletasks;
    $mw->after(200);
}

After a short delay, we enter the Button's space, press it, and release it. The release event invokes the Button's callback, which prints "Hello Perl/Tk".

$mw->after(1000);
 
$b->eventGenerate('<Enter>');
$b->eventGenerate('<ButtonPress-1>');
$b->eventGenerate('<ButtonRelease-1>');

We create a virtual event using eventAdd. Once a virtual event is defined, we must create an actual binding to trigger the event. The following code creates the virtual event <<Gromit>>. Notice that virtual event names are surrounded by double angle brackets to distinguish them from real event names.

The <<Gromit>> virtual event is bound to the real event, <KeyPress>. Once defined, we bind <<Gromit>> to the subroutine look_for_gromit, which simply searches for the string "Gromit" (in this case, from an Entry widget).

We call bindDump and eventInfo to display interesting binding and event information.

my $e = $mw->Entry->pack;
$e->focus;
$e->eventAdd('<<Gromit>>' => '<KeyPress>');
$e->bind('<<Gromit>>' => \&look_for_gromit);
 
&bindDump($e);
print $e->eventInfo, "\n";
 
sub look_for_gromit {
    my $text = $_[0]->get;
    print "Found Gromit in '$text'\n" if $text =~ /Gromit/i;
}		    

Figure 15-9 shows the Entry and what we typed in it.

Figure 15-9. Searching for Gromit

As soon as we type the t and ! characters, look_for_gromit prints this:

Found Gromit in '123gROMit'
Found Gromit in '123gROMit!'

This is an excerpt from the bindDump output, showing the Entry widget's instance bindings.

2. Binding tag '.entry' has these bindings:
                    <<Gromit>> : Tk::Callback=ARRAY(0x82d5160)
                                   CODE(0x8270928)

The eventInfo method can return the event descriptor(s) associated with a virtual event. If no virtual event is specified, it returns a list of all virtual events.

<<LeftTab>><<Copy>><<Gromit>><<Undo>><<Cut>><<Redo>><<Paste>>

There's also an eventDelete method to remove an event descriptor from a virtual event or delete a virtual event entirely.

Coexisting with Other GUI Main Loops

It's perfectly possible to have more than one GUI main loop running concurrently. It's a simple matter of cooperation and balance. By balance, we mean how the events are portioned out. It's very easy for one main loop to "take control" and "starve" the other loop of processing time. In this section, we'll demonstrate how to use both OpenGL and Tk widgets in the same application. We've found that, generally, to keep Tk events flowing, it's sufficient to call update once in a while. If update starves OpenGL, we fall back to DoOneEvent.

DoOneEvent allows us to fine tune a Tk event loop by processing only selected events, which we specify by bit pattern. We can inclusively OR the following symbols together and define the desired bit pattern: WINDOW_EVENTS, FILE_EVENTS, TIMER_EVENTS, and IDLE_EVENTS. To specify all possible events, use ALL_EVENTS, and to make the DoOneEvent call nonblocking, add DONT_WAIT.

When passed ALL