Difference between revisions of "Perl TK eksempel"
From Teknologisk videncenter
m (New page: <source lang=perl> #!/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...) |
(No difference)
|
Revision as of 08:17, 13 November 2009
#!/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',"EUC MIDT - 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');
}