Tk::Table example code

[Rob Seegel]

A few folks asked me for example code for Tk::Table so I thought I'd just save
time and post it here in case anyone is interested. Feel free to use and
abuse the code any way you see fit. It's something I whipped up to test
Tk::Table's suitability for a project I was working on a while back.

Cheers!

Rob

#! /usr/local/bin/perl
use Tk;
use Tk::Table;

$cols = 12;
$rows = 10;
%cell;

$mw = new MainWindow();

# Create Table Frame
$tableFrame = $mw->Frame(
-borderwidth => 2,
-relief => 'raised')->pack(
-expand => 'yes',
-fill => 'both');

$table = $tableFrame->Table(
-columns => 10,
-rows => 6,
-fixedrows => 1,
-scrollbars => 'se',
-relief => 'raised');

# Create Column headers
foreach my $c ( 1 .. $cols) {
$hdr = "H" . $c;
$tmp = $table->Label(
-text => $hdr,
-width => 6,
-relief => 'raised');
$table->put( 0, $c, $tmp );
}

# Fill Table with simple cells
# Originally I experiemented with different kinds of
# widgets for each cell. The Table widget will default
# to Label widgets for regular text - I chose to go
# ahead and explicity make them labels. This makes it
# easy for anyone to subst the widget of their choice

foreach my $r ( 1 .. $rows ) {
foreach my $c ( 1 .. $cols ) {
$data = $r . "," . $c;
$tmp = $table->Label(
-text => $data,
-padx => 2,
-anchor => 'w',
-background => 'white',
-relief => 'groove' );

$tmp->bind("<Button-1>", [ \&toggleRow, $table ]);
$table->put( $r, $c, $tmp );
}
}

$table->pack( -expand => 'yes', fill => 'both');

# Create Button bar
$buttonBar = $mw->Frame( -borderwidth => 4 )
->pack(-fill => 'y');

$printB = $buttonBar->Button(
-text => "Print Rows",
-width => 10,
-command => \&printRows);

$exitB = $buttonBar->Button(
-text => "Exit",
-width => 10,
-command => sub { exit });

foreach ( $printB, $exitB ) {
$_->pack(
-side => 'left',
-padx => 2 );
}

MainLoop;

##################################
## Subroutines
##################################

sub printRows {
print "Rows: ";
foreach ( sort numerically(values %cell)) {
print "$_ ";
}
print "\n";
}

sub numerically { $a <=> $b }

sub toggleRow {
my ($w, $t) = @_;

my ($row, $col) = $t->Posn( $w );
if (exists($cell{$row})) {
delete($cell{$row});
showUnselected( $t, $row );
print "Row: $row unselected\n";

} else {
$cell{$row} = int($row);
showSelected( $t, $row );
print "Row: $row selected\n";
}
}

sub showSelected {
my ($t, $r) = @_;
my $w;

print $row;
foreach $c (1 .. $cols) {
$w = $t->get($r, $c);
$w->configure(-background => 'grey');
}
}

sub showUnselected {
my ($t, $r) = @_;
my $w;

foreach $c (1 .. $cols) {
$w = $t->get($r, $c);
$w->configure(-background => 'white');
}
}