Наши проекты:
Журнал · Discuz!ML · Wiki · DRKB · Помощь проекту |
||
ПРАВИЛА | FAQ | Помощь | Поиск | Участники | Календарь | Избранное | RSS |
[3.139.90.131] |
|
Сообщ.
#1
,
|
|
|
Сделал 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. |
Сообщ.
#2
,
|
|
|
Цитата Kirilis2018 @ for i := 0 to Form1.sMemo1.Lines.Count - 1 do А как ты хочешь это расспаралелить? |
Сообщ.
#3
,
|
|
|
^D^ima,я тут даже не знаю как правильней это сделать ? Я так понял тут нужно что бы они синхронно работали ?
|
Сообщ.
#4
,
|
|
|
Я в потоках не силен, но ты уверен что это даст сильный прирост скорости?
|
Сообщ.
#5
,
|
|
|
^D^ima, А такой вариант реален: один тред = одному URL ?
Добавлено ^D^ima, В любом случае сбор адресов будет быстрее. Я видел как у других разработчиков в раз 10 быстрее работает в 5 потоков нежели в один. |
Сообщ.
#6
,
|
|
|
как в первом посте написали код через цикл так и запускайте, только в каждый поток передавайте юрл ссылку из списка, ну и синхронизация через критические секции.
|
Сообщ.
#7
,
|
|
|
vasya2019, Помогите сделать в потоках я не силен!
|
Сообщ.
#8
,
|
|
|
код не заработает, так как надо дочесать, просто скопипастил с вашего, но думаю смысл понятен
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; |
Сообщ.
#9
,
|
|
|
vasya2019, Увы но так не срабатывает.
|
Сообщ.
#10
,
|
|
|
что именно не срабатывает?
|
Сообщ.
#11
,
|
|
|
vasya2019, Вот тут идут ошибки при компиляции:
EnterCriticalSection(CriticalSection); Form1.sMemo2.Lines.Add(rege.Match[0]); LeaveCriticalSection(CriticalSection); |
Сообщ.
#12
,
|
|
|
ошибки, что CriticalSection не объявлен?
var CriticalSection: TRTLCriticalSection; |
Сообщ.
#13
,
|
|
|
vasya2019, Да, сейчас еще сижу и разбираюсь. После отпишу. Заранее спасибо за помощь.
|
Сообщ.
#14
,
|
|
|
Уже давно все юзают PPL
http://www.proghouse.ru/programming/36-delphi-xe7-ppl |
Сообщ.
#15
,
|
|
|
vasya2019,Cfon, В общем завис я на этом вопросе. Сегодня пол ночи просидел и результат просто НОЛЬ . Кто поможет, в долгу не останусь!
|
Сообщ.
#16
,
|
|
|
Вот для начала современный стиль многопоточного кодинга, балин красиво!
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; ПС. Я тащусь от Делфи Рио и тут функциональщина зашла |
Сообщ.
#17
,
|
|
|
За такие примеры - канделябром по башке нужно.
Во первых вызов 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; |
Сообщ.
#18
,
|
|
|
Цитата jack128 @ Во первых вызов TIdHTTP.Create(self) добавляет экземпляр TIdHTTP к список Components формы - в доп. потоке, а список не потокобезопасный. Соответственно если в основном потоке кто то будет испопользовать этот список - результат непредсказуем. Май бяд писал код в полудреме Цитата jack128 @ За такие примеры - канделябром по башке нужно. Я бы сразу ручки рубил |
Сообщ.
#19
,
|
|
|
Каждый запрос в отдельном потоке! Красиво
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 Рио, кста там ввели встроенные объявления переменных и выведение типов! Я писаюсь с Делфи рио |
Сообщ.
#20
,
|
|
|
Начиная с Делфи ХЕ8 через TNetHTTPClient + TNetHTTPRequest можно все это сделать легко
у них есть подержка асинхронного режима, да и OpenSSL не надо юзать. |
Сообщ.
#21
,
|
|
|
Для тех кто прогал на 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; Гениально |
Сообщ.
#22
,
|
|
|
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. |
Сообщ.
#23
,
|
|
|
Цитата Kirilis2018 @ 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; Это что? |
Сообщ.
#24
,
|
|
|
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. |
Сообщ.
#25
,
|
|
|
А какая у тя версия делфи? В делфи рио есть задачи и пул потоков с их помощью можно запускать хоть 10000 потоков.
|
Сообщ.
#26
,
|
|
|
Cfon, У меня Embarcadero® RAD Studio 10.1 Berlin.
|
Сообщ.
#27
,
|
|
|
там есть System.Threading?
можно еще через OmniThreadlibrary заюзать пцл потоков. ну или самому написать |
Сообщ.
#28
,
|
|
|
Cfon, Походу не решаемый вопрос, а жаль. У меня просто не хватает опыта.
|
Сообщ.
#29
,
|
|
|
Цитата Kirilis2018 @ Cfon, Походу не решаемый вопрос, а жаль. У меня просто не хватает опыта. Сделай memo по кол-ву потоков и запускай для каждого мемо свой поток, возможно это решить проблему, к.к. эти потоки будут независимы |
Сообщ.
#30
,
|
|
|
^D^ima, Дмитрий походу так и сделаю. Хоть и немного извращенно получится но выхода то нет. Спасибо всем, ребята, за помощь! Если удастся решить вопрос по человечески то опубликую исходник.
|