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

[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, Дмитрий походу так и сделаю. Хоть и немного извращенно получится но выхода то нет. Спасибо всем, ребята, за помощь! Если удастся решить вопрос по человечески то опубликую исходник.