Mega-Widget Implementation Details (Mastering Perl/Tk)

14.3. Mega-Widget Implementation Details

Once again, briefly, here's the basic structure of a Perl/Tk mega-widget, but this time using a derived NavListbox widget (described in Section 14.5, "Derived Mega-Widgets") as the model:

 1   package Tk::NavListbox;
 2 
 3   use vars qw($VERSION);
 4   $VERSION = '1.0';
 5 
 6   use Tk::widgets qw(Listbox Dialog);
 7   use base qw(Tk::Derived Tk::Listbox);
 8   use strict;
 9 
10   Construct Tk::Widget 'NavListbox';
11 
12   sub ClassInit {}
13   sub Populate {}
14 
15   1;

Line 1 declares the widget's class name.

Lines 3 and 4 show another way of specifying the module's version number.

Line 6 concisely declares the widgets used by the module.

Line 7 is the signature line of a derived mega-widget, because the base class list starts with Tk::Derived and includes another Tk widget class. Tk::Derived provides all the option specification and configuration, and method delegation support methods. A composite mega-widget would list a single base class, either Tk::Toplevel or Tk::Frame. As Figure 14-4 shows, composite mega-widgets need not include Tk::Derived in their @ISA array, because Tk::Derived is a base class of Tk::Frame.

Line 10, also written as Tk::Widget->Construct('NavListbox'), creates a constructor named NavListbox in the class Tk::Widget. When the user types:

$nlb = $mw->NavListbox;

Perl eventually finds Tk::Widget::NavListbox via MainWindow's @ISA array. This constructor, like all Perl/Tk widget constructors, then calls Tk::Widget::new (described next) to actually create the widget.

Lines 12 and 13 are well-known methods invoked by Tk::Widget::new. As we are about to see, there are several other methods you may occasionally find useful.

14.3.1. Tk::Widget::new, the Real Perl/Tk Widget Constructor

In chronological order, Tk::Widget::new performs these six major steps when creating a Perl/Tk widget:

Calls ClassInit to perform class initialization, such as creating class bindings.
Calls CreateArgs to perform argument processing that is applicable only at widget creation time (as opposed to later configuration). Toplevel's -colormap option is an example.
Puts actual widget creation and blessing into the proper package. The only arguments specified at this time are the keyword/value pairs returned by CreateArgs.
Calls SetBindtags to initialize the widget's bindtags list. See Chapter 15, "Anatomy of the MainLoop" for details.
Calls Populate to perform widget initialization. Populate calls ConfigSpecs to generate configuration specifications and Delegates to describe how methods are dispatched to subwidgets. Populate is called only because Tk::Derived is in the widget's @ISA hierarchy.
Actually configures the widget using the configuration specification hash generated by the previous call to Populate.

As mega-widget writers, we have access to the widget in steps 1, 2, 4, and 5, detailed in the following sections.

14.3.2. Subroutine ClassInit

ClassInit is called once per MainWindow, allowing class customization on a MainWindow basis. Initialization typically consists of defining class bindings, but it might also initialize class variables, images, and/or data structures. It is passed two arguments:

A class name, e.g., Tk::NavListbox
A reference to the MainWindow

Where you place the call to SUPER::ClassInit can be important. If you want to override a superclass binding, place your bind command after the call. If, as in ROText, you do not want any superclass bindings, don't call SUPER::ClassInit at all!

ClassInit must return a true value.

sub ClassInit {
    my($class, $mw) = @_;
    $class->SUPER::ClassInit($mw);
    $mw->bind($class, '<Event>' => \&callback);
}

14.3.3. Subroutine CreateArgs

The rarely used CreateArgs method is called prior to actual mega-widget creation, allowing access to the widget argument hash for specialized processing. It is passed three arguments:

A class name, e.g., Tk::NavListbox
A reference to the MainWindow
A reference to the argument hash

CreateArgs must return a list of keyword/value pairs that Perl/Tk supplies during the widget creation in step 3, described earlier. These keyword/value pairs are not available in step 6, when configure steps through the configuration specifications returned by Populate. The list of keyword/value pairs must also include any that the widget's superclasses might provide; this is very important.

sub CreateArgs {
    my($class, $mw, $args) = @_;
    my(%args) = (-special_arg => 'special_val');
    ($class->SUPER::CreateArgs($mw, $args), %args);
}

14.3.4. Subroutine SetBindtags

The SetBindtags method is called after mega-widget creation, providing a mechanism to alter the widget's bindtags list. It is passed one argument: a reference to the mega-widget.

The call to SUPER::SetBindtags initializes the bindtags list differently depending on the type of mega-widget. For Toplevels, the list is [class, instance, "all"], and for all others, it's [class, instance, Toplevel, "all"].

SetBindtags is not expected to return a result.

sub SetBindtags {
    my($self) = @_;
    $self->SUPER::SetBindtags;
}

14.3.5. Subroutine Populate

Finally, it's Populate time! This method is invoked only because Tk::Derived is somewhere in the @ISA method lookup hierarchy. Since composite widgets are based on Tk::Frame or Tk::Toplevel, they need not include Tk::Derived in their @ISA lists, because Tk::Derived is a base class of the Frame or Toplevel. Derived mega-widgets, on the other hand, must specifically declare Tk::Derived.

Populate is passed two arguments: a reference to the mega-widget and a reference to the argument hash. If the argument hash contains options that aren't destined for configure, they must be removed before calling SUPER::Populate. The idiom uses delete, like this:

my $frog = delete $args->{-frog};

$frog then contains the value of the -frog option.

As we learned earlier, SUPER::Populate often makes ConfigSpecs calls on behalf of the mega-widget, so remember to call SUPER::Populate.

Populate is also the appropriate place to create subwidget bindings. Note that if you want the subwidgets of a mega-widget to react to the class bindings created byClassInit, you'll have to add the new class to the subwidget's bindtags list (see Chapter 15, "Anatomy of the MainLoop" for more details).

Populate is not expected to return a result.

sub Populate {
    my($self, $args) = @_;
    $self->SUPER::Populate($args);
    # Create and advertise subwidgets here.
    $self->ConfigSpecs( );
    $self->Delegates( );
}

In general, Populate should never perform any explicit mega-widget configuration, for these reasons:

Doing so prevents the user from customizing the widget to her liking.
Often it won't work anyway and only leads to frustration and confusion.

To see why, let's start with this tiny program, el, that uses a mythical EntList (Entry and Listbox) composite. Using the Subwidget method, the code fetches the widget references to the advertised Entry and Listbox widgets and inserts some text into each.

my $el = $mw->EntList->pack;
$el->Subwidget('entry')->insert('end', 'Entry!');
$el->Subwidget('listbox')->insert('end', 'Listbox!');

Suppose the user of this code has established some color and font preferences in his .Xdefaults file:

el*Foreground: purple
el*Font: -adobe-courier-bold-r-normal--34-240-100-100-m-200-iso8859-1

When the code is executed, the user expects large, purple text, shown in Figure 14-6.

Figure 14-6. Large, purple text

Now, it's okay to provide a default font and color scheme, but we can't mandate one. Let's examine EntList.pm to see the right and wrong way to do this. First, the incorrect way:

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

package Tk::EntList;

use Tk::widgets qw/Entry Listbox/;
use base qw/Tk::Frame/;
use strict;

Construct Tk::Widget 'EntList';

sub Populate {

    my($self, $args) = @_;

    $self->SUPER::Populate($args);

    my $e = $self->Entry->pack;
    my $l = $self->Listbox(-height => 2)->pack;
    $self->Advertise('entry'   => $e);
    $self->Advertise('listbox' => $l);

    # Wrong - hardcoding configurable options leads to 
    # frustration and confusion.

    $e->configure(-font => '9x15', -foreground => 'red');
    $l->configure(-font => '9x15', -foreground => 'red');

} # end Populate

1;

When the poor user runs his code, instead of large, purple text, he sees small, purple text, as seen in Figure 14-7.

Figure 14-7. Small, purple text

Now two people are confused: the user, because the font size is too small, and the programmer, because the foreground color is wrong! So replace the two configure lines with this call:

    $self->ConfigSpecs(
        -font       => [[$e, $l], qw/font Font 9x15/],
        -foreground => [[$e, $l], qw/foreground Foreground red/],
    );

Each ConfigSpecs entry (explained in the next section) is a reference to a list of values, the first of which specifies where to apply the option. In this case, it's another list of widgets. Now the user can customize the widget either via the option database or explicit configure calls, and if he doesn't, our default of 9x15, red lettering takes effect (see Figure 14-8).

Figure 14-8. 9x15 red lettering

The following sections describe other methods often called from Populate.

14.3.6. Subroutine ConfigSpecs

The ConfigSpecs method tells Perl/Tk what to do when a configure (or cget) request for an option is received. Any number of option/value pairs can be specified in the call, and ConfigSpecs can be called any number of times. (Indeed, we know that one or more of the mega-widget's superclasses may call ConfigSpecs.)

These are the three major ways of using ConfigSpecs:

$self->ConfigSpecs(
    'DEFAULT' => [where],
    -alias    => '-otherattribute',
    -option   => [where, DBname, DBclass, default_value]
);

If Perl/Tk can't find a ConfigSpecs entry for an option, the default where action is used (described later).

You can use the second flavor of ConfigSpecs to make aliases for options. Perl/Tk automatically aliases -bg and -fg for -background and -foreground, respectively.

The third form is the most common. DBname and DBclass are the name and class of the option in the X11 resource database, fully described in Chapter 16, "User Customization". If the option isn't specified when Tk::Widget::new autoconfigures the mega-widget, the option is assigned the default_value.

where specifies how Perl/Tk configures the mega-widget and/or its subwidgets. It's a scalar: either a single value from the following list or a reference to a list of the following values. All these values are strings except the last, which is a real widget reference:

'ADVERTISED': The configure request is sent to all advertised subwidgets. A subwidget is advertised explicitly via an Advertise call or implicitly via a Component call.
'CALLBACK': Treats the value of the option as a standard Perl/Tk callback: a code reference or a reference to an array with a code reference and subroutine arguments. The proper way to invoke the callback is to use the Callback method, e.g., $widget->Callback(-option [=> @args]). Perl/Tk will look up the value of -option (the callback) and then call it, passing any optional arguments.
'CHILDREN': The configure request is sent to the mega-widget's immediate children.
'DESCENDANTS': The configure request is sent to the mega-widget's descendants (children, children of children, and so on).
'METHOD': Perl/Tk invokes a subroutine having the same name as the option (excluding the leading dash). The method is called for configure and cget calls. For a configure request, it's called with two arguments: the mega-widget reference and the option value. For a cget request, it's called with only the mega-widget reference, and the subroutine should return the option's value.
'PASSIVE': The option/value pair is simply stored in a hash instance variable. cget can retrieve the value at any time. See Section 14.3.9, "Mega-Widget Instance Variables" for details you really shouldn't know!
'SELF': The configure request is applied only to the mega-widget (the Frame, Toplevel, or derived widget).
$widget: The configure request is applied only to the specified widget.

14.3.6.1. ConfigSpecs Examples

This example defines a -validate option that expects a Perl/Tk callback as its value and supplies a default subroutine that always validates true:

$self->ConfigSpecs(
    -validate => ["CALLBACK", "validate", "Validate", sub { return 1 }],
);

This is an example from Section 14.4.1, "Tk::Thermometer", described later in this chapter.

$self->ConfigSpecs(
    -background                   =>
     [['DESCENDANTS', 'SELF'], 'background', 'Background', 'white'],
    -from                         => [$scale, qw/from From 500/],
    -highlightthickness => 
      [[@highlightthickness], qw/highlightThickness HighlightThickness 0/],
    -length                       => [$scale, qw/length Length 200/],
    -tscale                       => [qw/METHOD tscale Tscale/, $TSCALES[0]],
    -sliderlength                 => [$scale, qw/sliderLength SliderLength 10/],
    -to                           => [$scale, qw/to To 0/],
    -width                        => [$scale, qw/width Width 10/],
    'DEFAULT'                     => [$scale],
);

The -background option is applied to the mega-widget ($self) and all it descendants, with a default value of white. The -from option is applied to the widget, $scale with a default of 500. The -highlightthickness option is applied to a list of widgets @highlightthickness, with a default of 0. The -length option is applied to $scale with a default of 200. The -tscale option is a method (when the option is configured, Tk invokes the subroutine tscale) with a default of $TSCALE[0]. The -sliderlength, -to, and -width options all apply to $scale, with the indicated default values. All other options default to $scale.

Finally, multiple options can be configured across multiple widgets simultaneously if where is a hash reference. Suppose we have this ConfigSpecs entry:

-option => [{-optionX => $w1, -optionY => [$w2, $w3]}, DBname, ... ]

Then:

$cw->configure(-option => value);

actually does:

$w1->configure(-optionX => value);
$w2->configure(-optionY => value);
$w3->configure(-optionY => value);

14.3.7. Subroutine Delegates

This method tells Perl/Tk how to dispatch mega-widget methods to the component subwidgets. Any number of option/value pairs can be specified in the call, and Delegates can be called any number of times.

$self->Delegates(
    'method1'   => $subwidget1,
    'method2'   => 'advertised_name',
    'Construct' => $subwidget2,
    'DEFAULT'   => $subwidget3,
);

The 'Construct' delegation has a special meaning. After 'Construct' is delegated, all widget constructors are redirected; e.g., after:

$self->Delegates('Construct' => $subframe);

$self->Button really does a $subframe->Button, so the Button is a child of $subframe and not $self. Delegates works only with methods that the mega-widget does not have itself.

14.3.8. Other Useful Methods

The following sections describe various methods that are useful when writing mega-widgets.

14.3.8.1. Subroutine Advertise

Advertise a subwidget reference so it's officially part of the mega-widget's public interface. Use the Subwidget method to map an advertised name to a widget reference.

$self->Advertise('advertised_name' => $subwidget);

Any other valid widget options can be appended as well.

14.3.8.2. Subroutine Callback

Execute an option's standard Perl/Tk callback. %args is an optional argument hash passed to the callback. The option -option (e.g., -command) is required and should be declared in a call to ConfigSpecs as type 'CALLBACK'. The Callback method looks up the actual callback associated with -option and invokes it with the optional arguments %args.

$self->Callback(-option  => ?%args?);

14.3.8.3. Subroutine Component

Create a widget of class WidgetClass as a child of $self and advertise it with the specified name. Use the Subwidget method to map an advertised name to a widget reference.

$self->Component('WidgetClass' => 'advertised_name');

Any other valid widget options can be appended as well.

14.3.8.4. Subroutine Descendants

Return a list of widgets derived from a parent widget and all its descendants of a particular class. If Class is not specified, it returns the entire widget hierarchy starting at $self.

$self->Descendants(? Class ?);

14.3.8.5. Subroutine Subwidget

Return the widget reference corresponding to an advertised name.

$subwidget_ref = $self->Subwidget('advertised_name');

Any Scrolled widget is actually a mega-widget. To get the actual widget reference, use the Subwidget command with the special advertised name scrolled.

14.3.8.6. Subroutine Walk

Traverse a widget hierarchy while executing a subroutine.

$self->Walk($code_ref => @args);

14.3.9. Mega-Widget Instance Variables

The mega-widget hash is Perl/Tk territory, but that hasn't stopped folks from using it as their private data structure. Typically, they just swipe a few hash keys to store their instance data, but there's always the risk of clobbering a key used by Perl/Tk. For the most part, Perl/Tk reserves keys beginning with an underscore. Unfortunately, over time, important keys not beginning with an underscore have crept into the mega-widget support code.

Now we're not supposed to peek at object internals, but for the record, these important mega-widget related keys are also reserved by Perl/Tk:

ConfigSpecs

Configure

Delegates

SubWidget

Since we're being bad, let's run this tiny program, named xray, and look inside an opaque LabOptionmenu widget. Each of the four hash keys is a reference to an anonymous hash, and xray just pretty-prints the keys and values from these hashes. Notice the tkinit convenience command that creates a MainWindow and returns its reference, which we use to create a widget of the class specified on the command line.

#!/usr/local/bin/perl -w

use Tk;

die "Usage:  xray widget" unless @ARGV >= 1;
my $class = shift;        # get class name from command line

require "Tk/$class.pm";
my $w = tkinit->$class(@ARGV)->pack;
print "X-ray data for widget $w\n";


foreach my $secret (
                    ["Advertised Subwidgets"      => 'SubWidget'],
                    ["Delegated Methods"          => 'Delegates'],
                    ["configure( ) Options"      => 'Configure'],
                    ["Configure Specifications"   => 'ConfigSpecs'],
                   ) {
    printf "\n%-11s - %s\n", $secret->[1], $secret->[0];
    foreach (keys %{$w->{$secret->[1]}}) {
        printf "%20s: %31s\n", $_, $w->{$secret->[1]}->{$_};
    }
}

MainLoop;

We run the program by typing xray LabOptionmenu -label X-ray (which effectively does $mw->LabOptionmenu(-label => 'X-ray'), and we see this output:

X-ray data for widget Tk::LabOptionmenu=HASH(0x814d394)


SubWidget   - Advertised Subwidgets
               label:       Tk::Label=HASH(0x8251070)
          optionmenu:  Tk::Optionmenu=HASH(0x828884c)

Delegates   - Delegated Methods
             DEFAULT:  Tk::Optionmenu=HASH(0x828884c)

Configure   - configure( ) Options
         -background:                         #d9d9d9
         -foreground:                           Black
              -label:                           X-ray
      -labelVariable:               SCALAR(0x814d5c4)

ConfigSpecs - Configure Specifications
         -background:                ARRAY(0x814d3b4)
                 -bg:                     -background
                 -fg:                     -foreground
         -foreground:                ARRAY(0x814d420)
              -label:                ARRAY(0x82863b8)
        -labelAnchor:                ARRAY(0x81e0320)
    -labelBackground:                ARRAY(0x82a5158)
        -labelBitmap:                ARRAY(0x82a51dc)
   -labelBorderwidth:                ARRAY(0x82a5f34)
        -labelCursor:                ARRAY(0x82a5fb8)
          -labelFont:                ARRAY(0x82a603c)
    -labelForeground:                ARRAY(0x82a60c0)
        -labelHeight:                ARRAY(0x82a6144)
-labelHighlightbackground:           ARRAY(0x82a61c8)
-labelHighlightcolor:                ARRAY(0x82a624c)
-labelHighlightthickness:            ARRAY(0x82a6c04)
         -labelImage:                ARRAY(0x82a6c88)
       -labelJustify:                ARRAY(0x82a6d0c)
          -labelPack:                ARRAY(0x8286304)
          -labelPadx:                ARRAY(0x82a6d90)
          -labelPady:                ARRAY(0x82a6e14)
        -labelRelief:                ARRAY(0x82a6e98)
     -labelTakefocus:                ARRAY(0x82a6f1c)
          -labelText:                ARRAY(0x82a6fa0)
  -labelTextvariable:                ARRAY(0x82a7cd0)
     -labelUnderline:                ARRAY(0x82a7d54)
      -labelVariable:                ARRAY(0x8286340)
         -labelWidth:                ARRAY(0x82a7dd8)
    -labelWraplength:                ARRAY(0x82a7e5c)
             DEFAULT:                ARRAY(0x814cd3c)

The first thing to note is that the SubWidget key points to a hash of advertised widgets, with their names as keys and widget references as values. The Delegates key references a hash of Delegates options, and there we see our DEFAULT entry, the Optionmenu subwidget. Perl/Tk uses the anonymous hash referenced by Configure to store all PASSIVE option values and as instance variables for other options; notice -label and its value from the command line. Finally, the ConfigSpecs key points to all the ConfigSpecs entries, all but one (DEFAULT) of which Perl/Tk supplied automatically.