Win32::PingICMP - ICMP Ping support for Win32 based on ICMP.DLL

  use Win32::PingICMP;
  use Data::Dumper;

  my $p = Win32::PingICMP->new();

  if ($p->ping(@ARGV)) {
    print "Ping took ".$p->details->{roundtriptime}."\n";
  } else {
    print "Ping unsuccessful: ".$p->details->{status}."\n";
  }
  print Data::Dumper->Dump([$p->details()]);







  $p->ping_async(@ARGV);

  until ($p->wait(0)) {
    Win32::Sleep(10);
    print "Waiting\n";
  }

  if ($p->details()->{status} eq 'IP_SUCCESS') {
    print "Ping took ".$p->details()->{roundtriptime}."\n";
  } else {
    print "Ping unsuccessful: ".$p->details()->{status}."\n";
  }
  print Data::Dumper->Dump([$p->details()]);

###########################################################################
# Copyright 2002,2004,2006 Toby Ovod-Everett.  All rights reserved.
#
# This file is distributed under the Artistic License. See
# http://www.ActiveState.com/corporate/artistic_license.htm or
# the license that comes with your perl distribution.
#
# For comments, questions, bugs or general interest, feel free to
# contact Toby Ovod-Everett at toby@ovod-everett.org
##########################################################################

use strict;

package Win32::PingICMP;

use Carp;
use Win32::API;
use Win32::Event;
use Data::BitMask;

use vars qw($VERSION);

$VERSION='0.51';

sub new {
	my $class = shift;
	my($proto, $def_timeout, $bytes) = @_;

	(defined $proto && $proto ne 'icmp') and
			croak "Win32::PingICMP::new Illegal protocol value - only 'icmp' is supported";

	my $self = {
		def_timeout => defined $def_timeout ? $def_timeout+0 : 5,
		RequestData => "\0" x (defined $bytes ? int($bytes) : 0),
	};

	$self->{IcmpHandle} = &IcmpCreateFile();
	$self->{event} = Win32::Event->new();


	bless $self, $class;
	return $self;
}

sub ping {
	my $self = shift;
	my($host, $timeout, %options) = @_;

	my $details = $self->{details} = {};

	$self->{IcmpHandle} or croak "Win32::PingICMP::ping IcmpHandle has been closed";

	$details->{host} = $host;
	if ($host =~ /^(?:\d{1,3}\.){3}(?:\d{1,3})$/) {
		$details->{ipaddr} = $host;
	} else {
		$host ne '' or croak "Win32::PingICMP::ping requires \$host parameter";
		$details->{ipaddr} = join('.', unpack('C4', (gethostbyname($host))[4]));
	}

	$details->{timeout} = (defined $timeout ? $timeout : $self->{def_timeout}) * 1000;

	my($count, $Buffer) = &IcmpSendEcho($self->{IcmpHandle}, $details->{ipaddr},
			$self->{RequestData}, (scalar(keys %options) ? \%options : undef),
			$details->{timeout});

	if (defined $Buffer) {
		$details->{buffer} = $Buffer;
		$self->parse_details($count);
	}

	return $details->{success};
}

sub ping_async {
	my $self = shift;
	my($host, $timeout, %options) = @_;

	exists $self->{details}->{pbuffer} and croak "Win32::PingICMP::ping_async called while object still waiting on ping_async";

	my $details = $self->{details} = {};

	$self->{IcmpHandle} or croak "Win32::PingICMP::ping_async IcmpHandle has been closed";

	$details->{host} = $host;
	if ($host =~ /^(?:\d{1,3}\.){3}(?:\d{1,3})$/) {
		$details->{ipaddr} = $host;
	} else {
		$host ne '' or croak "Win32::PingICMP::ping_async requires \$host parameter";
		$details->{ipaddr} = join('.', unpack('C4', (gethostbyname($host))[4]));
	}

	$details->{timeout} = (defined $timeout ? $timeout : $self->{def_timeout}) * 1000;

	$self->{event}->reset();

	my($count, $pBuffer) = &IcmpSendEcho2($self->{IcmpHandle}, ${$self->{event}},
			$details->{ipaddr}, $self->{RequestData}, (scalar(keys %options) ? \%options : undef),
			$details->{timeout});

	$details->{pbuffer} = $pBuffer if defined $pBuffer;
}

sub wait {
	my $self = shift;
	my($timeout) = @_;

	exists $self->{details}->{pbuffer} or return 1;

	if ($self->{event}->wait($timeout)) {
		$self->{event}->reset();

		my $count = &IcmpParseReplies($self->{details}->{pbuffer});
		$self->{details}->{buffer} = &CopyMemory_Read($self->{details}->{pbuffer}, 1024);
		&LocalFree($self->{details}->{pbuffer});
		delete $self->{details}->{pbuffer};

		$self->parse_details($count);

		return 1;
	} else {
		return 0;
	}
}

sub requestdata {
	my $self = shift;

	$self->{RequestData} = $_[0] if scalar(@_);
	return $self->{RequestData};
}

sub parse_details {
	my $self = shift;
	my($count) = @_;

	my $details = $self->{details};
	$count = $count || 1;
	my $poffset;

	foreach my $i (0..$count-1) {
		my $reply = $details->{replies}->[$i] = {};

		@{$reply}{qw(address status roundtriptime datasize
					reserved pdata ttl tos flags optionssize poptionsdata)} =
				unpack('a4LLSSLCCCCL', substr($details->{buffer}, 28 * $i, 28));

		if (!defined $poffset) {
			$poffset = $reply->{pdata} - 28 * $count;
		}

		$reply->{data} = substr($details->{buffer}, $reply->{pdata}-$poffset, $reply->{datasize});
		delete($reply->{pdata});
		delete($reply->{datasize});

		$reply->{optionsdata} = substr($details->{buffer}, $reply->{poptionsdata}-$poffset, $reply->{optionssize});
		delete($reply->{poptionsdata});
		delete($reply->{optionssize});

		delete($reply->{reserved});

		$reply->{address} = join(".", unpack('C4', $reply->{address}));

		$details->{success} ||= ($reply->{status} == 0);

		$reply->{status} = &IP_STATUS()->explain_const($reply->{status});
	}

	foreach my $i (qw(status roundtriptime)) {
		$details->{$i} = $details->{replies}->[0]->{$i};
	}

	$details->{success} = $details->{success} ? 1 : 0;
}

sub details {
	my $self = shift;

	return {%{$self->{details}}};
}

sub close {
	my $self = shift;

	if ($self->{IcmpHandle}) {
		&IcmpCloseHandle($self->{IcmpHandle});
		delete $self->{IcmpHandle};
	}
}

sub DESTROY {
	my $self = shift;

	$self->close();
}



{
my $call;
sub IcmpCreateFile {
	$call ||= Win32::API->new('icmp', 'IcmpCreateFile', [qw()], 'N') or
			Carp::croak("Unable to connect to IcmpCreateFile.");

	my $IcmpHandle = $call->Call() or Carp::croak(&_format_error('IcmpCreateFile'));
	return $IcmpHandle;
}
}

{
my($call_n, $call_p);
sub IcmpSendEcho {
	my($IcmpHandle, $DestinationAddress, $RequestData, $RequestOptions, $Timeout) = @_;

	$call_n ||= Win32::API->new('icmp', 'IcmpSendEcho', [qw(N N P I N P N N)], 'N') or
			Carp::croak("Unable to connect to IcmpSendEcho.");
	$call_p ||= Win32::API->new('icmp', 'IcmpSendEcho', [qw(N N P I P P N N)], 'N') or
			Carp::croak("Unable to connect to IcmpSendEcho.");

	$DestinationAddress = &ip_as_IPAddr($DestinationAddress);
	defined $DestinationAddress or return;

	my $pRequestOptions = ref($RequestOptions) eq 'HASH' ?
		pack('CCCCV', @{$RequestOptions}{qw(ttl tos flags)}, 0, 0) :
		undef;

	my $Buffer = "\0" x 1024;

	my $count = (defined $pRequestOptions ? $call_p : $call_n)->Call($IcmpHandle, $DestinationAddress,
			$RequestData, length($RequestData), $pRequestOptions,
			$Buffer, length($Buffer), $Timeout);
	
	return($count, $Buffer);
}
}

{
my($call_n, $call_p);
sub IcmpSendEcho2 {
	my($IcmpHandle, $Event, $DestinationAddress, $RequestData, $RequestOptions, $Timeout) = @_;

	$call_n ||= Win32::API->new('icmp', 'IcmpSendEcho2', [qw(N N N N N P I N N N N)], 'N') or
			Carp::croak("Unable to connect to IcmpSendEcho2.");
	$call_p ||= Win32::API->new('icmp', 'IcmpSendEcho2', [qw(N N N N N P I P N N N)], 'N') or
			Carp::croak("Unable to connect to IcmpSendEcho2.");

	$DestinationAddress = &ip_as_IPAddr($DestinationAddress);
	defined $DestinationAddress or return;

	my $pRequestOptions = ref($RequestOptions) eq 'HASH' ?
		pack('CCCCV', @{$RequestOptions}{qw(ttl tos flags)}, 0, 0) :
		undef;

	my $pBuffer = &LocalAlloc('LPTR', 1024);

	my $count = (defined $pRequestOptions ? $call_p : $call_n)->Call($IcmpHandle,
			$Event, 0, 0, $DestinationAddress,
			$RequestData, length($RequestData), $pRequestOptions,
			$pBuffer, 1024, $Timeout);
	
	return($count, $pBuffer);
}
}


{
my $call;
sub IcmpParseReplies {
	my($pBuffer) = @_;

	$call ||= Win32::API->new('icmp', 'IcmpParseReplies', [qw(N N)], 'I') or
			Carp::croak("Unable to connect to IcmpParseReplies.");

	my $count = $call->Call($pBuffer, 1024);
	return $count;
}
}


{
my $call;
sub IcmpCloseHandle {
	my($IcmpHandle) = @_;

	$call ||= Win32::API->new('icmp', 'IcmpCloseHandle', [qw(N)], 'I') or
			Carp::croak("Unable to connect to IcmpCloseHandle.");

	$call->Call($IcmpHandle) or Carp::croak(&_format_error('IcmpCloseHandle'));
}
}

{
my $call;
sub CopyMemory_Read {
	my($pSource, $Length) = @_;

	$call ||= Win32::API->new('kernel32',
				'RtlMoveMemory', [qw(P I I)], 'V') or
			Carp::croak("Unable to connect to RtlMoveMemory.");

	my $Destination = "\0"x$Length;
	$call->Call($Destination, $pSource, $Length);
	return $Destination;
}
}

{
my $call;
sub CopyMemory_Write {
	my($string, $pDest) = @_;

	$call ||= Win32::API->new('kernel32',
				'RtlMoveMemory', [qw(I P I)], 'V') or
			Carp::croak("Unable to connect to RtlMoveMemory.");
	$call->Call($pDest, $string, length($string));
}
}

{
my $call;
sub LocalAlloc {
	my($uFlags, $uBytes) = @_;

	$uFlags = &LMEM_FLAGS->build_mask($uFlags);

	$call ||= Win32::API->new('kernel32',
				'LocalAlloc', [qw(I I)], 'I') or
			Carp::croak("Unable to connect to LocalAlloc.");

	my $ptr = $call->Call($uFlags, $uBytes);
	$ptr or Carp::croak("Unable to LocalAlloc $uBytes.");
	return $ptr;
}
}

{
my $call;
sub LocalFree {
	my($pObject) = @_;

	$call ||= Win32::API->new('kernel32',
				'LocalFree', [qw(I)], 'I') or
			Carp::croak("Unable to connect to LocalFree.");

	$call->Call($pObject);
}
}

sub _format_error {
	my($func, $retval) = @_;

	(my $msg = $func.": ".Win32::FormatMessage($retval || Win32::GetLastError()))
			=~ s/[\r\n]+$//;
	return $msg;
}

sub ip_as_IPAddr {
	my($value) = @_;

	if ($value =~ /^(?:\d{1,3}\.){3}(?:\d{1,3})$/) {
		my(@values) = split(/\./, $value);
		scalar(grep {$_ > 255} @values) and croak("Unable to parse '$value' as an IP address.");
		return unpack('V', pack('N', 16777216*$values[0]+65536*$values[1]+256*$values[2]+$values[3]));
	} elsif (length($value) == 4) {
		return unpack('V', $value);
	} elsif ($value =~ /^\d+$/) {
		return unpack('V', pack('N', int($value)));
	} else {
		return;
	}
}

{
my $cache;
sub IP_STATUS {
	$cache ||= Data::BitMask->new(
			IP_SUCCESS =>                   0,
			IP_BUF_TOO_SMALL =>         11001,
			IP_DEST_NET_UNREACHABLE =>  11002,
			IP_DEST_HOST_UNREACHABLE => 11003,
			IP_DEST_PROT_UNREACHABLE => 11004,
			IP_DEST_PORT_UNREACHABLE => 11005,
			IP_NO_RESOURCES =>          11006,
			IP_BAD_OPTION =>            11007,
			IP_HW_ERROR =>              11008,
			IP_PACKET_TOO_BIG =>        11009,
			IP_REQ_TIMED_OUT =>         11010,
			IP_BAD_REQ =>               11011,
			IP_BAD_ROUTE =>             11012,
			IP_TTL_EXPIRED_TRANSIT =>   11013,
			IP_TTL_EXPIRED_REASSEM =>   11014,
			IP_PARAM_PROBLEM =>         11015,
			IP_SOURCE_QUENCH =>         11016,
			IP_OPTION_TOO_BIG =>        11017,
			IP_BAD_DESTINATION =>       11018,
		);
}
}

{
my $cache;
sub LMEM_FLAGS {
	unless ($cache) {

		$cache = Data::BitMask->new(
				LMEM_FIXED          => 0x0000,
				LMEM_MOVEABLE       => 0x0002,
				LMEM_NOCOMPACT      => 0x0010,
				LMEM_NODISCARD      => 0x0020,
				LMEM_ZEROINIT       => 0x0040,
				LMEM_MODIFY         => 0x0080,
				LMEM_DISCARDABLE    => 0x0F00,
				LMEM_VALID_FLAGS    => 0x0F72,
				LMEM_INVALID_HANDLE => 0x8000,
			);

		$cache->add_constants(
				LHND        => $cache->build_mask('LMEM_MOVEABLE LMEM_ZEROINIT'),
				LPTR        => $cache->build_mask('LMEM_FIXED LMEM_ZEROINIT'),
				NONZEROLHND => $cache->build_mask('LMEM_MOVEABLE'),
				NONZEROLPTR => $cache->build_mask('LMEM_FIXED'),
			);
	}
	return $cache;
}
}

1;

__END__