Derived Mega-Widgets (Mastering Perl/Tk)

14.5.1. Tk::NavListbox

If you see limitations in the standard Listbox and want to make it more useful, perhaps the best thing to do is create your own derived widget. Let's start with a Listbox widget and add some features that allow a user to edit the items without need for additional controls.

We'll add these enhancements to our version of Listbox:

Display one widget only, not a combination of widgets. We want to keep the widget simple for future programmers.
Still be able to use scrollbars by using the built-in Scrollbars method, or let users attach scrollbars themselves.
Provide a popup menu to give the user a mechanism to manipulate Listbox entries.
Allow the programmer to define a validation routine for new/renamed entries; e.g., end user can enter only numbers.

Figure 14-10 shows what the NavListbox widget looks like while the user is editing an entry.

Figure 14-10. NavListbox, a derived mega-widget

The code to use the NavListbox might look like this:

$nlb = $mw->Scrolled("NavListbox", -width => 30, -height => 5, 
  -font     => "Courier 12",
  -validate =>
    sub 
    {
       my ($entry) = @_;
       print "Validate this: $entry"; 
       return 1 if ($entry =~ /^[0-9]*$/);
       return 0; 
    })->pack(-fill => 'both', -expand => 1);

The -validate method does a simple check; it will allow only digits in the text. The rest of the code is just standard widget creation stuff.

The NavListbox class hierarchy, shown in Figure 14-11, is pretty much what we expect, although there is an additional class, Tk::Clipboard, that manages clipboard operations.

Figure 14-11. Class hierarchy for a NavListbox widget

Now that we have a good idea of what the enhanced Listbox should do, we need to decide how to code it. We're going to need to create a menu to display to the user. We'll have to make sure the menu displays only meaningful entries depending on what entry is right-clicked. The other bit of fancy coding we'll have to do is figure out how to edit an item in-place. We'll see how to accomplish this as we go through the code.

As always, the package statement declares the mega-widget class name. Now, specify the module version, required widgets, and base class list, then build the constructor. Notice Tk::Derived in the first base class entry, marking this as a derived widget.

package Tk::NavListbox;

use vars qw($VERSION);
$VERSION = '1.0';

use Tk qw(Ev);
use Tk::widgets qw(Listbox Dialog);
use base qw(Tk::Derived Tk::Listbox);
use strict;

Construct Tk::Widget 'NavListbox';

We define our class bindings inside ClassInit. For NavListbox, we don't want to remove any of the default bindings for the widget, so we call ClassInit in some superclass as well. Our binding is for the right mouse button. When the user right-clicks in a NavListbox, we invoke the method, show_menu, which actually does the work of posting the Menu so the user can select an action. The arguments to show_menu are some coordinates, so we can calculate which item in the Listbox they want to perform an action on.

The other bindings are key bindings. If the user holds the Alt button and the Up or Down arrow, we invoke move_item with the correct direction. This only works if the user has tabbed to the NavListbox so that it has keyboard focus.

sub ClassInit
{
    my ($class, $mw) = @_;
    
    $class->SUPER::ClassInit($mw);
    $mw->bind($class, '<Button-3>' => [\&show_menu, Ev('X'), Ev('Y'), Ev('y')]);
    $mw->bind($class, '<Alt-Up>'   => [\&move_item, -1]);
    $mw->bind($class, '<Alt-Down>' => [\&move_item,  1]);
}

In Populate, we first construct a Menu that's activated via button 3. We then call ConfigSpecs to set up the option to allow a validation callback, and supply a dummy subroutine that always validates true. Remember that Populate is actually called because we used Tk::Derived when setting up the inheritance chain for our widget.

sub Populate
{
    my ($self, $args) = @_;
    
    $self->SUPER::Populate($args);

    my $menu = $self->Menu(-tearoff => 0);
    $menu->command(-label  => "New Item" ,
                  -command => [$self => 'new_item']);
    $menu->command(-label  => "Delete",
                  -command => [$self => 'delete_item']);
    $menu->command(-label  => "Duplicate",
                  -command => [$self => 'dup_item']);
    $menu->command(-label  => "Rename",
                  -command => [$self => 'rename_item']);
    $menu->separator;
    $menu->command(-label  => "^ Move up",
                  -command => [$self => 'move_item', -1]);
    $menu->command(-label  => "v Move down",
                  -command => [$self => 'move_item',  1]);
    $self->{'lbmenu'} = $menu;

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

The first bit of fun is displaying the Menu to the user when she right-clicks somewhere in the NavListbox. This is handled by the show_menu routine. This routine is really quite boring; it's just housekeeping. We first want to select whatever entry the user right-clicked. The standard Listbox doesn't do anything when a user right-clicks, so we need to handle that ourselves.

Using the third of the coordinates passed in (x coordinate with respect to MainWindow, y coordinate with respect to the MainWindow, and y relative to the NavListbox), we can determine which item in the Listbox was selected.

Once we know which item the user clicked, we can determine which menu items to enable or disable. It doesn't make any sense for the user to be able to move the very first item in the Listbox up or the very last item in the Listbox down. If the user didn't actually right-click on an item (we'll find index -1), we want to disable all actions except "New Item."

The last statement in show_menu posts the Menu to the screen wherever the user clicked. If the user selects an item in the Menu, the appropriate callback is invoked. If she doesn't select anything, the menu is un-posted when she releases the mouse button.

sub show_menu
{
    my ($lb, $x, $y, $lby) = @_;

    # select the index we just clicked on.
    my $index = $lb->nearest($lby);
    $lb->selectionClear("0", "end");
    $lb->selectionSet($index);

    my $m = $lb->{'lbmenu'};
    if ($index == -1) {
        foreach (1..3,5,6) { $m->entryconfigure($_, -state => 'disabled'); }
    } else {
        foreach (1..3,5,6) { $m->entryconfigure($_, -state => 'normal'); }
        if ($index == 0) { $m->entryconfigure(5, -state => 'disabled'); }
        if ($index == $lb->size - 1) { 
        $m->entryconfigure(6, -state => 'disabled'); }
    }

    # popup the menu; goes away when they select something
    $m->post($x, $y);
}

To create a new item in the list, we find out what item is selected (remember we selected whatever the user clicked on in show_menu) and insert the item at that index. We select the new item, then invoke the rename_item method to allow the user to edit the new item.

sub new_item
{
    my ($lb) = @_;
    my $index = $lb->curselection;

    $index = "end" if ! defined $index;
    $lb->insert($index, "<new item>");								
    $lb->selectionClear("0", "end");
    $lb->selectionSet($index);
    $lb->rename_item;
}

To delete a list item, we find out what item is selected and simply delete it.

sub delete_item 
{
    my ($lb) = @_;
    my $index = $lb->curselection;
    $lb->delete($index);
}

Copying a list item is similar to creating a new one, except we borrow the text from the currently selected item first. We also invoke rename_item so the user can edit the newly copied list item.

sub dup_item 
{
    my ($lb) = @_;
    my $index = $lb->curselection;
    $lb->insert($index, $lb->get($index));									
    $lb->selectionClear("0", "end");
    $lb->selectionSet($index);
    $lb->rename_item;
}

Inside rename_item is where the really neat stuff happens. Similar to all the other methods we have seen so far, we determine which item has been selected. Once we know that, we get some basic information about it so we can overlay it with an Entry widget that lets the user enter a new value while preserving the old value in the Listbox.

The bbox method will tell us how much space within the Listbox that item takes. In order to make our entry widget the correct size, we also have to find out how much space the NavListbox has allocated for the borderwidth. The borderwidth amount is doubled to account for both sides.

Creating the entry is standard, except we want our font size to match the size in our NavListbox. This will force the height of the entry to match the height of the item in the NavListbox, and also make it look like it belongs. The <Return> binding on the Entry is so that when the user finishes his editing by hitting the Return key, we check to see if he's entered valid information. We also bind to the Escape key, so he can abort editing at any time.

The rest of the code in the rename_item method handles the work of putting the widget inside the NavListbox using the place geometry manager, then keeping the user from doing anything else until editing is complete.

sub rename_item 
{
    my ($lb) = @_;

    my $index = $lb->curselection;
    my ($x, $y, $w, $h) = $lb->bbox($index);
    my $bd = $lb->cget(-borderwidth) * 2;

    $y -= $bd;
    my $e = $lb->Entry(-font => $lb->cget(-font));
    $e->insert("end", $lb->get($index));
    $e->selectionRange("0", "end");

    $e->bind("<Return>",
        [sub {
            my ($e, $lb, $i) = @_;

            if ( $lb->Callback(-validate => $e->get) ) {
                $e->placeForget;
                # Must insert first, then delete item
                # so that scrolling doesn't get mussed up.
                $lb->insert($i, $e->get);
                $lb->delete($i + 1);
                $lb->activate($i);
                $e->destroy;
            } else { $e->bell; }
        }, $lb, $index]);

    # Allows us to abort the editing we began ( can leave a new item empty )
    $e->bind("<Escape>", sub { 
        my ($e) = @_; $e->placeForget; $e->destroy; } );

    $e->place(-x => 0, -y => $y, -width => $lb->width - $bd);
    $e->focus;
    $e->grab;    # Don't let anything else happen until they finish w/entry.
    # Wait until the entry is destroyed before doing anything else
    $e->waitWindow;
}

The move_item method simply moves an item up or down in one direction. We put in some sanity checks, because this method can be called from either the Menu or from the user hitting some keys.

sub move_item
{
    my ($lb, $direction) = @_;
    my $index = $lb->curselection;
    # Sanity checks
    return if ($index == 0 && $direction == -1);
    return if ($index == $lb->size( )-1 && $direction == 1);

    my $newindex = $index + $direction;

    my $item = $lb->get($index);
    $lb->delete($index);
    $lb->insert($newindex, $item);
    $lb->selectionSet($newindex);
}

As always, the last thing in our module should be a 1, so that it loads correctly.

1;

14.5.2. Tk::CanvasPlot

Tk::CanvasPlot is a widget derived from a Canvas that plots simple 2D line plots and pie charts. Because a CanvasPlot widget is really a Canvas, you can do anything with CanvasPlot that you can with a normal Canvas widget. Now don't get all excited and assume this is a full-fledged plotting widget, because it's not. It's just an example of how you can graft new methods onto an existing widget and extend its functionality. The many design and user-interface considerations required for a robust plotting widget exceed the scope of this chapter.

The following code shows that CanvasPlot accepts a few more options than a regular Canvas, such as -font for labels and -colors for pie wedges. The new createPiePlot method parallels the standard Canvas item-creation methods both in name and calling sequence. To create a pie chart, we specify the pie's bounding box (in other words, the upper-left and lower-right coordinates of a rectangular region that just encloses the oval of the pie; the same as createOval) and pass an array reference pointing to the pie data.

my $cp = $mw->CanvasPlot(
    -background => 'white',
    -width      => 300,
    -height     => 200,
    -font       => $^O eq 'irix' ? '6x13' : 'fixed',
    -colors     => [qw/red green blue orange purple slategray cornflowerblue/],
)->grid;

my(@data) = qw/Mon 1 Tue 2 Wed 3 Thu 4 Fri 5 Sat 6 Sun 7/;
$cp->createPiePlot(25, 50, 125, 150, -data => \@data);

Figure 14-12 shows the resulting pie chart.

Figure 14-12. The derived mega-widget CanvasPlot can make pie charts

Here's an early version of the module and the standard mega-widget preamble: the module's version number, the module's class name, other Tk widgets required by the new module, the module's @ISA declaration (with Tk::Derived first), and the strict programming style.

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

package Tk::CanvasPlot;

use Tk::widgets qw/Canvas/;
use base qw/Tk::Derived Tk::Canvas/;
use strict;

Construct Tk::Widget 'CanvasPlot';

This particular widget doesn't do any class initialization, so we dispense with the ClassInit subroutine entirely. And all Populate does is initialize a few instance variables with PASSIVE configuration specifications, so we can cget them whenever required.

sub Populate {

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

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

    my @def_colors = qw/red green blue/;
    $self->ConfigSpecs(
        -colors  => ['PASSIVE', 'colors',  'Colors', \@def_colors],
        -font    => ['PASSIVE', 'font',    'Font',        'fixed'],
    );

} # end Populate

Actually creating the pie chart isn't too difficult, although we'll soon run into details that require some changes to this code. For now, just fetch the -data array reference, total the pie data to determine the number of degrees per unit, and create a series of arcs and labels of varying colors:

sub createPiePlot {

    my($self, $x1, $y1, $x2, $y2, %args) = @_;

    my $data = delete $args{-data};
    croak "createPiePlot:  No -data option." unless defined $data;

    my $total;
    for(my $i = 0; $i < $#{@$data}; $i += 2) {
        $total += $data->[$i+1];
    }

    my $colors = $self->cget(-colors);
    my $color;
    my $dp_unit = 360.0 / $total;

    my $degrees = 0;
    for(my $i = 0; $i < $#{@$data}; $i += 2) {
        my $d = $data->[$i+1];
        my $arc = $d * $dp_unit;
        $color = $$colors[ $i / 2 % @$colors ];
        $self->createArc(
            $x1, $y1, $x2, $y2,
            -start  => $degrees,
            -extent => $arc,
            -style  => 'pieslice',
            -fill   => $color,
        );
        $degrees += $d * $dp_unit;
        my $label = sprintf("%-15s %5d", $data->[$i], $data->[$i+1]);
        $self->createText(
            $x2 + 25, $y1 + ($i * 10),
            -text   => $label,
            -fill   => $color,
            -font   => $self->cget(-font),
            -anchor => 'w',
        );
    } # forend

} # end createPiePlot

Creating a line plot is even easier: it's just a call to createLine. You might say this is cheating, and you're probably correct. But the user doesn't have to know and besides, we might want to add various options that draw and label axes. Or we might just provide additional methods, such as createPlotAxis.

sub createLinePlot {

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

    my $data = delete $args{-data};
    croak "createLinePlot:  No -data option." unless defined $data;

    $self->createLine(@$data, %args);

} # end createLinePlot

Figure 14-13 shows an interesting line plot of terminal server activity.

Figure 14-13. createLinePlot highlighting a terminal server failure

The -data option points to an array of x-y pairs, where y is the number of connected users and x is the second of the day (all 86,400 of them). If we scale all the x values by 0.01, they'll fit comfortably on most of today's monitors (the y values require no scaling). createLinePlot then draws the line in canvas coordinates. createPlotAxis draws the x axis, and left and right y-axes, and labels all three.

my $x_scale = 0.01;             # pixels per second
my $hour = 60 * 60;             # seconds per hour
my $day = 24 * $hour;           # seconds per day
my $x_margin = 30;              # left margin in pixels
my $x_max = 864 + $x_margin;
my $ports = 138;
my $y_max = $ports + 30;

my $cp = $mw->CanvasPlot(
    -height     => $y_max + 30,
    -width      => $x_max,
    -background => 'white',
    -font       => $font,
)->grid;
$cp->createLinePlot(-data => \@data);

$cp->createPlotAxis(
    $x_margin, $y_max, $x_margin + ($x_scale*$day), $y_max,
    -fill => 'red',
    -tick  => ['blue', $font, 's', 0, 24, 1, $x_scale*$hour],
    -label => ['blue', $font, '', 1 .. 23, ''],
);
my @labels = ('', 10, '', 30, '', 50, '', 70, '', 90, '', 110, '', 130);
$cp->createPlotAxis(
    $x_margin, $y_max-$ports, $x_margin, $y_max,
    -fill => 'blue',
    -tick  => ['blue', $font, 'w',  0, 139, 10, 10],
    -label => ['blue', $font, @labels],
);
$cp->createPlotAxis(
    $x_margin + ($x_scale*$day), $y_max-$ports,
    $x_margin + ($x_scale*$day), $y_max,
    -fill => 'blue',
    -tick  => ['blue', $font, 'e', 0, 139, 10, 10],
    -label => ['blue', $font, @labels],
);

There's an implementation detail we've neglected: how we should reference these plots and charts. That is, Tk assigns normal canvas items identifiers that we can use to manipulate them, but these plots are composed of multiple canvas items. What shall we do?[36]

[36] In the interest of full disclosure, we should tell you that the real solution is to use a canvas group. Nick introduced the concept of canvas groups in Tk 800.018, which act as containers for any number of other canvas items. A group item has its own unique canvas ID and is manipulated just like any other atomic canvas item. It's precisely the solution we should use here.

One idea is to return a list of all the Canvas items used in the plot, so createPiePlot might do something like this:

push @ids, $self->createArc( ... );
push @ids, $self->createText( ... );
...
return @ids;

And user code would do this:

@pie_ids = $cp->createPiePlot( ... );
...
$cp->delete(@pie_ids);

So far so good, but most canvas methods accept only one item ID, not a list, so we've placed the extra burden of differentiating between normal canvas items and CanvasPlot mega-items on the user. Not nice.

Let's try shifting the work into the class itself. A normal canvas returns positive integers for items it creates, so let's have CanvasPlot return negative integers for its plot mega-items. That means we need a class variable to count the mega-items and, for each mega-item, another variable to store its component items. Sounds like a scalar and an array or hash are what we need. We'll use a hash so we can delete the key when the mega-item is deleted.

# Class data to track mega-item items.

my $id = 0;
my %ids = ( );

Now createPiePlot can do this:

push @ids, $self->createArc( ... );
push @ids, $self->createText( ... );
...
--$id;
$ids{$id} = [@ids];
return $id;

And user code can be written normally:

$pie_id = $cp->createPiePlot( ... );
...
$cp->delete($pie_id);

Except this won't work because the Canvas delete method has no idea what to do with a negative item ID. But we can override the superclass method by writing our own. This delete method can delete normal canvas items and our mega-items.

sub delete {
    my($self, @ids) = @_;
    foreach my $id (@ids) {
        if ($id >= 0) {
            $self->SUPER::delete($id);
        } else {
            $self->SUPER::delete(@{$ids{$id}});
            delete $ids{$id};
        }
    }
}

Now all we have to do is override every Canvas method that accepts an item ID. This is a satisfactory solutionand is the preferred solution if this is to be a drop-in replacement for the Canvas widget.

However, there's a middle ground that saves undue work for us, the mega-widget writers, and the user, if we're willing to stick to Canvas tags for identifying mega-items. User code can just do this:

$cp->createPiePlot(-tags => 'pie-tag', ... );

The only modification to CanvasPlot is to pass %args on all item creation commands:

$self->createArc(
    $x1, $y1, $x2, $y2,
    %args,
    -start  => $degrees,
    -extent => $arc,
    -style  => 'pieslice',
    -fill   => $color,
);

This allows users to supply any Canvas options they desire.

14.5.3. Tk::LCD

The Liquid Crystal Display (LCD) widget is derived from the Canvas widget and displays positive or negative integers. Each digit of the number is shown in an LCD element, consisting of seven segments that can be turned on or off. We'll label these segments a through g, as shown in Figure 14-14.

Figure 14-14. LCD widget

The segment shapes are defined using Canvas polygon items.[37] Figure 14-15 shows an LCD widget with 11 elements. You can easily see the segments, as well as which segments are on and which are off for each digit.

[37] Their coordinates came from Donal K. Fellows' game of Maze.

Figure 14-15. LCD widget with 11 elements

Here's how to use the widget:

use Tk::LCD;
my $lcd = $mw->LCD(-elements => 11)->pack;

Simple, eh? Since the segments are polygons, they have fill and outline colors too, so we can colorize the widget. There are two ways to specify the number to display: the set method or the -variable option. The -variable option requires Tie::Watch, which isn't discussed until Chapter 15, "Anatomy of the MainLoop", so we'll only touch on it briefly here. Let's look at the module in detail now.

Here is the standard mega-widget header, marking Tk::LCD as a derived Canvas widget. We also declare some class global variables.

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

package Tk::LCD;

use base qw/Tk::Derived Tk::Canvas/;
use vars qw/$ELW %SHAPE %LLCD %ULCD/;
use subs qw/ldifference/;
use strict;

Construct Tk::Widget 'LCD';

# LCD class data.

$ELW = 22;                      # element pixel width

Here are the relative Canvas coordinates for the shapes of each of the seven segments:

%SHAPE = (
    'a' => [qw/ 3.0  5  5.2  3  7.0  5  6.0 15  3.8 17  2.0 15/],
    'b' => [qw/ 6.3  2  8.5  0 18.5  0 20.3  2 18.1  4  8.1  4/],
    'c' => [qw/19.0  5 21.2  3 23.0  5 22.0 15 19.8 17 18.0 15/],
    'd' => [qw/17.4 21 19.6 19 21.4 21 20.4 31 18.2 33 16.4 31/],
    'e' => [qw/ 3.1 34  5.3 32 15.3 32 17.1 34 14.9 36  4.9 36/],
    'f' => [qw/ 1.4 21  3.6 19  5.4 21  4.4 31  2.2 33  0.4 31/],
    'g' => [qw/ 4.7 18  6.9 16 16.9 16 18.7 18 16.5 20  6.5 20/],
);

To display an LCD symbol we must turn certain segments on and off. %LLCD defines a list of segments to turn on for any particular symbol.

%LLCD = (
    '0' => [qw/a b c d e f/],
    '1' => [qw/c d/],
    '2' => [qw/b c e f g/],
    '3' => [qw/b c d e g/],
    '4' => [qw/a c d g/],
    '5' => [qw/a b d e g/],
    '6' => [qw/a b d e f g/],
    '7' => [qw/b c d/],
    '8' => [qw/a b c d e f g/],
    '9' => [qw/a b c d e g/],
    '-' => [qw/g/],
    ' ' => [''],
);

Similarly, %ULCD defines a list of LCD element segments to turn off for any particular symbol. Rather than manually generating the list of unlit segments, %ULCD is dynamically computed as the set difference of qw/a b c d e f g/ and the lit segments.

$ULCD{$_} = [ ldifference [keys %SHAPE], \@{$LLCD{$_}} ] foreach (keys %LLCD);

Subroutine Populate only defines additional configuration specifications for the new mega-widget. Construct has done all the hard work of making LCD like a Canvas, remember?

sub Populate {

    my($self, $args) = @_;
    $self->SUPER::Populate($args);

    $self->ConfigSpecs(
        -elements   => [qw/METHOD  elements   Elements   5/    ],
        -height     => [$self, qw/ height     Height     36/   ],
        -onoutline  => [qw/PASSIVE onoutline  Onoutline  cyan/ ],
        -onfill     => [qw/PASSIVE onfill     Onfill     black/],
        -offoutline => [qw/PASSIVE offoutline Offoutline white/],
        -offfill    => [qw/PASSIVE offfill    Offfill    gray/ ],
        -variable   => [qw/METHOD  variable   Variable/, undef ],
    );

} # end Populate

The only public method is set, which is responsible for creating all the lit and unlit segments and moving them to the proper spots on the Canvas. Each segment is tagged with the string lcd so it can be deleted on the next call.

# Public methods.

sub set {                       # show an LCD number

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

    my $offset  = 0;
    my $onoutl  = $self->cget(-onoutline);
    my $onfill  = $self->cget(-onfill);
    my $offoutl = $self->cget(-offoutline);
    my $offfill = $self->cget(-offfill);

    $self->delete('lcd');

    foreach my $c (split '', sprintf '%' . $self->{elements} . 'd', $number) {
        foreach my $symbol (@{$LLCD{$c}}) {

            $self->move(
                        $self->createPolygon(
                            $SHAPE{$symbol},
                            -tags    => 'lcd',
                            -outline => $onoutl,
                            -fill    => $onfill,
                        ),
            $offset, 0);

        }
        foreach my $symbol (@{$ULCD{$c}}) {

            $self->move(
                        $self->createPolygon(
                            $SHAPE{$symbol},
                            -tags    => 'lcd',
                            -outline => $offoutl,
                            -fill    => $offfill,
                        ),
            $offset, 0);

        }
        $offset += $ELW;
    } # forend all characters

} # end set

Now for Tk::LCD private methods. Subroutine elements is invoked when the user configures the LCD -elements option. The Canvas is resized to fit the new LCD dimensions exactly.

sub elements {

    my ($self, $elements) = @_;
    $self->{elements} = $elements;
    $self->configure(-width => $elements * $ELW);

} # end elements

Subroutine ldifference (list difference) computes the difference of two lists. It's basically right from the Camel (Programming Perl, O'Reilly) or The Perl FAQ.

sub ldifference {               # @d = ldifference \@l1, \@l2;

    my($l1, $l2) = @_;
    my %d;
    @d{@$l2} = (1) x @$l2;
    return grep(! $d{$_}, @$l1);

} # end ldifference

Subroutine variable handles the -variable option. Like other widgets with this option, it expects a reference to a scalar. When the scalar changes, the LCD display changes too. It uses Tie::Watch (described fully in Chapter 15, "Anatomy of the MainLoop") to watch the variable and magically invoke the set method. Notice the OnDestroy handler that removes the watchpoint when the LCD widget is destroyed.

sub variable {

    use Tie::Watch;

    my ($lcd, $vref) = @_;

    my $st = [sub {

        my ($watch, $new_val) = @_;
        my $argv= $watch->Args('-store');
        $argv->[0]->set($new_val);
        $watch->Store($new_val);

    }, $lcd];

    $lcd->{watch} = Tie::Watch->new(-variable => $vref, -store => $st);

    $lcd->OnDestroy( [sub {$_[0]->{watch}->Unwatch}, $lcd] );

} # end variable

1;


14.4. Composite Mega-Widgets		14.6. Packaging a Mega-Widget for Public Distribution

14.5. Derived Mega-Widgets