#!/usr/bin/perl
BEGIN {
# This code is from the POE::Loop::Select module and is a work-a
+round for a
# bug on Linux platforms relating to select calls with zero-seco
+nd timeouts.
# If select is called with a zero-second timeout and a signal ma
+nages
# interrupt, the select function is restarted and will block ind
+efinitely.
my $timeout = ($^O eq 'linux') ? 0.001 : 0;
eval "sub MINIMUM_TIMEOUT () { $timeout }";
# The Time::HiRes module is loaded if available as this provides
+ greater
# resolution in time-slice calculations.
eval "use Time::HiRes qw( time )";
}
use Carp;
use Socket;
use Symbol;
use strict;
use vars qw( $VERSION );
$VERSION = sprintf("%d.%02d", q$Revision: 1.0 $ =~ /(\d+)\.(\d+)/);
# The following subroutines return ICMP constants required for manua
+lly
# constructing the ICMP echo packet.
sub ICMP_ECHO () { 8 }
sub ICMP_ECHOREPLY () { 0 }
sub ICMP_FLAGS () { 0 }
sub ICMP_PORT () { 0 }
sub ICMP_STRUCT () { 'C2S3A56' }
sub ICMP_SUBCODE () { 0 }
sub QUEUE_EPOCH () { 0 }
sub QUEUE_SESSION () { 1 }
sub MAX_CONNECTIONS () { 128 }
sub TIMEOUT () { 2 }
my @hosts = (
'192.168.0.1',
'192.168.0.100',
'www.perlmonks.org'
);
# Initialise variables utilised by the time-slice execution loop mec
+hanism
my @timeout = ();
my %ping = ();
my ($length, $sequence, $socket);
# The main loop for execution centers around the list of scheduled e
+vents
# within the execution queue - As long as the execution queue is pop
+ulated,
# this loop will continue execution.
while (scalar @hosts or scalar @timeout) {
# If the number of concurrent ping sessions is less than the max
+imum number
# of sessions allowed for exection and there are hosts still pen
+ding
# connection tests, start a new ping session to test server conn
+ectivity.
while (scalar @hosts and scalar keys %ping < MAX_CONNECTIONS) {
# If no valid ICMP socket exists for communication, create t
+his socket.
unless (defined $socket) {
my $protocol;
$protocol = (getprotobyname('icmp'))[2] or
croak('Cannot get ICMP protocol number by name - ', $!
+);
$socket = Symbol::gensym;
socket($socket, PF_INET, SOCK_RAW, $protocol) or
croak('Cannot create IMCP socket - ', $!);
}
# Determine an unused sequence number for the new ICMP packe
+t - In addition
# to being used for the packet sequence, this value is also
+used as the
# unique name for the ping session.
while (1) {
$sequence = ($sequence + 1) & 0xFFFF;
last unless exists $ping{$sequence};
}
# Build the message packet without a checksum
my $checksum = 0;
my $msg = pack(
ICMP_STRUCT,
ICMP_ECHO,
ICMP_SUBCODE,
$checksum,
$$ & 0xFFFF,
$sequence,
'0' x 56
);
# Calculate the message checksum and rebuild the packet with
+ the newly
# calculated message checksum.
my $short = int(length($msg) / 2);
$checksum += $_ for unpack "S$short", $msg;
$checksum += ord(substr($msg, -1)) if length($msg) % 2;
$checksum = ($checksum >> 16) + ($checksum & 0xFFFF);
$checksum = ~(($checksum >> 16) + $checksum) & 0xFFFF;
$msg = pack(
ICMP_STRUCT,
ICMP_ECHO,
ICMP_SUBCODE,
$checksum,
$$ & 0xFFFF,
$sequence,
'0' x 56
);
$length = length $msg;
# Now that the ICMP echo packet has been built, grab an addr
+ess from the list
# of hosts of which test connectivity.
my $address = shift @hosts;
my $netaddr = inet_aton($address);
next unless defined $netaddr;
my $sockaddr = pack_sockaddr_in(ICMP_PORT, $netaddr);
send($socket, $msg, ICMP_FLAGS, $sockaddr) or
croak('Error sending ICMP packet - ', $!);
# Set a delay for the timeout period - Within a real time-sh
+aring environment,
# this would be set by insertion into a priority queue. How
+ever, it is not
# felt that the size of this application warrants the implem
+entation of such
# a queue where a basic queue with all events are added in a
+ time sequential
# fashion would suffice.
push @timeout, [time + TIMEOUT, $sequence];
# Create a new ping session entry in the session hash - This
+ session entry
# contains the host name being pinged and the time since epo
+ch at which the
# ping was sent.
$ping{$sequence} = [$address, time];
}
# Perform a select on the socket handle for the echo reply retur
+ned by the
# remote host - This has the added effect of performing a sleep
+type function
# until the next delay event is due, minimising wasted cycles.
my $timeout = $timeout[0]->[QUEUE_EPOCH] - time;
$timeout = MINIMUM_TIMEOUT if $timeout < MINIMUM_TIMEOUT;
vec(my $read_in = '', fileno($socket), 1) = 1;
select(my $read_out = $read_in, undef, undef, $timeout);
if (vec($read_out, fileno($socket), 1 )) {
my $now = time;
# Data is waiting to be read on the socket - Read this data,
+ decode the
# sequence number and process the echo reply.
recv($socket, my $data = '', 1500, ICMP_FLAGS);
my @reply = unpack(ICMP_STRUCT, substr($data, -$length));
my ($type, $reply_sequence) = @reply[0, 4];
if ($type == ICMP_ECHOREPLY) {
# If the returned message is indeed an echo reply and th
+e associated sequence
# is one sent previously by this application, it is take
+n that the host is
# indeed reachable and as such, can be incorporated into
+ the fetchmail
# configuration generated.
if (exists $ping{$reply_sequence}) {
# The next step is to remove the ping session so tha
+t further sessions can be
# created with the next iteration through this loop
+and remove the pending
# timeout event in the event queue.
my ($address, $time) = @{delete $ping{$reply_sequence}
+};
@timeout = grep { $_->[QUEUE_SESSION] ne $reply_sequen
+ce } @timeout;
# The ping attempt was successful and should now be
+actioned - Remember
# however, that this execution is taking place withi
+n a time-slice sharing
# environment and as such care should be taken to av
+oid any long or blocking
# processes.
print STDOUT sprintf("Reply time for %s - %.3f seconds
+\n", $address, $now - $time);
}
}
}
# The following test removes any sessions which have passed thei
+r expiry
# timeout and thus should be treated as failed connection checks
+.
my $now = time;
while (scalar @timeout and $timeout[0]->[QUEUE_EPOCH] < $now) {
my $item = shift @timeout;
my ($address) = @{delete $ping{$item->[QUEUE_SESSION]}};
# The ping attempt did not return any echo reply and as such
+ considered to
# have failed.
print STDOUT sprintf("No reply for %s\n", $address);
}
}
exit 0;
