unit uPingThread;
interface
uses
windows,
winsock,
Sysutils,
Classes;
const
PACKET_SIZE = 32;
ICMP_ECHO_REQUEST = 8;
type
PICMP = ^TICMP;
TICMP =
packed record
Typ : Byte;
Code : Byte;
CheckSum : Word;
ID : Word;
Seq_Num : Word;
Data :
array[1..PACKET_SIZE]
of Byte;
end;
TPingCallBack =
function(ErrorCode: integer; nMsec: integer;
const AMsg:
string; AICMP: TICMP): Boolean
of object;
TPingThread =
class(TThread)
private
FPingCallBack: TPingCallBack;
FIPAddr:
string;
FICMP: TICMP;
procedure Ping;
public
procedure Execute;
override;
constructor Create(
const AIPAddr:
string; APingCallBack: TPingCallBack);
destructor Destroy;
override;
end;
implementation
var
_WsadData : TWsaData;
_SeqNum : Word = 0;
_SeqID : Word = Word(-1);
_SocketLock : TRTLCriticalSection;
procedure TPingThread.Ping;
var
Addr: TSockAddr;
Sock: TSocket;
ICMP: TICMP;
ICMPret: PICMP;
i: Integer;
Start, Ende: Integer;
Read: TFDSet;
TimeOut: TTimeVal;
buf:
array [0..1023]
of Byte;
IPHeaderLen, IPLen: Integer;
Checksum: Word;
CheckSumTemp: Integer;
pw: PWord;
nMsec: integer;
begin
nMsec := Integer(-1);
try
nMsec := Integer(-1);
ZeroMemory(@FICMP, SizeOf(TICMP));
EnterCriticalSection(_SocketLock);
try
if _SeqNum = word(-1)
then _SeqNum := 0;
Inc(_SeqNum);
if _SeqID = 0
then _SeqNum := word(-1);
Dec(_SeqID);
finally
LeaveCriticalSection(_SocketLock);
end;
Sock := Socket(AF_INET, SOCK_RAW, IPPROTO_ICMP);
if Sock = invalid_Socket
then begin
FPingCallBack(WSAGetLastError, -1, SysErrorMessage(WSAGetLastError),
FICMP);
Exit;
end;
try
EnterCriticalSection(_SocketLock);
try
ICMP.Typ := ICMP_ECHO_REQUEST;
ICMP.Code := 0;
ICMP.CheckSum := 0;
ICMP.ID := _SeqID;
ICMP.Seq_Num := swap(_SeqNum);
FillChar(ICMP.Data, Length(ICMP.Data), 9);
pw := @ICMP;
CheckSum := 0;
for i := 1
to sizeof(ICMP)
div 2
do begin
CheckSumTemp := CheckSum +
not(swap(pw^));
CheckSum := CheckSumtemp
and $FFFF;
inc(CheckSum,(CheckSumTemp
and $10000)
shr 16);
inc(pw);
end;
if sizeof(ICMP)
mod 2 = 1
then begin
CheckSumTemp := CheckSum +
not(swap(word(ICMP.data[high(ICMP.data)])));
CheckSum := CheckSumtemp
and $FFFF;
inc(CheckSum, (CheckSumTemp
and $10000)
shr 16);
end;
ICMP.CheckSum:=swap(CheckSum);
addr.sin_family := AF_INET;
addr.sin_port := 0;
addr.sin_addr.S_addr := Inet_Addr(PAnsiChar(FIPAddr));
finally
LeaveCriticalSection(_SocketLock);
end;
if sendto(sock, ICMP, sizeof(ICMP), 0, addr, sizeof(Addr)) =
Socket_Error
then
begin
FPingCallBack(WSAGetLastError, -1, SysErrorMessage(WSAGetLastError),
FICMP);
Exit;
end;
start := gettickcount;
FD_ZERO(
Read);
FD_Set(sock,
Read);
TimeOut.tv_sec := 2;
TimeOut.tv_usec := 0;
if Select(0, @
Read,
nil,
nil, @TimeOut) > 0
then begin
IPLen := recv(sock, buf, length(buf), 0);
Ende := gettickcount;
if IPLen = Socket_Error
then
raise Exception.Create(
'
Fehler bei recv' + #13#10 +
SysErrorMessage(WSAGetLastError));
if ((buf[0]
and $F0)
shr 4 = 4)
then begin
IPHeaderlen := (buf[0]
and $0F) * 4;
if IPHEaderlen + sizeof(ICMP) < IPLen
then
raise Exception.Create('
Antwortpaket zu kurz');
ICMPret := @buf[IPHeaderlen];
move(ICMPret^, FICMP, SizeOf(TICMP));
case ICMPret^.Typ
of
0 :
begin
nMsec := Ende - Start;
FPingCallBack(WSAGetLastError, nMsec,
format(FIPAddr + '
Antwort in %d ms erhalten', [nMsec]),
FICMP);
end;
3 : FPingCallBack(WSAGetLastError, nMsec,
FIPAddr + '
Ziel nicht erreichbar Error ' +
IntToStr(ICMPret^.Code), FICMP);
11: FPingCallBack(WSAGetLastError, nMsec,
FIPAddr + '
Zeitlimit (TTL) überschritten' +
IntToStr(ICMPret^.Code), FICMP);
else
FPingCallBack(WSAGetLastError, nMsec,
format(FIPAddr + '
Unbekannte Antwort: Typ %d',
[ICMPret^.Code]), FICMP);
end;
end else
FPingCallBack(WSAGetLastError, nMsec,FIPAddr +
'
Kann IPv6 nicht lesen.', FICMP);
end else
FPingCallBack(WSAGetLastError, nMsec, FIPAddr + '
TimeOut',FICMP);
finally
closesocket(sock);
end;
except
on e:
exception do begin
FPingCallBack(WSAGetLastError, nMsec, e.
Message, FICMP);
end;
end;
end;
{ TPingThread }
constructor TPingThread.Create(
const AIPAddr:
string;
APingCallBack: TPingCallBack);
begin
inherited create(true);
FreeOnTerminate := true;
FPingCallBack := APingCallBack;
if @FPingCallBack =
nil then
Raise Exception.Create('
TPingCallBack not assigned!');
FIPAddr := AIPAddr;
ZeroMemory(@FICMP, SizeOf(TICMP));
Resume;
end;
destructor TPingThread.Destroy;
begin
inherited;
end;
procedure TPingThread.Execute;
begin
Ping;
Sleep(30);
Ping;
Sleep(30);
Ping;
Sleep(30);
end;
initialization
if (WSAStartup($0020, _WsadData) <> S_OK)
then
raise Exception.Create('
WSAStartup: ' + IntToStr(WSAGetLastError));
InitializeCriticalSection(_SocketLock);
finalization
DeleteCriticalSection(_SocketLock);
if (WSACleanup <> S_OK)
then
raise Exception.Create('
WSACleanup: ' + IntToStr(WSAGetLastError));
end.