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

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', );

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;
}

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

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"; '';
}