Sign In/My Account | View Cart  
advertisement


Listen Print

Creating Custom Widgets
by Steve Lidie | Pages: 1, 2

Since we are a Tk::DialogBox widget at heart, set up a default Cancel button to ensure our superclass' Populate() has a chance to process the option list, then withdraw the window until it's shown. 

    $args->{'-buttons'} = ['Cancel'] unless defined $args->{'-buttons'};
    $self->SUPER::Populate($args);

    $self->withdraw;

Create the canvas with its photo, and store the canvas reference and the image id as instance variables. We'll need access to both later. 

    $self->{can} = $self->Canvas(
        -width  => $cray_w,
        -height => $cray_h,
    )->pack;
    $self->{iid} = $self->{can}->createImage(0, 0,
        -anchor => 'nw',
        -image  => $crayons,
    );

Define the canvas callback that fetches and returns an RGB triplet. The CanvasBind() method operates on the entire canvas, unlike the canvas' bind() method that operates on an individual canvas tag or id. 

    $self->{can}->CanvasBind('<buttonrelease-1>' => [\&pick_color, $self]);

Related Reading
Mastering Perl/TkMastering Perl/Tk
By Steve Lidie & Nancy Walsh
Full Description

Next, create the tiny transparent trapezoids that cover the tip of the 64 crayons, and define the balloon help. When specifying balloon help for one or more canvas items, the balloon widget expects its -msg option to be a reference to a hash, where the hash keys are canvas tags or ids, and the hash values are the balloon help text.

So, we first create an instance variable that references an empty anonymous hash, then invoke the private method make_balloon_items() to do the dirty work. The method creates the canvas polygon items and populates the hash pointed to by $self->{col}. Then, we create the balloon widget, and attach the canvas and help messages. The ballon text appears next to the cursor. 

    $self->{col} = {};         # anonymous hash indexes colors by id
    $self->make_balloon_items;

    $self->{bal} = $self->Balloon;
    $self->{bal}->attach($self->{can},
        -balloonposition => 'mouse', 
        -msg             => $self->{col},
    );

} # end Populate

Here's the class private method make_balloon_items(), which simply makes 64 calls to make_poly().

The 64-crayon Crayola box in divided into 4 sections of 16 crayons each. Each section contains two rows of eight crayons. These subroutine calls create each section, starting with the section's background row, followed by the section's foreground row.

We create the polygons items from back to front so that the canvas stacking order is back to front. This ensures that the balloon help of foreground polygons items takes precedence over background items.

For obvious brevity, most of the make_poly() calls have been removed. 

sub make_balloon_items {

    my ($self) = @_;

    # 16 northwest crayons.

    $self->make_poly(132,   8, 'red');

    # 16 northeast crayons.

    $self->make_poly(306,  61, 'gray');

    # 16 southwest crayons.

    $self->make_poly(107,  97, 'brick red');

    # 16 southeast crayons.

    $self->make_poly(270, 157, 'tumbleweed');

} # end make_balloon_items

Given the coordinates of the point of a crayon, the class private method make_poly() creates a transparent polygon over the tip so we can attach a balloon message to it. The message is the crayon's color, and is stored in the hash pointed to by $self->{col}, indexed by polygon canvas id.

The transparent stipple is important, as it allows balloon events to be seen. The fill color is irrelevant; we just need something to fill the polygon items so events are registered.

If we remove the stipple, then the polygon items covering the crayon tips become visible, as shown in Figure 2. 

    sub make_poly {

        my ($self, $x, $y, $color) = @_;

        my $id = $self->{can}->createPolygon(
            $x-3, $y, $x+3, $y, $x+11, $y+38, $x-11, $y+38, $x-3, $y,
            -fill    => 'yellow',
            -stipple => 'transparent',
        );

        $self->{col}->{$id} = $color;

    } # end make_poly

  Figure 2. -- Crayons with Yellow Tips

Figure 2.

  

Subroutine pick_color() is our last class private method. It demonstrates a rather dubious object oriented programming technique - meddling with the internals of its superclass! But we do this out of necessity, as a workaround for the "balloons do not work with a grab" bug.

We want to override Tk::DialogBox::Show, so we need to know what its waitVariable() is waiting for. It's this variable that the dialog buttons set when we click on them, and it turns out to be $self->{'selected_button'}.

We make pick_color() set the same variable when returning a pixel's RGB values, thus unblocking the waitVariable() and returning the RGB data to the user.

In case you're interested, early-on in the coding I determined the coordinates of each crayon's point by printing $x and $y in this callback. 

    sub pick_color {

        my ($canvas, $self) = @_;
        my ($x, $y) = ($Tk::event->x, $Tk::event->y);
        my $i = $canvas->itemcget($self->{iid}, -image);
        $self->{'selected_button'} = $i->get($x, $y);

    } # end pick_color

Here is our only class public method, Show(). We can't use the standard DialogBox Show() method because the grab interferes with balloon help. So we roll our own, forgoing the modal approach. Control passes from waitVariable() in one of two ways: 1) a color is selected (see pick_color() above), or, 2), the Cancel button is activated. 

    sub Show {

        my ($self) = @_;
        $self->Popup;
        $self->waitVariable(\$self->{'selected_button'});
        $self->withdraw;
        return $self->{'selected_button'};

    } # end Show
And that's it. Until next time ... use Tk;
You can download the class module, associated .GIF file and a test program that uses the new class.

O'Reilly & Associates recently released (January 2002) Mastering Perl/Tk.