
Шустрый

Профиль
Группа: Участник
Сообщений: 59
Регистрация: 22.9.2006
Репутация: нет Всего: нет
|
есть сайт на котором я проверяю работоспособность страниц. Все нормально работает. Но после обработки 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.
|
Присоединённый файл ( Кол-во скачиваний: 13 )
get_link_new_2.zip 7,58 Kb
|