PingEx Alternative to Network PING

program pingex;
{$RESOURCE PINGEX32.RES}
{$APPTYPE CONSOLE}

uses
  SysUtils,
  math,
  httpapp,
  windows,
  winsock,
  mmsystem,
  Classes,
  urlmon,
  shellapi,
  ICMP in '..\delphi\ICMP.PAS';
const MAX_URLBUFFER=64*1024;

VAR MyICMP:TICMP;
count,successcount,trigger,i,irto:integer;
reply:PIcmpEchoReply;
LastPong:tdatetime;
errres,sitesres:TResourceStream;
icmperr:tstringlist;
t,tmax,bread,bmax,timerid:dword;
tmin:dword=$FFFFFFFF;
bmin:dword=$ffffffff;
hstat:hresult;
scomport,sh,s:string;
sites:tstringlist;
htimer,hf,hcom:thandle;
urlfile,oldtitle:array[0..max_path]of char;
PMask:pchar;
ipoptions:TIPOptionInformation;
urlbuff:array of ansichar;
data:array of byte;
totalt,totalb:extended;
a,b,c,d:byte;
function GetStatCode:string;
begin
result:='Unknown: '+Inttostr(reply.status);
if icmperr.IndexOf(inttostr(reply.status))=-1 then exit;
result := icmperr[icmperr.indexof(inttostr(reply.status))-1];
if reply.Status=0 then inc(Successcount);
if not comparemem(@myicmp.data[1],reply.data,length(myicmp.data)) then
result:=result+' INVALID DATA';
end;

function GetSize(fs:dword):String;
begin
result:=inttostr(fs)+' bytes';
if fs>1023 then result:=formatfloat('0.00',fs/1024)+' kilobytes';
if fs>(1024*1024)-1then result:=formatfloat('0.00',fs/(1024*1024))+' megabytes';
if fs=$FFFFFFFFthen result:='Size Error';
end;

function PingTime(tx:dword):string;
begin
if tx>999 then result:=formatdatetime('hh:mm:ss',tx*encodetime(0,0,0,1))else
result:=inttostr(tx)+'ms';
end;

function Divide(n,d:extended):Extended;
begin
result:=0;
if d>0then result:=n/d;
end;

function TimerThread(Dummy:pointer):dword;stdcall;
var contitle:array[0..255]of char;
label loop;
begin
loop:
setconsoletitle(strfmt(contitle,
'PingEx - %u Success, Packet Count %u, Packet Success: %f%s Last Pong: %s',[
successcount,count-1,Divide(successcount,count-1)*100,'%',DateTimeToStr(
lastpong)]));
sleep(100);
goto loop;
end;

function CtrlPing(typ:dword):bool;stdcall;
begin
result:=true;
writeln('Ping Details:');
writeln('Packets: Sent=',count-1,' Recevied=',successcount,' Lost=',(count-1)-
successcount);
if pos(' -url',lowercase(getcommandline))>0 then
writeln('Min. data: ',GetSize(bmin),' Max. data: ',getsize(bmax),' Ave. data: ',
getsize(trunc(divide(totalb,count-1))));
writeln('Min. Time: '+pingtime(tmin),' Max. Time: ',pingtime(tmax),' Ave. Time: ',
pingtime(Trunc(divide(totalt,count-1))));
writeln('Success rate:',trunc(100*divide(successcount,count-1)),'%');
writeln('Last Pong: ',datetimetostr(lastpong));
if typ<>CTRL_BREAK_EVENT then begin
setconsoletitle(oldtitle);
if scomport<>''then closehandle(hcom);
errres.Free;
icmperr.Free;
myicmp.Destroy;
if count-1>0 then
exitprocess(trunc(100*(successcount/(count-1))))else Exitprocess(0);
end;
end;

function GetDataSizeP:integer;
var i:integer;
begin
result:=0;
for i:=2 to paramcount do
if stricomp(pchar(paramstr(i)),'-l')=0then
result:=strtointdef(paramstr(i+1),32);
setlength(data,result);
for i:=0 to length(data)-2 do
data[i]:=(i mod 255)+1;
end;

function CheckPattern(const pattern:string;len:integer):boolean;
var i:integer;
begin
result:=false;
if(len<>length(pattern))then exit;
result:=true;
for i:=1to length(pattern)do result:=result and((i mod 16)=strtointdef('$'+
pattern[i],16));
end;

function GeneratePattern(len:integer):string;
var i:integer;
begin
result:='';
for i:=1to len do result:=result+inttohex(i mod 16,1);
end;

function GetDataString:string;
var i:integer;
begin
result:=datetimetostr(now)+'#'+inttostr(count)+' '+inttostr(getcurrentprocessid)+'.';
if strpos(getcommandline,' -url')<>nil then result:=generatepattern(getdatasizep);
for i:=1 to paramcount do begin
if stricomp('-d',pchar(paramstr(i)))=0then result:=paramstr(i+1);
if(stricomp('-dhex',pchar(paramstr(i)))=0) then result:=generatepattern(strtointdef(paramstr(i+1),32));
end;
if result='' then begin
writeln('Err:data parameter needs a string');
exitprocess(0);
end;
if getdatasizep>0 then result:=strpas(@Data[0]);
end;

function GetPacketCount:integer;
var i:integer;
begin
result:=-1;
for i:= 2 to paramcount do
if stricomp('-n',pchar(paramstr(i)))=0then result:=strtointdef(paramstr(i+1),4);
end;

Function GetDelay:dword;
var i:integer;
begin
result:=1000;
for i:=2 to paramcount do
if stricomp('-de',pchar(paramstr(i)))=0then result:=strtointdef(paramstr(i+1),
result);
end;

function GetTimeout:integer;
var i:integer;
begin
result:= myicmp.TimeOut;
for i:=2 to paramcount do
if stricomp('-w',pchar(paramstr(i)))=0then result:=strtointdef(paramstr(i+1),
result);
end;

function GetTOS:Integer;
var i:integer;
begin
result := myicmp.IPOptions.TOS;
for i:=2to paramcount do
if stricomp('-v',pchar(paramstr(i)))=0then result:=Strtointdef(paramstr(i+1),
result);
end;

function GetTTL:Integer;
var i:integer;
begin
result := myicmp.IPOptions.TTL;
for i:=2to paramcount do
if stricomp('-i',pchar(paramstr(i)))=0then result:=Strtointdef(paramstr(i+1),
result);
end;

function GetHTMLTitle:string;
begin
result :=copy(strpas(@urlbuff[0]),pos('<title>',lowercase(pchar(@urlbuff[0])))+
length('<title>'),pos('</title>',lowercase(pchar(@urlbuff[0])))-pos('<title>',
lowercase(pchar(@urlbuff[0])))-Length('</title'));
end;

function GetURLError:string;
begin
result:='Unknown Error';
if hstat=urlmon.INET_E_INVALID_URL then result:='Invalid URL';
if hstat=urlmon.INET_E_NO_SESSION then result:='No session';
if hstat=urlmon.INET_E_CANNOT_CONNECT then result:='Cannot Connect';
if hstat=urlmon.INET_E_RESOURCE_NOT_FOUND then result:='Resource Not Found';
if hstat=urlmon.INET_E_OBJECT_NOT_FOUND then result:='Object not found';
if hstat=urlmon.INET_E_DATA_NOT_AVAILABLE then result :='Data not available';
if hstat=urlmon.INET_E_DOWNLOAD_FAILURE then result := 'Download Failed';
if hstat=urlmon.INET_E_AUTHENTICATION_REQUIRED then result:='Login required';
if hstat=urlmon.INET_E_NO_VALID_MEDIA then result:='No valid media';
if hstat=urlmon.INET_E_CONNECTION_TIMEOUT then result:='Connection timedout';
if hstat=urlmon.INET_E_INVALID_REQUEST then result:='Invalid request';
if hstat=urlmon.INET_E_UNKNOWN_PROTOCOL then result:='Unsupported protocol';
end;

function ProcessPingExServer(html:PChar):boolean;
var data:tstringlist;
begin
result:=(paramstr(1)='');
if not result then Result:=((paramstr(1)[1]='-')and(stricomp(pchar(paramstr(1)),
'-urlr')<>0))or(strpos(getcommandline,' -ht')<>nil);
if not result then begin result:=true;exit;end;
if strpos(html,'<!-- PingEx_Server -->')=nil then result:=false;
data:=tstringlist.Create;
data.Text:=strpas(html);
if length(data.values['hex'])<>getdatasizep then begin result:=false;exit;end;
for i:=1to getdatasizep do result:=result and((i mod 16)=strtointdef('$'+
data.values['hex'][i],16));
end;

function HTMLValidate(const html:pchar):boolean;
var i:integer;
begin
result:=true;
for i:=2to paramcount do if stricomp(PChar(paramstr(i)),'-k')=0then
result:=result and (StrPos(html,pchar(paramstr(i+1)))=nil);
end;

function GetTrigger:integer;
var i:integer;
begin
result:=-1;
for i:=2 to paramcount do
if stricomp(PChar(paramstr(i)),'-tl')=0then result:=strtointdef(paramstr(i+1),5);
end;

function PlayWave(xwave:byte):bool;
const aWaves:array[0..2]of pchar=('PONG','OFFLINE','ONLINE');
begin
result:=false;
if strpos(getcommandline,' -nosound')<>nil then exit;
result:=playsound(awaves[xwave],hinstance,snd_resource or snd_sync);
end;

function InternetActup:boolean;
var hoffline:thandle;
dwwrite:dword;
a:atom;
cmdline:String;
comb:char;
batcmd,ab:array[0..255]of char;
statepath:array[0..max_path]of char;
txsuccess:bool;
i:integer;
begin
cmdline:=lowercase(getcommandline);
result := false;
inc(trigger);
if(trigger<gettrigger)or(gettrigger=-1)then exit;
trigger:=0;
result:=(scomport<>'');
txsuccess:=true;
for i:=2to paramcount do
if stricomp(pchar(paramstr(i)),'-bat')=0then result:=true;
if not result then exit;
writeln('Resetting internet connection. Please wait for ',irto div 60000,' minutes');
if pos(' -bat',cmdline)=0 then begin
comb:='1';
if pos(' -tx',cmdline)>0then txsuccess:=txsuccess and writefile(hcom,comb,1,
dwwrite,nil)else begin
//escapecommfunction(hcom,setdtr);
escapecommfunction(hcom,SETRTS);end;if not txsuccess then writeln('ComTXFail1:',
syserrormessage(getlasterror));
sleep(10000);
if pos(' -tx',cmdline)=0then
escapecommfunction(hcom,clrrts);
sleep(irto);
comb:='0';
if pos(' -tx',cmdline)>0then txsuccess:=txsuccess and writefile(hcom,comb,1,
dwwrite,nil)else escapecommfunction(hcom,clrdtr);if not txsuccess then
writeln('ComTXFail0:',syserrormessage(getlasterror));
end else begin
a:=globaladdatom(PChar('PingEx_OFFLINEBAT_'+floattostr(now)));
shellexecute(0,nil,'offline.bat',strfmt(batcmd,'%d %d',[a,trigger]),nil,
sw_hide);
writeln('Waiting for batch file to complete...');
while GlobalGetAtomName(a,ab,256)>0do sleep(2500);
end;
playwave(2);
writeln('Now rechecking...');
end;

function GetFileSize2(hf:thandle):DWord;
begin
result:= getfilesize(hf,nil);
if result=$FFFFFFFF then result:=0;
end;

function CharCount(const s:string;c:char):integer;
var i:integer;
begin
result:=0;
for i:=1to length(s)do if s[i]=c then inc(result);
end;

function FormatIP(var a,b,c,d:byte;size:integer;Host:string):String;
begin
result:=stringreplace(host,'@','%d',[rfReplaceAll]);
case size of
0:asm nop end;
1:begin if d=255then d:=0;D:=d+1;result:=format(result,[d]);end;
2:begin if c=255then begin c:=0;d:=d+1;end;if d=255then begin d:=0;c:=c+1;end;
d:=d+1;result:=format(result,[c,d]);end;
3:begin if b=255then b:=0;if c=255then begin c:=0;b:=b+1;end;
if d=255then begin d:=0;c:=c+1;end;d:=d+1;result:=format(result,[b,c,d]);end;
4:begin if a=255then a:=0;if b=255then begin b:=0;a:=a+1;end;if c=255then begin
c:=0;b:=b+1;end;if d=255then begin d:=0;c:=c+1;end;d:=d+1;result:=format(result,
[a,b,c,d]);end;
else begin writeln('Only up to 4 @ symbols allowed');exitprocess(
ERROR_INVALID_PARAMETER);end;
end;
end;



label PingLoop,URLLoop,lookup;
begin
getconsoletitle(oldtitle,max_path+1);
if stricomp('/resume',pchar(paramstr(1)))=0then exitprocess(globaldeleteatom(
strtoint(paramstr(2))));
if paramstr(1)='/?' then begin
writeln('Usage: ',extractfilename(paramstr(0)),' [address] [options]');
writeln('Options:');
writeln('-n count   Number of packets to send');
writeln('-d "data"  Data string to send in the echo request,by default is the system time,packet number and process id');
writeln('-w timeout timeout in milliseconds.');
writeln('-i TTL     Time To Live');
writeln('-v TOS     Type Of Service');
writeln('-de delay  Specifies the delay time between each request.');
writeln('-url       Use URL instead of ICMP [address] is the URL');
writeln('-urlr      Use random website URLs in the built-in database.');
writeln('-k "word"  HTML Error Keywords,used to tell if the URL request was successful, you can put more than one of this option in one command');
writeln('-l [size]  Size of data buffer');
writeln('-ir232 comport [timeout] Starts the internet resetter which toggles a relay to restart a misbehaving router/modem, [timeout] is in minutes');
writeln('-tl [count] Number of failed attemps before resetting the internet router/modem. Default is 5. This must be used with -ir232');
writeln('-bat        Run offline.bat file hiddenly when if went offline');
writeln('-tx         Transmitt ACSII 1s and 0s through the internet resetter serial port for using Arduino');
writeln('-nosound    Disable alert sounds.');
writeln('-dhex [size] Use a hexadecimal loop pattern. This will make the data string start from ASCII Number 1 to ASCII Letter F and then ASCII Number 0 then looping back around to make a string the specified size. This overrides the -d option.');
writeln('-ht          Uses PingEx HTTP Server url');
writeln;
writeln('Supported URL Protocols: HTTP,HTTPS,FTP');
writeln('You can put @ symbols in the address for ip address range example 127.0.0.@ will replace it with number between 1-255');
exitprocess(0);
end;
htimer:=createthread(nil,0,@timerthread,nil,0,timerid);
sitesres:=TResourceStream.Create(hinstance,'WEBSITES','TXT');
scomport:='';
for i:=2to paramcount do if stricomp('-ir232',pchar(paramstr(i)))=0then begin
scomport:='\\.\'+paramstr(i+1);
irto:=strtointdef(paramstr(i+2),5)*60000;
end;
if scomport<>''then begin
hcom:=createfile(pchar(scomport),generic_read or generic_write,0,nil,
open_existing,file_attribute_normal,0);
if hcom=invalid_handle_value then writeln('OpenCom:',syserrormessage(getlasterror));
end;
SetConsoleCtrlHandler(@ctrlping,true);
sites:=tstringlist.create;
sites.LoadFromStream(sitesres);sitesres.Free;
randomize;
icmperr:=tstringlist.Create;
errres:=tresourcestream.Create(hinstance,'ICMPERR','TXT');
icmperr.LoadFromStream(errres);
myicmp:=ticmp.create(nil);
ipoptions.OptionsSize:=myicmp.IPOptions.OptionsSize;
ipoptions.OptionsData:=myicmp.IPOptions.OptionsData;
IPOptions.TTL:=getttl;
iPOptions.TOS:=gettos;
myicmp.IPOptions:=ipoptions;
myicmp.TimeOut := gettimeout;
count:=1;
if (pos(' -url',lowercase(getcommandline))>0)or(paramcount=0)or(strpos(
getcommandline,' -ht')<>nil)then begin
if pos(' -urlr',lowercase(getcommandline))=0then begin
if paramcount<>0 then
writeln('Pinging ',paramstr(1),'...')else
writeln('Pinging http://172.86.120.127/test.asp...');
end else writeln('Pinging random URLs...');
a:=0;b:=0;c:=0;d:=0;
urlloop:
t:=gettickcount;
s:=paramstr(1);
if(paramcount=0)or(stricomp('-urlspeed',pchar(paramstr(1)))=0)then s:=
'http://172.86.120.127/test.asp';
s:=formatip(a,b,c,d,charcount(paramstr(1),'@'),s);
if pos(' -urlr',lowercase(getcommandline))>0then begin s:='http://'+sites[random(
sites.count)]+'/';write(copy(s,length('http://')+1,length(s)));end;
if pos('ftp:',lowercase(s))=0then
if strscan(pchar(s),'?')=nil then s:=s+'?'else s:=s+'&';
if pos('ftp:',lowercase(s))=0 then
s:=format(
'%sping.count=%d&ping.success=%d&ping.pid=%d&ping.size=%d',[s,count,successcount,
getcurrentprocessid,getdatasizep]);
if strscan(getcommandline,'@')<>nil then begin sh:=copy(s,pos('://',s)+3,length(s));
delete(sh,pos('?',sh),length(sh));write(sh,#32);end;
hstat:=URLDownloadToCacheFile(nil,pchar(s),urlfile,max_path,0,nil);
if (hstat=s_ok) then
begin
lastpong:=now;
hf:=createfile(urlfile,generic_read,0,nil,open_Existing,file_attribute_normal,0);
setlength(urlbuff,getfilesize(hf,nil)+1);
readfile(hf,urlbuff[0],length(urlbuff)-1,bread,nil);
trigger:=0;
if not htmlvalidate(@urlbuff[0]) then
write('KWFound: ');
if processpingexserver(@urlbuff[0])then
writeln(datetimetostr(now),'#',count,' Title:',gethtmltitle,' - Got ',getsize(
getfilesize(hf,nil)),' in ',pingtime(gettickcount-t))else begin
writeln(datetimetostr(now),'#',count,'Failed:',gethtmltitle,' - Got ',getsize(
getfilesize(hf,nil)),' in ',pingtime(gettickcount-t));dec(count);playwave(1);end;
bmin:=min(GetFilesize2(hf),bmin);
bmax:=max(getfilesize2(hf),bmax);
totalb:=totalb+getfilesize2(hf);
closehandle(hf);
deletefile(urlfile);
if htmlvalidate(@urlbuff[0]) then begin PlayWave(0); inc(successcount);end;
end else begin playwave(1);
 Writeln(datetimetostr(now),'#',count,' URL Error:',inttohex(hstat,0),#32,
geturlerror);
internetactup;
end;
totalt:=totalt+(gettickcount-t);
tmin:=min(tmin,gettickcount-t);
tmax:=max(tmax,gettickcount-t);
inc(count);
sleep(getdelay);
if getpacketcount=count-1 then ctrlping(ctrl_close_event);
goto urlloop;
end;
lookup:if strscan(getcommandline,'@')=nil then begin
myicmp.HostName:=paramstr(1);
if not myicmp.LookupAddress then begin
writeln(datetimetostr(now),' Failed to lookup ',myicmp.hostname);
sleep(2500);
playwave(1);
goto lookup;
end;end;
writeln('Pinging ',myicmp.hostname,'[',myicmp.hostip,']...');
a:=0;b:=0;c:=0;d:=0;
PingLoop:if strscan(getcommandline,'@')<>nil then begin
myicmp.HostName:=formatip(a,b,c,d,charcount(paramstr(1),'@'),myicmp.HostName);
write(myicmp.hostname,#32);
end;
t:=gettickcount;
myicmp.Data:=GetDataString;
reply:=myicmp.ping;
if reply=nil then begin
writeln(Datetimetostr(now),'#',count,' - No response');
playwave(0);
internetactup;
end else begin lastpong:=now;
writeln(datetimetostr(now),'#',count,#32,inet_ntoa(in_addr(reply.address)),' - ',
getstatcode,' Time:',pingtime(gettickcount-t),' TTL:',reply.options.ttl);
trigger:=0;
end;
totalt:=totalt+(gettickcount-t);
tmin:=min(tmin,gettickcount-t);
tmax:=max(tmax,gettickcount-t);
inc(count);
sleep(getdelay);
if getpacketcount=count-1 then ctrlping(ctrl_close_event);
goto pingloop;
end.