The Labs.Com Issue_07_Tk

TPJ: Issue_07_Tk

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

1. butbreak
2. butclass
3. butinst
4. buttags1
5. buttags2
6. keysym
7. votext
8. More Samples on Tk

Download butbreak

#!/usr/local/bin/perl -w

#

# butbreak - short circuit the bindtags search using break().

use English;

use Tk;

use strict;

my $mw = MainWindow->new;

my $b = $mw->Button(qw/-text Quit -command/ => \&exit)->grid;

my $noisy_button = $mw->Button(qw/-text NoisyButton -command/ =>\

sub {print "You invoked the <ButtonRelease-1> callback!\n"})\

->grid;

$noisy_button->bind('<ButtonRelease-1>' => [\&beep, 1]);

$noisy_button->bind('<ButtonRelease-2>' => [\&beep, 2]);

$noisy_button->bind('<ButtonRelease-3>' => [\&beep, 3]);

my(@tags) = $noisy_button->bindtags;

$noisy_button->bindtags([@tags[1, 0, 2, 3]]);

MainLoop;

sub beep {

my($button, $count) = @ARG;

while ($count-- > 0) {

$button->bell;                # ring the bell

$button->after(250);

}

$button->break;                # short circuit tag search

}

Issue_07_Tk 2. butclass

Download butclass

#!/usr/local/bin/perl -w

#

# butclass - show Button class bindings.

use Tk;

use strict;

my $mw = MainWindow->new;

my $b = $mw->Button(qw/-text Quit -command/ => \&exit);

my $class = ref $b;

print "Button \$b is an instance of class $class.\n" .

"This class has bindings for these events:\n\n";

print $b->bind($class), "\n";

Issue_07_Tk 3. butinst

Download butinst

#!/usr/local/bin/perl -w

#

# butinst - show a button's instance bindings.

use English;

use Tk;

use strict;

my $mw = MainWindow->new;

my $b = $mw->Button(qw/-text Quit -command/ => \&exit)->grid;

my $noisy_button = $mw->Button(qw/-text NoisyButton -command/ =>\

sub {print "You invoked the <ButtonRelease-1> callback!\n"})\

->grid;

$noisy_button->bind('<ButtonRelease-2>' => [\&beep, 2]);

$noisy_button->bind('<ButtonRelease-3>' => [\&beep, 3]);

my $class = ref $noisy_button;

print "Button \$noisy_button is an instance of class $class.\n" .

"This button has class bindings identical to our button\n" .

"\$b, plus additional instance bindings for these events:\n\n";

print $noisy_button->bind, "\n";

MainLoop;

sub beep {

my($button, $count) = @ARG;

while ($count-- > 0) {

$button->bell;                # ring the bell

$button->after(250);

}

}

Issue_07_Tk 4. buttags1

Download buttags1

#!/usr/local/bin/perl -w

#

# buttags1 - show a button's binding tag list.

use English;

use Tk;

use strict;

my $mw = MainWindow->new;

my $b = $mw->Button(qw/-text Quit -command/ => \&exit)->grid;

my $noisy_button = $mw->Button(qw/-text NoisyButton/);

print "Button \$noisy_button has this default list of binding tags:\n\\

n";

my(@bindtags) = $noisy_button->bindtags;

foreach my $tag (@bindtags) {

print "binding tag = '$tag'\n";

}

Issue_07_Tk 5. buttags2

Download buttags2

#!/usr/local/bin/perl -w

#

# buttags2 - show a button's tags and every tag's bindings.

use English;

use Tk;

use strict;

my $mw = MainWindow->new;

my $b = $mw->Button(qw/-text Quit -command/ => \&exit)->grid;

my $noisy_button = $mw->Button(qw/-text NoisyButton -command/ =>\

sub {print "You invoked two <ButtonRelease-1> callbacks!\n"}\

)->grid;

$noisy_button->bind('<ButtonRelease-1>' => [\&beep, 1]);

$noisy_button->bind('<ButtonRelease-2>' => [\&beep, 2]);

$noisy_button->bind('<ButtonRelease-3>' => [\&beep, 3]);

my $class = ref $noisy_button;

print "Button \$noisy_button is an instance of class $class.\n" .

"This button has class bindings identical to our button\n" .

"\$b, plus additional instance bindings for these events:\n\n";

print $noisy_button->bind, "\n";

print "\nHere are \$noisy_button's binding tags, and each tag's bindin\

gs:\n\n";

foreach my $tag ($noisy_button->bindtags) {

print "  bindtag tag '$tag' has these bindings:\n";

print "    ", $noisy_button->bind($tag), "\n";

}

print "\n";

MainLoop;

sub beep {

my($button, $count) = @ARG;

while ($count-- > 0) {

$button->bell;                # ring the bell

$button->after(250);

}

}

Issue_07_Tk 6. keysym

Download keysym

#!/usr/local/bin/perl -w

#

# keysym - print keyboard character keysysms and the cursor's position\

.

use English;

use Tk;

use strict;

my $mw = MainWindow->new;

$mw->Label(-text => 'Type a character to see its keysym.')->g\

rid;

$mw->Button(qw/-text Quit -command/ => \&exit)->grid;

$mw->bind('<Key>' => \&print_keysym);

MainLoop;

sub print_keysym {

my($widget) = @ARG;

my $e = $widget->XEvent;        # get reference to X11 event st\

ructure

my($keysym_text, $keysym_decimal) = ($e->K, $e->N);

my($X, $Y, $x, $y) = ($e->X, $e->Y, $e->x, $e->y);

print "Character = $keysym_decimal, keysym = $keysym_text" .

" at abs=($X,$Y), rel=($x,$y).\n";

} # end print_keysym

Issue_07_Tk 7. votext

Download votext

#!/usr/local/bin/perl -w

#

# votext - "view only" Text.

use English;

use Tk;

use strict;

my $mw = MainWindow->new;

my $b = $mw->Button(qw/-text Quit -command/ => \&exit)->grid;

my $t = $mw->Text->grid;

$t->insert(qw/end HelloWorld/);

$t->bindtags(undef);

MainLoop;

Issue_07_Tk 8. 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