#!/usr/local/bin/perl -w
# tkmain.pl -- using perl/tk
use strict;
use Tk;
# declaration of variables
my ($mw, $btn1, $btn2, $btn3, $btnx);
my ($entry);
my $var;
# create main window
$mw = MainWindow->new();
# create three buttons
$btn1 = $mw->Button(-text => "Hello World",
-command => \&greeting);
$btn2 = $mw->Button(-text => "Arg 1",
-command => [\&btn, "A1"]);
$btn3 = $mw->Button(-text => "Arg 2",
-command => [\&btn, "A2"]);
$btnx = $mw->Button(-text => "Exit",
-command => sub { exit 0; });
# create a text entry widget
$entry = $mw->Entry(-textvariable => \$var);
# bind the entry Return-Event to an anonymous sub
$entry->bind('<Return>',
sub { print "You said: $var\n"; });
# pack everything
$btn1->pack(-fill => 'x');
$btn2->pack(-fill => 'x');
$btn3->pack(-fill => 'x');
$btnx->pack(-fill => 'x');
$entry->pack(-fill => 'x', -padx => '1c', -pady => '1c');
# enter main event loop
MainLoop;
# the callbacks
sub greeting
{
print "Hello World!\n";
}
sub btn
{
my ($arg1) = @_;
print "You entered: $arg1\n";
}
Zurück
#!/usr/local/bin/perl -w
# tkbutton.pl -- demo of button widgets
use strict;
use Tk;
# declaration of the used variables
my ($mw, $btn1, $btn2, $btn3, $btn4, $btnxit);
my ($btnin, $btnvar, $btndis);
my ($now, $then);
# first of all, create a main window
$mw = MainWindow->new();
# create some buttons
#### calling an anonymous subroutine
$btn1 = $mw->Button(-text => "Anonymous Subroutine",
-command => sub { system("date"); });
#### calling a named subroutine
$btn2 = $mw->Button(-text => "Calling a named sub",
-command => \&hello);
#### calling a named subroutine with parameters passing
$btn3 = $mw->Button(-text => "Passing two args",
-command => [\&btn, "Arg1", "Arg2"]);
#### calling the same named subroutine, with
#### another parameter
$btn4 = $mw->Button(-text => "Passing one arg",
-command => [\&btn, "XYZ"]);
#### calling an anonymous subroutine,
#### quitting the program
$btnxit = $mw->Button(-text => "Exit",
-command => sub { exit 0; });
#### creating a button with init variable
$now = localtime(time);
$btnin = $mw->Button(-text => $now,
-command => [\&btn, "time", "init"]);
#### creating a button with variable text
$then = localtime(time);
$btnvar = $mw->Button(-textvariable => \$then,
-command => sub { $then = localtime(time) });
#### creating a disabled button
$btndis = $mw->Button(-text => "I am disabled",
-state => "disabled",
-command => sub { print "never called" });
# display everything
$btn1->pack(-fill => 'both', -expand => 'yes');
$btn2->pack(-fill => 'both', -expand => 'yes');
$btn3->pack(-fill => 'both', -expand => 'yes');
$btn4->pack(-fill => 'both', -expand => 'yes');
$btndis->pack(-fill => 'both', -expand => 'yes');
$btnin->pack(-fill => 'both', -expand => 'yes');
$btnvar->pack(-fill => 'both', -expand => 'yes');
$btnxit->pack(-fill => 'both', -expand => 'yes');
# enter main event collecting loop
MainLoop;
# helper routines
sub hello { print "Hello World!\n"; }
sub btn
{
my (@args) = @_;
my $arg;
print "Button pressed.\n";
foreach $arg (@args) {
print "\tArg: $arg\n";
}
}
Zurück
#!/usr/local/bin/perl -w
# tkcheck.pl -- demo of checkbutton widgets
use strict;
use Tk;
# declaration of the used variables
my ($mw, $c1, $c2, $c3, $c4, $c5);
my ($btnxit);
my ($now, $c1_value, $c2_value, $c_common, $c5_value);
# first of all, create a main window
$mw = MainWindow->new();
# create some checkbuttons
#### a simple checkbutton
$c1_value = "I am ready"; # predifined on
$c1 = $mw->Checkbutton(-text => "Ready",
-command => sub { print "c1: $c1_value\n" },
-state => "normal",
-variable => \$c1_value,
-onvalue => "I am ready",
-offvalue => "I ain't ready");
# a checkbutton with dynamic text
$now = localtime(time);
$c2 = $mw->Checkbutton(-textvariable => \$now,
-anchor => "w",
-command => sub { $now = localtime(time) },
-state => "active",
-variable => \$c2_value,
-onvalue => $now,
-offvalue => "No time");
#### c3 and c4 are related
$c3 = $mw->Checkbutton(-text => "Related with next button",
-anchor => "w",
-variable => \$c_common,
-onvalue => "ON",
-offvalue => "OFF");
$c4 = $mw->Checkbutton(-text => "Related with previous button",
-anchor => "w",
-variable => \$c_common,
-onvalue => "ON",
-offvalue => "OFF");
#### c5 is disabled
$c5 = $mw->Checkbutton(-text => "I am disabled",
-anchor => "w",
-state => "disabled",
-command => sub { print "never reached\n" },
-variable => \$c5_value);
# generate an exit-button
$btnxit = $mw->Button(-text => "Exit",
-command => sub { exit 0 });
# display everything
$c1->pack(-anchor => 'w', -fill => 'x');
$c2->pack(-anchor => 'w', -fill => 'x');
$c5->pack(-anchor => 'w', -fill => 'x');
$c3->pack(-anchor => 'w', -fill => 'x');
$c4->pack(-anchor => 'w', -fill => 'x');
$btnxit->pack(-fill => 'both', -expand => 'yes');
# enter main event collecting loop
MainLoop;
Zurück
#!/usr/local/bin/perl -w
# tkradio.pl -- demo of radiobutton widgets
use strict;
use Tk;
# declaration of the used variables
my ($mw);
my (%rf, %rh);
my ($btnxit);
my ($now, $r_ftp, $r_http);
my ($key);
my (%FTP_SERVERS, %HTTP_SERVERS);
# first of all, create a main window
$mw = MainWindow->new();
# create some radiobuttons
#### first group of radiobuttons on common var: $r_ftp
%FTP_SERVERS = ('Koeln' => 'ftp://ftp.rrz.uni-koeln.de',
'Bochum' => 'ftp://ftp.rz.ruhr-uni-bochum.de',
'UU' => 'ftp://ftp.uu.net',
'MIT' => 'ftp://ftp.mit.edu',
'FUNET' => 'ftp://ftp.funet.fi');
foreach $key (sort keys %FTP_SERVERS) {
$rf{$key} = $mw->Radiobutton(-text => $key,
-anchor => "w",
-variable => \$r_ftp,
-value => $FTP_SERVERS{$key},
-command => \&ftp);
$rf{$key}->configure(-state => "active") if ($key =~ /MIT/);
$rf{$key}->configure(-state => "disabled") if ($key =~ /FUNET/);
$rf{$key}->pack(-fill => 'x');
}
$r_ftp = $FTP_SERVERS{"Koeln"}; # select this value as default
#### generate an exit-button
$btnxit = $mw->Button(-text => "Exit",
-command => sub { exit 0 });
$btnxit->pack(-fill => 'both',
-expand => 'yes',
-pady => '1c', -padx => '1c');
#### second group of radiobuttons of common var: $r_http
%HTTP_SERVERS = ('Koeln' => 'http://www.uni-koeln.de',
'Perl' => 'http://www.perl.com',
'Sun' => 'http://www.sun.com');
foreach $key (sort keys %HTTP_SERVERS) {
$rh{$key} = $mw->Radiobutton(-text => $key,
-anchor => "w",
-variable => \$r_http,
-value => $HTTP_SERVERS{$key},
-command => \&http);
$rh{$key}->pack(-fill => 'x');
}
# enter main event collecting loop
MainLoop;
# ----- helper routines
sub ftp { print "you choose ftp: $r_ftp\n"; }
sub http { print "you choose http: $r_http\n"; }
Zurück
#!/usr/local/bin/perl -w
# tkframe.pl -- demo of the frame widgets
use strict;
use Tk;
# declaration of our variables
my ($mw);
my ($f1, $f2, $f3, $f21, $f22);
my ($lab1, $ent1, $lab2, $btn, $lab31, $lab32);
my ($ent1_val);
# first of all, create a main window
$mw = MainWindow->new();
# create three frames
$f1 = $mw->Frame(-relief => 'ridge',
-width => '10c',
-height => '3c',
-borderwidth => '2m');
$f2 = $mw->Frame(-relief => 'sunken',
-width => '10c',
-borderwidth => '2m');
$f3 = $mw->Frame(-relief => 'groove',
-width => '10c',
-height => '3c',
-borderwidth => '2m');
$f1->pack(-padx => '1c', -pady => '1c');
$f2->pack(-padx => '1c', -pady => '1c');
$f3->pack(-padx => '1c', -pady => '1c');
# fill the frame with objects
$lab1 = $f1->Label(-text => 'Filename:');
$ent1 = $f1->Entry(-textvariable => \$ent1_val);
$lab1->pack(-side => 'left', -pady => '0.5c', -padx => '0.3c');
$ent1->pack(-side => 'right', -pady => '0.5c', -padx => '0.3c');
$lab2 = $f2->Label(-text => "This is a sunken frame");
$lab2->pack(-pady => '0.5c', -padx => '1c');
# a nested frame
$f21 = $f2->Frame(-relief => 'raised',
-width => '5c',
-height => '1.5c',
-borderwidth => '2m');
$f21->pack(-pady => '1c', -padx => '1c');
$f21->Label(-text => 'raised')->pack();
# another nested frame
$f22 = $f2->Frame(-relief => 'flat',
-width => '5c',
-height => '1.5c',
-borderwidth => '2m');
$f22->pack(-pady => '0.5c', -padx => '1c');
$f22->Label(-text => 'flat')->pack();
$btn = $f2->Button(-text => "Exit",
-command => sub { exit 0 });
$btn->pack(-fill => 'x', -padx => '1c', -pady => '1c');
$lab31 = $f3->Label(-text => "Selected File:");
$lab32 = $f3->Label(-textvariable => \$ent1_val);
$lab31->pack();
$lab32->pack(-side => 'left', -padx => '1c');
# now enter main event loop
MainLoop;
Zurück
#!/usr/local/bin/perl -w
# tkentry.pl -- demo of entry widgets
use strict;
use Tk;
# declaration of the used variables
my ($mw, $ent1, $ent2, $ent3);
my ($ent1_val, $ent2_val, $ent3_val);
my ($fup, $fdw, $f1, $f2);
my ($btnxit);
# first of all, create a main window
$mw = MainWindow->new();
# create some frames stacked on top of each other
$fup = $mw->Frame()->pack();
$fdw = $mw->Frame()->pack();
$f1 = $fup->Frame()->pack(-side => 'left');
$f2 = $fup->Frame()->pack(-side => 'left');
# create some labels to ask user something
$f1->Label(-text => "Your Name:")->pack(-padx => '1c', -anchor => 'w');
$f1->Label(-text => "Your Age:")->pack(-padx => '1c', -anchor => 'w');
$f1->Label(-text => "Summary:")->pack(-padx => '1c', -anchor => 'w');
# now, create some entry widgets
$ent1 = $f2->Entry(-textvariable => \$ent1_val)->pack();
$ent2 = $f2->Entry(-textvariable => \$ent2_val)->pack();
$ent3 = $f2->Entry(-textvariable => \$ent3_val,
-state => "disabled")->pack();
# bind the <RETURN> event to the updater function
$ent1->bind('<Return>', \&update_val);
$ent2->bind('<Return>', \&update_val);
# create a label widget
# this will mirror the contents of the name
# while being edited
$fdw->Label(-textvariable => \$ent1_val)->pack(-pady => '1c');
# create a quit button
$btnxit = $fdw->Button(-text => "Exit",
-command => sub { exit 0; });
$btnxit->pack(-expand => 'both', -fill => 'both');
# the main event collector loop
MainLoop;
# --- the helper sub
sub update_val {
$ent3_val = "$ent1_val, $ent2_val years old";
}
Zurück
#!/usr/local/bin/perl -w
# tklabel.pl -- demo of the label widget
use strict;
use Tk;
my ($mw, $lab1, $lab2, $lab3);
my ($lab2_var, $lab3_var);
$lab2_var = localtime(time);
$lab3_var = `uname -a`;
# Create a main window
$mw = MainWindow->new();
# Create three labels
$lab1 = $mw->Label(-text => 'Statischer Test');
$lab2 = $mw->Label(-textvariable => \$lab2_var,
-relief => 'groove',
-borderwidth => '2m');
$lab3 = $mw->Label(-text => $lab3_var);
# pack everything
$lab1->pack();
$lab2->pack();
$lab3->pack();
# enter main event loop
MainLoop;
Zurück
#!/usr/local/bin/perl -w
# tklistbox.pl -- demo of listbox widgets
use strict;
use Tk;
# declaration of the used variables
my ($mw, $fup, $fdw, $fl, $fr);
my ($lbs, $lbx, $lbs_val, $lbx_val);
my ($btnxit, $btnsel);
my ($file);
# first of all, create a main window
$mw = MainWindow->new();
# create some frames
$fup = $mw->Frame(-relief => 'ridge',
-borderwidth => '2m')->pack(-pady => '0.5c');
$fdw = $mw->Frame(-relief => 'ridge',
-borderwidth => '2m')->pack(-pady => '0.5c');
$fl = $fup->Frame()->pack(-side => 'left');
$fr = $fup->Frame()->pack(-side => 'left');
# create a single selection listbox
$lbs = $fl->ScrlListbox(-label => 'Single Selection',
-selectmode => 'single',
-height => 5,
-exportselection => 0);
$lbs->pack(-pady => '1c', -padx => '0.5c');
# create an extended selection listbox
$lbx = $fr->ScrlListbox(-label => 'Extended Selection',
-selectmode => 'extended',
-height => 5,
-exportselection => 0);
$lbx->pack(-pady => '1c', -padx => '0.5c');
# fill in the listbox with entries
foreach $file (<*.pl>) {
$lbs->insert(0, $file); # insert at begin
# means reversed list
$lbx->insert("end", $file); # "normal" appending
}
# the lower frame $fdw will contain some status infos,
# a query button and label
# and the exit button
# create the getselection button
$btnsel = $fdw->Button(-text => "Read Selections",
-command => \&read_sel);
$btnsel->pack(-fill => 'both', -pady => '0.5c');
# create the result labels
$fdw->Label(-textvariable => \$lbs_val)->pack(-pady => '0.25c');
$fdw->Label(-textvariable => \$lbx_val)->pack(-pady => '0.25c');
# create a quit button
$btnxit = $fdw->Button(-text => "Exit",
-command => sub { exit 0; });
$btnxit->pack(-fill => 'both', -pady => '0.5c');
# the main event collector loop
MainLoop;
# the helper function
sub read_sel {
my @vals;
$lbs_val = $lbs->Getselected();
@vals = $lbx->Getselected();
$lbx_val = join(',', @vals);
}
Zurück
#!/usr/local/bin/perl -w
# tkmenu.pl -- demo of the menu-related widgets
use strict;
use Tk;
# declaration of our variables
my ($mw);
my ($mb, $m_file, $m_edit, $m_opts, $m_help);
my ($m_help_about);
my ($o_radio, $o_check1, $o_check2);
# create a main window
$mw = MainWindow->new();
# a menu consists of a horizontal menubar,
# with associated submenus
##### first create the horizontal menubar
$mb = $mw->Frame(-relief => 'raised', -bd => 2);
# now put in the menubar some menubuttons
$m_file = $mb->Menubutton(-text => "File",
-underline => 0);
$m_edit = $mb->Menubutton(-text => "Edit",
-underline => 0);
$m_opts = $mb->Menubutton(-text => "Options",
-underline => 0);
$m_help = $mb->Menubutton(-text => "Help",
-underline => 0);
# pack everything from the menubar
$mb->pack(-side => "top", -fill => "x");
$m_file->pack(-side => "left");
$m_edit->pack(-side => "left");
$m_opts->pack(-side => "left");
$m_help->pack(-side => "right");
#### now create the submenus
# the file menus
$m_file->command(-label => "New",
-command => [\&file, "new"]);
$m_file->command(-label => "Open",
-command => [\&file, "open"]);
$m_file->command(-label => "Save",
-command => [\&file, "save"],
-state => "disabled");
$m_file->command(-label => "Save As",
-command => [\&file, "saveas"],
-state => "disabled");
$m_file->separator();
$m_file->command(-label => "Exit",
-underline => 1,
-command => sub { exit 0; });
# the edit submenus
$m_edit->command(-label => "Copy",
-command => [\&edit, "copy"]);
$m_edit->command(-label => "Cut",
-command => [\&edit, "cut"]);
$m_edit->command(-label => "Paste",
-command => [\&edit, "paste"]);
# the opts submenus
$m_opts->command(-label => "Command",
-command => [\&opts, "command"]);
$m_opts->separator();
$m_opts->checkbutton(-label => "Check 1",
-variable => \$o_check1,
-command => [\&opts, "check"]);
$m_opts->checkbutton(-label => "Check 2",
-variable => \$o_check2,
-command => [\&opts, "check"]);
$m_opts->separator();
$m_opts->radiobutton(-label => "Radio 1",
-variable => \$o_radio,
-value => "r1",
-command => [\&opts, "radio"]);
$m_opts->radiobutton(-label => "Radio 2",
-variable => \$o_radio,
-value => "r2",
-command => [\&opts, "radio"]);
# the help submenus
$m_help->command(-label => "Help me",
-command => [\&help, "help"]);
$m_help->separator();
$m_help_about = $m_help->cget(-menu)->Menu();
$m_help->cascade(-label => "About",
-menu => $m_help_about);
$m_help_about->command(-label => "Perl",
-command => [\&about, "perl"]);
$m_help_about->command(-label => "Tk",
-command => [\&about, "tk"]);
$m_help_about->command(-label => "UNIX",
-command => [\&about, "unix"]);
##### finally, call the main event collecting loop
MainLoop;
#### the callbacks
sub file {
my ($arg) = @_;
print "file: $arg\n";
}
sub edit {
my ($arg) = @_;
print "edit: $arg\n";
}
sub opts {
my ($arg) = @_;
print "opts: $arg\n";
print " radio : $o_radio\n";
print " check 1: $o_check1\n";
print " check 2: $o_check2\n";
}
sub help {
my ($arg) = @_;
print "help: $arg\n";
}
sub about {
my ($arg) = @_;
print "about: $arg\n";
}
Zurück
#!/usr/local/bin/perl -w
# tkmessage.pl -- a simple message widget
use strict;
use Tk;
# declaration of our variables
my ($mw, $m1, $m2, $m3, $btnxit);
my ($mess_1, $mess_2, $mess_3);
# first of all, create a main window
$mw = MainWindow->new();
# create some message objects
$mess_1 = "this message is left-justified and is okay";
$mess_2 = "this other message is now horizontally centered";
$mess_3 = "this last message is justified to the right";
$m1 = $mw->Message(-text => $mess_1,
-width => "3.5c",
-justify => "left");
$m2 = $mw->Message(-text => $mess_2,
-width => "3.5c",
-justify => "center");
$m3 = $mw->Message(-text => $mess_3,
-width => "3.5c",
-justify => "right");
$m1->pack(-side => "left");
$m2->pack(-side => "left");
$m3->pack(-side => "left");
# create an exit button
$btnxit = $mw->Button(-text => "Exit",
-command => sub { exit 0 });
$btnxit->pack(-fill => "both", -expand => "both",
-padx => "1c");
# enter the main event collecting loop
MainLoop;
Zurück
#!/usr/local/bin/perl -w
# tkscale.pl -- demo of the scale widget
use strict;
use Tk;
# declaration of our variables
my ($mw, $s_red, $s_green, $s_blue);
my ($pad, $btnxit);
my ($f1, $f2);
# first, create the main window
$mw = MainWindow->new();
# now, create two frames, stacked on top of each other
$f1 = $mw->Frame()->pack();
$f2 = $mw->Frame(-relief => "ridge")->pack(-pady => "1c");
# the lower frame contains a canvas of the target color
$pad = $f2->Canvas(-background => "Black");
$pad->pack();
# the upper frame contains the 3 scales
$s_red = $f1->Scale(-from => 0, -to => 255,
-orient => "vertical",
-label => "Red",
-command => \&redraw);
$s_green = $f1->Scale(-from => 0, -to => 255,
-orient => "vertical",
-label => "Green",
-command => \&redraw);
$s_blue = $f1->Scale(-from => 0, -to => 255,
-orient => "vertical",
-label => "Blue",
-command => \&redraw);
$s_red->pack(-side => "left");
$s_green->pack(-side => "left");
$s_blue->pack(-side => "left");
$s_red->set(0); $s_green->set(0); $s_blue->set(0);
# create an exit button
$btnxit = $f1->Button(-text => "Exit",
-command => sub { exit 0 });
$btnxit->pack(-side => "left",
-expand => "both",
-fill => "both");
# enter the main event collecting loop
MainLoop;
#### helper function
sub redraw {
my $col;
$col = sprintf("#%02x%02x%02x",
$s_red->get(),
$s_green->get(),
$s_blue->get());
$pad->configure(-background => $col);
}
Zurück
#!/usr/local/bin/perl -w
# tktext.pl -- demo of the Tk's Text widget
# (C) 1997/01/29 Farid Hajji
use strict;
use Tk;
# declaration of our variables
my ($mw, $frame);
my ($text, $yscr, $xscr);
my ($fbut, $bread, $bask, $bxit);
# first create a main window
# and a frame, where to put the text widget
# together with the scrollbars
$mw = MainWindow->new();
$frame = $mw->Frame();
# now create a Text Widget,
# and two scrollbars in the Frame
# create the text widget
$text = $frame->Text(-wrap => 'none');
# create two scrollbars,
# and bind them to the $text widget
$yscr = $frame->Scrollbar(-command =>
[yview => $text],
-orient => 'vertical');
$xscr = $frame->Scrollbar(-command =>
[xview => $text],
-orient => 'horizontal');
# bind the $text widget to the scrollbars
$text->configure(-yscrollcommand => [ set => $yscr ]);
$text->configure(-xscrollcommand => [ set => $xscr ]);
# now, pack everything
# --- the frame
$frame->pack(-expand => 'yes', -fill => 'both');
# --- the scrollbars
$yscr->pack(-side => 'right', -fill => 'y');
$xscr->pack(-side => 'bottom', -fill => 'x');
# --- the text widget
$text->pack(-expand => 'yes', -fill => 'both',
-side => 'left');
# ---------------------------------
# Add some Buttons in another frame
$fbut = $mw->Frame();
$bread = $fbut->Button(-text => 'Read Source',
-command => \&do_read);
$bask = $fbut->Button(-text => 'Upper me!',
-command => \&do_upper);
$bxit = $fbut->Button(-text => 'Exit',
-command => sub { exit 0 });
$fbut->pack(-side => 'bottom', -expand => 'both',
-fill => 'both');
$bread->pack(-side => 'left');
$bask->pack(-side => 'left');
$bxit->pack(-side => 'left');
# now, enter the main event loop
MainLoop;
# ------------ helper routines -------------
sub do_read {
# read in the source into text widget
# the source is in $0
open (IFILE, "< $0") or die "can't open $0: $!\n";
while (<IFILE>) {
# DON'T chop()
$text->insert("end", $_);
}
close (IFILE);
}
sub do_upper {
# upper-case every char of every line
my $alltext = $text->get("1.0", "end");
$alltext =~ s/(.*?)\n/uc($1) . "\n"/meg;
$text->delete("1.0", "end");
$text->insert("end", $alltext);
}
Zurück
#!/usr/local/bin/perl -w
# tkbitmaps.pl -- shows Tk's predefined Bitmaps
use strict;
use Tk;
my @BITMAPS = qw ( error gray25 gray50 hourglass info
questhead question warning );
my ($mw, $bm);
# erzeugen wir ein Top-Level Fenster
$mw = MainWindow->new();
# nun erzeugen wir ein Label pro Bitmap
foreach $bm (@BITMAPS) {
$mw->Label(-bitmap => $bm)
->pack(-side => 'left',
-padx => '0.5c');
}
# main event loop
MainLoop;
Vorherige Seite, Nächste Seite, Index, Hauptindex.