404 многопоточный чекер – сырцы на Delphi

Много умничать не буду. Выложу сырцы 404 чекера с небольшими комментариями. За код не пинать, писалось так для себя и людям дать поюзать.

Первым будет файл проекта – к примеру checker404.dpr
[sourcecode language='delphi']
program checker404;
uses
Forms,
main in ‘main.pas’ {Form1};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
[/sourcecode]
Файл настроек – gpda.ini
[sourcecode language='delphi']
[setup]
Threads=500
[/sourcecode]

Главная форма.
[sourcecode language='delphi']
unit main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Menus, ComCtrls, ExtCtrls;
type
TForm1 = class(TForm)
StatusBar1: TStatusBar;
MainMenu1: TMainMenu;
Loadbase1: TMenuItem;
Checkbase1: TMenuItem;
Savecheked1: TMenuItem;
Exit1: TMenuItem;
Memo1: TMemo;
Timer1: TTimer;
Memo2: TMemo;
OpenDialog1: TOpenDialog;
procedure Timer1Timer(Sender: TObject);
procedure Loadbase1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);
procedure Savecheked1Click(Sender: TObject);
procedure Checkbase1Click(Sender: TObject);
private
{ Private declarations }
thrCount: Integer;
procedure ThreadDone(Sender: TObject);
public
{ Public declarations }
end;
var
Form1: TForm1;

implementation
uses ThreadHTTP, IniFiles;

{$R *.dfm}
var
MaxThreads: Integer;

procedure TForm1.ThreadDone(Sender: TObject);
begin
Dec(thrCount);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
StatusBar1.Panels[1].Text := ‘Total Good URL: ‘ + IntToStr(memo1.Lines.Count);

StatusBar1.Panels[2].Text := ‘Threads: ‘ + IntToStr(thrCount);
end;

procedure TForm1.Loadbase1Click(Sender: TObject);
begin
if OpenDialog1.Execute then memo2.Lines.LoadFromFile(OpenDialog1.FileName);
StatusBar1.Panels[0].Text := ‘Total loaded URL: ‘ + IntToStr(memo2.Lines.Count);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
AppIni: TIniFile;
begin
thrCount := 0;
AppIni := TIniFile.Create(ExtractFilePath(Application.ExeName) + ‘gpda.ini’);
MaxThreads := AppIni.ReadInteger(’setup’, ‘Threads’, 5);
AppIni.Free;
end;

procedure TForm1.Savecheked1Click(Sender: TObject);
begin
memo1.Lines.SaveToFile(ExtractFilePath(Application.ExeName) + ‘good.txt’);
end;

procedure TForm1.Checkbase1Click(Sender: TObject);
var
i: integer;
tmp: string;
lThrd: TGrabThread;
begin
i := 0;
while i <= memo2.Lines.Count do
begin
while thrCount > MaxThreads do Application.HandleMessage;
with TGrabThread.Create(true) do
begin
Application.HandleMessage;
url := Memo2.Lines[i];
inc(i);
FreeOnTerminate := true;
OnTerminate := ThreadDone;
Count := thrCount;
StatusBar1.Panels[3].Text := ‘Cheking: ‘ + IntToStr(i) + ‘ of ‘ + IntToStr(Memo2.Lines.Count);
inc(thrCount);
Resume;
end;
end;
end;
end.
[/sourcecode]

Ну и напоследок, файл для многопоточности ))
[sourcecode language='delphi']
unit threadHTTP;

interface

uses
Classes, SysUtils, IdHTTP, Dialogs, HTTPApp;

type
TGrabThread = class(TThread)
private

protected
procedure Execute; override;
public
http: TIdHTTP;

url: string;
html: string;
count: Integer;

ResponseCode: Integer;
procedure Sync;
constructor Create(Suspended: boolean);

end;

implementation
uses main;

constructor TGrabThread.Create(Suspended: boolean);

begin

inherited Create(Suspended);

end;

procedure TGrabThread.Execute;

begin
http := TIdHTTP.Create(nil);
http.ConnectTimeout := 30000;
http.ReadTimeout := 30000;
html := ”;
try
http.Head(url);
finally
ResponseCode := http.ResponseCode;
http.Free;
end;
Synchronize(Sync);
end;

procedure TGrabThread.Sync;
begin
if ResponseCode = 200 then
form1.Memo1.Lines.Add(url);
end;

end.
[/sourcecode]

Похожие посты:

• UniversalBIDs чекер – сырцы
• by.ru регер
• GoogleSnippets – сырцы, разбор полетов
• Mass ftp checker – массовая проверка фтп
• Google parser for a few minutes in Delphi7