#!/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 ()  { 5 }
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 = ();


#   This solitary goto provides an efficient means of entering the execution
#   loop and populating the session table using the existing mechanism for
#   initiating new sessions within the loop.

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

goto START;


#   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 @timeout )
{
    START:

    #   If there are hosts still pending connection tests, check to see if any new
    #   pings for testing server connectivity should be started.

    if ( scalar @hosts )
    {
        #   If the number of concurrent ping sessions is less than the maximum number
        #   of sessions allowed for exection, start a new ping session to test server
        #   connectivity.

        while ( 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 = $queue[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 $queue[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;