program minimalping;
{$mode objfpc}{$H+}
uses
SysUtils, Sockets, BaseUnix, netdb, Unix, DateUtils;
const
ICMP_ECHO = 8;
TIMEOUT_SEC = 2;
type
TICMPHeader = packed record
icmp_type: byte;
icmp_code: byte;
icmp_cksum: word;
icmp_id: word;
icmp_seq: word;
end;
function myGetTickCount: qword;
var
tv: ttimeval;
begin
fpgettimeofday(@tv, nil);
Result := Int64(tv.tv_sec) * 1000000 + tv.tv_usec;
end;
function Checksum(const Buf; Len: integer): word;
var
sum: cardinal = 0;
i: integer;
p: pbyte;
begin
p := @Buf;
i := 0;
while i < Len - 1 do
begin
sum := sum + (p[i] shl 8 + p[i + 1]);
Inc(i, 2);
end;
if (Len mod 2) <> 0 then
sum := sum + (p[Len - 1] shl 8);
sum := (sum shr 16) + (sum and $FFFF);
sum := sum + (sum shr 16);
Result := not word(sum);
end;
function IsValidIP(IP: string): boolean;
var
H: THostEntry;
begin
Result := ResolveHostByAddr(StrToHostAddr(IP), H);
end;
function GetHostIP(HostName: string): string;
var
H: THostEntry;
begin
if ResolveHostByName(HostName, H) then
Result := HostAddrToStr(NetToHost(H.Addr))
else
Result := '';
end;
function PingHost(const Host: string; var IP: string): double;
var
sock: cint;
sa: TInetSockAddr;
icmp: TICMPHeader;
buf: array[0..63] of byte;
n: integer;
id, seq: word;
sendTime, recvTime: qword;
ms: double;
fdset: TFDSet;
timeout: TTimeVal;
begin
Result := -99;
ip := host;
if not IsValidIP(ip) then
begin
ip := GetHostIP(host);
if ip = '' then
exit(-1); // WriteLn('Could not resolve ', host);
end;
writeln('ip ', ip);
FillChar(sa, SizeOf(sa), 0);
sa.sin_family := AF_INET;
sa.sin_addr := StrToNetAddr(ip);
sock := fpSocket(AF_INET, SOCK_DGRAM, IPPROTO_ICMP);
if sock = -1 then
exit(-2); // Socket error
id := word(FpGetPid);
seq := 1;
FillChar(icmp, SizeOf(icmp), 0);
icmp.icmp_type := ICMP_ECHO;
icmp.icmp_code := 0;
icmp.icmp_id := htons(id);
icmp.icmp_seq := htons(seq);
icmp.icmp_cksum := 0;
icmp.icmp_cksum := Checksum(icmp, SizeOf(icmp));
Move(icmp, buf, SizeOf(icmp));
sendTime := myGetTickCount;
n := fpSendTo(sock, @buf, SizeOf(icmp), 0, @sa, SizeOf(sa));
if n < SizeOf(icmp) then
begin
fpClose(sock);
exit(-3); // unknown error, reply smaller than icmp
end;
fpFD_ZERO(fdset);
fpFD_SET(sock, fdset);
timeout.tv_sec := TIMEOUT_SEC;
timeout.tv_usec := 0;
n := fpSelect(sock + 1, @fdset, nil, nil, @timeout);
if n > 0 then
begin
n := fpRecv(sock, @buf, SizeOf(buf), 0);
recvTime := myGetTickCount;
ms := (recvTime - sendTime) / 1000;
Result := ms;
end;
fpClose(sock);
end;
var
host, ip: string;
ms: double;
begin
if ParamCount <> 1 then
begin
WriteLn('Usage: minimalping <hostname-or-ip>');
Halt(1);
end;
host := ParamStr(1);
WriteLn('Pinging: ', host);
ms := PingHost(host, ip);
WriteLn('Result: ', ip, ' = ', ms: 0: 3, ' ms');
end.
Recent
