Perl TK eksempel

#!/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');
}