home | O'Reilly's CD bookshelfs | FreeBSD | Linux | Cisco | Cisco Exam    

Book HomeMastering Perl/TkSearch this book

21.2. Interfacing tkSquare.c with Perl/Tk

After creating the Tk-Square-1.0 directory structure depicted in Figure 21-2, copy the hand-edited tkSquare.c to pTk/mTk/generic. Create the MANIFEST file containing these lines:

MANIFEST
Makefile.PL
Square.pm
Square.xs
pTk/Makefile.PL
pTk/mTk/generic/tkSquare.c
t/square_demo.t

21.2.3. Square.pm

This Perl module bootstraps the Tk::Square loadable and defines class and instance methods and definitions. The Makefile.PL VERSION_FROM attribute directs MakeMaker to get the module's version number from this file. As with pure Perl mega-widgets, Construct plugs a "Square" symbol in Tk::Widget's symbol table, which is a code reference that invokes Tk::Widget::new.

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

package Tk::Square; 

use AutoLoader;
use Tk qw/Ev/;
use strict;

use base qw/Tk::Widget/;
Construct Tk::Widget 'Square';

bootstrap Tk::Square $Tk::VERSION; 
sub Tk_cmd {\&Tk::square} 

Tk::Methods(qw/cget configure position size/);

1;

For better performance, make autosplits subroutines after the _ _END__ statement, writing each to a separate .al file. Hopefully, the comments in each make the code self-explanatory.

__END__

sub ClassInit {

    # Establish bindings for class Square.

    my ($class, $mw) = @_;

    $class->SUPER::ClassInit($mw);

    my $move = ['move' =>, Ev('x'), Ev('y')];
    $mw->bind($class, '<1>'         => $move);
    $mw->bind($class, '<B1-Motion>' => $move);
    $mw->bind($class, '<a>'         => ['animate']);

} # end ClassInit

sub InitObject {

    # C widgets don't have a Populate( ) method (Tk::Derived
    # is not in their @ISA array). InitObject( ) performs per
    # instance Square initialization.

    my($self, $args) = @_;
    
    $self->SUPER::InitObject($args);
    $self->{-count} = 0;     # animation cycle count
    
} # end InitObject

sub animate  {

    # A <KeyPress-a> event invokes this callback to start or stop
    # a Square's animation.  Vary the size between 10 and 40 pixels.

    my $self = shift;

    if ($self->{-count} == 0) {
        $self->{-count} = 3;
        $self->{-tid} = $self->repeat(30 => [sub {
            my $self = shift;
            return if $self->{-count} == 0;
            my $s = $self->size;
            if ($s >= 40) {$self->{-count} = -3}
            if ($s <= 10) {$self->{-count} = +3}
            $self->size($s + $self->{-count});
        }, $self]);
    } else {
        $self->{-count} = 0;
        $self->afterCancel($self->{-tid});
    }

} # end animate

sub move {

    # Move a Square to the specified coordinate.

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

    my $s = $self->size;
    $self->position($x - ($s / 2), $y - ($s / 2));

} # end move

Finally, we complete the module with POD documentation.

=head1 NAME

Tk::Square - Create a Tk::Square widget.

=for pm Tk/Square.pm

=for category Tk Widget Classes

=head1 SYNOPSIS

S<    >I<$square> = I<$parent>-E<gt>B<Square>(I<-option> =E<gt> I<value>, ... );

=head1 DESCRIPTION

Create a B<Square> widget.

=over 4

=item B<-dbl>

Double buffer iff true.

=back

=head1 METHODS

=over 4

=item C<$square-E<gt>B<size>;>

Change the size of the Square.

=item C<$square-E<gt>B<position>(I<x>, I<y>);>

Move the Square to coordinate (I<x>,I<y>).

=back

=head1 DEFAULT BINDINGS

Perl/Tk automatically creates class bindings for Square widgets
that give them the following behaviour. 

=over 4

=item B<<B1>>

Move Square's top-left corner to cursor position.

=item B<<B1-Motion>>

Continuously move Square's top-left corner to cursor position.

=item B<<a>>

Starts/stop the Square's animation mode.

=back

=head1 AUTHORS

The Tcl/Tk group, Nick Ing-Simmons and Steve Lidie.

=head1 EXAMPLE

I<$square> = I<$mw>-E<gt>B<Square>(-dbl =E<gt> 0);

=head1 KEYWORDS

square, widget

=cut


Library Navigation Links

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











??????????????@Mail.ru