Perl TK eksempel
From Teknologisk videncenter
Eksempel 1
#!/usr/local/bin/perl
use Tk;
# Main Window
$mw = new MainWindow;
my $lab = $mw -> Label(-text=>"This is the root window.",
-font=>"ansi 12 bold") -> pack;
my $but = $mw -> Button(-text=>"Click to Create Toplevel",
-command=>\&makeTop) -> pack;
MainLoop;
#A function to make a toplevel window
sub makeTop {
my $top = $mw -> Toplevel(); #Make the window
#Put things in it
my $top_lab = $top -> Label(-text=>"This is the Toplevel window.",
-font=>"ansi 12 bold") -> pack;
my $txt = $top -> Text() -> pack;
$txt -> insert('end', "Widgets can be packed in this window.");
#An option to close the window.
my $but_close = $top -> Button(-text=>"Close",
-command => sub { destroy $top; } ) -> pack;
}
Eksempel 2
#!/usr/bin/perl -w
use strict;
use warnings;
use Tk;
use Net::Ping;
# Main window oprettes
my $i=0;
our $BstartTimer;
my $s2;
my @hosts = ("4.2.2.2", "www.jp.dk");
my $pingCount=0;
my $tv = "Running..";
my $mw = new MainWindow();
$mw->title("TK Perl menu eksempel 1");
#Knapper
my $Lstart = $mw->Label(-text => 'Pingtest ');
my $Bstart = $mw -> Button(-text => "Start", -command =>\&Bstart,
-overrelief => 'sunken', -relief => 'raised',-padx => 20);
my $Bstop = $mw -> Button(-text => "Stop ", -command =>\&Bstop,
-overrelief => 'sunken', -relief => 'raised',
-padx => 20,-state => 'disabled');
#Status felt
my $status = $mw -> Label (
-relief => 'flat' ,
-borderwidth => 2 ,
-height => 1 ,
-width => 40 ,
-justify => 'right' ,
-anchor => 'w',
-textvariable => \$tv );
my $c = " --:--:--";
my $c2=0;
my $clk = $mw -> Label (
-relief => 'ridge' ,
-borderwidth => 1 ,
-height => 1 ,
-width =>10 ,
-justify => 'left' ,
-textvariable => \$c );
$clk->repeat(500,\&mintid);
# Når er trykkes på F2 køres subrutinen menuclicked()
$mw->bind ( "<F2>" , \&menuClicked ) ;
# Når er trykkes på F3 køres subrutinen saveclicked()
$mw->bind ( "<F3>" , \&saveClicked ) ;
#MOpret et scrool-bart tekstområde i $mv (Hoved vindue)
my $txt = $mw->Scrolled('Text',-height => 20,-width => 50,
-scrollbars=>'osoe', -wrap => 'none');
#Opret en menubar i objktet
my $mbar = $mw->Menu();
$mw->configure(-menu => $mbar);
#Hovedenmer i menuen
my $file = $mbar->cascade(-label=>"File", -underline=>0, -tearoff => 0);
my $edit = $mbar->cascade(-label=>"Edit", -underline=>0, -tearoff => 0);
my $devices = $mbar->cascade(-label =>"Enheder", -underline=>0, -tearoff => 0);
my $help = $mbar->cascade(-label =>"Help", -underline=>0, -tearoff => 0);
## File Menu ##
$file -> command(-label => "New", -underline=>0,
-command=>sub { $txt -> delete('1.0','end');} );
$file -> checkbutton(-label =>"Open", -underline => 0,
-command => [\&menuClicked, "Open"],
-accelerator => "F2");
$file -> command(-label =>"Status", -underline => 0,
-command => [\&saveClicked, "Status"],
-accelerator => "F3");
$file -> separator();
$file -> command(-label =>"Exit", -underline => 1,
-command => sub { exit } );
## Enheder Menu ##
my $cisco = $devices -> cascade(-label =>"Cisco udstyr",
-underline => 0, -tearoff => 0);
$cisco -> command(-label =>"Opret enhed",
-command => sub { $txt->insert('end',
"Der oprettes en ny Cisco Router :-)\n");});
$cisco -> command(-label =>"Rediger enhed", -command=>sub {
$txt->insert('end',"Cisco enhed redigeres\n");});
$cisco -> command(-label =>"Slet enhed",
-command=> sub {$txt->insert('end',"Er du nu helt sikker?\n");});
$devices -> command(-label =>"Ping enhed", -underline => 7,
-command => sub { $txt->insert('end',"Ja her burde der pinges\n");});
## Help ##
$help -> command(-label =>"About", -command => sub {
$txt->delete('1.0','end');
$txt->insert('end',"Mercantec - Tk Perl eksempel 1 /HeTh\n")});
{
### Pack windows
$Lstart->grid(-row=>0,-column=>0,-sticky=>'e',-in => $mw);
$Bstart->grid(-row=>0,-column=>1,-sticky=>'e',-in => $mw);
$Bstop->grid(-row=>0,-column=>2,-sticky=>'e',-in => $mw);
$status->grid(-row=>2,-column=>0,-sticky=>"w",-in => $mw);
$clk->grid(-row=>2,-column=>2,-sticky=>"e",-in => $mw);
$txt->grid(-row=>1,-column=>0,-in => $mw,-columnspan => 3,-sticky=>'ewns');
}
### resize behaviour
$mw->gridRowconfigure (0,-weight => 0);
$mw->gridRowconfigure (1,-weight => 1);
$mw->gridRowconfigure (2,-weight => 0);
$mw->gridColumnconfigure (0,-weight => 1);
$mw->gridColumnconfigure (1,-weight => 0);
MainLoop;
sub Bstart {
$tv="Pingtest starter..";
$Bstop->configure(-state=>'normal');
$Bstart->configure(-state=>'disabled');
$txt->insert('end',"............Starter pingtest.\n");
$BstartTimer = $txt->repeat(500,\&MyPing);
}
sub Bstop {
$tv="Pingtest afsluttet. Der er ialt kørt $pingCount forløb.";
$Bstart->configure(-state=>'normal');
$Bstop->configure(-state=>'disabled');
$txt->insert('end',"............Stopper pingtest.\n");
$BstartTimer->cancel();
}
sub menuClicked {
my ($opt) = @_;
$mw->messageBox(-message => "Det er en vigtig besked",
-title => "Advarsel");
}
sub saveClicked {
my ($opt) = @_;
$i++;
$tv = "Nu er der klikket $i gange";
}
sub mintid {
my @mon_abbr =
qw( Jan Feb Mar Apr Maj Jun Jul Aug Sep Okt Nov Dec );
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime(time);
if ($c2 == 0) {
$c = sprintf(" %02i:%02i:%02i ", $hour, $min, $sec );
$c2 = 1;
} else {
$c = sprintf(" %02i %02i %02i ", $hour, $min, $sec );
$c2 = 0;
}
}
sub MyPing {
my $protocol = 'icmp';
my $p;
my $host;
$pingCount++;
$tv="Ping test kører $pingCount forløb.";
$txt->insert('end', "$pingCount: ");
foreach $host (@hosts) {
$p = Net::Ping->new($protocol,1);
if ( $p->ping($host) ) {
$txt->insert('end', "$host \($protocol\) er oppe ");
} else {
$txt->insert('end', "$host \($protocol\) er nede ");
}
$p->close();
}
$txt->insert('end',"\n");
$txt->see('end');
}
Eksempel 3
Graf - men det er kun leg
#!/usr/bin/perl
#use strict;
use warnings;
use Tk;
# Main window oprettes
my $i=0;
my $s2;
my $tv = "Running..";
my @lines1 = (); # array til linjer i grøn kurve
my @lines2 = (); # array til linjer i rød kurve
my @xlines = (); # array der holder de små linier med værdier på x aksen
my @xunits = ();
my @Ylines = (); # array der holder de små linier med værdier på y aksen
my $lastValue1=700; # Sidste y værdi
my $lastValue2=700; # Sidste y værdi
my $lastLine=-1; # Pointer til @lines1 array
my $mw = new MainWindow();
#-->$adj = $mw -> Adjuster();
$mw->title("EUC MIDT - TK Perl SNMP graf eksempel 1");
#Status felt
my $status = $mw -> Label (
-relief => 'sunken' ,
-borderwidth => 2 ,
-height => 1 ,
-width => 30 ,
-justify => 'right' ,
-anchor => 'w',
-textvariable => \$tv );
my $c = " --:--:--";
my $c2=0;
my $clk = $mw -> Label (
-relief => 'sunken' ,
-borderwidth => 1 ,
-height => 1 ,
-width =>10 ,
-justify => 'left' ,
-textvariable => \$c );
$clk->repeat(100,\&mintid); # 500 ms mellem ur trigges ------------------>
# Når er trykkes på F2 køres subrutinen menuclicked()
$mw->bind ( "<F2>" , \&menuClicked ) ;
# Når er trykkes på F3 køres subrutinen saveclicked()
$mw->bind ( "<F3>" , \&saveClicked ) ;
my $cvW = 700;
my $cvH = 200;
my $cv = $mw->Scrolled('Canvas',-width => $cvW, -height => $cvH,
-xscrollincrement =>1,
-yscrollincrement =>1, -confine => 0,
-scrollbars=>'osoe',-background=>'white');
$cv->configure( -scrollregion => [50,25,$cvW-50,$cvH-25]);
$cv->configure( -cursor => 'crosshair');
#MOpret et scrool-bart tekstområde i $mv (Hoved vindue)
my $txt = $mw->Scrolled('Text',-width => 50,-height=>5,-scrollbars=>'e');
#Opret en menubar i objktet
my $mbar = $mw->Menu();
$mw->configure(-menu => $mbar);
#Hovedenmer i menuen
my $file = $mbar->cascade(-label=>"File", -underline=>0, -tearoff => 0);
my $edit = $mbar->cascade(-label=>"Edit", -underline=>0, -tearoff => 0);
my $devices = $mbar->cascade(-label =>"Enheder", -underline=>0, -tearoff => 0);
my $help = $mbar->cascade(-label =>"Help", -underline=>0, -tearoff => 0);
## File Menu ##
$file -> command(-label => "New", -underline=>0,
-command=>sub { $txt -> delete('1.0','end');} );
$file -> checkbutton(-label =>"Open", -underline => 0,
-command => [\&menuClicked, "Open"],
-accelerator => "F2");
$file -> command(-label =>"Status", -underline => 0,
-command => [\&saveClicked, "Status"],
-accelerator => "F3");
$file -> separator();
$file -> command(-label =>"Exit", -underline => 1,
-command => sub { exit } );
## Enheder Menu ##
my $cisco = $devices -> cascade(-label =>"Cisco udstyr",
-underline => 0, -tearoff => 0);
$cisco -> command(-label =>"Opret enhed",
-command => sub { $txt->insert('end',
"Der oprettes en ny Cisco Router :-)\n");});
$cisco -> command(-label =>"Rediger enhed", -command=>sub {
$txt->insert('end',"Cisco enhed redigeres\n");});
$cisco -> command(-label =>"Slet enhed",
-command=> sub {$txt->insert('end',"Er du nu helt sikker?\n");});
$devices -> command(-label =>"Ping enhed", -underline => 7,
-command => sub { $txt->insert('end',"Ja her burde der pinges\n");});
## Help ##
$help -> command(-label =>"About", -command => sub {
$txt->delete('1.0','end');
$txt->insert('end',"EUC MIDT - Tk Perl eksempel 1 /HeTh\n")});
#Statuslinie nederst
#$status->pack(-expand=>1,-anchor=>'se',-side=>'left') ;
#$clk->pack(-expand=>1,-side=>'right',-in=>$status) ;
#$txt->pack(-expand=>1,-fill=>'both');
$cv->grid(-row=>0,-column=>0,-sticky=>"ewns",-in => $mw,-columnspan => 2);
$txt->grid(-row=>1,-column=>0,-in => $mw,-columnspan => 2,-sticky=>'ewns');
$status->grid(-row=>2,-column=>0,-sticky=>"w",-in => $mw);
$clk->grid(-row=>2,-column=>1,-sticky=>"e",-in => $mw);
### resize behaviour
$mw->gridRowconfigure (0,-weight => 1);
$mw->gridRowconfigure (1,-weight => 0);
$mw->gridColumnconfigure (0,-weight => 1);
$mw->gridColumnconfigure (1,-weight => 0);
#-->$adj -> packAfter($clk, -side => 'left');
cvInit();
MainLoop;
sub menuClicked {
my ($opt) = @_;
$mw->messageBox(-message => "Det er en vigtig besked",
-title => "Advarsel");
}
sub saveClicked {
my ($opt) = @_;
$i++;
$tv = "Nu er der klikket $i gange";
}
sub cvInit {
# Grid i scrooledarea i canvas
#$cv->createGrid(50,25,75,50, -lines => '2', -fill => 'lightgray',
# -width => '1', -dash => ',');
# X-akse
$cv->createLine(50, $cvH-25, $cvW-50, $cvH-25, -arrow => 'last');
for ( my $i=0,my $j1 = 0, my $j2=0; $i < $cvW-50; $i+=25, $j1++) {
$xlines[$j1] = $cv->createLine($i,$cvH-23,$i,$cvH-25);
if (($i % 100) == 0) {
$xunits[$j2]=$cv->createText($i+50,$cvH-13, -fill => 'blue', -text => "$i");
$j2++;
}
}
$cv->createText($cvW-40, $cvH-25, -fill => 'blue', -text => 'Tid');
$cv->createLine(50, 25, 50, $cvH-25,-arrow => 'first');
$cv->createText(50,15, -fill => 'blue', -text => 'Mbps');
my $j=0;
for ( my $i=$cvH-25; $i > 25; $i-=25) {
$cv->createLine(48,$i,50,$i);
$cv->createText(40,$i, -fill => 'blue', -text => $j++);
}
init();
}
sub mintid {
my @mon_abbr =
qw( Jan Feb Mar Apr Maj Jun Jul Aug Sep Okt Nov Dec );
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime(time);
if ($c2 == 0) {
$c = sprintf(" %02i:%02i:%02i ", $hour, $min, $sec );
$c2 = 1;
} else {
$c = sprintf(" %02i %02i %02i ", $hour, $min, $sec );
$c2 = 0;
}
drawNext();
}
sub init {
my ($i,$j);
for ( $i=55, $j=0; $i < $cvW-50; $i+=5,$j++) {
$lines1[$j] = $cv->createLine($i-5,$cvH-25,$i,$cvH-25,-fill=>'green',
-state => 'hidden', -width => 3 );
$lines2[$j] = $cv->createLine($i-5,$cvH-25,$i,$cvH-25,-fill=>'red',
-state => 'hidden', -width => 3);
}
#$cv->itemconfigure($lines1[$j-1],-width => 3,-fill => 'black');
#$cv->itemconfigure($lines2[$j-1],-width => 3,-fill => 'black');
}
sub getInfo {
$deviation = 25;
return(int(rand($deviation) - $deviation/2));
}
use diagnostics;
sub drawNext {
my ($i1,$i2);
my ($x1a1,$y1a1,$x2a1,$y2a1);
my ($x1a2,$y1a2,$x2a2,$y2a2);
my ($x1b,$y1b,$x2b,$y2b);
if ( $lastLine > ($#lines1-1) ){
for (my $cou = 0; $cou < $#lines1 ; $cou++ ) {
($x1a1,$y1a1,$x2a1,$y2a1) = $cv->coords($lines1[$cou+1]);
($x1a2,$y1a2,$x2a2,$y2a2) = $cv->coords($lines2[$cou+1]);
($x1b,$y1b,$x2b,$y2b) = $cv->coords($lines1[$cou]);
$cv->coords($lines1[$cou], $x1b,$y1a1,$x2b,$y2a1);
$cv->coords($lines2[$cou], $x1b,$y1a2,$x2b,$y2a2);
}
print "\n---------------> xlines <----------------\n";
#X-kurve
for ( my $i = 0; $i <= $#xlines ; $i++) {
($x1b,$y1b,$x2b,$y2b) = $cv->coords($xlines[$i]);
#if ( $x1b <= 50 ) {
# $x1b = $cvW-50;
# $x2b = $cvW-50;
#} else {
$x1b = $x1b-5;
$x2b = $x2b-5;
#}
if ( $x1b <= 50 ) {
$x1b = $cvW-50;
$x2b = $cvW-50;
}
$cv->coords($xlines[$i], $x1b,$y1b,$x2b,$y2b);
print "($i)=$x1b ";
}
print "\n---------------> xunits <----------------\n";
# X units
for ( my $i = 0; $i <= $#xunits ; $i++) {
($x1b,$y1b) = $cv->coords($xunits[$i]);
if ( $x1b < 50 ) {
$cv->itemconfigure($xunits[$i], -text => "");
} if ( $x1b <= -50 ) {
$x1b = $cvW-50;
$clk=localtime();
$clk =~ /(\d+:\d+:\d+)/;
$cv->itemconfigure($xunits[$i], -text => $1);
} else {
$x1b = $x1b-5;
#if ($x1b >= $cvW-75) {
#}
}
$cv->coords($xunits[$i], $x1b,$y1b);#,$x2b,$y2b);
print "($i)=$x1b ";
}
} else {
$lastLine++;
}
$i1 = getInfo() + getInfo() + getInfo() / 3;
$i2 = getInfo() + getInfo() + getInfo() / 3;
$cv->coords($lines1[$lastLine],50 + (5*$lastLine), # From X
$cvH-($lastValue1/1500*$cvH)-25, # From Y
55 + (5*$lastLine), # To X
$cvH-(($lastValue1-$i1)/1500*$cvH)-25); # To Y
$cv->coords($lines2[$lastLine],50 + (5*$lastLine), # From X
$cvH-($lastValue2/1500*$cvH)-25, # From Y
55 + (5*$lastLine), # To X
$cvH-(($lastValue2-$i2)/1500*$cvH)-25); # To Y
$cv->itemconfigure($lines1[$lastLine],state => 'normal');
$cv->itemconfigure($lines2[$lastLine],state => 'normal');
$lastValue1 = $lastValue1 - $i1;
$lastValue2 = $lastValue2 - $i2;
}