404 многопоточный чекер - сырцы на Delphi
Tools - SeoCoder  @ 10:36 pm

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

Первым будет файл проекта - к примеру checker404.dpr


program checker404;
uses
  Forms,
  main in ‘main.pas’ {Form1};
{$R *.res}
begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

Файл настроек - gpda.ini


[setup]
Threads=500


Главная форма.


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.


Ну и напоследок, файл для многопоточности ))


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.
google.com bobrdobr.ru del.icio.us technorati.com news2.ru rumarkz.ru memori.ru moemesto.ru

5 Comments »

  • Отлично! Но было бы лучше исходником в архиве :)

Comment by Biclope — December 9, 2007 @ 5:44 pm

  • эхх…писал же я тебе на гоуфаке
    зряне прислушался :)

Comment by Dmitry HT — December 9, 2007 @ 7:06 pm

  • 2Dmitry HT - просто с переездом блога часть постов похерилась. Выкладывай сюда что ты там мне писал, пусть народ юзает индейцев грамотно. ;)

Comment by admin — December 9, 2007 @ 7:09 pm

  • 2Biclope - я код выкладываю, чтобы думать могли юзеры, а не тупо юзать что есть. Для этих целей есть тут уже готовые экзешники.

Comment by admin — December 9, 2007 @ 7:10 pm

  • Все хорошо, но файл .dfm ты невыложил вроде, закинь куда нибудь…

Comment by m1c — January 28, 2008 @ 3:05 am


RSS feed for comments on this post. TrackBack URL

Leave a comment

 


Подписка по RSS
Comments RSS

TNX.net - уникальный международный сервис для вебмастеров и оптимизаторов

Категории

Блоги:



Старые статьи

Meta: