Утечка памяти при мультипоточном сканировании сети NetShareEnum

← →
Josh © (2009-01-30 00:13) [0]

Есть приложение, которое выполняет функции сканера общих ресурсов в
локальной сети (наподобие LanScope). Задается диапазон IP-адресов, который
нужно сканировать. Для сканирования каждого компьютера в этом диапазоне
создается отдельный поток, который пингует компьютер и в случае, если ответ
пришел, с помощью функции NetShareEnum пытается узнать доступные ресурсы.

Так вот, после каждого сканирования диапазона адресов занимаемая память
приложения (см. в диспетчере задач) увеличивается на 200-300 КБ по
необъяснимым причинам. Для отслеживания утечки памяти использовал FastMM4
(Fast Memory Manager), но он молчит. Возможно, я его неправильно настроил
для работы с мультипоточным приложением.

Помогите, пожалуйста, определить и устранить причину таинственной "утечки"
памяти.

Ниже привожу упрощенный рабочий, но проблемный код. Для запуска на форме
должна находится кнопка Button1 - для начала сканирования диапазона и поле
Memo1 - для вывода списка найденных общих ресурсов (желательно в Memo1
вставить вертикальный скроллинг). Диапазон адресов изменяется в тексте
программы, по умолчанию стоит от 192.168.1.1 до192.168.1.254.

← →
Josh © (2009-01-30 00:13) [1]

----------------------------------- Листинг (часть 1) ----------------------

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, WinSock, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

const
WSA_TYPE = $101;
IP_SUCCESS = 0;
SHARETYPE_DISKTREE = 0;

type
TIPAddress = array [1 .. 4] of Byte;
TIPAddressDynArray = array of TIPAddress;

TShareInfo = record
Name : String;
Path : String;
end;
TShareInfoDynArray = packed array of TShareInfo;

TSharedComputer = record
IPAddress : TIPAddress;
SharesList : TShareInfoDynArray;
end;
TSharedComputerDynArray = packed array of TSharedComputer;

TThreadScanResources = class(TThread)
private
Started : Boolean;
IPAddress : TIPAddress;
ShowHiddenShares : Boolean;
SharesList : TShareInfoDynArray;
protected
procedure Execute; override;
end;

TShareInfo1 = packed record
SHI1_NetName : PWChar;
SHI1_Type : DWORD;
SHI1_Remark : PWChar;
end;
TShareInfo1Array = packed array [1 .. 512] of TShareInfo1;
PShareInfo1Array = ^TShareInfo1Array;

IPOptionInformation = packed record
TTL : Byte;
TOS : Byte;
Flags : Byte;
OptionsSize : Byte;
OptionsData : Pointer;
end;

ICMPEchoReply = packed record
Address : Integer;
Status : Integer;
RTTime : Integer;
DataSize : Word;
Reserved : Word;
Data : Pointer;
Options : IPOptionInformation;
end;

PIPINFO = ^IPOptionInformation;
PVOID = Pointer;

function NetShareEnum(ServerName: PWideChar; Level: DWORD; BufPtr: Pointer;
PrefMaxLen: DWORD; EntriesRead, TotalEntries,
Resume_Handle: LPDWORD): DWORD;
stdcall; external "NETAPI32.DLL";

function ICMPCreateFile: THandle; stdcall; external "ICMP.DLL" Name
"IcmpCreateFile";

function ICMPCloseHandle(IcmpHandle: THandle): Bool; stdcall; external
"ICMP.DLL" Name "IcmpCloseHandle";

function ICMPSendEcho(ICMPHandle: THandle; DestAddress: u_long; RequestData:
PVOID;
RequestSize: Word; RequestOptns: PIPINFO; ReplyBuffer:
PVOID;
ReplySize: DWORD; Timeout: DWORD): DWORD; stdcall;
external "ICMP.DLL" Name "IcmpSendEcho";

← →
Josh © (2009-01-30 00:14) [2]

----------------------------------- Листинг (часть 2) ----------------------

procedure Delay(ms: Longint);
{$IFNDEF WIN32}
var
TheTime: Longint;
{$ENDIF}
begin
{$IFDEF WIN32}
Sleep(ms);
{$ELSE}
TheTime:= GetTickCount + ms;
while GetTickCount < TheTime do Application.ProcessMessages;
{$ENDIF}
end;

procedure StrToPWChar(S: String; var Buffer: PWChar; BufferSize: Byte =
255);
var
L: Integer;
begin
L:= SizeOf(WideChar) * BufferSize;
GetMem(Buffer, L);
StringToWideChar(S, Buffer, L);
end;

function FullIP(IPSegment1, IPSegment2, IPSegment3, IPSegment4: Byte):
TIPAddress;
begin
Result[1]:= IPSegment1;
Result[2]:= IPSegment2;
Result[3]:= IPSegment3;
Result[4]:= IPSegment4;
end;

function IPToStr(IPAddress: TIPAddress): String;
begin
Result:= IntToStr(IPAddress[1]) + "." + IntToStr(IPAddress[2]) + "." +
IntToStr(IPAddress[3]) + "." + IntToStr(IPAddress[4]);
end;

function FullNetSharePath(RemoteHost, ShareName: String): String;
begin
Result:= "\\" + RemoteHost + "\" + ShareName + "\";
end;

function PingComputer(ComputerName: String; Timeout: Cardinal): Integer;
var
hIP : THandle;
PingBuffer : array [0 .. 31] of Char;
pIPe : ^ICMPEchoReply;
PHostEn : PHostEnt;
LWSAData : WSAData;
DestAddress : In_Addr;
WVersionRequested : WORD;
begin
Result:= -1;
hIP:= ICMPCreateFile;
GetMem(pIPe, SizeOf(ICMPEchoReply) + SizeOf(PingBuffer));
pIPe.Data := @PingBuffer;
pIPe.DataSize := SizeOf(PingBuffer);
WVersionRequested := MakeWord(1, 1);
try
if WSAStartup(WVersionRequested, LWSAData) = 0 then
begin
PHostEn:= GetHostByName(PChar(ComputerName));
if GetLastError = 0 then
begin
DestAddress:= PInAddr(PHostEn^.H_Addr_List^)^;
IcmpSendEcho(hIP, DestAddress.S_Addr, @PingBuffer,
SizeOf(PingBuffer), nil, pIPe, SizeOf(ICMPEchoReply) + SizeOf(PingBuffer),
Timeout);
if GetLastError = 0 then Result:= pIPe^.Status;
end;
WSACleanup;
end;
finally
ICMPCloseHandle(hIP);
FreeMem(pIPe);
end;
end;

function ComputerEnabled(ComputerName: String): Boolean;
begin
Result:= PingComputer(ComputerName, 500) = IP_SUCCESS;
end;

procedure GetShares(ComputerName: String; var SharesList:
TShareInfoDynArray; ShowHidden: Boolean);
var
ShareInfo1 : PShareInfo1Array;
EntriesRead : DWORD;
TotalEntries : DWORD;
CompName : PWChar;
TotalSharesList : TShareInfoDynArray;
i : Integer;
begin
StrToPWChar(ComputerName, CompName, 64);

if NetShareEnum(CompName, 1, @ShareInfo1, DWORD(-1), @EntriesRead,
@TotalEntries, nil) = 0 then
for i:= 1 to EntriesRead do
if (ShareInfo1^[i].SHI1_Type = SHARETYPE_DISKTREE) and
(ShowHidden or
(String(ShareInfo1^[i].SHI1_NetName)[Length(String(ShareInfo1^[i].SHI1_NetName)) ]
<> "$")) then
begin
SetLength(TotalSharesList, Length(TotalSharesList) + 1);
TotalSharesList[Length(TotalSharesList) - 1].Name:=
String(ShareInfo1^[i].SHI1_NetName);
TotalSharesList[Length(TotalSharesList) - 1].Path:= "";
end;

FreeMem(CompName);
SharesList:= Copy(TotalSharesList);
TotalSharesList:= nil;
end;

procedure GetSharesFromIPRange(IPFrom, IPTo: TIPAddress; var
SharedComputers: TSharedComputerDynArray; var EmptyComputers:
TIPAddressDynArray; ShowHidden: Boolean);
var
ScanThreads : array of TThreadScanResources;
TotalSharedComputers : TSharedComputerDynArray;
TotalEmptyComputers : TIPAddressDynArray;
i: Integer;
begin
if (IPFrom[1] = IPTo[1]) and (IPFrom[2] = IPTo[2]) and (IPFrom[3] =
IPTo[3]) and (IPFrom[4] <= IPTo[4]) then
begin
for i:= IPFrom[4] to IPTo[4] do
begin
SetLength(ScanThreads, Length(ScanThreads) + 1);
ScanThreads[Length(ScanThreads) - 1]:=
TThreadScanResources.Create(True);
with ScanThreads[Length(ScanThreads) - 1] do
begin
Started:= False;
IPAddress:= FullIP(IPFrom[1], IPFrom[2], IPFrom[3], i);
ShowHiddenShares:= ShowHidden;
SetLength(SharesList, 0);
Priority:= tpLowest;
Resume;
end;
end;

for i:= 0 to Length(ScanThreads) - 1 do
with ScanThreads[i] do
begin
while not Started do Delay(100);
WaitForSingleObject(Handle, INFINITE);

if Length(SharesList) > 0 then
begin
SetLength(TotalSharedComputers, Length(TotalSharedComputers) +
1);
TotalSharedComputers[Length(TotalSharedComputers) - 1].IPAddress
:= IPAddress;
TotalSharedComputers[Length(TotalSharedComputers) -
1].SharesList := Copy(SharesList);
end
else
begin
SetLength(TotalEmptyComputers, Length(TotalEmptyComputers) + 1);
TotalEmptyComputers[Length(TotalEmptyComputers) - 1]:=
IPAddress;
end;

FreeAndNil(ScanThreads[i]);
Application.ProcessMessages;
end;

SharedComputers := Copy(TotalSharedComputers);
EmptyComputers := Copy(TotalEmptyComputers);
TotalSharedComputers := nil;
TotalEmptyComputers := nil;
end;
end;

procedure TThreadScanResources.Execute;
begin
Started:= True;
if ComputerEnabled(IPToStr(IPAddress)) then GetShares(IPToStr(IPAddress),
SharesList, ShowHiddenShares);
end;

{ - - Пример использования - -}

procedure TForm1.Button1Click(Sender: TObject);
var
SharedComputers : TSharedComputerDynArray;
EmptyComputers : TIPAddressDynArray;
n, p: Integer;
begin
GetSharesFromIPRange(FullIP(192, 168, 1, 1), FullIP(192, 168, 1, 254),
SharedComputers, EmptyComputers, False);

Memo1.Clear;
Memo1.Lines.Add(TimeToStr(GetTime));
for n:= 0 to Length(SharedComputers) - 1 do
for p:= 0 to Length(SharedComputers[n].SharesList) - 1 do
Memo1.Lines.Add(FullNetSharePath(IPToStr(SharedComputers[n].IPAddress),
SharedComputers[n].SharesList[p].Name));
Memo1.Lines.Add("");
Memo1.Lines.Add("EmptyComputers = " + IntToStr(Length(EmptyComputers)));

SharedComputers := nil;
EmptyComputers := nil;
end;

{ - - - }

end.

← →
Slym © (2009-01-30 17:48) [3]

говнокод... на рефакторинг!
первая ошибка - один IP, один поток - нафега?
должно быть: N потоков (ну никак не 255 как у тебя!), буфер из M айпишников...
Поток берет из буфера IP ищет шары и снова ныряет в буфер за новым ипишником
procedure TThreadScanResources.Execute;
begin
while not terminated do
begin
if not GetIP(IP) then exit;
if ComputerEnabled(IPToStr(IPAddress)) then
begin
GetShares(IPToStr(IPAddress),SharesList, ShowHiddenShares);
SetIPShares(IP,SharesList);
end;
end;

end

← →
Josh © (2009-01-30 19:56) [4]

Большое спасибо! Я очень люблю и уважаю критику, особенно с примерами!
Уже переделываю код...

← →
Josh © (2009-02-01 00:00) [5]

Slym, еще раз спасибо! При уменьшении количества потоков до 5:

1. Время сканирования одного сегмента сети увеличилось в среднем до 0,5 - 1 мин.

2. Остается свободным сетевой канал (другие сетевые приложения могут продолжать нормально работать, в отличие, когда мой сканер при 255 потоках полностью "забивал" канал).

3. Исчезла утечка памяти! :)

колво потоков можно смело поднять до 8-10
Исчезла утечка памяти возможно и нет :) а снизилось ее проявление в 255/5 раз :)

← →
FireMan_Alexey (2009-02-04 01:13) [7]

procedure TForm1.Button1Click(Sender: TObject);
var
SharedComputers : TSharedComputerDynArray;
EmptyComputers : TIPAddressDynArray;
n, p: Integer;
begin
GetSharesFromIPRange(FullIP(192, 168, 1, 1), FullIP(192, 168, 1, 254),
SharedComputers, EmptyComputers, False);

Memo1.Clear;
Memo1.Lines.Add(TimeToStr(GetTime));
for n:= 0 to Length(SharedComputers) - 1 do
for p:= 0 to Length(SharedComputers[n].SharesList) - 1 do
Memo1.Lines.Add(FullNetSharePath(IPToStr(SharedComputers[n].IPAddress),
SharedComputers[n].SharesList[p].Name));
Memo1.Lines.Add("");
Memo1.Lines.Add("EmptyComputers = " + IntToStr(Length(EmptyComputers)));

SharedComputers := nil;
EmptyComputers := nil;
end

С динамическим массивом надо SetLength(???,0);
Я один раз забыл, так у меня на 8 Мег утекло :)

← →
FireMan_Alexey (2009-02-04 01:17) [8]

Length(SharedComputers[n].SharesList) - 1 = High(SharedComputers[n].SharesList) на пару шагов меньше :)

Утечка памяти при мультипоточном сканировании сети NetShareEnum Найти похожие ветки