Модераторы: Snowy, Poseidon, MetalFan
  

Поиск:

Ответ в темуСоздание новой темы Создание опроса
> парсинг html, виснет на 1000 странице 
:(
    Опции темы
AlanFree
Дата 4.9.2009, 12:39 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 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
PM MAIL   Вверх
xordata
Дата 8.9.2009, 08:22 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 1
Регистрация: 8.9.2009

Репутация: нет
Всего: нет



Код

procedure TFrmMain.parseHTMLFiles(filename: string; testUrl: string);
const
    baseLink = 'Скачать фильм';
var
 j, i: integer;
 obj, next: TObject;
 HTMLTag: THTMLTag;
 HTMLParam: THTMLParam;
begin
    if Not FileExists(fileName) then
        Exit;
    Inc(x);
    HTMLParser:=THTMLParser.Create;
    Try
        HTMLParser.Lines.LoadFromFile(filename);
        HTMLParser.Execute;
        for i:=0 to Pred(HTMLParser.parsed.Count) do
        begin
            obj:=HTMLParser.parsed[i];
            if obj.classtype = THTMLTag then
            Try
                HTMLTag:=THTMLTag(obj);
                if (uppercase(HTMLTag.Name) = 'A') And
                        Not (Not Assigned(HTMLTag.Params) or (HTMLTag.Params.Count = 0)) then
                for j:=0 to Pred(HTMLTag.Params.Count) do
                begin
                    HTMLParam:=HTMLTag.Params[j];
                    if upperCase(HTMLParam.key) = 'HREF' then
                    begin
                        next:=HTMLParser.parsed[j];
                        if (next.classtype = THTMLText) and (upperCase(THTMLText(next).Line) = upperCase(baseLink)) then
                        if (Not CheckUrlFTP(HTMLParam.value)) and (Copy(HTMLParam.value, 10, 1)<>'3') then
                            WriteLog(testUrl);
                    end;
                end;
            Finally
                HTMLTag.Free;
            End;
        end;
    Finally
        HTMLParser.Free;
    End;
    PrgsBar.Position:=Round(xPrgs * x);
    LblPrgs.Caption:=IntToStr(Round(PrgsBar.Position/10)) + ' %';
    FrmMain.Refresh;
end;


Студент! (?)
1. Кто объекты за тобой подчищать будет? Здесь нет garbage collector!
2. Строка
Код

HTMLParam:=HTMLTag.Params[1-1];

Может быть должна выглядеть так?
Код

HTMLParam:=HTMLTag.Params[j-1];

3. Ну на кой чёрт такая проверка?
Код

 if i < HTMLParser.parsed.Count then


P.S. правку выполнил, не вникая в смысл написанного. Маленькое пожелание - узнай про with ... do
Удачи!
PM MAIL   Вверх
MetalFan
Дата 8.9.2009, 11:59 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Аццкий Сотона
****


Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 14
Всего: 128



AlanFree, прогони каким-нибудь профайлером, чтобы отследить где у тебя память течет...
либо вдумчиво пересмотри код)


--------------------
There are always someone smarter than you...
PM MAIL   Вверх
  
Ответ в темуСоздание новой темы Создание опроса
Правила форума "Delphi: Сети"
Snowy
Poseidon
MetalFan

Запрещено:

1. Публиковать ссылки на вскрытые компоненты

2. Обсуждать взлом компонентов и делится вскрытыми компонентами

  • Литературу по Дельфи обсуждаем здесь
  • Действия модераторов можно обсудить здесь
  • С просьбами о написании курсовой, реферата и т.п. обращаться сюда
  • Вопросы по реализации алгоритмов рассматриваются здесь
  • 90% ответов на свои вопросы можно найти в DRKB (Delphi Russian Knowledge Base) - крупнейшем в рунете сборнике материалов по Дельфи

Если Вам помогли и атмосфера форума Вам понравилась, то заходите к нам чаще! С уважением, Snowy, Poseidon, MetalFan.

 
1 Пользователей читают эту тему (1 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема | Delphi: Сети | Следующая тема »


 




[ Время генерации скрипта: 0.0670 ]   [ Использовано запросов: 21 ]   [ GZIP включён ]


Реклама на сайте     Информационное спонсорство

 
По вопросам размещения рекламы пишите на vladimir(sobaka)vingrad.ru
Отказ от ответственности     Powered by Invision Power Board(R) 1.3 © 2003  IPS, Inc.