#!/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 () { 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 mec +hanism my @timeout = (); my %ping = (); # This solitary goto provides an efficient means of entering the exe +cution # 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 e +vents # within the execution queue - As long as the execution queue is pop +ulated, # this loop will continue execution. while ( scalar @timeout ) { START: # If there are hosts still pending connection tests, check to se +e 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, crea +te 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 p +acket - In addition # to being used for the packet sequence, this value is a +lso 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 tim +e-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 im +plementation 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 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 = $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 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_seque +nce } }; @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 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 second +s\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 $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;
In reply to Time-Slice Concurrent Ping by rob_au
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |