The Labs.Com Issue_06_Tk

TPJ: Issue_06_Tk

This is a collection of programs published by The Perl Journal. You can download all source-code also from TPJ: Programs.

1. Adjuster.pl
2. Axis.pl
3. Balloon.pl
4. BrowseEntry.pl
5. Dial.pl
6. DialogBox.pl
7. DialogBox2.pl
8. FileDialog.pl
9. FileSelect.pl
10. Font.pl
11. HList.pl
12. Menus.pl
13. NoteBook.pl
14. Pod.pl
15. WaitBox.pl
16. More Samples on Tk

Download Adjuster.pl

# Adjuster - allow packed widgets to be adjusted by a user.

use Tk::Adjuster;

use vars qw/$top/;

sub Adjuster {

my($demo) = @ARG;

my $demo_widget = $MW->WidgetDemo(

-name => $demo,

-text => 'Adjuster - allow packed widgets to be adjusted by\

a user.',

);

$top = $demo_widget->top;        # get grid master

my(@pack) = qw/-fill both -expand 1/;

my $t1 = $top->Text(qw/-width 20 -height 5/)->packAdjust(@pa\

ck);

foreach (1 .. 10) {$t1->insert('end', "Text 1, line $ARG\n")}

my $t2 = $top->Text(qw/-width 20 -height 5/)->pack(@pack);

foreach (1 .. 10) {$t2->insert('end', "Text 2, line $ARG\n")}

}

Issue_06_Tk 2. Axis.pl

Download Axis.pl

# Axis - a canvas with X and Y axes (a derived widget).

use Tk::Axis;

use vars qw/$top/;

sub Axis {

my($demo) = @ARG;

my $demo_widget = $MW->WidgetDemo(

-name => $demo,

-text => 'Axis - a canvas with X and Y axes (a derived widg\

et).',

-geometry_manager => 'grid',

);

$top = $demo_widget->top;        # get grid master

my$t = $top->Axis(qw/-xmax 10 -ymax 10/)->grid;             \

$t->create('line', $t->plx(1.5), $t->ply(1.5), $t->plx\

(6), $t->ply(9));

}

Issue_06_Tk 3. Balloon.pl

Download Balloon.pl

# Balloon - popup MacOS-like help balloons.

use Tk::Balloon;

use vars qw/$top/;

sub Balloon {

my($demo) = @ARG;

my $demo_widget = $MW->WidgetDemo(

-name => $demo,

-text => 'Balloon - popup MacOS-like help balloons.',

-geometry_manager => 'grid',

);

$top = $demo_widget->top;        # get grid master

my $s = $top->Label(qw/-width 20 -borderwidth 2 -relief sunken/\

)->grid;

my $t = $top->Text(qw/-width 20 -height 5 -background azure/)-&\

gt;grid;

my $balloon = $top->Balloon(-statusbar => $s);

$balloon->attach($s, -balloonmsg => 'See Balloon help here',

-statusmsg => 'This is a Label widget');

$balloon->attach($t, -balloonmsg => 'Type Text Here',

-statusmsg => 'This is a Text widget');

}

Issue_06_Tk 4. BrowseEntry.pl

Download BrowseEntry.pl

# BrowseEntry - a LabEntry widget with a pulldown list.

use Tk::BrowseEntry;

use vars qw/$top/;

sub BrowseEntry {

my($demo) = @ARG;

my $demo_widget = $MW->WidgetDemo(

-name => $demo,

-text => 'BrowseEntry - a LabEntry widget with a pulldown l\

ist.',

-geometry_manager => 'grid',

);

$top = $demo_widget->top;        # get grid master

my $var;

my $be = $top->BrowseEntry(-label => "Label", -variable =>\

; \$var)->grid;

foreach my $opt (1 .. 15) {$be->insert('end', "opt$opt")}

}

Issue_06_Tk 5. Dial.pl

Download Dial.pl

# Dial - a widget similar to an automobile speedometer.

use Tk::Dial;

use vars qw/$top/;

sub Dial {

my($demo) = @ARG;

my $demo_widget = $MW->WidgetDemo(

-name => $demo,

-text => 'Dial - a widget similar to an automobile speedome\

ter.',

-geometry_manager => 'grid',

);

$top = $demo_widget->top;        # get grid master

$top->Dial(qw/-margin 20 -radius 48 -min 0 -max 100 -value 0 -f\

ormat %d/)->grid;

}

Issue_06_Tk 6. DialogBox.pl

Download DialogBox.pl

# DialogBox - like Dialog, but the top frame can contain anything.

use Tk::DialogBox;

use vars qw/$top/;

sub DialogBox {

my($demo) = @ARG;

my $demo_widget = $MW->WidgetDemo(

-name => $demo,

-text => 'DialogBox - like Dialog, but the top frame can co\

ntain anything.',

-geometry_manager => 'grid',

);

$top = $demo_widget->top;        # get grid master

my $d = $top->DialogBox(qw/-title DialogBox -buttons/ => [qw\

/OK Cancel/]);

my $c = $d->add(qw/Canvas -width 160 -height 40/)->grid;

$c->createPolygon(qw/10 10 20 5 10 30 15 30 20 20 10 15 10 10 -\

fill red/);

$c->createText(qw/100 20 -text/ => 'A strange polygon');

$top->Button(qw/-text DialogBox -command/ =>

sub{

print "You selected button ", $d->Show, ".\n";

})->grid;

}

Issue_06_Tk 7. DialogBox2.pl

Download DialogBox2.pl

# DialogBox2 - this demonstration displays a Photo image.

use Tk::DialogBox;

use vars qw/$top/;

sub DialogBox2 {

my($demo) = @ARG;

my $demo_widget = $MW->WidgetDemo(

-name => $demo,

-text => 'DialogBox2 - this demonstration displays a Photo \

image.',

-geometry_manager => 'grid',

);

$top = $demo_widget->top;        # get grid master

my $d = $top->DialogBox(qw/-title DialogBox2 -buttons/ => [q\

w/OK Cancel/]);

$d->add('Frame')->grid;

my $frame = $d->Subwidget('frame');

$frame->Message(-text => 'This DialogBox has a populated fra\

me.')->grid;

$frame->Label(-image => $d->Photo(-file =>

Tk->findINC('demos/images/teapot.ppm')))->grid;

$top->Button(qw/-text DialogBox -command/ =>

sub{

print "You selected button ", $d->Show, ".\n";

})->grid;

}

Issue_06_Tk 8. FileDialog.pl

Download FileDialog.pl

# FileDialog - a fancier version of FileSelect.

use Tk::FileDialog;

use vars qw/$top/;

sub FileDialog {

my($demo) = @ARG;

my $demo_widget = $MW->WidgetDemo(

-name => $demo,

-text => 'FileDialog - a fancier version of FileSelect.',

-geometry_manager => 'grid',

);

$top = $demo_widget->top;        # get grid master

my $fdialog = $top->FileDialog('Path' => $ENV{HOME});

$top->Button(qw/-text FileDialog -command/ =>

sub {

my $fname = $fdialog->Show;

print "You selected $fname.\n" if defined $fname;

print "You canceled.\n" unless defined $fname;

})->grid;

}

Issue_06_Tk 9. FileSelect.pl

Download FileSelect.pl

# FileSelect - a file/directory selector widget.

use Tk::FileSelect;

use vars qw/$top/;

sub FileSelect {

my($demo) = @ARG;

my $demo_widget = $MW->WidgetDemo(

-name => $demo,

-text => 'FileSelect - a file/directory selector widget.',

-geometry_manager => 'grid',

);

$top = $demo_widget->top;        # get grid master

my $fselect = $top->FileSelect(-directory => $ENV{HOME});

$top->Button(qw/-text FileSelect -command/ =>

sub {

my $fname = $fselect->Show;

print "You selected $fname.\n" if defined $fname;

print "You canceled.\n" unless defined $fname;

})->grid;

}

Issue_06_Tk 10. Font.pl

Download Font.pl

# Font - find X fonts.

use Tk::Font;

use vars qw/$top/;

sub Font {

my($demo) = @ARG;

my $demo_widget = $MW->WidgetDemo(

-name             => $demo,

-text             => 'Font - find X fonts.',

-geometry_manager => 'grid',

);

$top = $demo_widget->top;        # get grid master

my $font = $top->Font(qw/foundry adobe family times point 120/)\

;

$top->Label(-text => $font, -font => $font)->grid;

$font = $top->Font('*-courier-medium-r-normal-*-*');

$top->Label(-text => $font, -font => $font)->grid;

}

Issue_06_Tk 11. HList.pl

Download HList.pl

# HList - A hierarchial listbox widget.

use Tk::HList;

use subs qw/show_dir/;

use vars qw/$top/;

sub HList {

my($demo) = @ARG;

my $demo_widget = $MW->WidgetDemo(

-name => $demo,

-text => 'HList - A hierarchial listbox widget.',

-geometry_manager => 'grid',

);

$top = $demo_widget->top;        # get grid master

my $h = $top->Scrolled(qw\HList -separator / -itemtype imagetex\

t\)->grid;

$h->{file_image} = $top->Bitmap(-file => Tk->findINC('\

file.xbm'));

$h->{fold_image} = $top->Bitmap(-file => Tk->findINC('\

folder.xbm'));

$h->configure(-command => sub {

print "Selected $ARG[0], size=", $h->info('data', $ARG[0]) \

,".\n";

});

my $text = Tk->findINC('demos');

chdir $text;

show_dir '.', $text, $h;

}

sub show_dir {

my($entry_path, $text, $h) = @ARG;

opendir H, $entry_path;

my(@dirent) = grep ! /^\.\.?$/, sort(readdir H);

closedir H;

my($file_img, $fold_img) = ($h->{file_image}, $h->{fold_imag\

e});

$h->add($entry_path, -text => $text, -image => $fold_img,\

-data => 'DIR');

while ($ARG = shift @dirent) {

my $file = "$entry_path/$ARG";

if (-d $file) {

show_dir $file, $ARG, $h;

} else {

my $size = -s $file;

$h->add($file, -text => $ARG, -image => $file_img\

, -data => $size);

}

}

} # end show_dir

Issue_06_Tk 12. Menus.pl

Download Menus.pl

# Menus - do neat menu stuff we haven't seen before.

use vars qw/$top/;

sub puts {print "$_[0]\n"}

sub Menus {

my($demo) = @ARG;

my $demo_widget = $MW->WidgetDemo(

-name => $demo,

-text => 'Menus - do neat menu stuff we haven\'t seen befor\

e.',

-geometry_manager => 'grid',

);

$top = $demo_widget->top;        # get grid master

my $menubar = $top->Frame(qw/-bd 5 -relief ridge -bg orange/)-&\

gt;grid;

my $aircraft = 'B-52';

my $file = $menubar->Menubutton(qw/-text File -relief raised -m\

enuitems/ =>

[

[Button    => '~Open', -command => [\&pu\

ts, 'Open']],

[Separator => ''],

[qw/Cascade ~Aircraft -menuitems/ =>

[

[qw/Radiobutton B-52  -variable/ => \$air\

craft],

[qw/Radiobutton B-2   -variable/ => \$air\

craft],

[qw/Radiobutton F-117 -variable/ => \$air\

craft],

[qw/Radiobutton F-22  -variable/ => \$air\

craft],

]],

[Separator => ''],

[Button => '~Popup Menu'],

[Separator => ''],

[Button    => '~Quit', -command =>[\&put\

s, 'Quit'] ],

]

);

$file->grid(qw/-row 0 -column 0/);

my $p = $menubar->Menu(qw/-tearoff 0 -menuitems/ =>

[

[qw/Button Hi -command/ => [\&puts, 'Hi']],

[qw/Checkbutton frog -onvalue 1 -offvalue 0/],

],

);

$file->entryconfigure('Popup Menu', -command => [$p => 'P\

opup']);

my $o = $menubar->Optionmenu(-textvariable => \$aircraft,

-options      => [qw/B-52 B-2 F-11\

7 F-22/],

-command      => sub {print "$airc\

raft!\n"},

-relief       => 'raised');

$o->grid(qw/-row 0 -column 1/);

}

Issue_06_Tk 13. NoteBook.pl

Download NoteBook.pl

# NoteBook - display windows with a notebook metaphor.

use Tk::NoteBook;

use Tk::LabEntry;

use vars qw/$top/;

sub NoteBook {

my($demo) = @ARG;

my $demo_widget = $MW->WidgetDemo(

-name => $demo,

-text => 'NoteBook - display windows with a notebook metaph\

or.',

-geometry_manager => 'grid',

);

$top = $demo_widget->top;        # get grid master

my $name = "Rajappa Iyer";

my $email = "rsi\@somewhere.com";

my $os = "Linux";

# Create the NoteBook and add 2 pages, which are really Frames wit\

h tabs.

# Given that, we create LabEntry widgets and pack them as usual.

my $n = $top->NoteBook(qw/-ipadx 6 -ipady 6/)->pack;

my $address = $n->add(qw/address -label Address     -underline \

0/);

my $pref    = $n->add(qw/pref    -label Preferences -underline \

0/);

$address->LabEntry(-label => "Name:             ", -width =&\

gt; 20,

-labelPack => [qw/-side left -anchor w/],

-textvariable => \$name)->pack(qw/-anchor\

nw/);

$address->LabEntry(-label => "Email Address:", -width => \

50,

-labelPack => [qw/-side left -anchor w/],

-textvariable => \$email)->pack(qw/-ancho\

r nw/);

$pref->LabEntry(-label => "Operating System:",-width => 1\

5,

-labelPack => [qw/-side left/],

-textvariable => \$os)->pack(qw/-anchor nw/)\

;

$top->Button(qw/-text Update -command/ =>

sub {

print "name = $name, email = $email, os = $os\n";

})->pack;

}

Issue_06_Tk 14. Pod.pl

Download Pod.pl

# Pod - Display Plain Old Documentation.

use Tk::Pod;

use subs qw/pod/;

use vars qw/$top/;

sub Pod {

my($demo) = @ARG;

my $demo_widget = $MW->WidgetDemo(

-name => $demo,

-text => 'Pod - Display Plain Old Documentation.',

-geometry_manager => 'grid',

);

$top = $demo_widget->top;        # get grid master

$top->Button(-text => 'Show Pod', -command =>

[$top => 'Pod', -file, pod])->grid;

}

sub pod {

# Write POD data to a file.  Depending upon your application, -fil\

e

# could easily refer to $0, ___FILE__, or even __DATA__.

my $pod = '/tmp/pod.pl.pod';

open(P, ">$pod") or die "Cannot open POD file $pod:  $OS_ERROR"\

;

print P << 'PODEND';

=head1 NAME

Breakout() - a simple game of Breakout.

=head1 SYNOPSIS

use Tk::Breakout;

$breakout = $MW->Breakout(

-balls  => [{-color    => 'yellow',  -size     => 40,

-position => [90, 250], -velocity => [6.0, 9.0\

]},

],

(other canvas creation options ...)

);

=head1 DESCRIPTION

The -balls configure attribute is a list of hash.  Each ball has a col\

or,

a diameter in pixels, a position given by a canvas X/Y coordinate pair\

,

and a velocity that describes how many pixels to translate the ball in

the X and Y dimensions for each game tick.

=head1 METHODS

=over 4

=item B<move_balls($speed);>

$speed is the ball speed, as a percentage.

Essentially, move_balls() is invoked to move all of the balls in a

games's ball list once - from their current to their new postion.

After moving one ball a call to DoOneEvent() is made to handle pending\

XEvents.  The I<user> of this module has their own main loop whi\

ch calls

DoOneEvent() and move_balls() to keep the game active.

=back

=cut

PODEND

close P;

return $pod;

}

Issue_06_Tk 15. WaitBox.pl

Download WaitBox.pl

# WaitBox - a "Please Wait" Dialog with a progress bar.

use Tk::WaitBox;

use vars qw/$top/;

sub WaitBox {

my($demo) = @ARG;

my $demo_widget = $MW->WidgetDemo(

-name => $demo,

-text => 'WaitBox - a "Please Wait" Dialog with a progress \

bar.',

-geometry_manager => 'grid',

);

$top = $demo_widget->top;        # get grid master

my $utxt = 'Initializing...';

my $wb;

$wb = $top->WaitBox(

-txt1          => 'Saving PICT file',

-canceltext    => 'Stop',

-cancelroutine =>

sub {

print "You selected Stop.\n";

$wb->unShow;

$utxt = undef; # tell progress loop to stop

});

# Create a percent-complete label and progress bar in the "user fr\

ame".

# Since this is a WaitBox, the progress loop can be really simple-\

minded.

my $u = $wb->Subwidget('uframe');

$u->pack(-expand => 1, -fill => 'both');

$u->Label(-textvariable => \$utxt)->pack(-expand => 1,\

-fill => 'both');

my $base = $u->Frame(qw/ -relief sunken -borderwidth 2 -height \

20/);

$base->pack(qw/-side left -anchor w -expand 1 -fill both/);

$base->packPropagate(0);

my $bar = $base->Frame(qw/-borderwidth 2 -relief raised -height\

20

-width 0 -background blue/);

$bar->pack(qw/-fill y -side left/);

$top->Button(qw/-text WaitBox -command/ =>

sub {

$wb->Show;

for my $i (1 .. 100) {

after 100;

$bar->configure(-width => int($i / 100 * $base-&\

gt;Width));

$utxt = int(100 * $i / 100) . "% Complete";

$wb->update;

last unless defined $utxt;

};

$wb->unShow;

})->grid;

}

Issue_06_Tk 16. More Samples on Tk

• Issue_01_Tk
• Issue_02_Tk
• Issue_03_Tk
• Issue_04_Tk
• Issue_05_Tk
• Issue_06_Tk
• Issue_07_Tk
• Issue_09_Tk