Book HomeMastering Perl/TkSearch this book

14.4. Composite Mega-Widgets

There are several composite mega-widgets in the Perl/Tk distribution; DialogBox and LabEntry are two simple ones. Before we delve into derived mega-widgets, here's a final, more complex composite.

14.4.1. Tk::Thermometer

This Thermometer widget is Frame-based and capable of displaying temperature in Kelvin, Celsius, or Fahrenheit. The default temperature scale is Kelvin, but is easily changed when the widget is instantiated.

my $therm = $mw->Thermometer(
    -label  => 'Reactants Temp',
    -tscale => 'Celsius',
)->pack;
$therm->set(-273);

Figure 14-9 shows the results of these statements. The mega-widget consists of a Scale widget packed on the left side of the Frame and three Radiobuttons packed vertically on the right. Instead of labeling the Radiobuttons with text, Pixmap images are used. Notice that the entire mega-widget is a uniform, white background color. This is because the configuration specifications were cleverly devised so that the Frame, Scale, and Radiobuttons all receive -background configure requests. Other configuration specifications define the default look of the mega-widget, from its width and height to the size of the slider. The beauty of using configuration specifications is that none of this is hardcoded in the mega-widget. Users are free to make changes as they see fit, either during widget creation or in later calls to configure.

Figure 14-9

Figure 14-9. A Frame-based Thermometer widget

The module, Thermometer.pm, begins in the standard fashion by declaring the version, class name, required widgets, and base class, as well as building a constructor.

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

package Tk::Thermometer;

use Tk::widgets qw/Radiobutton Scale/;
use base qw/Tk::Frame/;
use strict;

Construct Tk::Widget 'Thermometer';

Here we declare two class variables[35] that manage data available to the entire class.

[35] This book is not about object-oriented techniques. Package-scoped lexicals are fine for this example, but you may find ideas in perltoot more to your liking.

%PIXMAPS stores the three Radiobutton Pixmap images. These images are created once during class initialization and shared by all Thermometer instances. @TSCALES is an array of supported temperature scales.

my %PIXMAPS;                           # images for the class
my @TSCALES = qw/Kelvin Celsius Fahrenheit/;

We don't have any class bindings, but ClassInit is a perfect place to create all our images (see Chapter 17, "Images and Animations") and store their references in a hash indexed by temperature scale name.

sub ClassInit {

    my($class, $mw) = @_;
    $class->SUPER::ClassInit($mw);
    
    foreach my $unit (@TSCALES) {
        $PIXMAPS{$unit} = $mw->Pixmap(-file => "images/$unit.xpm");
    }

} # end ClassInit

sub Populate {

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

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

Component creates the vertical Scale widget and advertises it with the name "scale", which we then pack left.

    my $scale = $self->Component(qw/Scale scale -orient vertical/);
    $scale->pack(qw/-side left -fill both -expand 1/);

Each Thermometer object holds two instance variables that store the old and new temperature scales. When a Radiobutton is pushed, changing the temperature scale, the current temperature is converted from the old to the new units. These two variables determine the name of the conversion subroutine.

    $self->{tscale} = $self->{old_tscale} = $TSCALES[0];

The highlightthickness borders surrounding the subwidgets create visual boundaries that detract from the overall appearance of the mega-widget. The @highlightthickness array stores a list of widgets whose -highlightthickness options we wish to configure, beginning with the Scale widget.

    my @highlightthickness = $scale;

Create a Radiobutton for each temperature scale and label it with a Pixmap. The current (or new) temperature scale is stored in the instance variable pointed to by -variable. When the Radiobutton is selected, the instance variable is updated with the new temperature scale and the -command callback is invoked. Also, add the Radiobutton to the @highlightthickness array.

    foreach my $unit (@TSCALES) {
        my $r = $self->Component('Radiobutton' => "radiobutton-$unit",
            -image    => $PIXMAPS{$unit},
            -variable => \$self->{tscale},
            -value    => $unit,
            -command  => [$self => 'tscale', $unit],
        )->pack(-side => 'top');
        push @highlightthickness, $r;
    }

The following ConfigSpecs call has several interesting features. To color the entire background, we need to specify SELF (the Frame) and DESCENDANTS (all widgets descended from the Frame: the Scale and Radiobuttons).

The -from, -length, -sliderlength, -to, and -width options all apply to only the Scale widget.

The -highlightthickness option applies to all subwidgets in the array @highlightthickness, which includes the Scale and Radiobuttons. But for this mega-widget, that's the same as saying DESCENDANTS, so we could have saved some code.

The -tscale option invokes the like-named method tscale. The method is supplied two arguments: the mega-widget reference and the new -tscale value (a temperature scale). We'll look at subroutine tscale shortly.

Any other mega-widget options default to the Scale.

In all cases, Perl/Tk uses the default ConfigSpecs value for options omitted by the user.

    $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],
    );
    $self->Delegates('DEFAULT' => $scale);

} # end Populate

When the Thermometer's temperature scale is changed, either programmatically by a configure(-tscale => $new_tscale) call or a Radiobutton click, we must convert the Scale's temperature value to the new units. The Thermometer class has various methods for converting from one temperature scale to another, having names of the form "old_scale2new_scale". All we need do is get the Scale's current temperature value, convert it to the new units, and update the Scale. Notice the use of Subwidget to fetch the advertised Scale widget reference.

tscale is called also on cget requests, so the subroutine both sets and gets the temperature scale.

sub tscale {

    # The temperature scale has changed - update the thermometer's
    # lower bound and reset the current temperature in the new scale.

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

    if ($#_ > 0) {
        my $old_tscale = $self->{old_tscale};
        return if $new_tscale eq $old_tscale;

        my $subr = "${old_tscale}2${new_tscale}";
        $self->{tscale} = $self->{old_tscale} = $new_tscale;
        my $scale = $self->Subwidget('scale');
        $scale->set( $self->$subr( $scale->get ) );
    } else {
        $self->{tscale};    # cget( ) requests here
    }

} # end tscale

# Scale conversion data and subroutines.
#
#   Temperature     Kelvin   Celsius   Fahrenheit
#
#   Absolute Zero        0   -273.16      -459.69
#   Freezing        273.16         0           32
#   Boiling         373.16       100          212

use constant ABSZ_CELSIUS    => -273.16;
use constant ABSZ_FAHRENHEIT => -459.69;
use constant ABSZ_KELVIN     => 0;
use constant FREZ_FAHRENHEIT => 32;
use constant FIVE_NINTHS     => 5.0 / 9.0;
use constant NINE_FIFTHS     => 9.0 / 5.0;

# All conversion subroutines are called with two arguments, the
# mega-widget reference, and the temperature in the old scale.

sub Kelvin2Celsius {
    $_[0]->configure(-to => ABSZ_CELSIUS);
    $_[1] + ABSZ_CELSIUS;
}

sub Kelvin2Fahrenheit {
    $_[0]->configure(-to => ABSZ_FAHRENHEIT);
    NINE_FIFTHS * ( $_[1] + ABSZ_CELSIUS ) + FREZ_FAHRENHEIT;
}

sub Celsius2Kelvin {
    $_[0]->configure(-to => ABSZ_KELVIN);
    $_[1] - ABSZ_CELSIUS;
}

sub Celsius2Fahrenheit {
    $_[0]->configure(-to => ABSZ_FAHRENHEIT);
    NINE_FIFTHS * $_[1] + FREZ_FAHRENHEIT;
}

sub Fahrenheit2Kelvin {
    $_[0]->configure(-to => ABSZ_KELVIN);
    FIVE_NINTHS * ( $_[1] - FREZ_FAHRENHEIT ) - ABSZ_CELSIUS;
}

sub Fahrenheit2Celsius {
    $_[0]->configure(-to => ABSZ_CELSIUS);
    FIVE_NINTHS * ( $_[1] - FREZ_FAHRENHEIT );
}

1;


Library Navigation Links

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