trying out Tk.pm

[Chris Benson]

I just came across these old demo scripts and since Alice is using Tk, I
thought I'd forward them to the list just for info.

tk1		two buttons, anonymous and named subs
tk2		button + label + entry
tk-grid		using a grid to layout label + entry
tk-query	a database query app!

Best wishes
-- 
Chris Benson
-------------- next part --------------
#!/usr/bin/perl -w
use strict;
use Tk;

my $main = new MainWindow;
my $b1 = $main->Button( -text => "Press me!", 
			-command => sub {print "Ouch!\n"});
$b1->pack;
my $b2 = $main->Button( -text => "Quit", -command => \&b2 );
$b2->pack;
MainLoop;

sub b2 { print "Done!\n"; exit }
-------------- next part --------------
#!/usr/bin/perl -w
use strict;
use Tk;
my $main = new MainWindow;
$main->Button( -text => "Quit", -command => \&b2 )->pack(-side=>'bottom');
$main->Label( -text => "Message")->pack(-side=>'left');
my $e1 = $main->Entry( -width => 30 );
$e1->pack(-side => 'right', -fill => 'x');
MainLoop;
sub b2 { print $e1->get ? $e1->get : 'Bye!'; exit }
-------------- next part --------------
#!/usr/bin/perl -w
use Tk;
use strict;
my($r, $c) = (0, 0);
my $main = new MainWindow;
$main->Label(-text => 'Entry1')->grid(-row => $r, -column => $c++);
$main->Entry(-width => 20)->grid(-row => $r, -column => $c);
++$r; $c = 0;
$main->Label(-text => 'Entry2')->grid(-row => $r, -column => $c++);
$main->Entry(-width => 10)->grid(-row => $r, -column => $c);
MainLoop;
-------------- next part --------------
#!/usr/bin/perl -w
use Tk;
use DBI;
use strict;
use diagnostics;

# open the database
my $db = 'DBI:mysql:ipp';
$main::dbh = DBI->connect($db, $ENV{USER}) or
	die "$0: can't connect to database: $DBI::errstr\n";

# draw the screen
my $main = new MainWindow;
my $out = $main->Frame( -borderwidth => 2, -relief => 'groove');
$out->pack( -side => 'bottom', -fill => 'both');

my $msg = $main->Label( -width => 60, -anchor => 'w');
$msg->pack( -side => 'bottom', -fill => 'x');

$main->Label( -text => 'SQL Query')->pack( -side => 'left');
$main->Button( -text => 'Run Query', -command => \&run_query)->pack( -side => 'right');

my $e = $main->Entry( -width => 30);
$e->pack( -fill => 'x', -expand => 1);

# start!
MainLoop;

#######################################
# utility/callback functions

sub run_query {

	# clear anything in the listbox
	my $x;
	foreach $x ( $out->gridSlaves ) {
		$x->destroy;
	}

	# run the query
	unless ( $e->get ) {
		$msg->configure(-text => 'Please enter a query first!');
		return;
	}
	my $sth;
	unless ( $sth  = $main::dbh->prepare( $e->get ) ) {
		$msg->configure(-text => "Prepare failed!: $DBI::errstr");
		return;
	}
	unless ( $sth->execute ) {
		$msg->configure(-text => "Execute failed!: $DBI::errstr");
		return;
	}
	
	# get results and push into listbox
	$msg->configure(-text => "Running ...");
	$main->idletasks;	# so we can see the message
	
	## get column names and display
	my ($r, $c) = (0,0);
	foreach $x ( @{$sth->{NAME}} ) {
		$out->Label(-text => $x)->grid(-row=>$r, -column=>$c++);
	}
	++$r; $c = 0;

	my @x;
	while ( @x = $sth->fetchrow_array ) {
		foreach $x (@x) {
			$out->Label(-text => $x)->grid(-row=>$r, -column=>$c++,
				-sticky => ($x =~ /^\d+$/) ? 'e' : 'w');
		}
		++$r; $c = 0;
	}

	# done
	$msg->configure(-text => "Selected ".$sth->rows." rows.");
	$sth->finish;
}