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

##</code><code>##

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

##</code><code>##

#!/usr/bin/perl


BEGIN {

    #   This code is from the POE::Loop::Select module and is a work-around for a
    #   bug on Linux platforms relating to select calls with zero-second timeouts.
    #   If select is called with a zero-second timeout and a signal manages
    #   interrupt, the select function is restarted and will block indefinitely.

    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 manually
#   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 mechanism

my @timeout = ();
my %ping = ();


my ($length, $sequence, $socket);


#   The main loop for execution centers around the list of scheduled events
#   within the execution queue - As long as the execution queue is populated,
#   this loop will continue execution.

while (scalar @hosts or scalar @timeout) {

    #   If the number of concurrent ping sessions is less than the maximum number
    #   of sessions allowed for exection and there are hosts still pending 
    #   connection tests, start a new ping session to test server connectivity.

    while (scalar @hosts and scalar keys %ping < MAX_CONNECTIONS) {
    
        #   If no valid ICMP socket exists for communication, create this 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 packet - 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 address 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-sharing environment,
        #   this would be set by insertion into a priority queue.  However, it is not
        #   felt that the size of this application warrants the implementation 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 epoch at which the
        #   ping was sent.

        $ping{$sequence} = [$address, time];
    }

    #   Perform a select on the socket handle for the echo reply returned 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 the associated sequence
            #   is one sent previously by this application, it is taken 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 that 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_sequence } @timeout;

                #   The ping attempt was successful and should now be actioned - Remember
                #   however, that this execution is taking place within a time-slice sharing
                #   environment and as such care should be taken to avoid 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 their 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;