21.2.1. Makefile.PL

use Tk::MMutil;

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

21.2.2. Square.xs

#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

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

__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

=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

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

    '';
}