Difference between revisions of "Perl Multicast Sender example"
From Teknologisk videncenter
m |
m |
||
| (One intermediate revision by the same user not shown) | |||
| Line 1: | Line 1: | ||
<source lang=perl> | <source lang=perl> | ||
#!/usr/bin/perl -w | #!/usr/bin/perl -w | ||
| − | # | + | # Author : heth@mercantec.dk |
| + | # Method : Quick and dirty - no responsibility whatsoever by author | ||
use strict; | use strict; | ||
use warnings; | use warnings; | ||
use Tk; | use Tk; | ||
| − | |||
use IO::Socket::Multicast qw(:all); | use IO::Socket::Multicast qw(:all); | ||
use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR | use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR | ||
| Line 544: | Line 544: | ||
} | } | ||
</source> | </source> | ||
| + | [[Category:Perl]] | ||
Latest revision as of 16:55, 6 May 2010
#!/usr/bin/perl -w
# Author : heth@mercantec.dk
# Method : Quick and dirty - no responsibility whatsoever by author
use strict;
use warnings;
use Tk;
use IO::Socket::Multicast qw(:all);
use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR
inet_aton inet_ntoa sockaddr_in );;
use Time::HiRes qw ( time alarm sleep );
# Luk console vindue
BEGIN {
if ($^O eq 'MSWin32' ) {
require Win32::Console;
Win32::Console::Free();
}
}
## Initialise randomizer
srand;
# Main window oprettes
my $status = "Status: ";
my $packets = 0;
my $packetsSendSession = 0;
my $packetsSendTotal = 0;
my $BstartTimer;
my $packetData = ""; # Contains nonsens data for packet fill
for my $i (1..57) { $packetData=$packetData ."abcdefghijklmnopqrstuvwxyz"; }
my $packetToSend; # To contain Multicast Packet to be send
my $socket = IO::Socket::Multicast->new();
my $mw = new MainWindow();
$mw->title("Mercantec - MultiCast Sender");
##################
# Menu #
##################
my $Lstart = $mw->Label(-text => 'Send ');
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 $Wstatus = $mw->Label (
-relief => 'sunken' ,
-borderwidth => 1 ,
-height => 1 ,
-width => 70 ,
-justify => 'right' ,
-anchor => 'w',
-textvariable => \$status );
my $Wpackets = $mw->Label (
-relief => 'sunken' ,
-borderwidth => 1 ,
-height => 1 ,
-width =>10 ,
-justify => 'left' ,
-textvariable => \$packets );
#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 $help = $mbar->cascade(-label =>"Help", -underline=>0, -tearoff => 0);
## File Menu ##
$file -> command(-label =>"Status", -underline => 0,
-command => [\&saveClicked, "Status"],
-accelerator => "F3");
$file -> separator();
$file -> command(-label =>"Exit", -underline => 1,
-command => sub { exit } );
## Help ##
$help -> command(-label =>"About",
-command => [\&aboutClicked, "Open"],
-accelerator => "F9");
# Når er trykkes på F9 køres subrutinen aboutClicked()
$mw->bind ( "<F9>" , \&aboutClicked ) ;
###################
### LabelFrames ###
###################
## LFsender LabelFrame ##
my $IPadr = '226.1.2.3';
my $port = 7777;
my $ttl = 64;
my $LFsender = $mw->Labelframe(-text => 'Sender options',
-padx => 2,
-pady => 2);
#IP address
$LFsender->Label( -text => "IP Address:", -width => 20, -anchor => 'w', -pady => 3)
->grid(-row=>0,-column=>0,-sticky=>'e',-in => $LFsender);
my $EIPadr = $LFsender->Entry(-width => 15, -textvariable => \$IPadr,
-validatecommand => \&validateIPadr,
-validate => 'focusout');
$EIPadr->grid(-row=>0,-column=>1,-sticky=>'w',-in => $LFsender);
#UDP port
$LFsender->Label( -text => "UDP Port:", -width => 20, -anchor => 'w', -pady => 3)
->grid(-row=>1,-column=>0,-sticky=>'e',-in => $LFsender);
my $Eport = $LFsender->Entry(-width => 5, -textvariable => \$port,
-validatecommand => \&validatePort,
-validate => 'focusout');
$Eport->grid(-row=>1,-column=>1,-sticky=>'w',-in => $LFsender);
#TTL
$LFsender->Label( -text => "Time-To-Live (TTL):", -width => 20, -anchor => 'w', -pady => 3)
->grid(-row=>2,-column=>0,-sticky=>'e',-in => $LFsender);
my $Ettl = $LFsender->Entry(-width => 3, -textvariable => \$ttl,
-validatecommand => \&validateTTL,
-validate => 'focusout');
$Ettl->grid(-row=>2,-column=>1,-sticky=>'w',-in => $LFsender);
#######################
# LFsize LabelFrame #
#######################
my $PACKETMINIMUMSIZE = 64; # Mindste tilladte pakke
my $PACKETMAXIMUMSIZE = 1500; # Største tilladte pakke
my $sizeMin = 100;
my $sizeMax = 1000;
my $size = 500;
my $sizeSelected = 'Constant';
my $LFsize = $mw->Labelframe(-text => 'Size of packets in Bytes',
-padx => 2,
-pady => 2);
#Labelframe SizeConstant inside Labelframe LFsize
my $LFsizeConstant = $LFsize->Labelframe(-padx => 2,-pady => 2);
$LFsizeConstant->grid(-row=>0,-column=>0,-pady => '2m', -padx => '2m');
my $RBsizeConstant = $LFsizeConstant->Radiobutton(
-text => 'Constant Packet Size',
-variable => \$sizeSelected,
-value => 'Constant',
-command => \&sizeConstantSelected,-padx => 0);
$LFsizeConstant->configure(-labelwidget => $RBsizeConstant);
my $Lsize = $LFsizeConstant->Label( -text => "Constant Size:", -width => 30,
-anchor => 'w', -pady => 3)
->grid(-row=>2,-column=>0,-sticky=>'e',-in => $LFsizeConstant);
my $Esize = $LFsizeConstant->Entry(-width => 5, -textvariable => \$size,
-validatecommand => \&validateSize,
-validate => 'focusout');
$Esize->grid(-row=>2,-column=>1,-sticky=>'w',-in => $LFsizeConstant);
#Labelframe SizeRandom inside Labelframe LFsize
my $LFsizeRandom = $LFsize->Labelframe(-padx => 2,-pady => 2);
$LFsizeRandom->grid(-row=>1,-column=>0,-pady => '2m', -padx => '2m');
my $RBsize = $LFsizeRandom->Radiobutton(
-text => 'Random Packet Size',
-variable => \$sizeSelected,
-value => 'Random',
-command => \&sizeRandomSelected,-padx => 0);
$LFsizeRandom->configure(-labelwidget => $RBsize);
my $LsizeMin = $LFsizeRandom->Label( -text => "Random Size Minimum:",
-width => 30,-anchor => 'w', -pady => 3)
->grid(-row=>0,-column=>0,-sticky=>'e',-in => $LFsizeRandom);
my $EsizeMin = $LFsizeRandom->Entry(-width => 5, -textvariable => \$sizeMin,
-validatecommand => \&validateSizeMin,
-validate => 'focusout');
$EsizeMin->grid(-row=>0,-column=>1,-sticky=>'w',-in => $LFsizeRandom);
my $LsizeMax = $LFsizeRandom->Label( -text => "Random Size Maximum:",
-width => 30,-anchor => 'w', -pady => 3)
->grid(-row=>1,-column=>0,-sticky=>'e',-in => $LFsizeRandom);
my $EsizeMax = $LFsizeRandom->Entry(-width => 5, -textvariable => \$sizeMax,
-validatecommand => \&validateSizeMax,
-validate => 'focusout');
$EsizeMax->grid(-row=>1,-column=>1,-sticky=>'w',-in => $LFsizeRandom);
## Default size Constant
sizeConstantSelected();
###########################
# LFinterval LabelFrame #
###########################
my $intervalMin = 10;
my $intervalMax = 1000;
my $interval = 100;
my $intervalSelected = 'Constant';
my $LFinterval = $mw->Labelframe(-text => 'Interval between packets in Milli Seconds',
-padx => 2,
-pady => 2);
#Labelframe IntervalConstant inside Labelframe LFinterval
my $LFintervalConstant = $LFinterval->Labelframe(-padx => 2,-pady => 2);
$LFintervalConstant->grid(-row=>0,-column=>0,-pady => '2m', -padx => '2m');
my $RBintervalConstant = $LFintervalConstant->Radiobutton(
-text => 'Constant Packet Interval',
-variable => \$intervalSelected,
-value => 'Constant',
-command => \&intervalConstantSelected,-padx => 0);
$LFintervalConstant->configure(-labelwidget => $RBintervalConstant);
my $Linterval = $LFintervalConstant->Label( -text => "Constant Interval:", -width => 30,
-anchor => 'w', -pady => 3)
->grid(-row=>2,-column=>0,-sticky=>'e',-in => $LFintervalConstant);
my $Einterval = $LFintervalConstant->Entry(-width => 5, -textvariable => \$interval,
-validatecommand => \&validateInterval,
-validate => 'focusout');
$Einterval->grid(-row=>2,-column=>1,-sticky=>'w',-in => $LFintervalConstant);
#Labelframe IntervalRandom inside Labelframe LFinterval
my $LFintervalRandom = $LFinterval->Labelframe(-padx => 2,-pady => 2);
$LFintervalRandom->grid(-row=>1,-column=>0,-pady => '2m', -padx => '2m');
my $RBinterval = $LFintervalRandom->Radiobutton(
-text => 'Random Packet Interval',
-variable => \$intervalSelected,
-value => 'Random',
-command => \&intervalRandomSelected,-padx => 0);
$LFintervalRandom->configure(-labelwidget => $RBinterval);
my $LintervalMin = $LFintervalRandom->Label( -text => "Random Interval Minimum:",
-width => 30,-anchor => 'w', -pady => 3)
->grid(-row=>0,-column=>0,-sticky=>'e',-in => $LFintervalRandom);
my $EintervalMin = $LFintervalRandom->Entry(-width => 5, -textvariable => \$intervalMin,
-validatecommand => \&validateIntervalMin,
-validate => 'focusout');
$EintervalMin->grid(-row=>0,-column=>1,-sticky=>'w',-in => $LFintervalRandom);
my $LintervalMax = $LFintervalRandom->Label( -text => "Random Interval Maximum:",
-width => 30,-anchor => 'w', -pady => 3)
->grid(-row=>1,-column=>0,-sticky=>'e',-in => $LFintervalRandom);
my $EintervalMax = $LFintervalRandom->Entry(-width => 5, -textvariable => \$intervalMax,
-validatecommand => \&validateIntervalMax,
-validate => 'focusout');
$EintervalMax->grid(-row=>1,-column=>1,-sticky=>'w',-in => $LFintervalRandom);
## Default interval Constant
intervalConstantSelected();
##################
# 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);
$LFsender->grid(-row=>1,-column=>0,-sticky=>'w',-in => $mw, -padx => 25, -pady => 5);
$LFsize->grid(-row=>2,-column=>0,-sticky=>'w',-in => $mw, -padx => 25, -pady => 5);
$LFinterval->grid(-row=>3,-column=>0,-sticky=>'w',-in => $mw, -padx => 25, -pady => 5 );
$Wstatus->grid(-row=>4,-column=>0,-sticky=>"w",-in => $mw);
$Wpackets->grid(-row=>4,-column=>2,-sticky=>"e",-in => $mw);
### resize behaviour
$mw->gridRowconfigure (0,-weight => 1);
$mw->gridRowconfigure (1,-weight => 2);
$mw->gridRowconfigure (2,-weight => 3);
MainLoop;
####################
# Event Handlers #
####################
sub aboutClicked {
my ($opt) = @_;
$mw->messageBox(-message => "MultiCast Sender version 1.0\nHenrik Thomsen 2007\n\n\nheth\@mercantec.dk",
-title => "About");
}
sub intervalRandomSelected {
## Deselect Constant interval LabelFrame Widgets
$Linterval->configure(-state => 'disabled' );
$Einterval->configure(-state => 'disabled' );
## Select Random interval LabelFrame Widgets
$LintervalMin->configure(-state => 'active' );
$EintervalMin->configure(-state => 'normal' );
$LintervalMax->configure(-state => 'active' );
$EintervalMax->configure(-state => 'normal' );
}
sub intervalConstantSelected {
## Select Constant interval LabelFrame Widgets
$Linterval->configure(-state => 'active' );
$Einterval->configure(-state => 'normal' );
## Select Random interval LabelFrame Widgets
$LintervalMin->configure(-state => 'disabled' );
$EintervalMin->configure(-state => 'disabled' );
$LintervalMax->configure(-state => 'disabled' );
$EintervalMax->configure(-state => 'disabled' );
}
sub sizeRandomSelected {
## Deselect Constant size LabelFrame Widgets
$Lsize->configure(-state => 'disabled' );
$Esize->configure(-state => 'disabled' );
## Select Random size LabelFrame Widgets
$LsizeMin->configure(-state => 'active' );
$EsizeMin->configure(-state => 'normal' );
$LsizeMax->configure(-state => 'active' );
$EsizeMax->configure(-state => 'normal' );
}
sub sizeConstantSelected {
## Select Constant interval LabelFrame Widgets
$Lsize->configure(-state => 'active' );
$Esize->configure(-state => 'normal' );
## Select Random interval LabelFrame Widgets
$LsizeMin->configure(-state => 'disabled' );
$EsizeMin->configure(-state => 'disabled' );
$LsizeMax->configure(-state => 'disabled' );
$EsizeMax->configure(-state => 'disabled' );
}
sub SOL_IP { 0; };
sub IP_TOS { 1; };
sub Bstart {
$status="Multicast sending.....";
$Bstop->configure(-state=>'normal');
$Bstart->configure(-state=>'disabled');
$packetsSendSession = 1;
if ( validateSize() && validateSizeMin() && validateSizeMax() &&
validateInterval() && validateIntervalMin() && validateIntervalMax() &&
validateIPadr() && validatePort() && validateTTL()) {
$socket->mcast_ttl($ttl);
#$socket->setsockopt($socket, SOL_IP, IP_TOS(), pack("I*", 32) ) || die "setsockopt: $!\n";;
#$socket->setsockopt($socket, 0,1, pack("I*", 32) ) || die "setsockopt: $!\n";;
$socket->sockopt(1,pack("I*",32));
#->sockopt('IP_TOS' => '24');
#$socket->setsockopt(IPPROTO_UDP,'IP_TOS',32) || die "setsockopt $!\n";
#Build first packet to be send.....
my $thisPacketSize = findPacketSize() - 20 - 8 - 26;
$packetToSend = pack("iFa$thisPacketSize",$packetsSendSession,time(),$packetData);
$BstartTimer = $Bstart->after(findInterval(),\&sendPacket);
}
}
sub Bstop {
$packetsSendTotal += $packetsSendSession;
$status = "Multicast afsluttet. Der er ialt sendt $packetsSendTotal pakker.";
$Bstart->configure(-state=>'normal');
$Bstop->configure(-state=>'disabled');
if ( $Bstart->afterInfo($BstartTimer)) {
$BstartTimer->cancel();
}
}
sub sendPacket {
$packetsSendSession++;
#Send packet that was packed before. (Dont spend time building packet
#after timer trigged)
$socket->mcast_send($packetToSend,"$IPadr:$port");
# Build Packet to send. (Size - 20 bytes IP - 8 bytes UDP - 26 bytes
# for number of packet and HiRes timestamp)
# Packets contains packetnumber,HiRes time, fill data
my $thisPacketSize = findPacketSize() - 20 - 8 - 26;
$packetToSend = pack("iFa$thisPacketSize",$packetsSendSession,time(),$packetData);
$packets = "$packetsSendSession";
$BstartTimer = $Bstart->after(findInterval(),\&sendPacket);
}
# Find tidsintervallet mellem pakkerne
sub findInterval {
if ( $intervalSelected eq 'Constant' ) {
return $interval;
} else {
return int($intervalMin + ( rand() * ($intervalMax - $intervalMin) ));
}
}
sub findPacketSize {
if ( $sizeSelected eq 'Constant' ) {
return $size;
} else {
return int($sizeMin + ( rand() * ($sizeMax - $sizeMin) ));
}
}
##########################
# Validate user input #
#########################
sub validateSize {
if ( $size =~ /^\d+$/ ) {
if ( ($size < $PACKETMINIMUMSIZE ) || ( $size > $PACKETMAXIMUMSIZE ) ) {
Bstop(); # Stop sending
$Esize->configure(-background => 'red');
$status = "ERROR: Packet size should be an integer between $PACKETMINIMUMSIZE and $PACKETMAXIMUMSIZE Bytes";
return 0;
} else {
$status = "";
$Esize->configure(-background => 'white');
return 1;
}
} else {
Bstop();
$Esize->configure(-background => 'red');
$status = "ERROR: Packet size should be an integer between $PACKETMINIMUMSIZE and $PACKETMAXIMUMSIZE Bytes";
return 0;
}
}
sub validateSizeMin {
if ( $sizeMin =~ /^\d+$/ ) {
if ( $sizeMin > $sizeMax ) {
Bstop(); # Stop sending
$EsizeMin->configure(-background => 'red');
$status = "ERROR: Minimum packetsize should be less than maximum packetsize";
return 0;
}
if ( ($sizeMin < $PACKETMINIMUMSIZE ) || ( $sizeMin > $PACKETMAXIMUMSIZE ) ) {
Bstop(); # Stop sending
$EsizeMin->configure(-background => 'red');
$status = "ERROR: Minimum packet size should be an integer between $PACKETMINIMUMSIZE and $PACKETMAXIMUMSIZE Bytes";
return 0;
} else {
$status = "";
$EsizeMin->configure(-background => 'white');
return 1;
}
} else {
Bstop();
$EsizeMin->configure(-background => 'red');
$status = "ERROR: Minimum packet size should be integer an between $PACKETMINIMUMSIZE and $PACKETMAXIMUMSIZE Bytes";
return 0;
}
}
sub validateSizeMax {
if ( $sizeMax =~ /^\d+$/ ) {
if ( ($sizeMax < $PACKETMINIMUMSIZE ) || ( $sizeMax > $PACKETMAXIMUMSIZE ) ) {
Bstop(); # Stop sending
$EsizeMax->configure(-background => 'red');
$status = "ERROR: Maximum packet size should be an integer between $PACKETMINIMUMSIZE and $PACKETMAXIMUMSIZE Bytes";
return 0;
} else {
$status = "";
$EsizeMax->configure(-background => 'white');
return 1;
} if ( $sizeMax < $sizeMin ) {
Bstop(); # Stop sending
$EsizeMax->configure(-background => 'red');
$status = "FEJL: Maximum packetsize should be larger than minimum packetsize";
return 0;
}
} else {
Bstop();
$EsizeMax->configure(-background => 'red');
$status = "ERROR: Maximum packet size should be an integer between $PACKETMINIMUMSIZE and $PACKETMAXIMUMSIZE Bytes";
return 0;
}
}
sub validateInterval {
if ( $interval =~ /^\d+$/ ) {
$status = "";
return 1;
} else {
Bstop(); # Stop sending
$status = "ERROR: Packetinterval should be an integer in milliseconds";
return 0;
}
}
sub validateIntervalMin {
if ( $intervalMin =~ /^\d+$/ ) {
if ( $intervalMin > $intervalMax ) {
Bstop(); # Stop sending
$status = "ERROR: Minimum packetinterval should be less than maximum packetinterval";
return 0;
} else {
$status = "";
return 1;
}
} else {
Bstop();
$status = "ERROR: Packetinterval should be an integer in milliseconds";
return 0;
}
}
sub validateIntervalMax {
if ( $intervalMax =~ /^\d+$/ ) {
if ( $intervalMax < $intervalMin ) {
Bstop(); # Stop sending
$status = "ERROR: Maximum packetinterval should be larger than minimum packetinterval";
return 0;
} else {
$status = "";
return 1;
}
} else {
Bstop();
$status = "ERROR: Packetinterval should be an integer in milliseconds";
return 0;
}
}
sub validateIPadr {
if ( $IPadr =~ /^(\d+).(\d+).(\d+).(\d+)$/ ) {
if (($1 >= 224 ) && ($1 <= 239) && ($2 <= 255) &&
($3 <= 255) && ($4 <= 255) ) {
$status = "";
return 1;
}
}
Bstop();
$status = "ERROR: Multicast IP address should be between 224.0.0.0 and 239.255.255.255";
return 0;
}
sub validatePort {
if ( $port =~ /^\d+$/ ) {
if ( $port > 65535 || $port < 1) {
Bstop(); # Stop sending
$status = "ERROR: UDP port number should be an integer between 1 and 65535";
return 0;
} else {
$status = "";
return 1;
}
} else {
Bstop();
$status = "ERROR: UDP port number should be an integer between 1 and 65535";
return 0;
}
}
sub validateTTL {
if ( $ttl =~ /^\d+$/ ) {
if ( $ttl > 255 || $ttl < 1) {
Bstop(); # Stop sending
$status = "ERROR: Time-To-Live (TTL) should be an integer between 1 and 255";
return 0;
} else {
$status = "";
return 1;
}
} else {
Bstop();
$status = "ERROR: Time-To-Live (TTL) should be an integer between 1 and 255";
return 0;
}
}