есть сайт на котором я проверяю работоспособность страниц. Все нормально работает. Но после обработки 1100-1200 страницы программа виснет, хотя добавил процедуру приостановки цикла.
на момент зависания ехе - файл занимает в процессах 200 мб оперативной памяти... Видимо нужно что-то чистить в цикле, но не пойму что?
з.ы в атаче с модулями парсинга
| Код |
unit ftpUnit;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, WinInet, htmlParsUnit, ExtCtrls, ComCtrls;
type
TFrmMain = class(TForm)
Panel1: TPanel;
baseURL: TEdit;
operationButton: TButton;
PrgsBar: TProgressBar;
LblPrgs: TLabel;
EditF: TEdit;
EditL: TEdit;
Label1: TLabel;
Label2: TLabel;
procedure operationButtonClick(Sender: TObject);
private
{Private section}
public
{Public section}
HTMLParser: THTMLParser;
procedure parseHTMLFiles(filename: string; testUrl: string);
function downloadPages(baseURL: string; startPage: integer; countPages: integer): boolean;
procedure WriteLog(str: string);
function CheckUrlFTP(testUrl:string): boolean;
end;
var
FrmMain: TFrmMain;
fPage, lPage: integer;
x: real=0;
xPrgs: real;
procedure Msg(str: string);
procedure Delay(ATimeout: Integer);
const
fileName = 'log.txt';
implementation
{$R *.dfm}
procedure Msg(str: string);
begin
showMessage(str)
end;
procedure Delay(ATimeout: Integer);
var
t: Cardinal;
begin
while ATimeout > 0 do
begin
t := GetTickCount;
if MsgWaitForMultipleObjects(0, nil^, False, ATimeOut, QS_ALLINPUT) = WAIT_TIMEOUT then
Exit;
Application.ProcessMessages; // Пришли новые сообщения Windwos , обрабатываем их..
dec(ATimeout, GetTickCount - t);
end;
end;
procedure TFrmMain.parseHTMLFiles(filename: string; testUrl: string);
const
baseLink = 'Скачать фильм';
var
j, i: integer;
obj, next: TObject;
HTMLTag: THTMLTag;
HTMLParam: THTMLParam;
begin
if FileExists(fileName) = False then Exit;
x:=x+1;
HTMLParser:=THTMLParser.Create;
HTMLParser.Lines.LoadFromFile(filename);
HTMLParser.Execute;
for i:=1 to HTMLParser.parsed.Count do
begin
obj:=HTMLParser.parsed[i-1];
if obj.classtype = THTMLTag then
begin
HTMLTag:=THTMLTag(obj);
if uppercase(HTMLTag.Name) = uppercase('A') then
if not ((HTMLTag.Params = nil) or (HTMLTag.Params.Count = 0)) then
for j:=1 to HTMLTag.Params.Count do
begin
HTMLParam:=HTMLTag.Params[1-1];
if upperCase(HTMLParam.key) = uppercase('href') then
begin
if i < HTMLParser.parsed.Count then
begin
next:=HTMLParser.parsed[i];
if next.classtype = THTMLText then
if upperCase(THTMLText(next).Line) = upperCase(baseLink) then
begin
if (CheckUrlFTP(HTMLParam.value) = false) and
(Copy(HTMLParam.value, 10, 1)<>'3') then
WriteLog(testUrl);
end;
end;
end;
end;
end;
end;
PrgsBar.Position:=Round(xPrgs * x);
LblPrgs.Caption:=IntToStr(Round(PrgsBar.Position/10)) + ' %';
FrmMain.Refresh;
end;
function TFrmMain.CheckUrlFTP(testUrl:string): boolean;
var
hSession, hURL: HInternet;
begin
Result:=False;
hSession := InternetOpen('Program_Name',
INTERNET_OPEN_TYPE_PRECONFIG,
nil, nil, 0);
if hSession = nil then
begin
Msg('Unable to get access to WinInet.Dll');
Exit
end;
hURL := InternetOpenURL(hSession, PChar(testUrl), nil,0,0,0);
if hURL <> nil then Result := True;
InternetCloseHandle(hSession);
end;
procedure TFrmMain.WriteLog(str: string);
var
f: TextFile;
begin
try
AssignFile(f, fileName); // привязка названия к переменной
if not FileExists(fileName) then
begin
Rewrite(f);
CloseFile(f);
end;
Append(f);
WriteLn(f, str); // запись в файл строки с символами перевода строки
CloseFile(f); // закрыть файл
except
Msg('Ошибка создания или записи в файл');
exit;
end;
end;
function GetInetFile(const fileURL, fileName: string): boolean;
{-----------------------------------------------------------}
{ Функция скачивания файла из интернета, с возможностью ... }
{ ... ограничения размера скачиваемого блока файла }
{ }
{ Параметры: }
{ fileURL - адрес скачиваемого файла, }
{ fileName - имя сохраняемого файла }
{-----------------------------------------------------------}
const
bufferSize = 1024;
var
hSession, hURL: HInternet;
buffer: array[1..bufferSize] of byte;
bufferLen: DWORD;
f: file;
sAppName: string;
begin
result:=false;
sAppName:=extractfilename(Application.ExeName);
hSession:=InternetOpen(PChar(sAppName), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
if hSession = nil then
begin
Msg('Не могу подключиться к сереверу');
Exit
end;
hURL:=InternetOpenURL(hSession, pChar(fileURL), nil, 0, 0, 0);
if hURL = nil then
begin
Msg('Не могу подключиться к сереверу');
Exit
end;
try
assignfile(f, fileName);
rewrite(f,1);
repeat
InternetReadFile(hURL, @Buffer, SizeOf(Buffer), BufferLen);
BlockWrite(f, Buffer, BufferLen)
until bufferLen = 0;
closefile(f);
result:=true
finally
InternetCloseHandle(hURL);
end;
InternetCloseHandle(hSession);
Delay(100);
end;
function TFrmMain.downloadPages(baseURL: string; startPage: integer; countPages: integer): boolean;
{-------------------------------------------------------------------}
{ Функция скачивания файлов из интернета, определяемых ссылками ... }
{ ... вида "sitename/num/" (например, http://www.nemets.com/page/2/)}
{ }
{ Параметры: }
{ baseURL - базовый URL для скачиваемых страниц, }
{ countPages - число скачиваемых страниц }
{-------------------------------------------------------------------}
const
basePagename = 'noname';
var
i: integer;
begin
result:=False;
if baseURL <> '' then
begin
for i:=startPage to countPages do
begin
if baseURL[length(baseURL)] = '/' then
baseURL:=copy(baseURL, 0, length(baseURL) - 1);
result:=result and GetInetFile(baseURL + '/' + inttostr(i) + '/', basePagename + inttostr(i) + '.htm');
parseHTMLFiles(basePagename + inttostr(i) + '.htm', baseURL + '/' + inttostr(i) + '/');
deleteFile(basePagename + inttostr(i) + '.htm');
result:=true;
end;
end;
end;
procedure TFrmMain.operationButtonClick(Sender: TObject);
begin
if FileExists(fileName) then deleteFile(fileName);
fPage:=StrToInt(EditF.Text); lPage:=StrToInt(EditL.Text);
if lPage-fPage < 0 then
begin
msg ('Начальная страница не должна быть больше конечной!');
Exit
end;
if lPage-fPage > 0 then xPrgs:=1000/(lPage-fPage);
if lPage-fPage = 0 then xPrgs:=1000;
if downloadPages(baseURL.Text, fPage, lPage) then
Msg('Формирование списка ссылок завершено успешно!')
else
Msg('Ошибка формирования списка ссылок...');
PrgsBar.Position:=0;
end;
end.
|
|