Много-поточность

[Kirilis2018]

Сделал Proxy Парсер по ссылкам и что бы форма не зависала переместил в отдельный поток.

Мужики, знатоки в потоках помогите решить задачу: Как сделать что бы программа работала в 50 потоков.

И предполагаю что это что то типа (В моем случае):

for i:=0 to 50 do
 begin
    TPotok.Create(true);
 end;

Вот готовый одно-поточный вариант (Очень надеюсь на вашу помощь, Уважаемые программисты!):

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdHTTP, Buttons, RegExpr, sMemo, sSkinProvider,
  sSkinManager, acPNG, ExtCtrls, jpeg, sButton, sLabel, IdBaseComponent,
  IdAntiFreezeBase, IdAntiFreeze;
 
type
  TForm1 = class(TForm)
    SaveDialog1: TSaveDialog;
    sSkinManager1: TsSkinManager;
    sSkinProvider1: TsSkinProvider;
    sMemo1: TsMemo;
    sMemo2: TsMemo;
    sLabel1: TsLabel;
    sLabel2: TsLabel;
    sButton1: TsButton;
    IdAntiFreeze1: TIdAntiFreeze;
    Label1: TLabel;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    Label2: TLabel;
    procedure Image4Click(Sender: TObject);
    procedure sButton1Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure sMemo2Change(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
  // Поток
type
  TPotok = class(TThread)
  private
    html: WideString;
    procedure reg;
  protected
    procedure Execute; override;
  end;
 
var
  Form1: TForm1;
  Potok: TPotok;
  HTTP: TIdHTTP;
  site, html, s: string;
  rege: tregexpr;
  i: integer;
 
implementation
 
uses Unit2;
 
{$R *.dfm}
 
procedure TPotok.reg;
begin
  Form1.sMemo2.Lines.Add(rege.Match[0]);
end;
 
procedure TPotok.Execute;
begin
  for i := 0 to Form1.sMemo1.Lines.Count - 1 do
  begin
    try
      site := Form1.sMemo1.Lines.Strings[i];
      html := HTTP.Get(site);
    except
    end;
    if rege.Exec(html) then
      repeat
        Synchronize(reg);
      until (not rege.ExecNext) or Potok.Terminated;
    if Potok.Terminated then
      break;
  end;
  HTTP.Free;
  rege.Free;
end;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  sMemo2.clear;
end;
 
procedure TForm1.Button2Click(Sender: TObject);
begin
  if SaveDialog1.Execute then
    sMemo2.Lines.SaveToFile(SaveDialog1.FileName);
end;
 
procedure TForm1.Button3Click(Sender: TObject);
begin
  if not Assigned(Potok) then
    ShowMessage('Программа не запущена')
  else
  begin
    Potok.Terminate;
  end;
end;
 
procedure TForm1.Button4Click(Sender: TObject);
begin
  HTTP := TIdHTTP.Create(nil); // экземпляр tidhttp
  rege := tregexpr.Create;
  rege.Expression := '\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}:\d{1,5}';
 
  Potok := TPotok.Create(true); // т.к запускаем через Resume
  Potok.Priority := tpLower;
  Potok.FreeOnTerminate := true;
  Potok.Resume;
end;
 
procedure TForm1.Button5Click(Sender: TObject);
begin
  Potok.suspend;
end;
 
procedure TForm1.Image4Click(Sender: TObject);
begin
  sMemo2.clear;
end;
 
procedure TForm1.sButton1Click(Sender: TObject);
var
  i, j: integer;
begin
  for i := sMemo2.Lines.Count - 1 downto 0 do
    for j := i - 1 downto 0 do
      if sMemo2.Lines[i] = sMemo2.Lines[j] then
        sMemo2.Lines.Delete(i);
end;
 
procedure TForm1.sMemo2Change(Sender: TObject);
begin
  Label1.Caption := IntToStr(sMemo2.Lines.Count);
end;
 
end.

[^D^ima]

Цитата Kirilis2018 @ 07.03.19, 09:09

for i := 0 to Form1.sMemo1.Lines.Count - 1 do

А как ты хочешь это расспаралелить?

[Kirilis2018]

^D^ima,я тут даже не знаю как правильней это сделать ? Я так понял тут нужно что бы они синхронно работали ?

[^D^ima]

Я в потоках не силен, но ты уверен что это даст сильный прирост скорости?

[Kirilis2018]

^D^ima, А такой вариант реален: один тред = одному URL ?

Добавлено 07.03.19, 09:56
^D^ima, В любом случае сбор адресов будет быстрее. Я видел как у других разработчиков в раз 10 быстрее работает в 5 потоков нежели в один.

[vasya2019]

как в первом посте написали код через цикл так и запускайте, только в каждый поток передавайте юрл ссылку из списка, ну и синхронизация через критические секции.

[Kirilis2018]

vasya2019, Помогите сделать в потоках я не силен!

[vasya2019]

код не заработает, так как надо дочесать, просто скопипастил с вашего, но думаю смысл понятен

function ThreadFunc(Info: Pointer): Integer; stdcall;
var
  i: Integer;
  HTTP: TIdHTTP;
  html: WideString;
begin
  HTTP := TIdHTTP.Create(nil);
  html := HTTP.Get(Info);
  rege.Exec(html)
  if rege.Exec(html) then
    repeat
      EnterCriticalSection(CriticalSection);
      Form1.sMemo2.Lines.Add(rege.Match[0]);
      LeaveCriticalSection(CriticalSection);
    until (not rege.ExecNext);
  HTTP.Free;
  ExitThread(4);
end;
 
procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
  TID: Cardinal;
begin
  InitializeCriticalSection(CriticalSection);
    for i := 0 to sMemo2.Lines.Count - 1 do CreateThread(nil, 0, @ThreadFunc, @sMemo2.Lines[i], 0, TID);
end;

[Kirilis2018]

vasya2019, Увы но так не срабатывает.

[vasya2019]

что именно не срабатывает?

[Kirilis2018]

vasya2019, Вот тут идут ошибки при компиляции:

EnterCriticalSection(CriticalSection);
Form1.sMemo2.Lines.Add(rege.Match[0]);
LeaveCriticalSection(CriticalSection);

[vasya2019]

ошибки, что CriticalSection не объявлен?

var
CriticalSection: TRTLCriticalSection;

[Kirilis2018]

vasya2019, Да, сейчас еще сижу и разбираюсь. После отпишу. Заранее спасибо за помощь.

[Cfon]

Уже давно все юзают PPL
http://www.proghouse.ru/programming/36-delphi-xe7-ppl

[Kirilis2018]

vasya2019,Cfon, В общем завис я на этом вопросе. Сегодня пол ночи просидел и результат просто НОЛЬ . Кто поможет, в долгу не останусь!

[Cfon]

Вот для начала современный стиль многопоточного кодинга, балин красиво!

procedure TForm1.Button1Click(Sender: TObject);
var url: string;
begin
  url:= 'http://docwiki.embarcadero.com/Libraries/Rio/en/Main_Page';
  TTask.Run(procedure
    var
      res: string;
    begin    
      res:= TIdHTTP.Create(self).Get(url);
      TThread.Queue(nil, procedure
        begin
          Memo1.Lines.Add(res);
        end);
    end);
end;

ПС. Я тащусь от Делфи Рио и тут функциональщина зашла

[jack128]

За такие примеры - канделябром по башке нужно.

Во первых вызов TIdHTTP.Create(self) добавляет экземпляр TIdHTTP к список Components формы - в доп. потоке, а список не потокобезопасный. Соответственно если в основном потоке кто то будет испопользовать этот список - результат непредсказуем.

Во вторых то, что ты оставляешь инстанс TIdHTTP живым после того как он стал не нужен - это мемлик. Не надо так делать. Корректный пример выглядит примерно так:

procedure TForm1.Button1Click(Sender: TObject);
var url: string;
begin
  url:= 'http://docwiki.embarcadero.com/Libraries/Rio/en/Main_Page';
  TTask.Run(procedure
    var
      http: TIdHTTP;
      res: string;
    begin    
      http := TIdHTTP.Create(nil);
      try
        res:= http.Get(url);
      finally
        http.Free;
      end;
      TThread.Queue(nil, procedure
        begin
          Memo1.Lines.Add(res);
        end);
    end);
end;

Сообщение отредактировано: jack128 - 10.03.19, 16:34

[Cfon]

Цитата jack128 @ 10.03.19, 16:33

Во первых вызов TIdHTTP.Create(self) добавляет экземпляр TIdHTTP к список Components формы - в доп. потоке, а список не потокобезопасный. Соответственно если в основном потоке кто то будет испопользовать этот список - результат непредсказуем.

Май бяд писал код в полудреме

Цитата jack128 @ 10.03.19, 16:33

За такие примеры - канделябром по башке нужно.

Я бы сразу ручки рубил

[Cfon]

Каждый запрос в отдельном потоке! Красиво

procedure TForm1.Button1Click(Sender: TObject);
var
  url: string;
begin
  var RunTask:= procedure(url: string)
  begin
    TTask.Run(procedure
    var
      res: string;
    begin
      var http:= TIdHttp.Create(nil);
      try
        res:= http.Get(url);        
        if TRegEx.IsMatch(res, 'DOCTYPE') then
        begin
          TThread.Queue(nil, procedure
          begin
            Memo2.Lines.Add('Done.');
          end);
        end;
      finally
        http.Free;
      end;
    end);
  end;
 
  // Запускаем запросы в отдельном потоке
  for url in Memo1.Lines do
    RunTask(url);
end;

ПС. Надо еще добавить обработку завершения потоков например по закрытию окна
Тестил на Делфи 10.3 Рио, кста там ввели встроенные объявления переменных и выведение типов! Я писаюсь с Делфи рио

Сообщение отредактировано: Cfon - 11.03.19, 18:20

[Cfon]

Начиная с Делфи ХЕ8 через TNetHTTPClient + TNetHTTPRequest можно все это сделать легко
у них есть подержка асинхронного режима, да и OpenSSL не надо юзать.

[Cfon]

Для тех кто прогал на JS

procedure TForm1.Button1Click(Sender: TObject);
var
  url: string;
begin
  for url in Memo1.Lines do
  begin
    TThread.CreateAnonymousThread((function (url: string): TProc
    begin
      Result:= procedure
      var
        res: string;
        http: THTTPClient;
      begin
        http:= THTTPClient.Create;
        try
          res:= http.Get(url).ContentAsString;
          if TRegEx.IsMatch(res, 'DOCTYPE') then
          begin
            TThread.Queue(nil, procedure
            begin
              Memo2.Lines.Add('Done.');
            end);
          end;
        finally
          http.Free;
        end;
      end;
    end)(url)).Start;
  end;
end;

Гениально

Сообщение отредактировано: Cfon - 12.03.19, 17:30

[Kirilis2018]

Cfon,jack128, Сделал вот так:
1. В memo1 - ссылки на сайты где есть списки proxy
2. А в Memo2 Сохраняется результат (Списки прокси)
3. И кнопка, при нажатию, на которую происходит сбор прокси по ссылкам.

Но не работает, а просто выкидывает из программы (Или копируются ссылки с Memo1 в Memo2). Ниже полный код.

Где я накосячил ?

unit Unit1;
 
interface
 
uses
 
 
  Windows, RegExpr, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdHTTP, Buttons,
   ExtCtrls, jpeg,  IdBaseComponent,
  IdAntiFreezeBase, IdAntiFreeze;
 
type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Memo2: TMemo;
    Button1: TButton;
    procedure ThreadEndHandler(Sender:TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
 
  TMyThread=class(TThread)
public
  URL:string;
  Result:string;
  procedure Execute; override;
  constructor Create(AURL:string; ATermFunc:TNotifyEvent);
  private
end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
 constructor TMyThread.Create(AURL:string; ATermFunc:TNotifyEvent);
begin
  inherited Create(True);
  FreeOnTerminate:=true;
  OnTerminate := ATermFunc;
  URL := AURL;
end;
 
procedure TMyThread.Execute;
var h: TIdHTTP;
  s:string;
  r:TRegExpr;
begin
  h:=TidHttp.Create(NIL);
  r := tregexpr.Create;
  try
    r.Expression := '\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}:\d{1,5}';
    s:=H.get(URL);
    if r.Exec (S) then
      REPEAT
       Result := Result + r.Match [0] + ',';
      UNTIL not r.ExecNext;
    finally r.Free;
    h.free;
    r.free;
  end;
end;
 
procedure TForm1.ThreadEndHandler(Sender:TObject);
var th:TMyThread absolute Sender;
begin
  memo2.lines.add(th.URL);
  memo2.lines.add(th.result);
end;
 
procedure TForm1.Button1Click(Sender: TObject);
var i:integer;
  th:TMyThread;
begin
  for i :=0 to memo1.lines.Count-1 do
  begin
    th := TMyThread.Create(memo1.lines[i], ThreadEndHandler);
    th.Resume;
  end;
end;
 
end.

А если делаю вот так то работает секунд 20 и останавливается:

unit Unit1;
 
interface
 
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdHTTP, Buttons, RegExpr, sMemo, sSkinProvider,
  sSkinManager, acPNG, ExtCtrls, jpeg, sButton, sLabel, IdBaseComponent,
  IdAntiFreezeBase, IdAntiFreeze;
 
type
  TForm1 = class(TForm)
    SaveDialog1: TSaveDialog;
    sSkinManager1: TsSkinManager;
    sSkinProvider1: TsSkinProvider;
    sMemo1: TsMemo;
    sMemo2: TsMemo;
    sLabel1: TsLabel;
    sLabel2: TsLabel;
    IdAntiFreeze1: TIdAntiFreeze;
    Label1: TLabel;
    Button4: TButton;
    Label2: TLabel;
    procedure Button4Click(Sender: TObject);
 
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
//Поток
type
 TPotok = class(TThread)
  public
    site: AnsiString;
  private
    HTTP: TIdHTTP;
    html: WideString;
    rege: tregexpr;
    procedure reg;
  protected
    procedure Execute; override;
  end;
 
var
  Form1: TForm1;
  Potok:TPotok;
  HTTP:TIdHTTP;
  site, html, s:string;
  rege:tregexpr;
  i:integer;
 
implementation
 
uses Unit2;
 
{$R *.dfm}
 
procedure TPotok.reg;
begin
 Form1.sMemo2.Lines.Add(rege.Match[0]);
end;
 
 
 
procedure TPotok.Execute;
begin
  HTTP := TIdHTTP.Create(nil);
  rege := tregexpr.Create;
  rege.Expression := '\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}:\d{1,5}';
  try
    site := Form1.sMemo1.Lines.Strings[i];
    html := HTTP.Get(site);
  except
  end;
  if rege.Exec(html) then
  repeat
     Synchronize(reg);
  until (not rege.ExecNext) or Potok.Terminated;
  HTTP.Free;
  rege.Free;
end;
 
 
procedure TForm1.Button4Click(Sender: TObject);
var
  Potok: TPotok;
begin
  for i := 0 to Form1.sMemo1.Lines.Count - 1 do
  begin
    Potok := TPotok.Create(true);
    Potok.FreeOnTerminate := true;
    Potok.site := Form1.sMemo1.Lines.Strings[i];
    Potok.Resume;
  end;
end;
 
end.

Сообщение отредактировано: Kirilis2018 - 15.03.19, 13:35

[Cfon]

Цитата Kirilis2018 @ 15.03.19, 13:18

procedure TForm1.ThreadEndHandler(Sender:TObject);
[CODE]var th:TMyThread absolute Sender;
begin
  memo2.lines.add(th.URL);
  memo2.lines.add(th.result);
end;

var th:TMyThread absolute Sender;
Это что?

Сообщение отредактировано: Cfon - 16.03.19, 11:14

[Kirilis2018]

Cfon, Это уже исправил. Но теперь проблема вот в чем: ЧТО сколько в MEMO1 строк столько и подключается потоков!. Как ограничить количество потоков ??? А то к примеру если в memo 2000 строк по подключается 2000 потоков и все виснет:

unit Unit1;
 
interface
 
uses
 
 
  Windows, RegExpr, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdHTTP, Buttons,
   ExtCtrls, jpeg,  IdBaseComponent,
  IdAntiFreezeBase, IdAntiFreeze;
 
type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Memo2: TMemo;
    Button1: TButton;
    procedure ThreadEndHandler(Sender:TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
 
  TMyThread=class(TThread)
public
  URL:string;
  Result:string;
  procedure Execute; override;
  constructor Create(AURL:string; ATermFunc:TNotifyEvent);
  private
end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
 constructor TMyThread.Create(AURL:string; ATermFunc:TNotifyEvent);
begin
  inherited Create(True);
  FreeOnTerminate:=true;
  OnTerminate := ATermFunc;
  URL := AURL;
end;
 
procedure TMyThread.Execute;
var h: TIdHTTP;
  s:string;
  r:TRegExpr;
begin
  h:=TidHttp.Create(NIL);
  r := tregexpr.Create;
  try
    r.Expression := '\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}:\d{1,5}';
    s:=H.get(URL);
  
    if r.Exec (S) then
      REPEAT
       Result := Result + r.Match [0] + ',';
      UNTIL not r.ExecNext;
 
    finally r.Free;
 
    h.free;
 
  end;
end;
 
procedure TForm1.ThreadEndHandler(Sender:TObject);
var th:TMyThread absolute Sender;
begin
 
  memo2.lines.add(th.result);
end;
 
procedure TForm1.Button1Click(Sender: TObject);
var i:integer;
  th:TMyThread;
begin
  for i :=0 to memo1.lines.Count-1 do
  begin
    th := TMyThread.Create(memo1.lines[i], ThreadEndHandler);
    th.Resume;
  end;
end;
 
end.

[Cfon]

А какая у тя версия делфи? В делфи рио есть задачи и пул потоков с их помощью можно запускать хоть 10000 потоков.

[Kirilis2018]

Cfon, У меня Embarcadero® RAD Studio 10.1 Berlin.

[Cfon]

там есть System.Threading?
можно еще через OmniThreadlibrary заюзать пцл потоков.
ну или самому написать

[Kirilis2018]

Cfon, Походу не решаемый вопрос, а жаль. У меня просто не хватает опыта.

[^D^ima]

Цитата Kirilis2018 @ 16.03.19, 18:04

Cfon, Походу не решаемый вопрос, а жаль. У меня просто не хватает опыта.

Сделай memo по кол-ву потоков и запускай для каждого мемо свой поток, возможно это решить проблему, к.к. эти потоки будут независимы

[Kirilis2018]

^D^ima, Дмитрий походу так и сделаю. Хоть и немного извращенно получится но выхода то нет. Спасибо всем, ребята, за помощь! Если удастся решить вопрос по человечески то опубликую исходник.