Interfacing tkSquare.c with Perl/Tk (Mastering Perl/Tk)

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.1. Makefile.PL

The topmost Makefile.PL is a Perl program written in a specialized MakeMaker language enhanced for generating Perl/Tk Makefiles. The OBJECT attribute includes pTk/tkSquare.o to satisfy the external Tk_SquareCmd. For more information, read the ExtUtils::MakeMaker documentation.

use Tk::MMutil;

Tk::MMutil::TkExtMakefile(
    'NAME'         => 'Tk::Square',
    'VERSION_FROM' => 'Square.pm',
    'OBJECT'       => '$(O_FILES) pTk/tkSquare.o',
);

21.2.2. Square.xs

This extension subroutine, or XSUB, lets Perl call Tk_SquareCmd. Of special note are Tk's VTABLES (vector tables), which are structs with pointers to functions as their members. The vector tables provide a modular, operating system-independent means for dynamically loadable Tk modules (.so for Unix, .dll for Win32) to call externals in other loadables. The .m files define macros that transform apparent function calls into vector table lookups.

#include <EXTERN.h>          /* standard ... */
#include <perl.h>            /* ... XSUB ... */
#include <XSUB.h>            /* ... headers  */

#include "tkGlue.def"        /* map Tcl structs to Perl SV * etc. */

#include "pTk/tkPort.h"      /* OS dependant definitions */
#include "pTk/tkInt.h"       /* Tk widget internals */ 
#include "pTk/tkVMacro.h"    /* includes the *.m files etc. for you */
#include "tkGlue.h"          /* _The_ Perl <-> Tk glue header */
#include "tkGlue.m"          /* header functions as macros via table */

extern int Tk_SquareCmd _ANSI_ARGS_((ClientData, Tcl_Interp *, int, Arg *));

DECLARE_VTABLES;             /* declare the pointers to tables */

MODULE = Tk::Square PACKAGE = Tk

PROTOTYPES: DISABLE

void
square(...)
CODE: 
{
    XSRETURN(XSTkCommand(cv, Tk_SquareCmd, items, &ST(0)));
}

BOOT: 
{
    IMPORT_VTABLES;
}

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

21.2.4. pTk/Makefile.PL

This special Makefile.PL program serves two main purposes: it determines the location of installation include and executable files, and it munges all the hand-edited C files in pTk/mTk/generic.

use File::Basename;
use Tk::MMutil;
use strict;

my $inst_tk = Tk::MMutil::installed_tk( );
my $inst_inc  = "$inst_tk/pTk";

Tk::MMutil::TkExtMakefile(
    'OBJECT' => '$(O_FILES)',
    'INC'    => " -I${inst_inc}",
    'clean'  => {'FILES' => 'tkSquare.c'},
);

sub MY::post_initialize {

    my $self = shift;

    my $perl = $self->{'PERL'};
    foreach my $tcl (<mTk/generic/*.c>) {
        my $ptk = basename $tcl;
        print "Munging $tcl -> $ptk\n";
        system ($perl, "$inst_tk/pTk/Tcl-pTk", $tcl, $ptk );
    }

    push @{$self->{O_FILES}}, "\ttkSquare.o";

    '';
}