|
Шаблон класса для работы с потоком (WThread, Thread)
#38415620
Ссылка:
Ссылка на сообщение:
Ссылка с названием темы:
Ссылка на профиль пользователя:
|
Участник
Откуда: Санкт-Петербург
Сообщения: 26 163
|
|
fd00ch, теперь и я не понял, откуда тролль Димонка высосал проблему... Действительно её не существует и такой способ для передачи строк таки нормально себя ведет.
Проверка. Модуль: 1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
unit WThread;
// модуль для работы с доп.потоками
// позволяет "общаться" дополнительному и основному потокам посредством системной очереди сообщений
// без вызова синхронизации
// (c) wadman 2013
// использование:
// 1. Создать наследника с объявленными обработчиками сообщений между WM_THREAD_BASE и WM_THREAD_MAX
// пример: procedure WMTestProc(var Msg: TMessage); message WM_TEST_PROC;
// 2. Присвоить обработчика(ов) события OnThreadReceiveMessage, OnTimeOut - при необходимости
// Для обмена строками рекомендууется использовать функции NewString и FreeString
interface
uses
Classes,
Windows,
Messages,
SysUtils;
const
WM_THREAD_BASE = WM_USER + $110;
WM_THREAD_MAX = WM_USER + $7FFF;
type
TWThread = class;
// событие на получение сообщения из потока
TWThreadReceiveMessage = procedure(Sender: TWThread; var Msg: Cardinal; var WParam: WPARAM; var LParam: LPARAM) of object;
// событие из потока на таймаут
TWThreadTimeOut = procedure(Sender: TWThread) of object;
TWThread = class(TThread)
private
FToolWindow: THandle;
hCloseEvent: THandle;
FOnThreadReceiveMessage: TWThreadReceiveMessage;
FTimeOut: Cardinal;
FOnTimeOut: TWThreadTimeOut;
procedure SetTimeOut(const Value: Cardinal);
protected
procedure WWindowProc(var Msg: TMessage);
// отправка сообщения из этого потока для вызова обрабочика OnThreadReceiveMessage
procedure SendMessageFromMe(const Msg: Cardinal; const WParam: WPARAM; const LParam: LPARAM);
procedure DoThreadReceiveMessage(var Msg: Cardinal; var WParam: WPARAM; var LParam: LPARAM);
procedure DoTimeout;
procedure Execute; override;
public
constructor Create; overload;
constructor Create(CreateSuspended: Boolean); overload;
destructor Destroy; override;
// отправка любого сообщения В этот поток
function SendToThreadMessage(AMsg: UInt; wParam: WPARAM; lParam: LPARAM): BOOL;
// остановка потока по феншую
function StopThread: boolean;
// событие на получение данных ИЗ этого потока, вызывается в основном потоке
property OnThreadReceiveMessage: TWThreadReceiveMessage read FOnThreadReceiveMessage write FOnThreadReceiveMessage;
// событие, возникающее при превышении интервала ожидания
property OnTimeOut: TWThreadTimeOut read FOnTimeOut write FOnTimeOut;
// интервал ожидания в мс, по-умолчанию - бесконечно
property TimeOut: Cardinal read FTimeOut write SetTimeOut default INFINITE;
end;
function NewString(const Text: string): LPARAM;
function FreeString(var P: LPARAM): String;
implementation
const
WM_MSG = WM_USER+$100;
WM_TIMEOUT = WM_USER+$101;
SizeOfChar = SizeOf(Char);
function NewString(const Text: string): LPARAM;
begin
Result:=0;
string(Result) := Text;
end;
function FreeString(var P: LPARAM): String;
begin
LPARAM(Result) := P;
end;
{function FreeString(var P: LPARAM): String;
begin
if LongBool(P) then begin
SetLength(Result, Length(PChar(P)));
Move(Pointer(P)^, Pointer(Result)^, Length(Result)*SizeOfChar);
P := LocalFree(HLOCAL(P));
end;
end;
function NewString(const Text: string): LPARAM;
var l: Integer;
begin
l := Length(Text)*SizeOfChar;
if L > 0 then begin
Result := LocalAlloc(LPTR, l+SizeOfChar);
if LongBool(Result) then
Move(Pointer(Text)^, Pointer(Result)^, l);
end else
Result := 0;
end; }
{ TWThread }
constructor TWThread.Create(CreateSuspended: Boolean);
begin
inherited;
FToolWindow := AllocateHWnd(WWindowProc);
hCloseEvent := CreateEvent(nil, true, false, nil);
FTimeOut := INFINITE;
end;
constructor TWThread.Create;
begin
Create(False);
end;
destructor TWThread.Destroy;
begin
CloseHandle(hCloseEvent);
DeallocateHWnd(FToolWindow);
inherited;
end;
procedure TWThread.DoThreadReceiveMessage(var Msg: Cardinal; var WParam: WPARAM; var LParam: LPARAM);
begin
if Assigned(FOnThreadReceiveMessage) then
FOnThreadReceiveMessage(Self, Msg, WParam, LParam);
end;
procedure TWThread.DoTimeout;
begin
if Assigned(FOnTimeOut) then
FOnTimeOut(Self);
end;
function TWThread.SendToThreadMessage(AMsg: UInt; wParam: WPARAM; lParam: LPARAM): BOOL;
begin
result := (not Suspended)and(PostThreadMessage(ThreadID, AMsg, wParam, lParam));
end;
procedure TWThread.SetTimeOut(const Value: Cardinal);
begin
if FTimeOut <> Value then begin
FTimeOut := Value;
if not Suspended then
PostThreadMessage(ThreadID, WM_TIMEOUT, Value, 0);
end;
end;
procedure TWThread.Execute;
var
HandlesToWaitFor: array [0 .. 0] of THandle;
dwHandleSignaled: DWORD;
msg: TMsg;
message: TMessage;
MSWait: Cardinal;
Label
EndOfThread;
begin
// следующая строка должна быть всегда первой в процедуре, т.к. запускает очередь сообщений для потока
PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE);
HandlesToWaitFor[0] := hCloseEvent;
// SleepEx не нужен, если подготовительный код до цикла while будет достаточно долго выполняться
// уточняется опытным путем, иначе очередь сообщений потока не успеет запуститься и сообщения могут улететь в пустоту
//SleepEx(20, false);
MSWait := FTimeOut; // изменяя кол-во миллисекунд в MSWait можно организовать событие-таймер, см WAIT_TIMEOUT
// в данном случае установлено бесконечное ожидание любого события
while not Terminated do begin
if not PeekMessage(msg, 0, WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE) then begin
dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, MSWait, QS_ALLINPUT);
case dwHandleSignaled of
WAIT_OBJECT_0: begin // выставлено событие остановки потока
if not FreeOnTerminate then
Terminate;
goto EndOfThread;
end;
WAIT_OBJECT_0 + 1: begin // получено сообщение
Continue;
end;
WAIT_TIMEOUT: begin
SendMessageFromMe(WM_TIMEOUT, 0, 0);
Continue;
end;
end;
end;
if msg.hwnd <> 0 then begin
TranslateMessage(msg);
DispatchMessage(msg);
Continue;
end;
case msg.message of
WM_QUIT, WM_CLOSE, WM_DESTROY: begin // оконные сообщения тоже получаем
if not FreeOnTerminate then
Terminate;
goto EndOfThread;
end;
WM_TIMEOUT: begin
MSWait := msg.wParam;
end
else begin
message.Msg := Msg.message;
message.WParam := Msg.wParam;
message.LParam := Msg.lParam;
Dispatch(message);
end;
end;
end;
EndOfThread:
// все что создали в начале процедуры, здесь удаляем
end;
procedure TWThread.SendMessageFromMe(const Msg: Cardinal; const WParam: WPARAM; const LParam: LPARAM);
begin
if FToolWindow <> 0 then
PostMessage(FToolWindow, Msg, WParam, LParam);
end;
function TWThread.StopThread: boolean;
begin
SetEvent(hCloseEvent);
SleepEx(1, false);
result := WaitForSingleObject(Handle, 10000) <> WAIT_TIMEOUT;
end;
procedure TWThread.WWindowProc(var Msg: TMessage);
begin
case Msg.Msg of
WM_TIMEOUT: begin
DoTimeout;
end;
WM_THREAD_BASE..WM_USER+WM_THREAD_MAX: begin
DoThreadReceiveMessage(Msg.Msg, Msg.WParam, Msg.LParam);
Msg.Result := 1;
end
else
Msg.Result := DefWindowProc(FToolWindow, Msg.Msg, Msg.wParam, Msg.lParam);
end;
end;
end.
Программа:
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
unit ThreadTestMain;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, WThread;
const
WM_STRING = WM_THREAD_BASE + 1;
type
TMyThread = class(TWThread)
private
procedure ReceiveString(var Msg: TMessage); message WM_STRING;
end;
TfrmWThreadTest = class(TForm)
Memo1: TMemo;
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
FThread: TMyThread;
procedure ReceiveMsg(Sender: TWThread; var Msg: Cardinal; var WParam: WPARAM; var LParam: LPARAM);
procedure StartThread;
procedure StopThread;
public
end;
var
frmWThreadTest: TfrmWThreadTest;
implementation
{$R *.dfm}
procedure TfrmWThreadTest.Button1Click(Sender: TObject);
begin
if Assigned(FThread) then
StopThread
else
StartThread;
end;
procedure TfrmWThreadTest.Button2Click(Sender: TObject);
var s: string;
begin
if Assigned(FThread) and InputQuery('Input', 'Enter text', s) then begin
// отправляем введенную строку в доп. поток
Memo1.Lines.Add(Format('-> %s', [s]));
FThread.SendToThreadMessage(WM_STRING, 0, NewString(s));
s := '';
end;
end;
procedure TfrmWThreadTest.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if Assigned(FThread) then
StopThread;
end;
procedure TfrmWThreadTest.FormCreate(Sender: TObject);
begin
Memo1.Lines.Clear;
end;
procedure TfrmWThreadTest.ReceiveMsg(Sender: TWThread; var Msg: Cardinal; var WParam: WPARAM; var LParam: LPARAM);
begin
case Msg of
WM_STRING: begin
Memo1.Lines.Add(Format('<- %s', [FreeString(LParam)]));
end;
end;
end;
procedure TfrmWThreadTest.StartThread;
begin
if not Assigned(FThread) then begin
FThread := TMyThread.Create(false);
FThread.OnThreadReceiveMessage := ReceiveMsg;
end;
end;
procedure TfrmWThreadTest.StopThread;
begin
if Assigned(FThread) then begin
if not FThread.StopThread then
MessageDlg('You dont kill me!', mtError, [mbOk], 0);
FThread.Free;
FThread := nil;
end;
end;
{ TMyThread }
procedure TMyThread.ReceiveString(var Msg: TMessage);
var s: string;
begin
s := FreeString(Msg.LParam);
// отправляем полученную строку обратно главному потоку
SendMessageFromMe(Msg.Msg, Msg.WParam, NewString(s));
sleep(5000);
SendMessageFromMe(Msg.Msg, Msg.WParam, NewString(s));
end;
end.
Результат в мемо:
автор-> 1
<- 1
-> 2
-> 3
-> 4
-> 5
<- 1
<- 2
<- 2
<- 3
<- 3
<- 4
<- 4
<- 5
<- 5
Никаких потерь. |
|
|
