The following is an updated version of this code which fixes a couple of small bugs in the code posted in the parent node and incorporates portions of the patch offered by isotope - One element of this patch which this code does not incorporate is the shift of the array @timeout into a hash-based structure. This is because this portion of the patch from isotope, although increasing the accuracy of timing associated with ping results, increases the number of empty processing cycles iterated through by the script, thereby impacting upon the load of the host machine. If accuracy is important for the timing of ping results, replace the line:

select(my $read_out = $read_in, undef, undef, $timeout);
[download]

With the following:

select(my $read_out = $read_in, undef, undef, MINIMUM_TIMEOUT);
[download]

The complete code follows:

#!/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;
[download]