Book HomeMastering Perl/TkSearch this book
PreviousNext

15.3. 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.

15.3.1. 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, "Creating Custom Widgets in Pure Perl/Tk" 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.

15.3.2. 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.
PreviousHomeNext
15.2. Binding to EventsBook Index15.4. Executing Nonblocking System Commands
Library Navigation Links

Copyright © 2002 O'Reilly & Associates. All rights reserved.