Версия для печати
Нажмите сюда для просмотра этой темы в оригинальном формате
Форум на Исходниках.RU > Delphi: Общие вопросы > Много-поточность


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

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

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

<{CODE_COLLAPSE_OFF}><{CODE_WRAP_OFF}>
    for i:=0 to 50 do
     begin
        TPotok.Create(true);
     end;


Вот готовый одно-поточный вариант (Очень надеюсь на вашу помощь, Уважаемые программисты!):
<{CODE_COLLAPSE_OFF}><{CODE_WRAP_OFF}>
    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 07.03.19, 09:40
Цитата Kirilis2018 @
for i := 0 to Form1.sMemo1.Lines.Count - 1 do

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

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

Автор: ^D^ima 07.03.19, 09:54
Я в потоках не силен, но ты уверен что это даст сильный прирост скорости?

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

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

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

Автор: Kirilis2018 07.03.19, 11:07
vasya2019, Помогите сделать в потоках я не силен!

Автор: vasya2019 07.03.19, 11:29
код не заработает, так как надо дочесать, просто скопипастил с вашего, но думаю смысл понятен
<{CODE_COLLAPSE_OFF}><{CODE_WRAP_OFF}>
    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 07.03.19, 13:10
vasya2019, Увы но так не срабатывает.

Автор: vasya2019 07.03.19, 15:49
что именно не срабатывает?

Автор: Kirilis2018 07.03.19, 19:47
vasya2019, Вот тут идут ошибки при компиляции:
<{CODE_COLLAPSE_OFF}><{CODE_WRAP_OFF}>
    EnterCriticalSection(CriticalSection);
    Form1.sMemo2.Lines.Add(rege.Match[0]);
    LeaveCriticalSection(CriticalSection);

Автор: vasya2019 07.03.19, 20:02
ошибки, что CriticalSection не объявлен?
<{CODE_COLLAPSE_OFF}><{CODE_WRAP_OFF}>
    var
    CriticalSection: TRTLCriticalSection;

Автор: Kirilis2018 07.03.19, 21:58
vasya2019, Да, сейчас еще сижу и разбираюсь. После отпишу. Заранее спасибо за помощь.

Автор: Cfon 08.03.19, 02:12
Уже давно все юзают PPL :D
http://www.proghouse.ru/programming/36-delphi-xe7-ppl

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

Автор: Cfon 08.03.19, 18:32
Вот для начала современный стиль многопоточного кодинга, балин красиво! :D
<{CODE_COLLAPSE_OFF}><{CODE_WRAP_OFF}>
    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;

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

Автор: jack128 10.03.19, 16:33
За такие примеры - канделябром по башке нужно.

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

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

<{CODE_COLLAPSE_OFF}><{CODE_WRAP_OFF}>
    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;

Автор: Cfon 11.03.19, 08:15
Цитата jack128 @
Во первых вызов TIdHTTP.Create(self) добавляет экземпляр TIdHTTP к список Components формы - в доп. потоке, а список не потокобезопасный. Соответственно если в основном потоке кто то будет испопользовать этот список - результат непредсказуем.

Май бяд писал код в полудреме :D
Цитата jack128 @
За такие примеры - канделябром по башке нужно.

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

Автор: Cfon 11.03.19, 17:36
Каждый запрос в отдельном потоке! Красиво :D
<{CODE_COLLAPSE_OFF}><{CODE_WRAP_OFF}>
    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 Рио, кста там ввели встроенные объявления переменных и выведение типов! Я писаюсь с Делфи рио :dance:

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

Автор: Cfon 12.03.19, 17:28
Для тех кто прогал на JS :D
<{CODE_COLLAPSE_OFF}><{CODE_WRAP_OFF}>
    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;

Гениально :lool:

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

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

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

<{CODE_COLLAPSE_OFF}><{CODE_WRAP_OFF}>
    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 и останавливается:
<{CODE_COLLAPSE_OFF}><{CODE_WRAP_OFF}>
    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.

Автор: Cfon 16.03.19, 11:12
Цитата Kirilis2018 @
<{CODE_COLLAPSE_OFF}><{CODE_WRAP_OFF}>
    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;
Это что? :D

Автор: Kirilis2018 16.03.19, 12:33
Cfon, Это уже исправил. Но теперь проблема вот в чем: ЧТО сколько в MEMO1 строк столько и подключается потоков!. Как ограничить количество потоков ??? А то к примеру если в memo 2000 строк по подключается 2000 потоков и все виснет:
<{CODE_COLLAPSE_OFF}><{CODE_WRAP_OFF}>
    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 16.03.19, 12:50
А какая у тя версия делфи? В делфи рио есть задачи и пул потоков с их помощью можно запускать хоть 10000 потоков.

Автор: Kirilis2018 16.03.19, 13:05
Cfon, У меня Embarcadero® RAD Studio 10.1 Berlin.

Автор: Cfon 16.03.19, 16:14
там есть System.Threading?
можно еще через OmniThreadlibrary заюзать пцл потоков.
ну или самому написать :D

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

Автор: ^D^ima 16.03.19, 19:29
Цитата Kirilis2018 @
Cfon, Походу не решаемый вопрос, а жаль. У меня просто не хватает опыта.

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

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

Powered by Invision Power Board (https://www.invisionboard.com)
© Invision Power Services (https://www.invisionpower.com)