Multi thread Ping in Free Pascal

Am arătat în articolul precedent cum se poate utiliza WMI pentru testarea disponibilității unui device dintr-o rețea. În articolul curent prezint codul sursă a unei aplicații ce permite lansarea de comenzi ping către diferite IP-uri prin multi thread-uri.

program project1;

{$mode objfpc}{$H+}

uses Classes, SysUtils, CustApp, Windows, ActiveX, ComObj, GetOpts;

Type TPingThread = Class(TThread)
 Computer: String;
 Procedure Execute; Override;
 End;

Const Buffer: Integer= 32;
 Timeout: Integer= 100;
 Retries: Integer= 4;
 MaxThreads: Integer= 30;

Var c: Char;
 OptionIndex: Longint;
 TheOpts: Array[1..5] Of TOption;
 i, ActiveThreads, IpOffline, IpOnLine: Integer;
 IpList: TStringList;
 t: TPingThread;
 Start: Variant;

Function WmiPing(Const Address: String; Const BufferSize, Timeout: Word): Integer;
Const WmiUser = '';
 WmiPassword = '';
 WmiComputer = 'localhost';
 WmiFlagForwardOnly = $00000020;
Var WmiLocator : OLEVariant;
 WmiService : OLEVariant;
 WmiObjectSet: OLEVariant;
 WmiObject : Variant;
 oEnum : ActiveX.IEnumvariant;
 WmiQuery : String[250];
begin
 Result:= -1;
 CoInitialize(Nil);
 Try
 WmiLocator := ComObj.CreateOleObject('WbemScripting.SWbemLocator');
 WmiService := WmiLocator.ConnectServer(WmiComputer, 'root\CIMV2', WmiUser, WmiPassword);
 WmiQuery := Format('Select * From Win32_PingStatus '+
 'Where Address=%s And BufferSize=%d And TimeOut=%d',
 [QuotedStr(Address), BufferSize, Timeout]);
 WmiObjectSet:= WmiService.ExecQuery(WmiQuery, 'WQL', WmiFlagForwardOnly);
 oEnum := IUnknown(WmiObjectSet._NewEnum) As IEnumVariant;
 While oEnum.Next(1, WmiObject, Nil) = 0 Do
 Begin
 Result:= LongInt(WmiObject.Properties_.Item('StatusCode').Value);
 WmiObject:= Unassigned;
 End;
 Finally
 CoUninitialize;
 End;
end;

Procedure TPingThread.Execute;
Var i, k: Integer;
begin
 k:= 0;
 For i:= 1 To Retries Do
 If WmiPing(Computer, Buffer, Timeout)= 0 Then
 Inc(k);

If k= 0 Then
 Inc(IpOffLine)
 Else
 Inc(IpOnLine);

Writeln(Computer, ';', k, ';', Retries);
 Dec(ActiveThreads);
End;

begin
 Start:= GetTickCount;
 IpList:= TStringList.Create;

With TheOpts[1] Do
 Begin
 Name:= 'ipfile';
 Has_Arg:= 1;
 Flag:= Nil;
 Value:= #0;
 End;
 With TheOpts[2] Do
 Begin
 Name:= 'buffer';
 Has_Arg:= 1;
 Flag:= Nil;
 Value:= #0;
 End;
 With TheOpts[3] Do
 Begin
 Name:= 'timeout';
 Has_Arg:= 1;
 Flag:= Nil;
 Value:= #0;
 End;
 With TheOpts[4] Do
 Begin
 Name:= 'retries';
 Has_Arg:= 1;
 Flag:= Nil;
 Value:= #0;
 End;
 With TheOpts[5] Do
 Begin
 Name:= 'maxthreads';
 Has_Arg:= 1;
 Flag:= Nil;
 Value:= #0;
 End;

c:= #0;
 Repeat
 c:= GetLongopts(':i:b:t:r:m:', @TheOpts[1], OptionIndex);
 Case c Of
 'i': If FileExists(OptArg) Then
 Begin
 IpList.LoadFromFile(OptArg);
 If IpList.Count= 0 Then
 Begin
 Writeln('Empty IP File: ', OptArg);
 Exit;
 End;
 End
 Else
 Begin
 Writeln('IP File not found: ', OptArg);
 Exit;
 End;

'b': Begin
 Buffer:= StrToInt(OptArg);
 If (Buffer< 0) Or (Buffer> 65500) Then
 Begin
 Writeln('Ping Buffer ', OptArg, ' out of limit 0..65500');
 Exit;
 End;
 End;
 't': Begin
 Timeout:= StrToInt(OptArg);
 If (Timeout< 10) Or (Timeout> 10000) Then
 Begin
 Writeln('Ping Timeout ', OptArg, ' out of limit 10..10000');
 Exit;
 End;
 End;
 'r': Begin
 Retries:= StrToInt(OptArg);
 If (Retries< 1) Or (Retries> 10) Then
 Begin
 Writeln('Ping Retries ', OptArg, ' out of limit 1..10');
 Exit;
 End;
 End;
 'm': Begin
 MaxThreads:= StrToInt(OptArg);
 If (MaxThreads< 1) Or (MaxThreads> 500) Then
 Begin
 Writeln('Max Threads ', OptArg, ' out of limit 1..500');
 Exit;
 End;
 End;
 End; { case }
 Until c= EndOfOptions;

ActiveThreads:= 0;
 IpOffline:= 0;
 IpOnLine:= 0;
 i:= 0;
 Writeln('Computer;Success;Total');
 While i< IpList.Count Do
 Begin
 If ActiveThreads< MaxThreads Then
 Begin
 t:= TPingThread.Create(True);
 Inc(ActiveThreads);
 Inc(i);
 t.Computer:= IpList[i- 1];
 t.FreeOnTerminate:= True;
 t.Start;
 End;
 End;

While ActiveThreads> 0 Do ;

WriteLn;
 WriteLn('Ip Count= ', IpList.Count);
 WriteLn('Ip Online= ', IpOnLine);
 WriteLn('Ip Offline= ', IpOffline);
 WriteLn('Buffer= ', Buffer);
 WriteLn('Timeout= ', Timeout, ' ms');
 WriteLn('Retries= ', Retries);
 WriteLn('Max Threads= ', MaxThreads);
 WriteLn('Elapsed Time= ', (GetTickCount- Start)/ 1000, 's');

IpList.Free;
end.

Pentru a-l putea folosi descărcați ultima versiune de Lazarus IDE. Eu am compilat programul cu v1.2.0 pe 64 biți. După compilare, din linia de comandă se utilizează astfel:

Pinguin64.exe -i "IP LIST.txt" -b 32 -t 100 -r 4 -m 500 > "IP RESULT.TXT"

unde “IP LIST.txt” este un fișierul care conține lista de IP-uri țintă, iar “IP RESULT.TXT” este fișierul în care vor fi vărsate rezultatele. Parametrii  -b 32 arată faptul că se trimit 32 biți prin ping, -t 100 reprezintă timeout-ul ping-ului în milisecunde, -r 4 reprezintă numărul de încercări succesive efectuate către fiecare IP în parte, iar -m 500 numărul de thread-uri utilizate. Atenție: un număr prea mare de thread-uri se poate să nu poată fi încărcat în memoria computerului dvs!

 

sdfsdfsd