Difference between revisions of "Perl TK eksempel"

From Teknologisk videncenter
Jump to: navigation, search
m
m (→‎Eksempel 2)
Line 218: Line 218:
 
   $txt->insert('end',"\n");
 
   $txt->insert('end',"\n");
 
   $txt->see('end');
 
   $txt->see('end');
 +
}
 +
</source>
 +
= Eksempel 3 =
 +
Graf - men det er kun leg
 +
<source lang=perl>
 +
#!/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;
 +
 +
 +
 +
 
}
 
}
 
</source>
 
</source>
 
[[category:Perl]]
 
[[category:Perl]]

Revision as of 09:02, 13 November 2009

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;




}
Retrieved from "http://mars.merhot.dk/w/index.php?title=Perl_TK_eksempel&oldid=9947"